- bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] r2472 - branches/trunk-reorg/thirdparty/cffi-070901/uffi-compat
by ksprotte＠common-lisp.net 11 Feb '08

11 Feb '08

Author: ksprotte Date: Mon Feb 11 09:08:26 2008 New Revision: 2472 Added: branches/trunk-reorg/thirdparty/cffi-070901/uffi-compat/uffi.noasd - copied unchanged from r2469, branches/trunk-reorg/thirdparty/cffi-070901/uffi-compat/uffi.asd Removed: branches/trunk-reorg/thirdparty/cffi-070901/uffi-compat/uffi.asd Log: renamed uffi-compat/uffi.asd to uffi-compat/uffi.noasd

1 0

[bknr-cvs] r2471 - branches/trunk-reorg/thirdparty/cl-gd-0.5.6
by ksprotte＠common-lisp.net 11 Feb '08

11 Feb '08

Author: ksprotte Date: Mon Feb 11 09:07:36 2008 New Revision: 2471 Modified: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd Log: cl-gd now always depends on uffi Modified: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd ============================================================================== --- branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd (original) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd Mon Feb 11 09:07:36 2008 @@ -54,5 +54,4 @@ (:file "drawing") (:file "strings") (:file "misc")) - :depends-on (#-(or :clisp :openmcl) :uffi - #+(or :clisp :openmcl) :cffi-uffi-compat)) + :depends-on (:uffi))

1 0

[bknr-cvs] r2470 - in branches/trunk-reorg/thirdparty/uffi: . benchmarks debian doc examples src src/corman tests
by ksprotte＠common-lisp.net 11 Feb '08

11 Feb '08

Author: ksprotte Date: Mon Feb 11 09:06:27 2008 New Revision: 2470 Added: branches/trunk-reorg/thirdparty/uffi/ branches/trunk-reorg/thirdparty/uffi/AUTHORS branches/trunk-reorg/thirdparty/uffi/ChangeLog branches/trunk-reorg/thirdparty/uffi/INSTALL branches/trunk-reorg/thirdparty/uffi/LICENSE branches/trunk-reorg/thirdparty/uffi/Makefile branches/trunk-reorg/thirdparty/uffi/Makefile.common branches/trunk-reorg/thirdparty/uffi/NEWS branches/trunk-reorg/thirdparty/uffi/README branches/trunk-reorg/thirdparty/uffi/TODO branches/trunk-reorg/thirdparty/uffi/benchmarks/ branches/trunk-reorg/thirdparty/uffi/benchmarks/Makefile branches/trunk-reorg/thirdparty/uffi/benchmarks/allocation.lisp branches/trunk-reorg/thirdparty/uffi/debian/ branches/trunk-reorg/thirdparty/uffi/debian/README.Debian branches/trunk-reorg/thirdparty/uffi/debian/changelog branches/trunk-reorg/thirdparty/uffi/debian/cl-uffi.doc-base branches/trunk-reorg/thirdparty/uffi/debian/compat branches/trunk-reorg/thirdparty/uffi/debian/control branches/trunk-reorg/thirdparty/uffi/debian/copyright branches/trunk-reorg/thirdparty/uffi/debian/cvsbp-prepare.sh (contents, props changed) branches/trunk-reorg/thirdparty/uffi/debian/docs branches/trunk-reorg/thirdparty/uffi/debian/make-upstream.sh (contents, props changed) branches/trunk-reorg/thirdparty/uffi/debian/postinst branches/trunk-reorg/thirdparty/uffi/debian/preinst (contents, props changed) branches/trunk-reorg/thirdparty/uffi/debian/prerm branches/trunk-reorg/thirdparty/uffi/debian/rules (contents, props changed) branches/trunk-reorg/thirdparty/uffi/debian/upload.sh (contents, props changed) branches/trunk-reorg/thirdparty/uffi/debian/watch branches/trunk-reorg/thirdparty/uffi/doc/ branches/trunk-reorg/thirdparty/uffi/doc/COPYING.GFDL branches/trunk-reorg/thirdparty/uffi/doc/Makefile branches/trunk-reorg/thirdparty/uffi/doc/appendix.xml branches/trunk-reorg/thirdparty/uffi/doc/bookinfo.xml branches/trunk-reorg/thirdparty/uffi/doc/catalog-darwin.xml branches/trunk-reorg/thirdparty/uffi/doc/catalog-debian.xml branches/trunk-reorg/thirdparty/uffi/doc/catalog-mandrake.xml branches/trunk-reorg/thirdparty/uffi/doc/catalog-suse.xml branches/trunk-reorg/thirdparty/uffi/doc/catalog-suse90.xml branches/trunk-reorg/thirdparty/uffi/doc/catalog-suse91.xml branches/trunk-reorg/thirdparty/uffi/doc/catalog-ubuntu.xml branches/trunk-reorg/thirdparty/uffi/doc/entities.inc branches/trunk-reorg/thirdparty/uffi/doc/fo.xsl branches/trunk-reorg/thirdparty/uffi/doc/glossary.xml branches/trunk-reorg/thirdparty/uffi/doc/html.tar.gz (contents, props changed) branches/trunk-reorg/thirdparty/uffi/doc/html.xsl branches/trunk-reorg/thirdparty/uffi/doc/html_chunk.xsl branches/trunk-reorg/thirdparty/uffi/doc/intro.xml branches/trunk-reorg/thirdparty/uffi/doc/notes.xml branches/trunk-reorg/thirdparty/uffi/doc/preface.xml branches/trunk-reorg/thirdparty/uffi/doc/ref_aggregate.xml branches/trunk-reorg/thirdparty/uffi/doc/ref_declare.xml branches/trunk-reorg/thirdparty/uffi/doc/ref_func_libr.xml branches/trunk-reorg/thirdparty/uffi/doc/ref_object.xml branches/trunk-reorg/thirdparty/uffi/doc/ref_primitive.xml branches/trunk-reorg/thirdparty/uffi/doc/ref_string.xml branches/trunk-reorg/thirdparty/uffi/doc/schemas.xml branches/trunk-reorg/thirdparty/uffi/doc/uffi.pdf branches/trunk-reorg/thirdparty/uffi/doc/uffi.xml branches/trunk-reorg/thirdparty/uffi/doc/xinclude.mod branches/trunk-reorg/thirdparty/uffi/examples/ branches/trunk-reorg/thirdparty/uffi/examples/Makefile branches/trunk-reorg/thirdparty/uffi/examples/Makefile.msvc branches/trunk-reorg/thirdparty/uffi/examples/acl-compat-tester.lisp branches/trunk-reorg/thirdparty/uffi/examples/arrays.lisp branches/trunk-reorg/thirdparty/uffi/examples/atoifl.lisp branches/trunk-reorg/thirdparty/uffi/examples/c-test-fns.c branches/trunk-reorg/thirdparty/uffi/examples/c-test-fns.lisp branches/trunk-reorg/thirdparty/uffi/examples/compress.lisp branches/trunk-reorg/thirdparty/uffi/examples/file-socket.lisp branches/trunk-reorg/thirdparty/uffi/examples/getenv.lisp branches/trunk-reorg/thirdparty/uffi/examples/gethostname.lisp branches/trunk-reorg/thirdparty/uffi/examples/getshells.lisp branches/trunk-reorg/thirdparty/uffi/examples/gettime.lisp branches/trunk-reorg/thirdparty/uffi/examples/run-examples.lisp branches/trunk-reorg/thirdparty/uffi/examples/strtol.lisp branches/trunk-reorg/thirdparty/uffi/examples/test-examples.lisp branches/trunk-reorg/thirdparty/uffi/examples/union.lisp branches/trunk-reorg/thirdparty/uffi/src/ branches/trunk-reorg/thirdparty/uffi/src/Makefile branches/trunk-reorg/thirdparty/uffi/src/aggregates.lisp branches/trunk-reorg/thirdparty/uffi/src/corman/ branches/trunk-reorg/thirdparty/uffi/src/corman/corman-notes.txt branches/trunk-reorg/thirdparty/uffi/src/corman/getenv-ccl.lisp branches/trunk-reorg/thirdparty/uffi/src/functions.lisp branches/trunk-reorg/thirdparty/uffi/src/libraries.lisp branches/trunk-reorg/thirdparty/uffi/src/objects.lisp branches/trunk-reorg/thirdparty/uffi/src/os.lisp branches/trunk-reorg/thirdparty/uffi/src/package.lisp branches/trunk-reorg/thirdparty/uffi/src/primitives.lisp branches/trunk-reorg/thirdparty/uffi/src/readmacros-mcl.lisp branches/trunk-reorg/thirdparty/uffi/src/strings.lisp branches/trunk-reorg/thirdparty/uffi/tests/ branches/trunk-reorg/thirdparty/uffi/tests/Makefile branches/trunk-reorg/thirdparty/uffi/tests/Makefile.msvc branches/trunk-reorg/thirdparty/uffi/tests/arrays.lisp branches/trunk-reorg/thirdparty/uffi/tests/atoifl.lisp branches/trunk-reorg/thirdparty/uffi/tests/casts.lisp branches/trunk-reorg/thirdparty/uffi/tests/compress.lisp branches/trunk-reorg/thirdparty/uffi/tests/foreign-loader.lisp branches/trunk-reorg/thirdparty/uffi/tests/foreign-var.lisp branches/trunk-reorg/thirdparty/uffi/tests/getenv.lisp branches/trunk-reorg/thirdparty/uffi/tests/gethostname.lisp branches/trunk-reorg/thirdparty/uffi/tests/make.sh branches/trunk-reorg/thirdparty/uffi/tests/objects.lisp branches/trunk-reorg/thirdparty/uffi/tests/package.lisp branches/trunk-reorg/thirdparty/uffi/tests/rt.lisp branches/trunk-reorg/thirdparty/uffi/tests/strtol.lisp branches/trunk-reorg/thirdparty/uffi/tests/structs.lisp branches/trunk-reorg/thirdparty/uffi/tests/time.lisp branches/trunk-reorg/thirdparty/uffi/tests/uffi-c-test-lib.lisp branches/trunk-reorg/thirdparty/uffi/tests/uffi-c-test.c branches/trunk-reorg/thirdparty/uffi/tests/union.lisp branches/trunk-reorg/thirdparty/uffi/uffi-tests.asd branches/trunk-reorg/thirdparty/uffi/uffi.asd Log: added uffi to thirdparty Added: branches/trunk-reorg/thirdparty/uffi/AUTHORS ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/AUTHORS Mon Feb 11 09:06:27 2008 @@ -0,0 +1,12 @@ +Kevin M. Rosenberg <kevin(a)rosenberg.net> + Primary author + +John Desoi <desoi(a)mac.com> + Contributed MCL & OpenMCL support + +Reini Urban <rurban(a)x-ray.at> + Contributed initial Corman support + +Edi Weitz <edi(a)weitz.de> + Contributed with-cast-pointer and def-foreign-var along with + documentation Added: branches/trunk-reorg/thirdparty/uffi/ChangeLog ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/ChangeLog Mon Feb 11 09:06:27 2008 @@ -0,0 +1,354 @@ +2007-09-17 Kevin Rosenberg (kevin(a)rosenberg.net) + * doc/Makefile, doc/html.xsl: Change output encoding from + ISO-8859-1 to UTF-8 + +2007-07-22 Kevin Rosenberg (kevin(a)rosenberg.net) + * Version 1.6.0 (SPECIFICATION CHANGE) + * doc/ref_func_libr.xml: Change the specification of + load-foreign-library to better match the actual action of the + function. Rather than returning NIL for failure to load library, + signal an error. + * src/libraries.lisp: Rework load-foreign-library to ensure errors + are signaled on failure to load library. This was the case for + some implementations, change the other implementations to + match. (Inconsistency found due to Mark Wooding's remarks) + +2007-04-12 Kevin Rosenberg (kevin(a)rosenberg.net) + * Version 1.5.18 + * src/functions.lisp: Patch from Ian Eslick for Lispworks 5 + +2006-10-10 Kevin Rosenberg (kevin(a)rosenberg.net) + * Version 1.5.17 + * src/functions.lisp: Patch from Edi Weitz for Lispworks 5/Linux + +2006-09-02 Kevin Rosenberg (kevin(a)rosenberg.net) + * Version 1.5.16 + * src/libraries.lisp: Add cygwin support + +2006-08-13 Kevin Rosenberg (kevin(a)rosenberg.net) + * Version 1.5.15 + * src/{objects,strings}.lisp: Add support for Lispworks 5 + thanks to patches from Bill Atkins + +2006-07-04 Kevin Rosenberg (kevin(a)rosenberg.net) + * Version 1.5.14 + * src/{objects,strings}.lisp: Apply patch from Edi Weitz + +2006-05-17 Kevin Rosenberg (kevin(a)rosenberg.net) + * Version 1.5.13 + * src/libraries.lisp: Revert buggy patch from Yaroslav Kavenchuk. + +2006-05-17 Kevin Rosenberg (kevin(a)rosenberg.net) + * Version 1.5.12 + * src/libraries.lisp: Patch from Yaroslav Kavenchuk to set + default drive letters on MS Windows. + +2006-05-11 Kevin Rosenberg (kevin(a)rosenberg.net) + * Version 1.5.11: Export new macro DEF-POINTER-VAR based on patch from + James Bielman to support defining variables on platforms which + support saving objects, such as openmcl + +2006-04-17 Kevin Rosenberg (kevin(a)rosenberg.net) + * Version 1.5.10: Commit patch from Gary King for openmcl's + feature list change + +2005-11-14 Kevin Rosenberg (kevin(a)rosenberg.net) + * Version 1.5.7 + * src/strings.lisp: Add with-foreign-strings by James Biel + +2005-11-14 Kevin Rosenberg (kevin(a)rosenberg.net) + * Version 1.5.6 + * src/os.lisp: Remove getenv setter + +2005-11-07 Kevin Rosenberg (kevin(a)rosenberg.net) + * Version 1.5.5 + * src/os.lisp: Add support for getenv getter and setter + +2005-09-17 Kevin Rosenberg (kevin(a)rosenberg.net) + * Version 1.5.4 + * src/objects.lisp: prepend _ character for entry + point on Allegro macosx, patch by Luis Oliveira + +2005-07-05 Kevin Rosenberg (kevin(a)rosenberg.net) + * Version 1.5.0 + * Remove vestigial LLGPL license notices as UFFI as been + BSD-licensed for several years. + +2005-06-09 Kevin Rosenberg (kevin(a)rosenberg.net) + * Version 1.4.39 + * tests/objects.lisp: Rename from pointers.lisp. + Fix test CHPTR.4 as noted by Jorg Hohle + * src/objects.lisp: Remove default from ensure-char-integer + +2005-06-09 Kevin Rosenberg (kevin(a)rosenberg.net) + * Version 1.4.38 + * src/libraries.lisp: Commit patch from Edi Weitz to + allow plain filename library names to allow underlying + lisp implementation to find foreign libraries in the + locations known to the operating system. + * tests/cast.lisp: Add :module keyword as noted by Jorg Hohle. + * src/strings.lisp: Avoid multiple evaluation of input + parameters for macros as noted by Jorg Hohle. + +2005-04-12 Kevin Rosenberg (kevin(a)rosenberg.net) + * Version 1.4.37 + * src/strings.lisp: Fix variable name + +2005-04-04 Kevin Rosenberg (kevin(a)rosenberg.net) + * src/strings.lisp, src/aggregates.lisp: Support change in SBCL copy + function [Thanks for Nathan Froyd and Zach Beane] + +2005-04-03 Kevin Rosenberg (kevin(a)rosenberg.net) + * src/objects.lisp: Commit patch from James Bielman to add + def-foreign-var support for OpenMCL + +2005-03-03 Kevin Rosenberg (kevin(a)rosenberg.net) + * src/primitives.lisp: Add support for :union types + [patch from Cyrus Harmon] + * tests/union.lisp, tests/structs.lisp: Tests for + union and structure types [from Cyrus Harmon] + +2005-02-22 Kevin Rosenberg (kevin(a)rosenberg.net) + * src/primitives.lisp, src/strings.lisp: Better support + for sb-unicode [from Yoshinori Tahara and R. Mattes] + +2005-01-22 Kevin Rosenberg (kevin(a)rosenberg.net) + * src/primitives.lisp: Better support SBCL-AMD64 + +2004-11-08 Kevin Rosenberg (kevin(a)rosenberg.net) + * src/strings.lisp: Better support sb-unicode + * tests/compress.lisp: Support sb-unicode + +2004-10-07 Kevin Rosenberg (kevin(a)rosenberg.net) + * src/objects.lisp: Add new function: + convert-from-foreign-usb8 + +2004-04-15 Kevin Rosenberg (kevin(a)rosenberg.net) + * src/objects.lisp: Add new functions: + MAKE-POINTER and POINTER-ADDRESS + +2004-04-13 Kevin Rosenberg (kevin(a)rosenberg.net) + * src/string.lisp: Add new FOREIGN-STRING-LENGTH + +2003-08-15 Kevin Rosenberg (kevin(a)rosenberg.net) + * Added with-cast-pointer and def-foreign-var (patches submitted + by Edi Weitz). + * Added many new tests + +2002-10-16 Kevin Rosenberg (kevin(a)rosenberg.net) + * Added support for SBCL and SCL + +2002-09-29 Kevin Rosenberg (kevin(a)rosenberg.net) + * Numerous changes in openmcl support (uffi now supports + clsql on openmcl) + +2002-09-19 Kevin Rosenberg (kevin(a)rosenberg.net) + - Integrate John Desoi's OpenMCL support into src-mcl + * examples/Makefile: add section for building on MacOS X (John Desoi) + * examples/test-examples: changed from mk: to asdf: package loading (KMR) + * examples/run-examples: changed from mk: to asdf: package loading (KMR), + add conditional loading if UFFI not loaded (John Desoi) + * examples/compress.cl: Add dylib to library types for MacOSX (John Desoi), + converted compressed output to hexidecimal display (KMR) + * examples/union.cl: Rework the tests (KMR) + * src-main/libraries.cl: add dylib as default library type on MacOSX (John Desoi) + * src-main/aggregates.cl: convert from uffi type in deref-array (John Desoi) + +2002-09-16 Kevin Rosenberg (kevin(a)rosenberg.net) + - Restructure directories to move to a asdf definition file + without pathnames. + +2002-08-25 Kevin Rosenberg (kevin(a)rosenberg.net) + - Restructure directories to attempt to properly handle both + Common Lisp Controller and non-CLC systems + +2002-08-17 Kevin Rosenberg (kevin(a)rosenberg.net) + + - add uffi.asd for ASDF users + +2002-08-01 Kevin Rosenberg (kevin(a)rosenberg.net) + - Restructure directories to improve Common Lisp Controller v3 + compatibility + +2002-07-25 Kevin Rosenberg (kevin(a)rosenberg.net) + + - Rework handling of logical pathnames. + - Move run-examples.cl to examples directory. + +2002-06-28 Kevin Rosenberg (kevin(a)rosenberg.net) + + - Added size-of-foreign-type function. + +2002-06-26 Kevin Rosenberg (kevin(a)rosenberg.net) + + - Fix bug in Lispworks allocate-foreign-object + - Added new :unsigned-byte type. Made :byte signed. + +2002-04-27 Kevin Rosenberg (kevin(a)rosenberg.net) + - misc files + First debian version + +2002-04-23 Kevin Rosenberg (kevin(a)rosenberg.net) + - doc/* + Updated to debian docbook catalog + +2002-04-23 John DeSoi (desoi(a)mac.com) + * src/mcl/* + Improved MCL support + +2002-04-06 Kevin Rosenberg (kevin(a)rosenberg.net) + * src/mcl/libraries.cl: + Removed unnecessary function and added find-foreign-library + * src/mcl/*.cl: + Added authorship for John DeSoi + * doc/ref.sgml: + Added documentation for find-foreign-library + * uffi.system: + Simplied logical pathnames and MCL loading + +2002-04-04 John DeSoi (desoi(a)mac.com) + * src/mcl/*.cl + Added initial support for MCL + +2002-04-02 Kevin Rosenberg (kevin(a)rosenberg.net) + * src/libraries.cl: + Added test for .so libraries on CMUCL and use sys::load-object-file instead + of alien:load-library-file + * examples/Makefile: + Updated defaults so library is created correctly on Linux, FreeBSD, and Solaris + +2002-04-02 Kevin Rosenberg (kevin(a)rosenberg.net) + * examples/compress.cl: + Fixed missing '/' + * examples/union.cl: + Added support for SPARC big-endian + * test-examples.cl: + Automated testing suite + +2002-04-01 Kevin Rosenberg (kevin(a)rosenberg.net) + * src/libraries.cl: + * examples/Makefile: + Changed default type for FreeBSD and updated Makefile for + FreeBSD and Solaris. Enhanced find-foreign-library to + take a list of types to search. + * examples/compress.cl: + Add support to use find-foreign-library + +2002-03-31 Kevin Rosenberg (kevin(a)rosenberg.net) + * src/strings.cl: + Fixed bug in with-foreign-string (Thanks Harald Hanche-Olsen) + * examples/Makefile: + Create a .a library file for FreeBSD + * src/libraries.cl: + Added default type and find-foreign-library functions + +2002-03-29 Kevin Rosenberg (kevin(a)rosenberg.net) + * src/objects.cl: + Fixed bug in deref-pointer (Thanks John Desoi!) + +2002-03-22 Kevin Rosenberg (kevin(a)rosenberg.net) + * src/aggregates.cl: + Changed name and implementation of def-array to more appropriate + def-array-pointer + * src/ref.sgml: + Updated def-array-pointer documentation + * src/primitives.cl: + Made results of def-constant equal those of cl:defconstant + * src/objects.cl: + Made type be evaluated for with-foreign-object and allocate-foreign-object + * VERSION: + Increase to 0.3.0 to coincide with the release of CLSQL. + +21 Mar 2002 + * Fixed problem with NULL foreign-strings with CMUCL + * Added c-test-fns to examples for allow more specific testing + of UFFI. Builds on UNIX and Win32 platforms. + * Added def-union function, added union.cl example + * Fixed error with ensure-char-[character|integer] + * Added 2-d array example to examples/arrays.cl + * Fixed documentation error on gethostname + * Added ensure-char-* and def-union to documentation + * Added double-float vector example to c-test-fns + * Reworked cstring on Lispworks to have LW handle string conversion + * First pass at with-foreign-object -- unoptimized + * Added gethostname2 example which uses with-foreign-object + * Added char-array-to-pointer function to encapsulate + converting a char array to a char pointer + * Converted with-foreign-object to use stack allocation on CMUCL and LW + * Added benchmark code, first file is for allocation + +20 Mar 2002 + * Updated strings.cl so that foreign-strings are always unsigned. + Fixes a problem with strtol example. + * Added ensure-char-character and ensure-char-integer to handle + differences in implementations dereferencing of (* :char). + * Added section on design priorities for UFFI + * Added section in TODO on splitting implementation-dependent code + +19 Mar 2002 + * Added size parameter to allocate-foreign-object. Creates an array + of dimensions size. + * Got array-2d example working with a 1-d array. + * Cleaned strtol example + * Added TODO file + +18 Mar 2002 + * Documentation fixes (Erik Winkels) + * Fixed missing '.' in CMUCL type declarations (Erik Winkels) + +17 Mar 2002 + * Changed deref-pointer so it always returns a character when + called with a :char or :unsigned-char type + * Removed function ensure-char as no longer needed + * Added missing :byte specifier to Lispworks + * Changed default string type in Lispworks to :unsigned-char + which is the native type for Lispworks foreign-strings. + * Reworked strtol to handle new character pointing method + +16 Mar 2002 + * Fixed return value in load-foreign-library (Thanks Erik Winkels), + modified routine to accept pathnames as well as strings. + * Fix documention with :pointer-void (Again, Erik Winkels) + * Added missing type specifiers for CMUCL (Thanks a bunch, Erik!) + +15 Mar 2002 + * Finished basic skeleton of documentation. + +14 Mar 2002 + * Changed license to more liberal Lisp Lessor GNU Public License + * Fixed problem with uffi.system absent from in distribution + (Thanks John DeSoi) + * Fixed compiler warnings + + +11 Mar 2002 + * Changed def-type to def-foreign-type + * Created new macro def-type to generate cl:deftype forms. Removed + uffi-declare and uffi-slot-type as they are no longer necessary. + +10 Mar 2002 + * Modified input parameters to load-foreign-library + * Added to documention + * Changed parameter order in get-slot-value and deref-array + +9 Mar 2002 + * Added to documentation + * Made Allegro CL array access more efficient + * Changed def-routine name to def-function + * Fixed bug in def-function for Lispworks] + * Fixed error in +null-c-string-pointer+ name + * Fixed error in (make-null-pointer) for Lispworks + * Reworked Lispwork c-strings to be (* :char) rather than the + implementation default of (* (:unsigned :char)) to be consistent + with CMUCL. Bumped version to 0.2.0 because of change this change. + * Renamed c-string to cstring to emphasize it as a basic type + * Modified getenv.cl example to avoid name collison with LW + * Modified compress.cl to setup output buffer as :unsigned*char + * Added test-all-examples function. All routines tested okay with + ACL, LW, and CMUCL + +8 Mar 2002 + * Added ZIP file output with LF->CRLF translations to distribution + * Modified def-enum to use uffi:def-constant rather than + cl:defconstant + Added: branches/trunk-reorg/thirdparty/uffi/INSTALL ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/INSTALL Mon Feb 11 09:06:27 2008 @@ -0,0 +1,3 @@ +Detailed installation instructions are supplied in PDF format +in the file ./doc/uffi.pdf. + Added: branches/trunk-reorg/thirdparty/uffi/LICENSE ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/LICENSE Mon Feb 11 09:06:27 2008 @@ -0,0 +1,26 @@ +Copyright (c) 2001-2003 Kevin M. Rosenberg and contributors. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of the contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/uffi/Makefile ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/Makefile Mon Feb 11 09:06:27 2008 @@ -0,0 +1,45 @@ +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for the uffi package +# Programer: Kevin M. Rosenberg, M.D. +# Date Started: Mar 2002 +# +# CVS Id: $Id$ +# +# This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg + +PKG:=uffi +DEBPKG=cl-uffi +SUBDIRS:= examples src benchmarks +DOCSUBDIRS:=doc + +include Makefile.common + + +.PHONY: all +all: + + +.PHONY: distclean +distclean: clean + @$(MAKE) -C doc $@ +# ./debian/rules clean + + +SOURCE_FILES=src doc examples Makefile uffi.system uffi.debian.system \ + benchmarks COPYRIGHT README TODO INSTALL ChangeLog NEWS \ + test-examples.cl set-logical.cl + +.PHONY: doc +doc: + $(MAKE) -C doc + +.PHONY: dist +dist: clean + $(MAKE) -C doc $@ + +.PHONY: TAGS +TAGS: + if [ -f TAGS ]; then mv -f TAGS TAGS~; fi + find . -name \*.lisp -exec /usr/bin/etags -a \{\} \; Added: branches/trunk-reorg/thirdparty/uffi/Makefile.common ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/Makefile.common Mon Feb 11 09:06:27 2008 @@ -0,0 +1,17 @@ +all: + + +.PHONY: clean +clean: + @rm -rf .bin + @rm -f *.ufsl *.fsl *.fas *.x86f *.sparcf *.fasl + @rm -f *.fasla8 *.fasla16 *.faslm8 *.faslm16 *.faslmt + @rm -f *~ *.bak *.orig *.err \#*\# .#* + @rm -f *.so *.a + @rm -rf debian/cl-uffi +ifneq ($(SUBDIRS)$(DOCSUBDIRS),) + @set -e; for i in $(SUBDIRS) $(DOCSUBDIRS); do \ + $(MAKE) -C $$i $@; done +endif + +.SUFFIXES: # No default suffixes Added: branches/trunk-reorg/thirdparty/uffi/NEWS ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/NEWS Mon Feb 11 09:06:27 2008 @@ -0,0 +1 @@ +UFFI now supports AllegroCL AMD64 Added: branches/trunk-reorg/thirdparty/uffi/README ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/README Mon Feb 11 09:06:27 2008 @@ -0,0 +1,20 @@ +Package: UFFI (Universal Foreign Language Interface) +Web site: http://uffi.b9.com +Author: Kevin M. Rosenberg + + +BRIEF DESCRIPTION +----------------- +uffi is a Common Lisp package for interfacing C-language compatible +libraries. Every Common Lisp implementation has a method for +interfacing to such libraries. Unfortunately, these method vary widely +amongst implementations. uffi gathers a common subset of functionality +between Common Lisp implementations. uffi wraps this common subset of +functionality into it's own syntax and provides macro translation of +uffi features into the specific syntax of supported Common Lisp +implementations. + +Currently, AllegroCL (Linux and Microsoft Windows), Lispworks (Linux +and Microsoft Windows), CMUCL, SBCL, and OpenMCL are supported. + + Added: branches/trunk-reorg/thirdparty/uffi/TODO ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/TODO Mon Feb 11 09:06:27 2008 @@ -0,0 +1,7 @@ +- Run test-suite on MCL port + +- Add OpenMCL support for with-cast-pointer and def-foreign-var + +- Add support for direct vector passing to and from foreign functions + to avoid copying elements in and out of vector. + Added: branches/trunk-reorg/thirdparty/uffi/benchmarks/Makefile ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/benchmarks/Makefile Mon Feb 11 09:06:27 2008 @@ -0,0 +1,6 @@ +SUBDIRS := + +include ../Makefile.common + +.PHONY: distclean +distclean: clean Added: branches/trunk-reorg/thirdparty/uffi/benchmarks/allocation.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/benchmarks/allocation.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,126 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: allocation.cl +;;;; Purpose: Benchmark allocation and slot-access speed +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :cl-user) + + +(defun stk-int () + #+allegro + (ff:with-stack-fobject (ptr :int) + (setf (ff:fslot-value ptr) 0)) + #+lispworks + (fli:with-dynamic-foreign-objects ((ptr :int)) + (setf (fli:dereference ptr) 0)) + #+cmu + (alien:with-alien ((ptr alien:signed)) + (let ((p (alien:addr ptr))) + (setf (alien:deref p) 0))) + #+sbcl + (sb-alien:with-alien ((ptr sb-alien:signed)) + (let ((p (sb-alien:addr ptr))) + (setf (sb-alien:deref p) 0))) + ) + +(defun stk-vector () + #+allegro + (ff:with-stack-fobject (ptr '(:array :int 10) ) + (setf (ff:fslot-value ptr 5) 0)) + #+lispworks + (fli:with-dynamic-foreign-objects ((ptr (:c-array :int 10))) + (setf (fli:dereference ptr 5) 0)) + #+cmu + (alien:with-alien ((ptr (alien:array alien:signed 10))) + (setf (alien:deref ptr 5) 0)) + #+sbcl + (sb-alien:with-alien ((ptr (sb-alien:array sb-alien:signed 10))) + (setf (sb-alien:deref ptr 5) 0)) + ) + +(defun stat-int () + #+allegro + (let ((ptr (ff:allocate-fobject :int :c))) + (declare (dynamic-extent ptr)) + (setf (ff:fslot-value-typed :int :c ptr) 0) + (ff:free-fobject ptr)) + #+lispworks + (let ((ptr (fli:allocate-foreign-object :type :int))) + (declare (dynamic-extent ptr)) + (setf (fli:dereference ptr) 0) + (fli:free-foreign-object ptr)) + #+cmu + (let ((ptr (alien:make-alien (alien:signed 32)))) + (declare ;;(type (alien (* (alien:unsigned 32))) ptr) + (dynamic-extent ptr)) + (setf (alien:deref ptr) 0) + (alien:free-alien ptr)) + #+sbcl + (let ((ptr (sb-alien:make-alien (sb-alien:signed 32)))) + (declare ;;(type (alien (* (alien:unsigned 32))) ptr) + (dynamic-extent ptr)) + (setf (sb-alien:deref ptr) 0) + (sb-alien:free-alien ptr)) + ) + +(defun stat-vector () + #+allegro + (let ((ptr (ff:allocate-fobject '(:array :int 10) :c))) + (declare (dynamic-extent ptr)) + (setf (ff:fslot-value-typed '(:array :int 10) :c ptr 5) 0) + (ff:free-fobject ptr)) + #+lispworks + (let ((ptr (fli:allocate-foreign-object :type '(:c-array :int 10)))) + (declare (dynamic-extent ptr)) + (setf (fli:dereference ptr 5) 0) + (fli:free-foreign-object ptr)) + #+cmu + (let ((ptr (alien:make-alien (alien:array (alien:signed 32) 10)))) + (declare ;;(type (alien (* (alien:unsigned 32))) ptr) + (dynamic-extent ptr)) + (setf (alien:deref ptr 5) 0) + (alien:free-alien ptr)) + #+sbcl + (let ((ptr (sb-alien:make-alien (sb-alien:array (sb-alien:signed 32) 10)))) + (declare ;;(type (sb-alien (* (sb-alien:unsigned 32))) ptr) + (dynamic-extent ptr)) + (setf (sb-alien:deref ptr 5) 0) + (sb-alien:free-alien ptr)) + ) + + +(defun stk-vs-stat () + (format t "~&Stack allocation, Integer") + (time (dotimes (i 1000) + (dotimes (j 1000) + (stk-int)))) + (format t "~&Static allocation, Integer") + (time (dotimes (i 1000) + (dotimes (j 1000) + (stat-int)))) + (format t "~&Stack allocation, Vector") + (time (dotimes (i 1000) + (dotimes (j 1000) + (stk-int)))) + (format t "~&Static allocation, Vector") + (time (dotimes (i 1000) + (dotimes (j 1000) + (stat-int)))) +) + + +(stk-vs-stat) + + + Added: branches/trunk-reorg/thirdparty/uffi/debian/README.Debian ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/debian/README.Debian Mon Feb 11 09:06:27 2008 @@ -0,0 +1,7 @@ +The Debian Package CL-UFFI +-------------------------- + +This is the UFFI Common Lisp system packaged for Debian by +Kevin M. Rosenberg <kmr(a)debian.org>, April 2002. + +The home page for UFFI is http://uffi.med-info.com/ Added: branches/trunk-reorg/thirdparty/uffi/debian/changelog ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/debian/changelog Mon Feb 11 09:06:27 2008 @@ -0,0 +1,872 @@ +cl-uffi (1.6.0-1) unstable; urgency=low + + * New upstream (closes: 433814) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 22 Jul 2007 12:39:49 -0600 + +cl-uffi (1.5.18-3) unstable; urgency=low + + * debian/watch: New version + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 18 Jul 2007 20:27:04 -0600 + +cl-uffi (1.5.18-2) unstable; urgency=low + + * Fix build twice in a row (closes: 424155) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 22 May 2007 11:33:27 -0600 + +cl-uffi (1.5.18-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 12 Apr 2007 23:48:46 -0600 + +cl-uffi (1.5.17-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 10 Oct 2006 08:34:43 -0600 + +cl-uffi (1.5.16-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 02 Sep 2006 20:31:11 -0600 + +cl-uffi (1.5.15-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 14 Aug 2006 00:21:47 -0600 + +cl-uffi (1.5.14-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 4 Jul 2006 19:23:10 -0600 + +cl-uffi (1.5.13-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 17 May 2006 09:08:58 -0600 + +cl-uffi (1.5.12-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 17 May 2006 08:09:13 -0600 + +cl-uffi (1.5.11-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 9 May 2006 09:33:59 -0600 + +cl-uffi (1.5.10-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 17 Apr 2006 18:05:56 -0600 + +cl-uffi (1.5.9-1) unstable; urgency=low + + * add GNU uname (closes: 355924) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 8 Mar 2006 12:06:17 -0700 + +cl-uffi (1.5.8-1) unstable; urgency=low + + * Really commit patch for GNU/kFreeBSD (closes: 345220) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 16 Jan 2006 14:47:08 -0700 + +cl-uffi (1.5.7-2) unstable; urgency=low + + * Commit patch for GNU/kFreeBSD (closes: 345220) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 31 Dec 2005 11:11:36 -0700 + +cl-uffi (1.5.7-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 14 Nov 2005 19:39:25 -0700 + +cl-uffi (1.5.6-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 14 Nov 2005 12:02:07 -0700 + +cl-uffi (1.5.5-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 4 Nov 2005 11:59:50 -0700 + +cl-uffi (1.5.4-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 18 Sep 2005 01:22:50 -0600 + +cl-uffi (1.5.3-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 17 Sep 2005 23:44:20 -0600 + +cl-uffi (1.5.2-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 17 Sep 2005 22:48:11 -0600 + +cl-uffi (1.5.1-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 6 Jul 2005 21:29:46 -0600 + +cl-uffi (1.5.0-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 5 Jul 2005 19:03:23 -0600 + +cl-uffi (1.4.39-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 8 Jun 2005 18:37:06 -0600 + +cl-uffi (1.4.38-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 08 Jun 2005 10:42:10 -0600 + +cl-uffi (1.4.37-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 13 Apr 2005 12:42:41 -0600 + +cl-uffi (1.4.36-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 6 Apr 2005 11:42:09 -0600 + +cl-uffi (1.4.35-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 4 Apr 2005 14:35:10 -0600 + +cl-uffi (1.4.34-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 3 Apr 2005 17:55:49 -0600 + +cl-uffi (1.4.33-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 2 Mar 2005 12:25:43 -0700 + +cl-uffi (1.4.32-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 22 Feb 2005 10:10:03 -0700 + +cl-uffi (1.4.31-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 22 Jan 2005 17:27:37 -0700 + +cl-uffi (1.4.30-1) unstable; urgency=low + + * New upstream, handle sb-unicode + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 8 Nov 2004 19:30:11 -0700 + +cl-uffi (1.4.29-1) unstable; urgency=low + + * New upstream, revert patch that broken clsql on debian + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 30 Oct 2004 11:30:14 -0600 + +cl-uffi (1.4.28-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 23 Oct 2004 09:05:50 -0600 + +cl-uffi (1.4.27-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 21 Oct 2004 16:44:11 -0600 + +cl-uffi (1.4.26-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 9 Sep 2004 22:20:47 -0600 + +cl-uffi (1.4.25-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 27 Aug 2004 06:33:16 -0600 + +cl-uffi (1.4.24-1) unstable; urgency=low + + * Fix for OpenMCL from James Bielman + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 15 Jul 2004 09:27:22 -0600 + +cl-uffi (1.4.23-1) unstable; urgency=low + + * Add support for new SBCL load-shared-object [supplied by Andreas Fuchs] + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 13 Jul 2004 09:19:32 -0600 + +cl-uffi (1.4.22-1) unstable; urgency=low + + * OpenMCL fix + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 23 Jun 2004 12:36:24 -0600 + +cl-uffi (1.4.21-1) unstable; urgency=low + + * Fix for WITH-FOREIGN-OBJECT macro on CMUCL + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 10 Jun 2004 00:17:31 -0600 + +cl-uffi (1.4.20-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 20 May 2004 09:59:07 -0600 + +cl-uffi (1.4.19-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 19 May 2004 12:16:03 -0600 + +cl-uffi (1.4.18-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 18 May 2004 15:40:58 -0600 + +cl-uffi (1.4.17-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 15 May 2004 11:02:22 -0600 + +cl-uffi (1.4.16-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 13 May 2004 04:23:13 -0600 + +cl-uffi (1.4.15-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 12 May 2004 22:40:39 -0600 + +cl-uffi (1.4.14-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 12 May 2004 12:48:13 -0600 + +cl-uffi (1.4.13-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 6 May 2004 10:14:10 -0600 + +cl-uffi (1.4.12-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 17 Apr 2004 12:26:00 -0600 + +cl-uffi (1.4.11-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 15 Apr 2004 05:48:48 -0600 + +cl-uffi (1.4.10-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 15 Apr 2004 01:59:37 -0600 + +cl-uffi (1.4.9-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 13 Apr 2004 16:03:22 -0600 + +cl-uffi (1.4.8-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 13 Apr 2004 14:13:04 -0600 + +cl-uffi (1.4.7-1) unstable; urgency=low + + * Fix fast-native-to-string on 16-bit wide char Allegro + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 2 Apr 2004 14:20:36 -0700 + +cl-uffi (1.4.6-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 25 Nov 2003 06:37:14 -0700 + +cl-uffi (1.4.5-1) unstable; urgency=low + + * Change documentation encoding to ISO-8859-1 + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 20 Nov 2003 20:35:15 -0700 + +cl-uffi (1.4.4-1) unstable; urgency=low + + * Add patch from Vebjorn Ljosa for fast-native-to-string + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 18 Nov 2003 13:09:32 -0700 + +cl-uffi (1.4.3-1) unstable; urgency=low + + * Improved test/make.sh and uffi-tests.asd + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 11 Nov 2003 15:02:40 -0700 + +cl-uffi (1.4.2-1) unstable; urgency=low + + * Yet another attempt for asdf-install + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 11 Nov 2003 04:51:24 -0700 + +cl-uffi (1.4.1-1) unstable; urgency=low + + * Fix for asdf-install + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 11 Nov 2003 04:29:27 -0700 + +cl-uffi (1.4.0-1) unstable; urgency=low + + * Make UFFI asdf-installable + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 11 Nov 2003 03:28:06 -0700 + +cl-uffi (1.3.9-1) unstable; urgency=low + + * Use local XSL files, add Debian-specific catalog + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 11 Nov 2003 00:12:34 -0700 + +cl-uffi (1.3.8-1) unstable; urgency=low + + * Use XInclude for documentation + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 10 Nov 2003 22:39:33 -0700 + +cl-uffi (1.3.7-1) unstable; urgency=low + + * Convert documentation to Docbook XML with new processing commands + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 10 Nov 2003 20:38:28 -0700 + +cl-uffi (1.3.6-1) unstable; urgency=low + + * More MacOSX changes + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 31 Aug 2003 20:45:23 -0600 + +cl-uffi (1.3.5-1) unstable; urgency=low + + * Rework loading of foreign libraries to better support MacOSX, especially + sbcl + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 27 Aug 2003 10:01:11 -0600 + +cl-uffi (1.3.4-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 26 Aug 2003 07:29:19 -0600 + +cl-uffi (1.3.3-1) unstable; urgency=low + + * Add gettimeofday to tests + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 26 Aug 2003 07:29:07 -0600 + +cl-uffi (1.3.2-1) unstable; urgency=low + + * Patch from Edi Weitz + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 22 Aug 2003 19:03:06 -0600 + +cl-uffi (1.3.1-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 14 Aug 2003 18:27:32 -0600 + +cl-uffi (1.3.0-1) unstable; urgency=low + + * Add initial support and tests for def-foreign-var + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 14 Aug 2003 15:38:33 -0600 + +cl-uffi (1.2.23-1) unstable; urgency=low + + * New upstream with fixes suggested and patches submitted by Edi Weitz. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 14 Aug 2003 12:26:07 -0600 + +cl-uffi (1.2.22-1) unstable; urgency=low + + * New upstream with Lispworks patch from Edi Weitz + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 12 Aug 2003 08:09:04 -0600 + +cl-uffi (1.2.21-1) unstable; urgency=low + + * New upstream -- fix for Franz's mlisp + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 19 Jul 2003 14:15:52 -0600 + +cl-uffi (1.2.20-1) unstable; urgency=low + + * New upstream -- really fix bug + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 8 Jul 2003 06:37:58 -0600 + +cl-uffi (1.2.19-1) unstable; urgency=low + + * Fix bug in sbcl/load-library + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 7 Jul 2003 18:49:37 -0600 + +cl-uffi (1.2.18-1) unstable; urgency=low + + * New BSD license + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 26 Jun 2003 12:01:24 -0600 + +cl-uffi (1.2.17-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 12 Jun 2003 06:12:30 -0600 + +cl-uffi (1.2.16-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 12 Jun 2003 06:04:06 -0600 + +cl-uffi (1.2.15-1) unstable; urgency=low + + * Documentation improvement by Nikodemus Siivola + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 5 May 2003 15:57:32 -0600 + +cl-uffi (1.2.14-1) unstable; urgency=low + + * New upstream + * Add to debhelper to depends (closes:192001) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 5 May 2003 08:53:30 -0600 + +cl-uffi (1.2.13-1) unstable; urgency=low + + * Fix getenv test + * Work-around load-object-file bug in CMUCL in testing script + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 1 May 2003 17:31:21 -0600 + +cl-uffi (1.2.12-1) unstable; urgency=low + + * Finish converting examples into test suite + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 30 Apr 2003 08:11:42 -0600 + +cl-uffi (1.2.11-1) unstable; urgency=low + + * Add test suite, new binary package uffi-tests + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 29 Apr 2003 08:10:26 -0600 + +cl-uffi (1.2.10-1) unstable; urgency=low + + * Fix allegro free-cstring bug + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 28 Mar 2003 12:58:08 -0700 + +cl-uffi (1.2.9-1) unstable; urgency=low + + * change ccl:%put-cstring to ccl::%put-cstring for openmcl + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 12 Mar 2003 14:12:03 -0700 + +cl-uffi (1.2.8-1) unstable; urgency=low + + * Change output on compress.lisp example + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 10 Mar 2003 10:37:00 -0700 + +cl-uffi (1.2.7-1) unstable; urgency=low + + * Remove reference to obsolete Corman module in uffi.asd + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 19 Feb 2003 14:56:15 -0700 + +cl-uffi (1.2.6-1) unstable; urgency=low + + * Add :language :ansi-c for Lispworks def-function + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 5 Feb 2003 23:54:12 -0700 + +cl-uffi (1.2.5-1) unstable; urgency=low + + * Rework allocate-foreign-array to evaluate type + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 28 Dec 2002 01:12:30 -0700 + +cl-uffi (1.2.4-1) unstable; urgency=low + + * Fix syntax error from last version + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 13 Dec 2002 18:54:41 -0700 + +cl-uffi (1.2.3-1) unstable; urgency=low + + * More external format changes for lispworks (thanks Marc Battyani) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 13 Dec 2002 15:46:23 -0700 + +cl-uffi (1.2.2-1) unstable; urgency=low + + * Add external format parameters to lispworks to avoid translating stringsl + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 13 Dec 2002 14:26:17 -0700 + +cl-uffi (1.2.1-1) unstable; urgency=low + + * Add uncompression test + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 9 Dec 2002 09:05:52 -0700 + +cl-uffi (1.2.0-1) unstable; urgency=low + + * Fixes in allocate-foreign-object and deref-array for allegro + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 2 Dec 2002 23:59:43 -0700 + +cl-uffi (1.1.8-1) unstable; urgency=low + + * Reverse broken bug "fixes" + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 28 Nov 2002 11:47:26 -0700 + +cl-uffi (1.1.7.1-1) unstable; urgency=low + + * Another allegro bug (Thanks Matthew Danish) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 23 Nov 2002 12:06:40 -0700 + +cl-uffi (1.1.7-1) unstable; urgency=low + + * bug fixes on allegro + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 23 Nov 2002 11:03:18 -0700 + +cl-uffi (1.1.6-1) unstable; urgency=low + + * More documention of cstrings and foreign strings + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 21 Nov 2002 19:51:55 -0700 + +cl-uffi (1.1.5-1) unstable; urgency=low + + * Documentation changes + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 21 Nov 2002 18:35:26 -0700 + +cl-uffi (1.1.4-1) unstable; urgency=low + + * OpenMCL/MCL fixes + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 20 Nov 2002 14:03:16 -0700 + +cl-uffi (1.1.3-1) unstable; urgency=low + + * Fix OpenMCL default library pathname type + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 17 Nov 2002 22:28:59 -0700 + +cl-uffi (1.1.2-1) unstable; urgency=low + + * src/objects.lisp: Fix bug in allocate-foreign-object for AllegroCL + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 14 Nov 2002 15:10:41 -0700 + +cl-uffi (1.1.1-1) unstable; urgency=low + + * Remove 'load-compiled-op from .asd file + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 8 Nov 2002 09:49:49 -0700 + +cl-uffi (1.1.0-1) unstable; urgency=low + + * Add SCL support. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 15 Oct 2002 11:22:35 -0600 + +cl-uffi (1.0.1-1) unstable; urgency=low + + * Add SBCL to documentation + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 14 Oct 2002 01:18:05 -0600 + +cl-uffi (1.0.0-1) unstable; urgency=low + + * Initial SBCL compatibility + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 13 Oct 2002 19:01:31 -0600 + +cl-uffi (0.9.2-1) unstable; urgency=high + + * Add AUTHORS file + * Integrate Reini Urban's cormanlisp patches into main source + * Add Depends: version on Common Lisp Controller + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 1 Oct 2002 08:11:21 -0600 + +cl-uffi (0.9.1-1) unstable; urgency=low + + * Rename .cl files to .lisp files + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 30 Sep 2002 04:01:58 -0600 + +cl-uffi (0.9.0-1) unstable; urgency=low + + * Reorganize directories, merge MCL/OpenMCL into main code + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 30 Sep 2002 01:32:03 -0600 + +cl-uffi (0.8.6-1) unstable; urgency=low + + * Fix :pointer-self for OpenMCL. + * Multiple changes to support OpenMCL with CLSQL + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 30 Sep 2002 01:31:37 -0600 + +cl-uffi (0.8.5-1) unstable; urgency=low + + * Add with-cstrings macro to mcl's source + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 29 Sep 2002 12:19:20 -0600 + +cl-uffi (0.8.4-1) unstable; urgency=low + + * Change mcl's load-library definition from macro to function + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 29 Sep 2002 11:49:32 -0600 + +cl-uffi (0.8.3-1) unstable; urgency=low + + * New upstream release. Passes all tests with OpenMCL in Debian PPC. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 29 Sep 2002 11:32:05 -0600 + +cl-uffi (0.8.2-2) unstable; urgency=low + + * Add pathname to clc-register-impl invocation + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 25 Sep 2002 06:38:44 -0600 + +cl-uffi (0.8.2-1) unstable; urgency=low + + * Add conditionals to .asd file to control clc autobuilding + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 22 Sep 2002 21:00:57 -0600 + +cl-uffi (0.8.1-1) unstable; urgency=low + + * Fix size of openmcl's and mcl's integers + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 20 Sep 2002 07:06:31 -0600 + +cl-uffi (0.8.0-1) unstable; urgency=low + + * Adds support for openmcl, numerous changes from John Desoi + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 19 Sep 2002 21:09:17 -0600 + +cl-uffi (0.7.1-1) unstable; urgency=low + + * New upstream version + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 18 Sep 2002 01:57:10 -0600 + +cl-uffi (0.7.0-1) unstable; urgency=low + + * Remove .system file, restructure directories for .asd file without pathnames + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 16 Sep 2002 12:00:45 -0600 + +cl-uffi (0.6.3-1) unstable; urgency=low + + * New upstream version, fixes problem with .asd file. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 6 Sep 2002 04:59:45 -0600 + +cl-uffi (0.6.2-1) unstable; urgency=low + + * New upstream version. Restructure directories once again to handle + non-CLC systems. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 23 Aug 2002 09:33:14 -0600 + +cl-uffi (0.6.1-1) unstable; urgency=low + + * Add uffi.asd file to upstream for ASDF users. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 17 Aug 2002 18:50:12 -0600 + +cl-uffi (0.6.0-2) unstable; urgency=low + + * Update e-mail address + * Update Standards version + + -- Kevin M. Rosenberg <kmr(a)debian.org> Mon, 12 Aug 2002 00:01:27 -0600 + +cl-uffi (0.6.0-1) unstable; urgency=low + + * New upstream version (Restructure directories to improve Common Lisp + Controller compatibility.) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 25 Jul 2002 21:24:53 -0600 + +cl-uffi (0.5.1-1) unstable; urgency=low + + * Rework upstream documentation. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 9 Jul 2002 12:45:56 -0600 + +cl-uffi (0.5.0-2) unstable; urgency=low + + * Add the LLGPL text to the copyright file. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 7 Jul 2002 15:40:05 -0600 + +cl-uffi (0.5.0-1) unstable; urgency=low + + * New upstream version + + * Additions to the copyright file to comply with Debian Policy + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 28 Jun 2002 11:16:28 -0600 + +cl-uffi (0.4.8-1) unstable; urgency=low + + * New upstream version + + -- Kevin M. Rosenberg <kmr(a)debian.org> Wed, 26 Jun 2002 21:35:07 -0600 + +cl-uffi (0.4.5-2) unstable; urgency=low + + * Fix Build-Depends-Indep + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 25 Jun 2002 06:12:19 -0600 + +cl-uffi (0.4.5-1) unstable; urgency=low + + * New upstream version. + + * Remove deprecated repository + + * Migrate to Debhelper V4 + + * Changed Maintainer: field from sponsor to sponsoree/packager + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 20 Jun 2002 07:43:53 -0600 + +cl-uffi (0.4.4-8) unstable; urgency=low + + * Improved control file in anticipation of having dpkg-buildpackage + generate the documentation rather than putting the documentation in + the upstream archive. + * Remade package to include upstream sources. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 5 May 2002 11:17:52 -0600 + +cl-uffi (0.4.4-7) unstable; urgency=low + + * Modified make-dist.sh to use cvs-buildpackage, added options + * Cleaned debian/rules, debian/copyright + * First version to upload. (closes: #145723) + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sat, 4 May 2002 16:03:11 -0600 + +cl-uffi (0.4.4-6) unstable; urgency=low + + * Fixed Maintainer and Uploader fields in debian control + + -- Kevin M. Rosenberg <kmr(a)debian.org> Fri, 3 May 2002 09:11:47 -0600 + +cl-uffi (0.4.4-5) unstable; urgency=low + + * Commented-out DH_VERBOSE flag. + * Uses debian/dirs with debhelper. + * Changed doc-base section to programming. + * Added Uploaders field to debian/control. + * Made .system file be a symbolic link to .system file in repository. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 2 May 2002 15:37:50 -0600 + +cl-uffi (0.4.4-4) unstable; urgency=low + + * Added upstream ChangeLog to debian distribution. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Tue, 30 Apr 2002 13:01:12 -0600 + +cl-uffi (0.4.4-3) unstable; urgency=low + + * Modified make-dist.sh to create better .diff.gz + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 28 Apr 2002 06:38:48 -0600 + +cl-uffi (0.4.4-2) unstable; urgency=low + + * Improved source code archive for debian upload. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Sun, 28 Apr 2002 03:04:52 -0600 + +cl-uffi (0.4.4-1) unstable; urgency=low + + * Initial package. + + -- Kevin M. Rosenberg <kmr(a)debian.org> Thu, 25 Apr 2002 19:13:41 -0600 + Added: branches/trunk-reorg/thirdparty/uffi/debian/cl-uffi.doc-base ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/debian/cl-uffi.doc-base Mon Feb 11 09:06:27 2008 @@ -0,0 +1,17 @@ +Document: cl-uffi +Title: UFFI Manual +Author: Kevin M. Rosenberg +Abstract: This manual describes the + use the UFFI (Universal Foreign Function Interface) + Common Lisp library. This library supports CMUCL, SBCL, + AllegroCL, Lispworks, SCL, OpenMCL, and MCL. +Section: programming + +Format: PDF +Files: /usr/share/doc/cl-uffi/cl-uffi.pdf.gz + +Format: HTML +Index: /usr/share/doc/cl-uffi/html/index.html +Files: /usr/share/doc/cl-uffi/html/*.html + + Added: branches/trunk-reorg/thirdparty/uffi/debian/compat ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/debian/compat Mon Feb 11 09:06:27 2008 @@ -0,0 +1 @@ +4 Added: branches/trunk-reorg/thirdparty/uffi/debian/control ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/debian/control Mon Feb 11 09:06:27 2008 @@ -0,0 +1,23 @@ +Source: cl-uffi +Section: devel +Priority: optional +Maintainer: Kevin M. Rosenberg <kmr(a)debian.org> +Build-Depends: zlib1g-dev,debhelper (>= 4.0.0) +Standards-Version: 3.7.2.2 + +Package: cl-uffi +Architecture: all +Depends: common-lisp-controller (>= 3.37) +Recommends: cl-uffi-tests +Description: Universal Foreign Function Library for Common Lisp + UFFI provides a universal foreign function interface (FFI) for + Common Lisp. + UFFI supports AllegroCL, CMUCL, Lispworks, MCL, OpenMCL, + SBCL, and SCL. + +Package: cl-uffi-tests +Architecture: any +Depends: common-lisp-controller (>= 3.37), cl-uffi, zlib1g-dev +Description: Regression tests for UFFI Common Lisp Library + This is a test of regression tests for UFFI. Besides providing + testing for UFFI, the tests serve as an example of UFFI usage. Added: branches/trunk-reorg/thirdparty/uffi/debian/copyright ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/debian/copyright Mon Feb 11 09:06:27 2008 @@ -0,0 +1,34 @@ +Debian Copyright Section +======================== + +Upstream Source URL: http://files.b9.com/uffi +Upstream Author: Kevin Rosenberg <kevin(a)rosenberg.net> +Debian Maintainer: Kevin M. Rosenberg <kmr(a)debian.org> + + +Copyright (c) 2001-2003 Kevin M. Rosenberg and contributors. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of the contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/uffi/debian/cvsbp-prepare.sh ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/debian/cvsbp-prepare.sh Mon Feb 11 09:06:27 2008 @@ -0,0 +1,9 @@ +#!/bin/bash + +set -e # abort on error + +# Clean checked out CVS directory +rm -f debian/upload.sh debian/make-upstream.sh debian/make-debian.sh +rm -f `find . -type f -name .cvsignore` +rm -f stamp-h.in build-stamp configure-stamp +rm -f debian/cvsbp-prepare.sh Added: branches/trunk-reorg/thirdparty/uffi/debian/docs ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/debian/docs Mon Feb 11 09:06:27 2008 @@ -0,0 +1,4 @@ +NEWS +README +TODO +AUTHORS Added: branches/trunk-reorg/thirdparty/uffi/debian/make-upstream.sh ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/debian/make-upstream.sh Mon Feb 11 09:06:27 2008 @@ -0,0 +1,6 @@ +#!/bin/bash -e + +bups uffi -d"-name .bin" + +exit 0 + Added: branches/trunk-reorg/thirdparty/uffi/debian/postinst ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/debian/postinst Mon Feb 11 09:06:27 2008 @@ -0,0 +1,52 @@ +#! /bin/sh +# postinst script for uffi +# +# see: dh_installdeb(1) + +set -e + +# package name according to lisp +LISP_PKG=uffi + +# summary of how this script can be called: +# * <postinst> `configure' <most-recently-configured-version> +# * <old-postinst> `abort-upgrade' <new version> +# * <conflictor's-postinst> `abort-remove' `in-favour' <package> +# <new-version> +# * <deconfigured's-postinst> `abort-deconfigure' `in-favour' +# <failed-install-package> <version> `removing' +# <conflicting-package> <version> +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package +# +# quoting from the policy: +# Any necessary prompting should almost always be confined to the +# post-installation script, and should be protected with a conditional +# so that unnecessary prompting doesn't happen if a package's +# installation fails and the `postinst' is called with `abort-upgrade', +# `abort-remove' or `abort-deconfigure'. + +case "$1" in + configure) + #clc-only-compatible $LISP_PKG allegro cmucl lispworks openmcl sbcl scl + /usr/sbin/register-common-lisp-source $LISP_PKG + ;; + + abort-upgrade|abort-remove|abort-deconfigure) + + ;; + + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + Added: branches/trunk-reorg/thirdparty/uffi/debian/preinst ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/debian/preinst Mon Feb 11 09:06:27 2008 @@ -0,0 +1,23 @@ +#!/bin/bash +# This is part of uffi program: +# http://uffi.med-info.com +# +# Copyright (c) 2002 Kevin M. Rosenberg <kmr(a)debian.org> + +pkg=uffi +dir=/usr/share/common-lisp/source/$pkg + +case "$1" in + install|upgrade|abort-upgrade) + # Remove any old versions + test -h $dir && rm $dir + rm -rf ${dir}-[0-9\.]* + ;; + *) + echo "preinst called with unknown argument '$1'" >&2 + ;; +esac + +#DEBHELPER# + +exit 0 Added: branches/trunk-reorg/thirdparty/uffi/debian/prerm ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/debian/prerm Mon Feb 11 09:06:27 2008 @@ -0,0 +1,42 @@ +#! /bin/sh +# prerm script for uffi +# +# see: dh_installdeb(1) + +set -e + +# package name according to lisp +LISP_PKG=uffi + +# summary of how this script can be called: +# * <prerm> `remove' +# * <old-prerm> `upgrade' <new-version> +# * <new-prerm> `failed-upgrade' <old-version> +# * <conflictor's-prerm> `remove' `in-favour' <package> <new-version> +# * <deconfigured's-prerm> `deconfigure' `in-favour' +# <package-being-installed> <version> `removing' +# <conflicting-package> <version> +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package + + +case "$1" in + remove|upgrade|deconfigure) + /usr/sbin/unregister-common-lisp-source $LISP_PKG + ;; + failed-upgrade) + ;; + *) + echo "prerm called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + Added: branches/trunk-reorg/thirdparty/uffi/debian/rules ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/debian/rules Mon Feb 11 09:06:27 2008 @@ -0,0 +1,127 @@ +#!/usr/bin/make -f + +pkg := uffi +pkg-tests := $(pkg)-tests +debpkg := cl-$(pkg) +debpkg-tests := $(debpkg)-tests + + +clc-source := usr/share/common-lisp/source +clc-systems := usr/share/common-lisp/systems +clc-files := $(clc-source)/$(pkg) +clc-tests := $(clc-source)/$(pkg-tests) +doc-dir := usr/share/doc/$(debpkg) +lib-dir := usr/lib/uffi + +configure: configure-stamp +configure-stamp: + dh_testdir + # Add here commands to configure the package. + touch configure-stamp + + +build: build-stamp + +build-stamp: configure-stamp + dh_testdir + # Add here commands to compile the package. + (cd tests; make) + touch build-stamp + +clean: + dh_testdir + dh_testroot + rm -f build-stamp configure-stamp + # Add here commands to clean up after the build process. + $(MAKE) clean + (cd tests; make clean) + rm -f debian/$(debpkg).postinst.* debian/$(debpkg).prerm.* + rm -f doc/cl-uffi.pdf.gz + dh_clean + +install: build + dh_testdir + dh_testroot + dh_clean -k + dh_installdirs --all $(clc-systems) $(clc-source) + + # Add here commands to install the package into debian/uffi. + dh_installdirs -p $(debpkg) $(doc-dir) $(clc-files)/src + dh_install $(pkg).asd $(clc-files) + dh_install "src/*.lisp" $(clc-files)/src + dh_link $(clc-files)/$(pkg).asd $(clc-systems)/$(pkg).asd + + rm -rf doc/html + (cd doc; tar xzf html.tar.gz; cd ..) + dh_install doc/html $(doc-dir) + rm -rf doc/html + cp doc/uffi.pdf doc/cl-uffi.pdf + rm -f doc/cl-uffi.pdf.gz # ensure file not present before making gz + gzip -9 doc/cl-uffi.pdf + dh_install doc/cl-uffi.pdf.gz $(doc-dir) + + dh_installdirs -p $(debpkg-tests) $(clc-tests)/tests $(lib-dir) + dh_install -p $(debpkg-tests) $(pkg-tests).asd $(clc-tests) + dh_install -p $(debpkg-tests) tests/*.lisp tests/*.c $(clc-tests)/tests + dh_install -p $(debpkg-tests) tests/*.so $(lib-dir) + dh_link -p $(debpkg-tests) $(clc-tests)/$(pkg-tests).asd $(clc-systems)/$(pkg-tests).asd + +# Build architecture-independent files here. +binary-indep: build install + dh_testdir -i + dh_testroot -i +# dh_installdebconf -i + dh_installdocs -i + dh_installexamples -i examples/*.lisp + dh_installmenu -i +# dh_installlogrotate -i +# dh_installemacsen -i +# dh_installpam -i +# dh_installmime -i +# dh_installinit -i + dh_installcron -i +# dh_installman -i + dh_installinfo -i +# dh_undocumented -i + dh_installchangelogs ChangeLog -i + dh_link -i + dh_compress -i + dh_fixperms -i + dh_installdeb -i +# dh_perl -i + dh_gencontrol -i + dh_md5sums -i + dh_builddeb -i + +# Build architecture-dependent files here. +binary-arch: build install + dh_testdir -a + dh_testroot -a +# dh_installdebconf -a + dh_installdocs -a +# dh_installlogrotate -a +# dh_installemacsen -a +# dh_installpam -a +# dh_installmime -a +# dh_installinit -a +# dh_installcron -a +# dh_installman -a +# dh_installinfo -a +# dh_undocumented -a +# dh_makeshlibs -a +# dh_perl -a + dh_installchangelogs ChangeLog -a + dh_strip -a + dh_link -a + dh_compress -a + dh_fixperms -a + dh_installmenu -a + dh_installdeb -a + dh_gencontrol -a + dh_shlibdeps -a + dh_md5sums -a + dh_builddeb -a + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary install configure + Added: branches/trunk-reorg/thirdparty/uffi/debian/upload.sh ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/debian/upload.sh Mon Feb 11 09:06:27 2008 @@ -0,0 +1,4 @@ +#!/bin/bash -e + +dup uffi -Ufiles.b9.com -D/home/ftp/uffi -su \ + -C"(umask 022; cd /opt/apache/htdocs/uffi; make install; find . -type d |xargs chmod go+rx; find . -type f | xargs chmod go+r)" $* Added: branches/trunk-reorg/thirdparty/uffi/debian/watch ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/debian/watch Mon Feb 11 09:06:27 2008 @@ -0,0 +1,2 @@ +version=3 +http://files.b9.com/uffi/uffi-([\d\.]*)\.tar\.gz debian uupdate Added: branches/trunk-reorg/thirdparty/uffi/doc/COPYING.GFDL ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/COPYING.GFDL Mon Feb 11 09:06:27 2008 @@ -0,0 +1,330 @@ + GNU Free Documentation License + Version 1.1, March 2000 + + Copyright (C) 2000 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + +0. PREAMBLE + +The purpose of this License is to make a manual, textbook, or other +written document "free" in the sense of freedom: to assure everyone +the effective freedom to copy and redistribute it, with or without +modifying it, either commercially or noncommercially. Secondarily, +this License preserves for the author and publisher a way to get +credit for their work, while not being considered responsible for +modifications made by others. + +This License is a kind of "copyleft", which means that derivative +works of the document must themselves be free in the same sense. It +complements the GNU General Public License, which is a copyleft +license designed for free software. + +We have designed this License in order to use it for manuals for free +software, because free software needs free documentation: a free +program should come with manuals providing the same freedoms that the +software does. But this License is not limited to software manuals; +it can be used for any textual work, regardless of subject matter or +whether it is published as a printed book. We recommend this License +principally for works whose purpose is instruction or reference. + + +1. APPLICABILITY AND DEFINITIONS + +This License applies to any manual or other work that contains a +notice placed by the copyright holder saying it can be distributed +under the terms of this License. The "Document", below, refers to any +such manual or work. Any member of the public is a licensee, and is +addressed as "you". + +A "Modified Version" of the Document means any work containing the +Document or a portion of it, either copied verbatim, or with +modifications and/or translated into another language. + +A "Secondary Section" is a named appendix or a front-matter section of +the Document that deals exclusively with the relationship of the +publishers or authors of the Document to the Document's overall subject +(or to related matters) and contains nothing that could fall directly +within that overall subject. (For example, if the Document is in part a +textbook of mathematics, a Secondary Section may not explain any +mathematics.) The relationship could be a matter of historical +connection with the subject or with related matters, or of legal, +commercial, philosophical, ethical or political position regarding +them. + +The "Invariant Sections" are certain Secondary Sections whose titles +are designated, as being those of Invariant Sections, in the notice +that says that the Document is released under this License. + +The "Cover Texts" are certain short passages of text that are listed, +as Front-Cover Texts or Back-Cover Texts, in the notice that says that +the Document is released under this License. + +A "Transparent" copy of the Document means a machine-readable copy, +represented in a format whose specification is available to the +general public, whose contents can be viewed and edited directly and +straightforwardly with generic text editors or (for images composed of +pixels) generic paint programs or (for drawings) some widely available +drawing editor, and that is suitable for input to text formatters or +for automatic translation to a variety of formats suitable for input +to text formatters. A copy made in an otherwise Transparent file +format whose markup has been designed to thwart or discourage +subsequent modification by readers is not Transparent. A copy that is +not "Transparent" is called "Opaque". + +Examples of suitable formats for Transparent copies include plain +ASCII without markup, Texinfo input format, LaTeX input format, SGML +or XML using a publicly available DTD, and standard-conforming simple +HTML designed for human modification. Opaque formats include +PostScript, PDF, proprietary formats that can be read and edited only +by proprietary word processors, SGML or XML for which the DTD and/or +processing tools are not generally available, and the +machine-generated HTML produced by some word processors for output +purposes only. + +The "Title Page" means, for a printed book, the title page itself, +plus such following pages as are needed to hold, legibly, the material +this License requires to appear in the title page. For works in +formats which do not have any title page as such, "Title Page" means +the text near the most prominent appearance of the work's title, +preceding the beginning of the body of the text. + + +2. VERBATIM COPYING + +You may copy and distribute the Document in any medium, either +commercially or noncommercially, provided that this License, the +copyright notices, and the license notice saying this License applies +to the Document are reproduced in all copies, and that you add no other +conditions whatsoever to those of this License. You may not use +technical measures to obstruct or control the reading or further +copying of the copies you make or distribute. However, you may accept +compensation in exchange for copies. If you distribute a large enough +number of copies you must also follow the conditions in section 3. + +You may also lend copies, under the same conditions stated above, and +you may publicly display copies. + + +3. COPYING IN QUANTITY + +If you publish printed copies of the Document numbering more than 100, +and the Document's license notice requires Cover Texts, you must enclose +the copies in covers that carry, clearly and legibly, all these Cover +Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on +the back cover. Both covers must also clearly and legibly identify +you as the publisher of these copies. The front cover must present +the full title with all words of the title equally prominent and +visible. You may add other material on the covers in addition. +Copying with changes limited to the covers, as long as they preserve +the title of the Document and satisfy these conditions, can be treated +as verbatim copying in other respects. + +If the required texts for either cover are too voluminous to fit +legibly, you should put the first ones listed (as many as fit +reasonably) on the actual cover, and continue the rest onto adjacent +pages. + +If you publish or distribute Opaque copies of the Document numbering +more than 100, you must either include a machine-readable Transparent +copy along with each Opaque copy, or state in or with each Opaque copy +a publicly-accessible computer-network location containing a complete +Transparent copy of the Document, free of added material, which the +general network-using public has access to download anonymously at no +charge using public-standard network protocols. If you use the latter +option, you must take reasonably prudent steps, when you begin +distribution of Opaque copies in quantity, to ensure that this +Transparent copy will remain thus accessible at the stated location +until at least one year after the last time you distribute an Opaque +copy (directly or through your agents or retailers) of that edition to +the public. + +It is requested, but not required, that you contact the authors of the +Document well before redistributing any large number of copies, to give +them a chance to provide you with an updated version of the Document. + + +4. MODIFICATIONS + +You may copy and distribute a Modified Version of the Document under +the conditions of sections 2 and 3 above, provided that you release +the Modified Version under precisely this License, with the Modified +Version filling the role of the Document, thus licensing distribution +and modification of the Modified Version to whoever possesses a copy +of it. In addition, you must do these things in the Modified Version: + +A. Use in the Title Page (and on the covers, if any) a title distinct + from that of the Document, and from those of previous versions + (which should, if there were any, be listed in the History section + of the Document). You may use the same title as a previous version + if the original publisher of that version gives permission. +B. List on the Title Page, as authors, one or more persons or entities + responsible for authorship of the modifications in the Modified + Version, together with at least five of the principal authors of the + Document (all of its principal authors, if it has less than five). +C. State on the Title page the name of the publisher of the + Modified Version, as the publisher. +D. Preserve all the copyright notices of the Document. +E. Add an appropriate copyright notice for your modifications + adjacent to the other copyright notices. +F. Include, immediately after the copyright notices, a license notice + giving the public permission to use the Modified Version under the + terms of this License, in the form shown in the Addendum below. +G. Preserve in that license notice the full lists of Invariant Sections + and required Cover Texts given in the Document's license notice. +H. Include an unaltered copy of this License. +I. Preserve the section entitled "History", and its title, and add to + it an item stating at least the title, year, new authors, and + publisher of the Modified Version as given on the Title Page. If + there is no section entitled "History" in the Document, create one + stating the title, year, authors, and publisher of the Document as + given on its Title Page, then add an item describing the Modified + Version as stated in the previous sentence. +J. Preserve the network location, if any, given in the Document for + public access to a Transparent copy of the Document, and likewise + the network locations given in the Document for previous versions + it was based on. These may be placed in the "History" section. + You may omit a network location for a work that was published at + least four years before the Document itself, or if the original + publisher of the version it refers to gives permission. +K. In any section entitled "Acknowledgements" or "Dedications", + preserve the section's title, and preserve in the section all the + substance and tone of each of the contributor acknowledgements + and/or dedications given therein. +L. Preserve all the Invariant Sections of the Document, + unaltered in their text and in their titles. Section numbers + or the equivalent are not considered part of the section titles. +M. Delete any section entitled "Endorsements". Such a section + may not be included in the Modified Version. +N. Do not retitle any existing section as "Endorsements" + or to conflict in title with any Invariant Section. + +If the Modified Version includes new front-matter sections or +appendices that qualify as Secondary Sections and contain no material +copied from the Document, you may at your option designate some or all +of these sections as invariant. To do this, add their titles to the +list of Invariant Sections in the Modified Version's license notice. +These titles must be distinct from any other section titles. + +You may add a section entitled "Endorsements", provided it contains +nothing but endorsements of your Modified Version by various +parties--for example, statements of peer review or that the text has +been approved by an organization as the authoritative definition of a +standard. + +You may add a passage of up to five words as a Front-Cover Text, and a +passage of up to 25 words as a Back-Cover Text, to the end of the list +of Cover Texts in the Modified Version. Only one passage of +Front-Cover Text and one of Back-Cover Text may be added by (or +through arrangements made by) any one entity. If the Document already +includes a cover text for the same cover, previously added by you or +by arrangement made by the same entity you are acting on behalf of, +you may not add another; but you may replace the old one, on explicit +permission from the previous publisher that added the old one. + +The author(s) and publisher(s) of the Document do not by this License +give permission to use their names for publicity for or to assert or +imply endorsement of any Modified Version. + + +5. COMBINING DOCUMENTS + +You may combine the Document with other documents released under this +License, under the terms defined in section 4 above for modified +versions, provided that you include in the combination all of the +Invariant Sections of all of the original documents, unmodified, and +list them all as Invariant Sections of your combined work in its +license notice. + +The combined work need only contain one copy of this License, and +multiple identical Invariant Sections may be replaced with a single +copy. If there are multiple Invariant Sections with the same name but +different contents, make the title of each such section unique by +adding at the end of it, in parentheses, the name of the original +author or publisher of that section if known, or else a unique number. +Make the same adjustment to the section titles in the list of +Invariant Sections in the license notice of the combined work. + +In the combination, you must combine any sections entitled "History" +in the various original documents, forming one section entitled +"History"; likewise combine any sections entitled "Acknowledgements", +and any sections entitled "Dedications". You must delete all sections +entitled "Endorsements." + + +6. COLLECTIONS OF DOCUMENTS + +You may make a collection consisting of the Document and other documents +released under this License, and replace the individual copies of this +License in the various documents with a single copy that is included in +the collection, provided that you follow the rules of this License for +verbatim copying of each of the documents in all other respects. + +You may extract a single document from such a collection, and distribute +it individually under this License, provided you insert a copy of this +License into the extracted document, and follow this License in all +other respects regarding verbatim copying of that document. + + +7. AGGREGATION WITH INDEPENDENT WORKS + +A compilation of the Document or its derivatives with other separate +and independent documents or works, in or on a volume of a storage or +distribution medium, does not as a whole count as a Modified Version +of the Document, provided no compilation copyright is claimed for the +compilation. Such a compilation is called an "aggregate", and this +License does not apply to the other self-contained works thus compiled +with the Document, on account of their being thus compiled, if they +are not themselves derivative works of the Document. + +If the Cover Text requirement of section 3 is applicable to these +copies of the Document, then if the Document is less than one quarter +of the entire aggregate, the Document's Cover Texts may be placed on +covers that surround only the Document within the aggregate. +Otherwise they must appear on covers around the whole aggregate. + + +8. TRANSLATION + +Translation is considered a kind of modification, so you may +distribute translations of the Document under the terms of section 4. +Replacing Invariant Sections with translations requires special +permission from their copyright holders, but you may include +translations of some or all Invariant Sections in addition to the +original versions of these Invariant Sections. You may include a +translation of this License provided that you also include the +original English version of this License. In case of a disagreement +between the translation and the original English version of this +License, the original English version will prevail. + + +9. TERMINATION + +You may not copy, modify, sublicense, or distribute the Document except +as expressly provided for under this License. Any other attempt to +copy, modify, sublicense or distribute the Document is void, and will +automatically terminate your rights under this License. However, +parties who have received copies, or rights, from you under this +License will not have their licenses terminated so long as such +parties remain in full compliance. + + +10. FUTURE REVISIONS OF THIS LICENSE + +The Free Software Foundation may publish new, revised versions +of the GNU Free Documentation License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. See +http://www.gnu.org/copyleft/. + +Each version of the License is given a distinguishing version number. +If the Document specifies that a particular numbered version of this +License "or any later version" applies to it, you have the option of +following the terms and conditions either of that specified version or +of any later version that has been published (not as a draft) by the +Free Software Foundation. If the Document does not specify a version +number of this License, you may choose any version ever published (not +as a draft) by the Free Software Foundation. + Added: branches/trunk-reorg/thirdparty/uffi/doc/Makefile ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/Makefile Mon Feb 11 09:06:27 2008 @@ -0,0 +1,144 @@ +############################################################################## +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for the uffi documentation +# Programer: Kevin M. Rosenberg +# Date Started: Mar 2002 +# +# CVS Id: $Id$ +# +# This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +############################################################################## + +DOCFILE_BASE_DEFAULT:=uffi +DOCFILE_EXT_DEFAULT:=xml + + +# Standard docfile processing + +DEBIAN=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Debian.*') +UBUNTU=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Ubuntu.*') +SUSE=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*SuSE.*') +SUSE91=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*SuSE Linux 9.1.*') +REDHAT=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Red Hat.*') +MANDRAKE=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Mandrake.*') +DARWIN=$(shell expr "`uname -a`" : '.*Darwin.*') + +ifneq (${DEBIAN},0) +OS:=debian +else + ifneq (${SUSE91},0) + OS=suse91 + else + ifneq (${SUSE},0) + OS=suse + else + ifneq (${REDHAT},0) + OS=redhat + else + ifneq (${MANDRAKE},0) + OS=mandrake + else + ifneq (${DARWIN},0) + OS=darwin + else + ifneq (${UBUNTU},0) + OS=ubuntu + endif + endif + endif + endif + endif + endif +endif + +ifndef DOCFILE_BASE +DOCFILE_BASE=${DOCFILE_BASE_DEFAULT} +endif + +ifndef DOCFILE_EXT +DOCFILE_EXT=${DOCFILE_EXT_DEFAULT} +endif + +DOCFILE:=${DOCFILE_BASE}.${DOCFILE_EXT} +FOFILE:=${DOCFILE_BASE}.fo +PDFFILE:=${DOCFILE_BASE}.pdf +PSFILE:=${DOCFILE_BASE}.ps +DVIFILE:=${DOCFILE_BASE}.dvi +TXTFILE:=${DOCFILE_BASE}.txt +HTMLFILE:=${DOCFILE_BASE}.html +TMPFILES:=${DOCFILE_BASE}.aux ${DOCFILE_BASE}.out ${DOCFILE_BASE}.log +DOCFILES:=$(shell echo *.xml *.xsl) + +ifeq ($(XSLTPROC),) + XSLTPROC:=xsltproc +endif + +CATALOG:=`pwd`/catalog-${OS}.xml +CHECK:=XML_CATALOG_FILES="$(CATALOG)" xmllint --noout --xinclude --postvalid $(DOCFILE) || exit 1 + +.PHONY: all +all: html pdf + +.PHONY: dist +dist: html pdf + +.PHONY: doc +doc: html pdf + +.PHONY: check +check: + @echo "Operating System Detected: ${OS}" + @$(CHECK) + +.PHONY: html +html: html.tar.gz + +html.tar.gz: $(DOCFILES) Makefile + @rm -rf html + @mkdir html + @XML_CATALOG_FILES="$(CATALOG)" $(XSLTPROC) --stringparam chunker.output.encoding UTF-8 \ + --xinclude --output html/ html_chunk.xsl $(DOCFILE) + @GZIP='-9' tar czf html.tar.gz html + +.PHONY: fo +fo: ${FOFILE} + +${FOFILE}: $(DOCFILES) Makefile + @XML_CATALOG_FILES="$(CATALOG)" xsltproc --xinclude --output $(FOFILE) fo.xsl $(DOCFILE) + +.PHONY: pdf +pdf: ${PDFFILE} + +${PDFFILE}: ${DOCFILES} Makefile + @$(MAKE) fo + @fop $(FOFILE) -pdf $(PDFFILE) > /dev/null + +.PHONY: dvi +dvi: ${DVIFILE} + +.PHONY: ps +ps: ${PSFILE} + +${PSFILE}: ${DOCFILES} Makefile + @$(MAKE) fo + @fop $(FOFILE) -ps $(PSFILE) > /dev/null + + +.PHONY: txt +txt: ${TXTFILE} + +${TXTFILE}: ${FOFILE} + @XML_CATALOG_FILES="$(CATALOG)" xsltproc --xinclude --output ${HTMLFILE} html.xsl $(DOCFILE) + lynx -dump ${HTMLFILE} > ${TXTFILE} + +.PHONY: clean +clean: + @rm -f *~ *.bak *.orig \#*\# .\#* texput.log + @rm -rf html ${PSFILE} ${HTMLFILE} + @rm -f ${TMPFILES} ${FOFILE} + @rm -f ${DVIFILE} ${TXTFILE} + +.PHONY: distclean +distclean: clean Added: branches/trunk-reorg/thirdparty/uffi/doc/appendix.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/appendix.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,35 @@ +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<appendix id="installation"> + <title>Installation</title> + <sect1 id="download"> + <title>Download &uffi;</title> + <para> +You need to download the &uffi; package from its web +<ulink url="http://uffi.b9.com"><citetitle>home</citetitle></ulink>. +You also need to have a copy of &asdf;. If you need a copy of +&asdf;, it is included in the + <ulink + url="http://www.sourceforge.net/projects/cclan"> + <citetitle>CCLAN</citetitle></ulink> package. You can download +the file <filename>defsystem.lisp</filename> from the CVS +<ulink url="http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/asdf.lisp"><citetitle>tree</citetitle></ulink>. + </para> + </sect1> + <sect1 id="loading"> + <title>Loading</title> + <para> + After downloading and installing &asdf;, simply + <function>push</function> the + directory containing &uffi; into + <varname>asdf:*central-registry*</varname> variable. Whenever you +want to load the &uffi; package, use the form + <computeroutput>(asdf:operate 'asdf:load-op :uffi)</computeroutput>. + </para> + </sect1> +</appendix> Added: branches/trunk-reorg/thirdparty/uffi/doc/bookinfo.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/bookinfo.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,77 @@ +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<bookinfo> + <title>&uffi; Reference Guide</title> + <author> + <firstname>Kevin</firstname> + <othername>M.</othername> + <surname>Rosenberg</surname> + <affiliation> + <orgname>Heart Hospital of New Mexico</orgname> + <address> + <email>kevin(a)rosenberg.net</email> + <street>504 Elm Street N.E.</street> + <city>Albuquerque</city> + <state>New Mexico</state> + <postcode>87102</postcode> + </address> + </affiliation> + </author> + + <printhistory> + <simpara>$Id$</simpara> + <simpara>File $Date$</simpara> + </printhistory> + <copyright> + <year>2002-2003</year> + <holder>Kevin M. Rosenberg</holder> + </copyright> + <legalnotice> + <itemizedlist> + <listitem> + <para>The &uffi; package was designed and + written by Kevin M. Rosenberg. + </para> + </listitem> + <listitem> + <para> + Permission is granted to copy, distribute and/or modify this document + under the terms of the GNU Free Documentation License, Version 1.1 + or any later version published by the Free Software Foundation; + with no Invariant Sections, with the no + Front-Cover Texts, and with no Back-Cover Texts. + A copy of the license is included in the &uffi; distribution. + </para> + </listitem> + <listitem> + <para> + <application>Allegro CL</application>® is a registered + trademark of Franz Inc. + </para> + </listitem> + <listitem> + <para> + <application>Lispworks</application>® is a registered + trademark of Xanalys Inc. + </para> + </listitem> + <listitem> + <para> + <application>Microsoft Windows</application>® is a + registered trademark of Microsoft Inc. + </para> + </listitem> + <listitem> + <para> + Other brand or product names are the registered trademarks + or trademarks of their respective holders. + </para> + </listitem> + </itemizedlist> + </legalnotice> +</bookinfo> Added: branches/trunk-reorg/thirdparty/uffi/doc/catalog-darwin.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/catalog-darwin.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,43 @@ +<?xml version="1.0" ?> +<!DOCTYPE catalog + PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN" + "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd"> + +<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog"> + +  + <group xml:base="file:///sw/share/xml/" > + +  + <rewriteSystem + systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/" + rewritePrefix="dtd/docbookx/4.2.0/" /> +  + <rewriteURI + uriStartString="http://docbook.sourceforge.net/release/xsl/current/" + rewritePrefix="xsl/docbook-xsl/" /> + +  + <nextCatalog catalog="dtd/xml/4.2/catalog.xml" /> + +  +  +  + <system + systemId="docbook.dtd" + uri="dtd/xml/4.2.0/xml/docbookx.dtd" /> + +  + <uri + name="docbook_html.xsl" + uri="xsl/docbook-xsl/xhtml/docbook.xsl" /> + <uri + name="docbook_chunk.xsl" + uri="xsl/docbook-xsl/xhtml/chunk.xsl" /> + <uri + name="docbook_fo.xsl" + uri="xsl/docbook-xsl/fo/docbook.xsl" /> + + </group> + +</catalog> Added: branches/trunk-reorg/thirdparty/uffi/doc/catalog-debian.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/catalog-debian.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,43 @@ +<?xml version="1.0" ?> +<!DOCTYPE catalog + PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN" + "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd"> + +<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog"> + +  + <group xml:base="file:///usr/share/sgml/docbook/" > + +  + <rewriteSystem + systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/" + rewritePrefix="dtd/xml/4.2/" /> +  + <rewriteURI + uriStartString="http://docbook.sourceforge.net/release/xsl/current/" + rewritePrefix="stylesheet/xsl/nwalsh/" /> + +  + <nextCatalog catalog="dtd/xml/4.2/catalog.xml" /> + +  +  +  + <system + systemId="docbook.dtd" + uri="dtd/xml/4.2/xml/docbookx.dtd" /> + +  + <uri + name="docbook_html.xsl" + uri="stylesheet/xsl/nwalsh/xhtml/docbook.xsl" /> + <uri + name="docbook_chunk.xsl" + uri="stylesheet/xsl/nwalsh/xhtml/chunk.xsl" /> + <uri + name="docbook_fo.xsl" + uri="stylesheet/xsl/nwalsh/fo/docbook.xsl" /> + + </group> + +</catalog> Added: branches/trunk-reorg/thirdparty/uffi/doc/catalog-mandrake.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/catalog-mandrake.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,43 @@ +<?xml version="1.0" ?> +<!DOCTYPE catalog + PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN" + "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd"> + +<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog"> + +  + <group xml:base="file:///usr/share/sgml/docbook/" > + +  + <rewriteSystem + systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/" + rewritePrefix="xml-dtd-4.2/" /> +  + <rewriteURI + uriStartString="http://docbook.sourceforge.net/release/xsl/current/" + rewritePrefix="xsl-stylesheets/" /> + +  + <nextCatalog catalog="xml-dtd-4.2/catalog.xml" /> + +  +  +  + <system + systemId="docbook.dtd" + uri="xml-dtd-4.2/docbookx.dtd" /> + +  + <uri + name="docbook_html.xsl" + uri="xsl-stylesheets/xhtml/docbook.xsl" /> + <uri + name="docbook_chunk.xsl" + uri="xsl-stylesheets/xhtml/chunk.xsl" /> + <uri + name="docbook_fo.xsl" + uri="xsl-stylesheets/fo/docbook.xsl" /> + + </group> + +</catalog> Added: branches/trunk-reorg/thirdparty/uffi/doc/catalog-suse.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/catalog-suse.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,43 @@ +<?xml version="1.0" ?> +<!DOCTYPE catalog + PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN" + "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd"> + +<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog"> + +  + <group xml:base="file:///usr/share/xml/" > + +  + <rewriteSystem + systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/" + rewritePrefix="db42xml/" /> +  + <rewriteURI + uriStartString="http://docbook.sourceforge.net/release/xsl/current/" + rewritePrefix="docbook/docbook-xsl/" /> + +  + <nextCatalog catalog="db42xml/catalog.xml" /> + +  +  +  + <system + systemId="docbook.dtd" + uri="db42xml/docbookx.dtd" /> + +  + <uri + name="docbook_html.xsl" + uri="docbook/stylesheet/nwalsh/current/xhtml/docbook.xsl" /> + <uri + name="docbook_chunk.xsl" + uri="docbook/stylesheet/nwalsh/current/xhtml/chunk.xsl" /> + <uri + name="docbook_fo.xsl" + uri="docbook/stylesheet/nwalsh/current/fo/docbook.xsl" /> + + </group> + +</catalog> Added: branches/trunk-reorg/thirdparty/uffi/doc/catalog-suse90.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/catalog-suse90.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,43 @@ +<?xml version="1.0" ?> +<!DOCTYPE catalog + PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN" + "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd"> + +<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog"> + +  + <group xml:base="file:///usr/share/sgml/" > + +  + <rewriteSystem + systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/" + rewritePrefix="db42xml/" /> +  + <rewriteURI + uriStartString="http://docbook.sourceforge.net/release/xsl/current/" + rewritePrefix="docbook/docbook-xsl/" /> + +  + <nextCatalog catalog="db42xml/catalog.xml" /> + +  +  +  + <system + systemId="docbook.dtd" + uri="db42xml/docbookx.dtd" /> + +  + <uri + name="docbook_html.xsl" + uri="docbook/docbook-xsl/xhtml/docbook.xsl" /> + <uri + name="docbook_chunk.xsl" + uri="docbook/docbook-xsl/xhtml/chunk.xsl" /> + <uri + name="docbook_fo.xsl" + uri="docbook/docbook-xsl/fo/docbook.xsl" /> + + </group> + +</catalog> Added: branches/trunk-reorg/thirdparty/uffi/doc/catalog-suse91.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/catalog-suse91.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,48 @@ +<?xml version="1.0" ?> +<!DOCTYPE catalog + PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN" + "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd"> + +<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog"> + +  + <group xml:base="file:///usr/share/xml/" > + +  + <rewriteSystem + systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/" + rewritePrefix="docbook/schema/dtd/4.2/" /> +  + <rewriteURI + uriStartString="http://docbook.sourceforge.net/release/xsl/current/" + rewritePrefix="docbook/stylesheet/nwalsh/current/" /> + +  + <nextCatalog catalog="docbook/schema/dtd/4.2/catalog.xml" /> + +  +  +  + <system + systemId="docbook.dtd" + uri="docbook/schema/dtd/4.2/docbookx.dtd" /> + <uri + name="docbookx.dtd" + uri="docbook/schema/dtd/4.2/docbookx.dtd" /> + <system + systemId="docbookx.dtd" + uri="docbook/schema/dtd/4.2/docbookx.dtd" /> +  + <uri + name="docbook_html.xsl" + uri="docbook/stylesheet/nwalsh/current/xhtml/docbook.xsl" /> + <uri + name="docbook_chunk.xsl" + uri="docbook/stylesheet/nwalsh/current/xhtml/chunk.xsl" /> + <uri + name="docbook_fo.xsl" + uri="docbook/stylesheet/nwalsh/current/fo/docbook.xsl" /> + + </group> + +</catalog> Added: branches/trunk-reorg/thirdparty/uffi/doc/catalog-ubuntu.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/catalog-ubuntu.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,43 @@ +<?xml version="1.0" ?> +<!DOCTYPE catalog + PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN" + "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd"> + +<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog"> + +  + <group xml:base="file:///usr/share/sgml/docbook/" > + +  + <rewriteSystem + systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/" + rewritePrefix="dtd/xml/4.2/" /> +  + <rewriteURI + uriStartString="http://docbook.sourceforge.net/release/xsl/current/" + rewritePrefix="stylesheet/xsl/nwalsh/" /> + +  + <nextCatalog catalog="dtd/xml/4.2/catalog.xml" /> + +  +  +  + <system + systemId="docbook.dtd" + uri="dtd/xml/4.2/xml/docbookx.dtd" /> + +  + <uri + name="docbook_html.xsl" + uri="stylesheet/xsl/nwalsh/xhtml/docbook.xsl" /> + <uri + name="docbook_chunk.xsl" + uri="stylesheet/xsl/nwalsh/xhtml/chunk.xsl" /> + <uri + name="docbook_fo.xsl" + uri="stylesheet/xsl/nwalsh/fo/docbook.xsl" /> + + </group> + +</catalog> Added: branches/trunk-reorg/thirdparty/uffi/doc/entities.inc ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/entities.inc Mon Feb 11 09:06:27 2008 @@ -0,0 +1,16 @@ +<!ENTITY uffi "<application><emphasis>UFFI</emphasis></application>"> +<!ENTITY ffi "<acronym>FFI</acronym>"> +<!ENTITY cmucl "<application>CMUCL</application>"> +<!ENTITY scl "<application>SCL</application>"> +<!ENTITY lw "<application>Lispworks</application>"> +<!ENTITY sbcl "<application>SBCL</application>"> +<!ENTITY openmcl "<application>OpenMCL</application>"> +<!ENTITY mcl "<application>MCL</application>"> +<!ENTITY acl "<application>AllegroCL</application>"> +<!ENTITY cl "<application>ANSI Common Lisp</application>"> +<!ENTITY t "<constant>T</constant>"> +<!ENTITY nil "<constant>NIL</constant>"> +<!ENTITY null "<constant>NULL</constant>"> +<!ENTITY c "<computeroutput>C</computeroutput>"> +<!ENTITY defsystem "<application>defsystem</application>"> +<!ENTITY asdf "<application>ASDF</application>"> Added: branches/trunk-reorg/thirdparty/uffi/doc/fo.xsl ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/fo.xsl Mon Feb 11 09:06:27 2008 @@ -0,0 +1,8 @@ +<?xml version='1.0'?> +<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" + version="1.0"> + +<xsl:import href="docbook_fo.xsl"/> +<xsl:param name="fop.extensions" select="1"/> +</xsl:stylesheet> + Added: branches/trunk-reorg/thirdparty/uffi/doc/glossary.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/glossary.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,21 @@ +<?xml version="1.0" ?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<glossary id="glossary"> + <glossentry id="gloss-ffi"> + <glossterm>Foreign Function Interface + <acronym>FFI</acronym>) + </glossterm> + <glossdef> + <para> + An interface to a C-compatible library. + </para> + </glossdef> + </glossentry> +</glossary> + + Added: branches/trunk-reorg/thirdparty/uffi/doc/html.tar.gz ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/uffi/doc/html.xsl ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/html.xsl Mon Feb 11 09:06:27 2008 @@ -0,0 +1,10 @@ +<?xml version='1.0'?> +<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" + version="1.0"> + +<xsl:import href="docbook_html.xsl"/> +<xsl:param name="use.id.as.filename" select="1"/> +<xsl:output encoding="UTF-8" method="html" /> + +</xsl:stylesheet> + Added: branches/trunk-reorg/thirdparty/uffi/doc/html_chunk.xsl ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/html_chunk.xsl Mon Feb 11 09:06:27 2008 @@ -0,0 +1,9 @@ +<?xml version='1.0'?> +<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" + version="1.0"> + +<xsl:import href="docbook_chunk.xsl"/> +<xsl:param name="use.id.as.filename" select="1"/> + +</xsl:stylesheet> + Added: branches/trunk-reorg/thirdparty/uffi/doc/intro.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/intro.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,113 @@ +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" +"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<chapter id="introduction"> + <title>Introduction</title> + <sect1 id="purpose"> + <title>Purpose</title> + <para> + This reference guide describes &uffi;, a package that provides a + cross-implementation interface from Common Lisp to C-language + compatible libraries. + </para> + </sect1> + + <sect1 id="background"> + <title>Background + </title> + <para> + Every Common Lisp implementation has a method for interfacing to + C-language compatible libraries. These methods are often termed + a <emphasis>Foreign Function Library Interface</emphasis> + (&ffi;). Unfortunately, these methods vary widely amongst + implementations, thus preventing the writing of a portable FFI + to a particular C-library. + </para> + <para> + &uffi; gathers a common subset of functionality between Common + Lisp implementations. &uffi; wraps this common subset of + functionality with it's own syntax and provides macro + translation of uffi functions into the specific syntax of + supported Common Lisp implementations. + </para> + <para> + Developers who use &uffi; to interface with C libraries will + automatically have their code function in each of uffi's supported + implementations. + </para> + </sect1> + + <sect1 id="supported-impl"> + <title>Supported Implementations</title> + <para>The primary tested and supported platforms for &uffi; are: + </para> + <itemizedlist mark="opencircle"> + <listitem><para>&acl; v6.2 on Debian GNU/Linux + FreeBSD 4.5, Solaris v2.8, and Microsoft Windows XP.</para></listitem> + <listitem><para>&lw; v4.2 on Debian GNU/Linux and Microsoft Windows XP.</para></listitem> + <listitem><para>&cmucl; 18d on Debian GNU/Linux, FreeBSD 4.5, and Solaris 2.8</para></listitem> + <listitem><para>&sbcl; 0.7.8 on Debian GNU/Linux</para></listitem> + <listitem><para>&scl; 1.1.1 on Debian GNU/Linux</para></listitem> + <listitem><para>&openmcl; 0.13 on Debian GNU/Linux for PowerPC</para></listitem> + </itemizedlist> + <para>Beta code is included with &uffi; for + </para> + <itemizedlist mark="opencircle"> + <listitem><para>&openmcl; and &mcl; with MacOSX</para></listitem> + </itemizedlist> + </sect1> + + <sect1 id="design"> + <title>Design</title> + <sect2> + <title>Overview</title> + <para> + &uffi; was designed as a cross-implementation + compatible <emphasis>Foreign Function Interface</emphasis>. + Necessarily, + only a common subset of functionality can be + provided. Likewise, not every optimization for that a specific + implementation provides can be supported. Wherever possible, + though, implementation-specific optimizations are invoked. + </para> + </sect2> + + <sect2> + <title>Priorities</title> + <para> + The design of &uffi; is dictated by the order of these priorities: + </para> + <itemizedlist> + <listitem> + <para> + Code using &uffi; must operate correctly on all + supported implementations. + </para> + </listitem> + <listitem> + <para> + Take advantage of implementation-specific optimizations. Ideally, + there will not a situation where an implementation-specific + &ffi; will be chosen due to lack of optimizations in &uffi;. + </para> + </listitem> + <listitem> + <para>Provide a simple interface to developers using + &uffi;. This priority is quite a bit lower than the above priorities. + This lower priority is manifest by programmers having to pass types in + pointer and array dereferencing, needing to use + <constant>cstring</constant> wrapper functions, and the use of + ensure-char-character and ensure-char-integer functions. My hope is + that the developer inconvenience will be outweighed by the generation + of optimized code that is cross-implementation compatible. + </para> + </listitem> + </itemizedlist> + </sect2> + </sect1> + +</chapter> Added: branches/trunk-reorg/thirdparty/uffi/doc/notes.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/notes.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,94 @@ +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<chapter id="notes"> + <title>Programming Notes</title> + + <sect1 id="impl-specific"> + <title>Implementation Specific Notes</title> + <para> + </para> + <sect2> + <title>&acl;</title> + <para> + </para> + </sect2> + <sect2> + <title>&lw;</title> + <para> + </para> + </sect2> + <sect2> + <title>&cmucl;</title> + <para> + </para> + </sect2> + </sect1> + + <sect1 id="object-represen"> + <title>Foreign Object Representation and Access</title> + <para> There are two main approaches used to represent foreign + objects: an integer that represents an address in memory, and a + object that also includes run-time typing. The advantage of + run-time typing is the system can dereference pointers and perform + array access without those functions requiring a type at the cost + of additional overhead to generate and store the run-time + typing. The advantage of integer representation, at least for + &acl;, is that the compiler can generate inline code to + dereference pointers. Further, the overhead of the run-time type + information is eliminated. The disadvantage is the program must + then supply + the type to the functions to dereference objects and array. + </para> + </sect1> + + <sect1 id="optimizing"> + <title>Optimizing Code Using UFFI</title> + <sect2> + <title>Background</title> + <para> + Two implementions have different techniques to optimize + (open-code) foreign objects. &acl; can open-code foreign + object + access if pointers are integers and the type of object is + specified in the access function. Thus, &uffi; represents objects + in &acl; as integers which don't have type information. + </para> <para> + &cmucl; works best when keeping objects as typed + objects. However, it's compiler can open-code object access when + the object type is specified in <function>declare</function> + commands and in <varname>:type</varname> specifiers in + <function>defstruct</function> and <function>defclass</function>. + </para> <para> &lw;, in converse to &acl; and &cmucl; does not do + any open coding of object access. &lw;, by default, maintains + objects with run-time typing. </para> + </sect2> + <sect2> + <title>Cross-Implementation Optimization</title> + <para> + To fully optimize across platforms, both explicit type + information must be passed to dereferencing of pointers and + arrays. Though this optimization only helps with &acl;, &uffi; + is designed to require this type information be passed the + dereference functions. Second, declarations of type should be + made in functions, structures, and classes where foreign + objects will be help. This will optimize access for &lw; + </para> + <para> + Here is an example that should both methods being used for + maximum cross-implementation optimization: + <screen> +(uffi:def-type the-struct-type-def the-struct-type) +(let ((a-foreign-struct (allocate-foreign-object 'the-struct-type))) + (declare 'the-struct-type-def a-foreign-struct) + (get-slot-value a-foreign-struct 'the-struct-type 'field-name)) + </screen> + </para> + </sect2> + </sect1> + +</chapter> Added: branches/trunk-reorg/thirdparty/uffi/doc/preface.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/preface.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,16 @@ +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<preface id="preface"> + <title>Preface</title> + <para>This reference guide describes the usage and features of + &uffi;. The first chapter provides an overview to the design of + &uffi;. Following that chapter is the reference section for all + user accessible functions of &uffi;. The appendix covers the + installation and implementation-specifc features of &uffi;. + </para> +</preface> Added: branches/trunk-reorg/thirdparty/uffi/doc/ref_aggregate.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/ref_aggregate.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,524 @@ +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<reference id="aggregates"> + <title>Aggregate Types</title> + <partintro> + <title>Overview</title> + <para> + Aggregate types are comprised of one or more primitive types. + </para> + </partintro> + + <refentry id="def-enum"> + <refnamediv> + <refname>def-enum</refname> + <refpurpose>Defines a &c; enumeration. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>def-enum</function> <replaceable>name fields &key separator-string</replaceable> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para>A symbol that names the enumeration. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>fields</parameter></term> + <listitem> + <para>A list of field defintions. Each definition can be +a symbol or a list of two elements. Symbols get assigned a value of the +current counter which starts at <computeroutput>0</computeroutput> and +increments by <computeroutput>1</computeroutput> for each subsequent symbol. It the field definition is a list, the first position is the symbol and the second +position is the value to assign the the symbol. The current counter gets set +to <computeroutput>1+</computeroutput> this value. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>separator-string</parameter></term> + <listitem> + <para>A string that governs the creation of constants. The +default is <computeroutput>"#"</computeroutput>.</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Declares a &c; enumeration. It generates constants with integer values for the elements of the enumeration. The symbols for the these constant +values are created by the <function>concatenation</function> of the +enumeration name, separator-string, and field symbol. Also creates +a foreign type with the name <parameter>name</parameter> of type +<constant>:int</constant>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(def-enum abc (:a :b :c)) +;; Creates constants abc#a (1), abc#b (2), abc#c (3) and defines +;; the foreign type "abc" to be :int + +(def-enum efoo (:e1 (:e2 10) :e3) :separator-string "-") +;; Creates constants efoo-e1 (1), efoo-e2 (10), efoo-e3 (11) and defines +;; the foreign type efoo to be :int + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Creates a :int foreign type, defines constants.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + + <refentry id="def-struct"> + <refnamediv> + <refname>def-struct</refname> + <refpurpose>Defines a &c; structure. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>def-struct</function> <replaceable>name &rest fields</replaceable> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para>A symbol that names the structure. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>fields</parameter></term> + <listitem> + <para>A variable number of field defintions. Each definition is a list consisting of a symbol naming the field followed by its foreign type. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Declares a structure. A special type is available as a slot +in the field. It is a pointer that points to an instance of the parent +structure. It's type is <constant>:pointer-self</constant>. + + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(def-struct foo (a :unsigned-int) + (b (* :char)) + (c (:array :int 10)) + (next :pointer-self)) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Creates a foreign type.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + + <refentry id="get-slot-value"> + <refnamediv> + <refname>get-slot-value</refname> + <refpurpose>Retrieves a value from a slot of a structure. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>get-slot-value</function> <replaceable>obj type field</replaceable> => <returnvalue>value</returnvalue> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>obj</parameter></term> + <listitem> + <para>A pointer to foreign structure. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para>A name of the foreign structure. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>field</parameter></term> + <listitem> + <para>A name of the desired field in foreign structure. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>value</returnvalue></term> + <listitem> + <para>The value of the field in the structure. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Accesses a slot value from a structure. This is generalized + and can be used with <function>setf</function>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(get-slot-value foo-ptr 'foo-structure 'field-name) +(setf (get-slot-value foo-ptr 'foo-structure 'field-name) 10) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="get-slot-pointer"> + <refnamediv> + <refname>get-slot-pointer</refname> + <refpurpose>Retrieves a pointer from a slot of a structure. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>get-slot-pointer</function> <replaceable>obj type field</replaceable> => <returnvalue>pointer</returnvalue> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>obj</parameter></term> + <listitem> + <para>A pointer to foreign structure. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para>A name of the foreign structure. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>field</parameter></term> + <listitem> + <para>A name of the desired field in foreign structure. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>pointer</returnvalue></term> + <listitem> + <para>The value of the field in the structure. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + This is similar to <function>get-slot-value</function>. It + is used when the value of a slot is a pointer type. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(get-slot-pointer foo-ptr 'foo-structure 'my-char-ptr) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + + <refentry id="def-array-pointer"> + <refnamediv> + <refname>def-array-pointer</refname> + <refpurpose>Defines a pointer to a array of type. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>def-array-pointer</function> <replaceable>name type</replaceable> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para>A name of the new foreign type. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para>The foreign type of the array elements. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Defines a type tat is a pointer to an array of type. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(def-array-pointer byte-array-pointer :unsigned-char) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Defines a new foreign type.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + + <refentry id="deref-array"> + <refnamediv> + <refname>deref-array</refname> + <refpurpose>Deference an array. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>deref-array</function> <replaceable>array type position</replaceable> => <returnvalue>value</returnvalue> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>array</parameter></term> + <listitem> + <para>A foreign array. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para>The foreign type of the array. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>position</parameter></term> + <listitem> + <para>An integer specifying the position to retrieve from +the array. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>value</returnvalue></term> + <listitem> + <para>The value stored in the position of the array. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Dereferences (retrieves) the value of an array element. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(def-array-pointer ca :char) +(let ((fs (convert-to-foreign-string "ab"))) + (values (null-char-p (deref-array fs 'ca 0)) + (null-char-p (deref-array fs 'ca 2)))) +=> &nil; + &t; + </screen> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The TYPE argument is ignored for CL implementations other than + AllegroCL. If you want to cast a pointer to another type use + WITH-CAST-POINTER together with DEREF-POINTER/DEREF-ARRAY. + </para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="def-union"> + <refnamediv> + <refname>def-union</refname> + <refpurpose>Defines a foreign union type. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>def-union</function> <replaceable>name &rest fields</replaceable> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para>A name of the new union type. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>fields</parameter></term> + <listitem> + <para>A list of fields of the union. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Defines a foreign union type. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(def-union test-union + (a-char :char) + (an-int :int)) + +(let ((u (allocate-foreign-object 'test-union)) + (setf (get-slot-value u 'test-union 'an-int) (+ 65 (* 66 256))) + (prog1 + (ensure-char-character (get-slot-value u 'test-union 'a-char)) + (free-foreign-object u))) +=> #\A + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Defines a new foreign type.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + +</reference> + Added: branches/trunk-reorg/thirdparty/uffi/doc/ref_declare.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/ref_declare.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,82 @@ +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<reference id="ref_declarations"> + <title>Declarations</title> + + <partintro> + <sect1> + <title>Overview</title> + <para>Declarations are used to give the compiler optimizing + information about foreign types. Currently, only &cmucl; + supports declarations. On &acl; and &lw;, these expressions + declare the type generically as &t; + </para> + </sect1> + </partintro> + + <refentry id="def-type"> + <refnamediv> + <refname>def-type</refname> + <refpurpose>Defines a Common Lisp type. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>def-type</function> <replaceable>name type</replaceable> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para>A symbol naming the type</para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para>A form that specifies the &uffi; type. It is not evaluated. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Defines a Common Lisp type based on a &uffi; type. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(def-type char-ptr '(* :char)) +... +(defun foo (ptr) +(declare (type char-ptr ptr)) +... + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Defines a new &cl; type.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> +</reference> + Added: branches/trunk-reorg/thirdparty/uffi/doc/ref_func_libr.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/ref_func_libr.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,264 @@ +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<reference id="func_libr"> + <title>Functions & Libraries</title> + + <refentry id="def-function"> + <refnamediv> + <refname>def-function</refname> + <refpurpose>Declares a function. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>def-function</function> <replaceable>name args &key module returning</replaceable> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para>A string or list specificying the function name. If it is a string, that names the foreign function. A Lisp name is created by translating #\_ to #\- and by converting to upper-case in case-insensitive Lisp implementations. If it is a list, the first item is a string specifying the foreign function name and the second it is a symbol stating the Lisp name. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>args</parameter></term> + <listitem> + <para>A list of argument declarations. If &nil;, indicates that the function does not take any arguments. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>module</parameter></term> + <listitem> + <para>A string specifying which module (or library) that the foreign function resides. (Required by Lispworks)</para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>returning</returnvalue></term> + <listitem> + <para>A declaration specifying the result type of the +foreign function. If <constant>:void</constant> indicates module does not return any value. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Declares a foreign function. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(def-function "gethostname" + ((name (* :unsigned-char)) + (len :int)) + :returning :int) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="load-foreign-library"> + <refnamediv> + <refname>load-foreign-library</refname> + <refpurpose>Loads a foreign library. + </refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> +<synopsis> + <function>load-foreign-library</function> <replaceable>filename &key module supporting-libraries force-load</replaceable> => <returnvalue>success</returnvalue> +</synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>filename</parameter></term> + <listitem> + <para>A string or pathname specifying the library location +in the filesystem. At least one implementation (&lw;) can not +accept a logical pathname. If this parameter denotes a pathname without a +directory component then most of the supported Lisp implementations will be +able to find the library themselves if it is located in one of the standard +locations as defined by the underlying operating system. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>module</parameter></term> + <listitem> + <para>A string designating the name of the module to apply +to functions in this library. (Required for Lispworks) + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>supporting-libraries</parameter></term> + <listitem> + <para>A list of strings naming the libraries required to +link the foreign library. (Required by CMUCL) + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>force-load</parameter></term> + <listitem> + <para>Forces the loading of the library if it has been previously loaded. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>success</returnvalue></term> + <listitem> + <para>A boolean flag, &t; if the library was able to be +loaded successfully or if the library has been previously loaded, + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Loads a foreign library. Applies a module name to functions +within the library. Ensures that a library is only loaded once during +a session. A library can be reloaded by using the <symbol>:force-load</symbol> key. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> + (load-foreign-library #p"/usr/lib/libmysqlclient.so" + :module "mysql" + :supporting-libraries '("c")) + => T + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Loads the foreign code into the Lisp system. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>Ability to load the file.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>An error will be signaled if the library is unable to be loaded.</para> + </refsect1> + </refentry> + + <refentry id="find-foreign-library"> + <refnamediv> + <refname>find-foreign-library</refname> + <refpurpose>Finds a foreign library file. + </refpurpose> + <refclass>Function</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> +<synopsis> + <function>find-foreign-library</function> <replaceable>names directories & drive-letters types</replaceable> => <returnvalue>path</returnvalue> +</synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>names</parameter></term> + <listitem> + <para>A string or list of strings containing the base name of the library file. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>directories</parameter></term> + <listitem> + <para>A string or list of strings containing the directory the library file. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>drive-letters</parameter></term> + <listitem> + <para>A string or list of strings containing the drive letters for the library file. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>types</parameter></term> + <listitem> + <para>A string or list of strings containing the file type of the library file. Default +is &nil;. If &nil;, will use a default type based on the currently running implementation. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>path</returnvalue></term> + <listitem> + <para>A path containing the path found, or &nil; if the library file was not found. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Finds a foreign library by searching through a number of possible locations. Returns +the path of the first found file. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(find-foreign-library '("libmysqlclient" "libmysql") + '("/opt/mysql/lib/mysql/" "/usr/local/lib/" "/usr/lib/" "/mysql/lib/opt/") + :types '("so" "dll") + :drive-letters '("C" "D" "E")) +=> #P"D:\\mysql\\lib\\opt\\libmysql.dll" + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + +</reference> + + Added: branches/trunk-reorg/thirdparty/uffi/doc/ref_object.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/ref_object.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,859 @@ +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<reference id="objects"> + <title>Objects</title> +<partintro> +<title>Overview</title> + <para> + Objects are entities that can allocated, referred to by pointers, and +can be freed. + </para> +</partintro> + + + <refentry id="allocate-foreign-object"> + <refnamediv> + <refname>allocate-foreign-object</refname> + <refpurpose>Allocates an instance of a foreign object. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>allocate-foreign-object</function> <replaceable>type &optional size</replaceable> => <returnvalue>ptr</returnvalue> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para>The type of foreign object to allocate. This parameter is evaluated. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>size</parameter></term> + <listitem> + <para>An optional size parameter that is evaluated. If specified, allocates and returns an +array of <parameter>type</parameter> that is <parameter>size</parameter> members long. This parameter is evaluated. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>ptr</returnvalue></term> + <listitem> + <para>A pointer to the foreign object. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Allocates an instance of a foreign object. It returns a pointer to the object. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(def-struct ab (a :int) (b :double)) +(allocate-foreign-object 'ab) +=> #<ptr> + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + + <refentry id="free-foreign-object"> + <refnamediv> + <refname>free-foreign-object</refname> + <refpurpose>Frees memory that was allocated for a foreign boject. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>free-foreign-object</function> <replaceable>ptr</replaceable> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>ptr</parameter></term> + <listitem> + <para>A pointer to the allocated foreign object to free. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Frees the memory used by the allocation of a foreign object. + </para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + + <refentry id="with-foreign-object"> + <refnamediv> + <refname>with-foreign-object</refname> + <refpurpose>Wraps the allocation of a foreign object around a body of code. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>with-foreign-object</function> <replaceable>(var type) &body body</replaceable> => <returnvalue>form-return</returnvalue> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>var</parameter></term> + <listitem> + <para>The variable name to bind. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para>The type of foreign object to allocate. This parameter is evaluated. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>form-return</returnvalue></term> + <listitem> + <para>The result of evaluating the <parameter>body</parameter>. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> +This function wraps the allocation, binding, and destruction of a foreign object. +On &cmucl; and +&lw; platforms the object is stack allocated for efficiency. Benchmarks show that &acl; performs +much better with static allocation. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(defun gethostname2 () + "Returns the hostname" + (uffi:with-foreign-object (name '(:array :unsigned-char 256)) + (if (zerop (c-gethostname (uffi:char-array-to-pointer name) 256)) + (uffi:convert-from-foreign-string name) + (error "gethostname() failed.")))) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="size-of-foreign-type"> + <refnamediv> + <refname>size-of-foreign-type</refname> + <refpurpose>Returns the number of data bytes used by a foreign object type. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>size-of-foreign-type</function> <replaceable>ftype</replaceable> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>ftype</parameter></term> + <listitem> + <para>A foreign type specifier. This parameter is evaluated. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Returns the number of data bytes used by a foreign object type. This does not include any Lisp storage overhead. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <para> +<screen> +(size-of-foreign-object :unsigned-byte) +=> 1 +(size-of-foreign-object 'my-100-byte-vector-type) +=> 100 +</screen> + </para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="pointer-address"> + <refnamediv> + <refname>pointer-address</refname> + <refpurpose>Returns the address of a pointer. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>pointer-address</function> <replaceable>ptr</replaceable> => <returnvalue>address</returnvalue> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>ptr</parameter></term> + <listitem> + <para>A pointer to a foreign object. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>address</parameter></term> + <listitem> + <para>An integer representing the pointer's address. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Returns the address as an integer of a pointer. + </para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + + <refentry id="deref-pointer"> + <refnamediv> + <refname>deref-pointer</refname> + <refpurpose>Deferences a pointer. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>deref-pointer</function> <replaceable>ptr type</replaceable> => <returnvalue>value</returnvalue> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>ptr</parameter></term> + <listitem> + <para>A pointer to a foreign object. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para>A foreign type of the object being pointed to. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>value</returnvalue></term> + <listitem> + <para>The value of the object where the pointer points. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Returns the object to which a pointer points. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <para> +<screen> +(let ((intp (allocate-foreign-object :int))) + (setf (deref-pointer intp :int) 10) + (prog1 + (deref-pointer intp :int) + (free-foreign-object intp))) +=> 10 +</screen> + </para> + </refsect1> + <refsect1> + <title>Notes</title> + <para> + The TYPE argument is ignored for CL implementations other than + AllegroCL. If you want to cast a pointer to another type use + WITH-CAST-POINTER together with DEREF-POINTER/DEREF-ARRAY. + </para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="ensure-char-character"> + <refnamediv> + <refname>ensure-char-character</refname> + <refpurpose>Ensures that a dereferenced <constant>:char</constant> pointer is +a character. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>ensure-char-character</function> <replaceable>object</replaceable> => <returnvalue>char</returnvalue> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>object</parameter></term> + <listitem> + <para>Either a character or a integer specifying a character code. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>char</returnvalue></term> + <listitem> + <para>A character. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Ensures that an objects obtained by dereferencing +<constant>:char</constant> and <constant>:unsigned-char</constant> +pointers are a lisp character. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <para> +<screen> +(let ((fs (convert-to-foreign-string "a"))) + (prog1 + (ensure-char-character (deref-pointer fs :char)) + (free-foreign-object fs))) +=> #\a +</screen> + </para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>Depending upon the implementation and what &uffi; expects, this +macro may signal an error if the object is not a character or +integer.</para> + </refsect1> + </refentry> + + <refentry id="ensure-char-integer"> + <refnamediv> + <refname>ensure-char-integer</refname> + <refpurpose>Ensures that a dereferenced <constant>:char</constant> pointer is +an integer. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>ensure-char-integer</function> <replaceable>object</replaceable> => <returnvalue>int</returnvalue> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>object</parameter></term> + <listitem> + <para>Either a character or a integer specifying a character code. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>int</returnvalue></term> + <listitem> + <para>An integer. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Ensures that an object obtained by dereferencing a +<constant>:char</constant> pointer is an integer. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <para> +<screen> +(let ((fs (convert-to-foreign-string "a"))) + (prog1 + (ensure-char-integer (deref-pointer fs :char)) + (free-foreign-object fs))) +=> 96 +</screen> + </para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>Depending upon the implementation and what &uffi; expects, this +macro may signal an error if the object is not a character or +integer.</para> + </refsect1> + </refentry> + + <refentry id="make-null-pointer"> + <refnamediv> + <refname>make-null-pointer</refname> + <refpurpose>Create a &null; pointer. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>make-null-pointer</function> <replaceable>type</replaceable> => <returnvalue>ptr</returnvalue> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para>A type of object to which the pointer refers. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>ptr</parameter></term> + <listitem> + <para>The &null; pointer of type <parameter>type</parameter>. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Creates a &null; pointer of a specified type. + </para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + + <refentry id="null-pointer-p"> + <refnamediv> + <refname>null-pointer-p</refname> + <refpurpose>Tests a pointer for &null; value. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>null-pointer-p</function> <replaceable>ptr</replaceable> => <returnvalue>is-null</returnvalue> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>ptr</parameter></term> + <listitem> + <para>A foreign object pointer. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>is-null</returnvalue></term> + <listitem> + <para>The boolean flag. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + A predicate testing if a pointer is has a &null; value. + </para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + + <refentry id="null-cstring-pointer"> + <refnamediv> + <refname>+null-cstring-pointer+</refname> + <refpurpose>A constant &null; cstring pointer. + </refpurpose> + <refclass>Constant</refclass> + </refnamediv> + <refsect1> + <title>Description</title> + <para> + A &null; cstring pointer. This can be used for testing +if a cstring returned by a function is &null;. + </para> + </refsect1> + </refentry> + + <refentry id="with-cast-pointer"> + <refnamediv> + <refname>with-cast-pointer</refname> + <refpurpose>Wraps a body of code with a pointer cast to a new type. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>with-cast-pointer</function> (<replaceable>binding-name ptr type) & body body</replaceable> => <returnvalue>value</returnvalue> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>binding-name</parameter></term> + <listitem> + <para>A symbol which will be bound to the casted object. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>ptr</parameter></term> + <listitem> + <para>A pointer to a foreign object. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para>A foreign type of the object being pointed to. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>value</returnvalue></term> + <listitem> + <para>The value of the object where the pointer points. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Executes BODY with POINTER cast to be a pointer to type TYPE. + BINDING-NAME is will be bound to this value during the execution of + BODY. + + This is a no-op in AllegroCL but will wrap BODY in a LET form if + BINDING-NAME is provided. + + This macro is meant to be used in conjunction with DEREF-POINTER or + DEREF-ARRAY. In Allegro CL the "cast" will actually take place in + DEREF-POINTER or DEREF-ARRAY. + </para> + </refsect1> + <refsect1> + <title>Examples</title> +<screen> +(with-foreign-object (size :int) + ;; FOO is a foreign function returning a :POINTER-VOID + (let ((memory (foo size))) + (when (mumble) + ;; at this point we know for some reason that MEMORY points + ;; to an array of unsigned bytes + (with-cast-pointer (memory :unsigned-byte) + (dotimes (i (deref-pointer size :int)) + (do-something-with + (deref-array memory '(:array :unsigned-byte) i))))))) +</screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="def-foreign-var"> + <refnamediv> + <refname>def-foreign-var</refname> + <refpurpose> +Defines a symbol macro to access a variable in foreign code + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>def-foreign-var</function> <replaceable>name type module</replaceable> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para> +A string or list specificying the symbol macro's name. If it is a + string, that names the foreign variable. A Lisp name is created + by translating #\_ to #\- and by converting to upper-case in + case-insensitive Lisp implementations. If it is a list, the first + item is a string specifying the foreign variable name and the + second it is a symbol stating the Lisp name. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>type</parameter></term> + <listitem> + <para>A foreign type of the foreign variable. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>module</returnvalue></term> + <listitem> + <para> + A string specifying the module (or library) the foreign variable + resides in. (Required by Lispworks) + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> +Defines a symbol macro which can be used to access (get and set) the +value of a variable in foreign code. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <refsect2> + <title>C code</title> +<screen> + int baz = 3; + + typedef struct { + int x; + double y; + } foo_struct; + + foo_struct the_struct = { 42, 3.2 }; + + int foo () { + return baz; + } +</screen> +</refsect2> +<refsect2> +<title>Lisp code</title> +<screen> + (uffi:def-struct foo-struct + (x :int) + (y :double)) + + (uffi:def-function ("foo" foo) + () + :returning :int + :module "foo") + + (uffi:def-foreign-var ("baz" *baz*) :int "foo") + (uffi:def-foreign-var ("the_struct" *the-struct*) foo-struct "foo") + + +*baz* + => 3 + +(incf *baz*) + => 4 + +(foo) + => 4 +</screen> +</refsect2> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + +</reference> Added: branches/trunk-reorg/thirdparty/uffi/doc/ref_primitive.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/ref_primitive.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,279 @@ +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<reference id="primitives"> + <title>Primitive Types</title> + <partintro> + <title>Overview</title> + <para> + Primitive types have a single value, these include + characters, numbers, and pointers. They are all symbols in + the keyword package. + </para> + <itemizedlist> + <listitem> + <para><constant>:char</constant> - Signed 8-bits. A + dereferenced :char pointer returns an character. + </para> + </listitem> + <listitem> + <para><constant>:unsigned-char</constant> - Unsigned 8-bits. A dereferenced :unsigned-char + pointer returns an character. + </para> + </listitem> + <listitem> + <para><constant>:byte</constant> - Signed 8-bits. A + dereferenced :byte pointer returns an integer. + </para> + </listitem> + <listitem> + <para><constant>:unsigned-byte</constant> - Unsigned 8-bits. A + dereferenced :unsigned-byte pointer returns an integer. + </para> + </listitem> + <listitem> + <para><constant>:short</constant> - Signed 16-bits. + </para> + </listitem> + <listitem> + <para><constant>:unsigned-short</constant> - Unsigned 16-bits. + </para> + </listitem> + <listitem> + <para><constant>:int</constant> - Signed 32-bits.</para> + </listitem> + <listitem> + <para><constant>:unsigned-int</constant> - Unsigned 32-bits.</para> + </listitem> + <listitem> + <para><constant>:long</constant> - Signed 32 or 64 bits, depending upon the platform.</para> + </listitem> + <listitem> + <para><constant>:unsigned-long</constant> - Unsigned 32 or 64 bits, depending upon the platform.</para> + </listitem> + <listitem> + <para><constant>:float</constant> - 32-bit floating point.</para> + </listitem> + <listitem> + <para><constant>:double</constant> - 64-bit floating point.</para> + </listitem> + <listitem> + <para><constant>:cstring</constant> - + A &null; terminated string used for passing and returning characters strings with a &c; function. + </para> + </listitem> + <listitem> + <para><constant>:void</constant> - + The absence of a value. Used to indicate that a function does not return a value. + </para> + </listitem> + <listitem> + <para><constant>:pointer-void</constant> - Points to a generic object.</para> + </listitem> + <listitem> + <para><constant>*</constant> - Used to declare a pointer to an object</para> + </listitem> + </itemizedlist> + </partintro> + + <refentry id="def-constant"> + <refnamediv> + <refname>def-constant</refname> + <refpurpose>Binds a symbol to a constant. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>def-constant</function> <replaceable>name value &key export</replaceable> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para>A symbol that will be bound to the value. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>value</parameter></term> + <listitem> + <para>An evaluated form that is bound the the name. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>export</parameter></term> + <listitem> + <para>When &t;, the name is exported from the current package. The default is &nil;</para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>This is a thin wrapper around <function>defconstant</function>. It evaluates at + compile-time and optionally exports the symbol from the package. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(def-constant pi2 (* 2 pi)) +(def-constant exported-pi2 (* 2 pi) :export t) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Creates a new special variable..</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="def-foreign-type"> + <refnamediv> + <refname>def-foreign-type</refname> + <refpurpose>Defines a new foreign type. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>def-foreign-type</function> <replaceable>name type</replaceable> + </synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>name</parameter></term> + <listitem> + <para>A symbol naming the new foreign type. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>value</parameter></term> + <listitem> + <para>A form that is not evaluated that defines the new + foreign type. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para>Defines a new foreign type. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(def-foreign-type my-generic-pointer :pointer-void) +(def-foreign-type a-double-float :double-float) +(def-foreign-type char-ptr (* :char)) + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>Defines a new foreign type. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="null-char-p"> + <refnamediv> + <refname>null-char-p</refname> + <refpurpose>Tests a character for &null; value. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsect1> + <title>Syntax</title> + <synopsis> + <function>null-char-p</function> <replaceable>char</replaceable> => <returnvalue>is-null</returnvalue> + </synopsis> + </refsect1> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>char</parameter></term> + <listitem> + <para>A character or integer. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>is-null</parameter></term> + <listitem> + <para>A boolean flag indicating if char is a &null; value. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + A predicate testing if a character or integer is &null;. This + abstracts the difference in implementations where some return a + <computeroutput>character</computeroutput> + and some return a + <computeroutput>integer</computeroutput> + whence dereferencing a + <computeroutput>C</computeroutput> + character pointer. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <screen> +(def-array-pointer ca :unsigned-char) +(let ((fs (convert-to-foreign-string "ab"))) + (values (null-char-p (deref-array fs 'ca 0)) + (null-char-p (deref-array fs 'ca 2)))) +=> &nil; + &t; + </screen> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None. + </para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> +</reference> Added: branches/trunk-reorg/thirdparty/uffi/doc/ref_string.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/ref_string.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,514 @@ +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +%myents; +]> + +<reference id="strings"> + <title>Strings</title> + <partintro> + <title>Overview</title> + <para> + &uffi; has functions to two types of <varname>C</varname>-compatible + strings: <emphasis>cstring</emphasis> and <emphasis>foreign</emphasis> + strings. cstrings are used <emphasis>only</emphasis> as parameters to + and from functions. In some implementations a cstring is not a foreign + type but rather the Lisp string itself. On other platforms a cstring + is a newly allocated foreign vector for storing characters. The + following is an example of using cstrings to both send and return a + value. + </para> + + <screen> +(uffi:def-function ("getenv" c-getenv) + ((name :cstring)) + :returning :cstring) + +(defun my-getenv (key) + "Returns an environment variable, or NIL if it does not exist" + (check-type key string) + (uffi:with-cstring (key-native key) + (uffi:convert-from-cstring (c-getenv key-native)))) + </screen> + + <para> + In contrast, foreign strings are always a foreign vector of + characters which have memory allocated. Thus, if you need to + allocate memory to hold the return value of a string, you must + use a foreign string and not a cstring. The following is an + example of using a foreign string for a return value. + </para> + + <screen> +(uffi:def-function ("gethostname" c-gethostname) + ((name (* :unsigned-char)) + (len :int)) + :returning :int) + +(defun gethostname () + "Returns the hostname" + (let* ((name (uffi:allocate-foreign-string 256)) + (result-code (c-gethostname name 256)) + (hostname (when (zerop result-code) + (uffi:convert-from-foreign-string name)))) + ;; UFFI does not yet provide a universal way to free + ;; memory allocated by C's malloc. At this point, a program + ;; needs to call C's free function to free such memory. + (unless (zerop result-code) + (error "gethostname() failed.")))) + </screen> + + <para> + Foreign functions that return pointers to freshly allocated + strings should in general not return cstrings, but foreign + strings. (There is no portable way to release such cstrings from + Lisp.) The following is an example of handling such a function. + </para> + + <screen> +(uffi:def-function ("readline" c-readline) + ((prompt :cstring)) + :returning (* :char)) + +(defun readline (prompt) + "Reads a string from console with line-editing." + (with-cstring (c-prompt prompt) + (let* ((c-str (c-readline c-prompt)) + (str (convert-from-foreign-string c-str))) + (uffi:free-foreign-object c-str) + str))) + </screen> + + </partintro> + + <refentry id="convert-from-cstring"> + <refnamediv> + <refname>convert-from-cstring</refname> + <refpurpose>Converts a cstring to a Lisp string.</refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>convert-from-cstring</function> + <replaceable>cstring</replaceable> + => + <returnvalue>string</returnvalue> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>cstring</parameter></term> + <listitem> + <para>A cstring. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>string</returnvalue></term> + <listitem> + <para>A Lisp string. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Converts a Lisp string to a <constant>cstring</constant>. This is + most often used when processing the results of a foreign function + that returns a cstring. + </para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + + <refentry id="convert-to-cstring"> + <refnamediv> + <refname>convert-to-cstring</refname> + <refpurpose>Converts a Lisp string to a cstring.</refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>convert-to-cstring</function> + <replaceable>string</replaceable> + => + <returnvalue>cstring</returnvalue> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>string</parameter></term> + <listitem> + <para>A Lisp string. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>cstring</returnvalue></term> + <listitem> + <para>A cstring. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Converts a Lisp string to a <varname>cstring</varname>. The + <varname>cstring</varname> should be freed with + <function>free-cstring</function>. + </para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>On some implementations, this function allocates memory.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + + <refentry id="free-cstring"> + <refnamediv> + <refname>free-cstring</refname> + <refpurpose>Free memory used by cstring. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>free-cstring</function> <replaceable>cstring</replaceable> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>cstring</parameter></term> + <listitem> + <para>A cstring. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Frees any memory possibly allocated by + <function>convert-to-cstring</function>. On some implementions, a cstring is just the Lisp string itself. + </para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + + <refentry id="with-cstring"> + <refnamediv> + <refname>with-cstring</refname> + <refpurpose>Binds a newly created cstring.</refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>with-cstring</function> + <replaceable>(cstring string) {body}</replaceable> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>cstring</parameter></term> + <listitem> + <para>A symbol naming the cstring to be created. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>string</parameter></term> + <listitem> + <para>A Lisp string that will be translated to a cstring. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>body</parameter></term> + <listitem> + <para>The body of where the cstring will be bound. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Binds a symbol to a cstring created from conversion of a + string. Automatically frees the <varname>cstring</varname>. + </para> + </refsect1> + <refsect1> + <title>Examples</title> + <para> + <screen> +(def-function ("getenv" c-getenv) + ((name :cstring)) + :returning :cstring) + +(defun getenv (key) + "Returns an environment variable, or NIL if it does not exist" + (check-type key string) + (with-cstring (key-cstring key) + (convert-from-cstring (c-getenv key-cstring)))) + </screen> + </para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + + <refentry id="convert-from-foreign-string"> + <refnamediv> + <refname>convert-from-foreign-string</refname> + <refpurpose>Converts a foreign string into a Lisp string.</refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>convert-from-foreign-string</function> + <replaceable>foreign-string &key length null-terminated-p</replaceable> + => + <returnvalue>string</returnvalue> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>foreign-string</parameter></term> + <listitem> + <para>A foreign string. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>length</parameter></term> + <listitem> + <para>The length of the foreign string to convert. The + default is the length of the string until a &null; + character is reached. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>null-terminated-p</parameter></term> + <listitem> + <para>A boolean flag with a default value of &t; When true, + the string is converted until the first &null; character is reached. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>string</returnvalue></term> + <listitem> + <para>A Lisp string. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Returns a Lisp string from a foreign string. + Can translated ASCII and binary strings. + </para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + + <refentry id="convert-to-foreign-string"> + <refnamediv> + <refname>convert-to-foreign-string</refname> + <refpurpose>Converts a Lisp string to a foreign string. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>convert-to-foreign-string</function> + <replaceable>string</replaceable> => + <returnvalue>foreign-string</returnvalue> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>string</parameter></term> + <listitem> + <para>A Lisp string. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>foreign-string</returnvalue></term> + <listitem> + <para>A foreign string. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Converts a Lisp string to a foreign string. Memory should be + freed with <function>free-foreign-object</function>. + </para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + + <refentry id="allocate-foreign-string"> + <refnamediv> + <refname>allocate-foreign-string</refname> + <refpurpose>Allocates space for a foreign string. + </refpurpose> + <refclass>Macro</refclass> + </refnamediv> + <refsynopsisdiv> + <title>Syntax</title> + <synopsis> + <function>allocate-foreign-string</function> <replaceable>size + &key unsigned</replaceable> => + <returnvalue>foreign-string</returnvalue> + </synopsis> + </refsynopsisdiv> + <refsect1> + <title>Arguments and Values</title> + <variablelist> + <varlistentry> + <term><parameter>size</parameter></term> + <listitem> + <para>The size of the space to be allocated in bytes. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><parameter>unsigned</parameter></term> + <listitem> + <para>A boolean flag with a default value of &t;. When true, + marks the pointer as an <constant>:unsigned-char</constant>. + </para> + </listitem> + </varlistentry> + <varlistentry> + <term><returnvalue>foreign-string</returnvalue></term> + <listitem> + <para>A foreign string which has undefined contents. + </para> + </listitem> + </varlistentry> + </variablelist> + </refsect1> + <refsect1> + <title>Description</title> + <para> + Allocates space for a foreign string. Memory should + be freed with <function>free-foreign-object</function>. + </para> + </refsect1> + <refsect1> + <title>Side Effects</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Affected by</title> + <para>None.</para> + </refsect1> + <refsect1> + <title>Exceptional Situations</title> + <para>None.</para> + </refsect1> + </refentry> + +</reference> Added: branches/trunk-reorg/thirdparty/uffi/doc/schemas.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/schemas.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,16 @@ +<?xml version="1.0"?> +<locatingRules xmlns="http://thaiopensource.com/ns/locating-rules/1.0"> + <uri resource="appendix.xml" typeId="DocBook"/> + <uri resource="bookinfo.xml" typeId="DocBook"/> + <uri resource="glossary.xml" typeId="DocBook"/> + <uri resource="intro.xml" typeId="DocBook"/> + <uri resource="notes.xml" typeId="DocBook"/> + <uri resource="preface.xml" typeId="DocBook"/> + <uri resource="ref_aggregate.xml" typeId="DocBook"/> + <uri resource="ref_declare.xml" typeId="DocBook"/> + <uri resource="ref_func_libr.xml" typeId="DocBook"/> + <uri resource="ref_object.xml" typeId="DocBook"/> + <uri resource="ref_primitive.xml" typeId="DocBook"/> + <uri resource="ref_string.xml" typeId="DocBook"/> + <uri resource="uffi.xml" typeId="DocBook"/> +</locatingRules> Added: branches/trunk-reorg/thirdparty/uffi/doc/uffi.pdf ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/uffi.pdf Mon Feb 11 09:06:27 2008 @@ -0,0 +1,2920 @@ +%PDF-1.3 +%�� +4 0 obj +<< /Type /Info +/Producer (FOP 0.20.5) >> +endobj +5 0 obj +<< /Length 201 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +GaqdX]aDVA&-UqjSmom=E4u;+CBYq42W:aU`jc=(4<^HFDa4C2;[pruRj?RM"`9CC5\c!@$)nLL3h\g!;4sXMmfN\;Ob/;ZJ4jmbWdP1T8;@d21LPNCB?%>c^1qP2i7r8X.ie[\P0lY%HhV`UBe#dQ"_J#\3Ui0X8G0l\r9<eU3G"mDiM+oL(Zu_Jh4NONnHDEn21t~> +endstream +endobj +6 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 5 0 R +>> +endobj +7 0 obj +<< /Length 965 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gau0Bhf%4&&:WfGn0=3URfk)AmA]JBeZIYgNc('34da.jX2/DV"(QiZ*"qb;,h;`f<N>tfIG`k/p0G1qp<Fufq#h?fSbG72omGiR59K]PLHRI$A*j)+\jSd[pQN_l$2T@Qn#b(.i,ioD6TcF1%@9.7B8VP!SY/8&)W>ZUq5AdCn<=r\6KFJq+B'#DKK+uASe#Y^7EH.-48iCMeot"J0k2]6$(m:faarMNY-s4#$fda!K$\]in@W.:rsbO`"bFihimpH/0d]2W`'Y)hQ6WChV@0:hFQ?-t9M!XGE<jPSU&[\le9"j@jH4&u-,-),JWsl?$'mU['``%a2hh>:B%rZ/K3PN*)V[[7-2Gd7P&&<R`>k.$Y2)-;<1#`(S\[k+:@&^f3gar)'V?+p3L_Vh9Ibga1?J*ZTNf3FWD&0q'?4/^OYR*$")_Ui#L7AHEUN,P]`Sqe^t.7$+>jT3DYW-\aR\nsG_kCnO9lShmE-OHGSHnO2l?:8eeTA)!*))0J;PpD3Ah65Y)fM^`@U1u;-cV-RmDqCj;RF/XPm5@2]Jb8-`#:9=8*YAh/K\#:e1Sh`L88OX6\FPZ_XDDVqi?;`(J$-AOdp;p<$-p'P;;5fCdZqc--*R.SO(,e0->AAR2DkCd5@+JbD*JbOS4d<'MfB5,fRDq<msIJV,<4,0>`W2EC,.o@sm$[U4k-2s#:5$5):NjsEfh6S$m&l'MeN]+MErK_%<=R0":5hUopj[22Kl;R+H#[9k%Q\PY1p9<'&f7@i*$o%1]nO`Y,,r2u`B_t@aheY@Sq*.LdNo<&"a/-F<XB5`'iUpaRmBYJPMb0?u`h%HtSEGsq#=u5\Ep:Z(/RAi[58[,U#1+a+M:=(;>jXAJ/NGa'N3o(jZFhcV4>eptt<K=(:#eQ2/rOD(),k%VDhplYNSL1TXiaFr=`#I^O:+d'4822siIHb$2T,s!u*d41R#F\(fhu~> +endstream +endobj +8 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 7 0 R +>> +endobj +9 0 obj +<< /Length 81 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Garg^iGoCd.c`?]8EV`b1=.gRYV7c]1UaMe0JP941GUmh0[MUU-q[K1isOjf_GG&\U1]Eh,lhpD'$^~> +endstream +endobj +10 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 9 0 R +>> +endobj +11 0 obj +<< /Length 2067 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gb"/l?#S1_'Sc)J.t"a>Kp)+Vq!/R8<as$#lk6g2m=fO,_+S6Ma%fJ,om"K?N84n."\MJbW`&L8[9["ZH[O,/f-a@kUL13m8"p<L^$0q*H]&L+r8rcZ&Y8]'7$:-c\2R]=s'/7H[nC`*NG0)$P(7N?U7Csa?Bmr2MRpCkrq3/'2hql*i\sAANk@G'U$@UkM'mc)*qc?Do/'CdA\S#-(R#%**s;Xr^7ArS-@pBGbtV<O'oM!a+,Ym2]\W0^;9O!gam-Mi<,;oY;dTb8"?K*WM27$3jE:O^>Qp3;[(4CMY00H#1/WGaZNbtG6]N-pY`Bc"dd6p!QCD?\p*V8A5bKp+irL:\qZ-,#ZX0!((/"V=&nJCVMNoUT<#$QVo*7aZ;dU(A1gE=d[MRFl;<<_1fn5%k%1!+563mltaW<4K%j<U76>gl761#=.Lk%_mVW4tZUsj>-9:=DB:apP&fVqXd"9RCbfPUX`3=LkNWSY5BnYIcQ10q$Q@U\0lZ`IBYUQ,P0L-eAfbZWC"8[9.WImqTHqUJb[q)lt5Q-PN$K?f<;V\Pca#-mjO4^Kb[6C(^!0<kWa!Y'sGCH/VS[-)_Br_Uc3Q/2h-&eJ_qFBm(aFba9$nQOh0REfRQEqUUekjI_RCX^'[\?8IRg4lp_6!q;':Lpk]rO5m%;&pFUC!lHu4O,]ZBr_KZm2g?[+'EJE7k`G9^</\6Q:S4%RBWl$=1pi4^:o&n5+<8J,j<J:GZr-)XLfV%JEXLNWO;D(ag.qdTBdejS)WklJ0GL+IFf"*mTTq7)H*/$m)SRoaHig\42*_+4Ttt7OCSD`i%F)<Iigpf@Qpr5f",f.EPDR+*]TS7&NXtD*d9.mh;mUmCf9.Ohf`%NVG10DAI\k>aiQr(aI,`k../Ap=]9auBq`*SE6s/$B0djI`9n0J7_K?eDu5s7\q4pT!>&p`A42uu73,M-;6a7Va4\((Nn6nL\?1BKk=+N!3T"-8o:T%TGK^!+MhMk'[!%]4N2*!S!Y(NUkhQnl39.]R?5/loOu9fR+OKqJ#nGH**%:+VLT6XZm8ui&!.c0kRIK.CMK<5iEskj+X(>Fp\*7oXoJ+Fd:EBW?h*L2Y/T[O(b'[LW74i&VYHB"&EZlP:W$c>h4-1b;0==TP9Q)tlB$n`H*s?oBA/'E!dVBR;,om04SVEDQKB1Np%K_4L+VqTTH$VWVF#Vtjk$.*>Zmc9&ra_b@JTFUGp9g/uf@YSJ2Xa?_d>nkd-bfcq#W+Y!TuHC@ADI"de)dmZdTZ"._<#RM&PnLCJ3[J84*oi8CN[\!=)T^F6ZW:jK7Q9P8>U3F*M_1jpE?`t*NE(W0pHGSJ^0I<9&2*Y7]ae8b!1c'H15blpG$4a"M.BK\ijZL[iR?SSK=]8R;@Z:Eg6h>jZ5XL:f#PX6Q&V>Xj2(09bsB!gd*(0=6\Q.25<dm7dm(M2H$oCRB'\/B)H6LSeVh#HR[A0)5CX"<2-u$/m9:DnC1M>!hDCjQ+GdV1pCl#<Vg$\ojei-,LZqm8eC3.\oge>UHIfP;q`g*WHh*^]#mi%!sA[R;<DcB'4obdoV`e!<n/rY(-B2oC6$(Ba;kE[-35m2q2*OmDl^t-Wr#1>VNZNq_bdSl(e"aTc4]!2\d&AM0F0Kt17CD2;<b!;W,HNPh1pqql.fCQ2=S<A+;!a3dDkPs+c5lGAS&+]Z6%>'\_>TnQ`:J01-#X4r?^]G/sDYB8?sk[JqR>A"?N5qh>Lr[ApneD-FArt$)Vs!5\E>/"Lq[f,Y2f)WUE1S%IlkP+OD!f#m'J&2W:pQU>@KIgPCCQH-epS<^5BqPpS&&Q+r+>$.,4IJ\Ip8GNY@?,6Ok18eX#c!e$gFh0iTrXS_9WpKJiF2apd1APq-iI^/Z1Ik+HclS"7Y(eY5<h5beVj"uRAbBRSTX$hdtHj5.N?8BBAq]ukjc<?OuCnEI9okjLolQ8,C#]u]mFO/!`Xd*Ul(G9Q&=IDFI+/I>U9B*GFkl6e6/OjU9)uII)`JLLI6..1Nr+9Ff]_Ucpd?Eh^NC,m<T@n64IbNS@,9D+r3,*hWq<(uZY<N%3Yd+!~> +endstream +endobj +12 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 11 0 R +/Annots 13 0 R +>> +endobj +13 0 obj +[ +14 0 R +16 0 R +18 0 R +20 0 R +22 0 R +24 0 R +26 0 R +28 0 R +30 0 R +32 0 R +34 0 R +36 0 R +38 0 R +40 0 R +42 0 R +44 0 R +46 0 R +48 0 R +50 0 R +52 0 R +54 0 R +56 0 R +58 0 R +60 0 R +62 0 R +64 0 R +66 0 R +68 0 R +70 0 R +72 0 R +74 0 R +76 0 R +78 0 R +80 0 R +82 0 R +84 0 R +86 0 R +88 0 R +90 0 R +92 0 R +94 0 R +96 0 R +98 0 R +100 0 R +102 0 R +104 0 R +106 0 R +108 0 R +110 0 R +112 0 R +114 0 R +116 0 R +118 0 R +120 0 R +122 0 R +124 0 R +126 0 R +] +endobj +14 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 120.0 704.89 149.98 694.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 15 0 R +/H /I +>> +endobj +16 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 120.0 693.89 179.44 683.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 17 0 R +/H /I +>> +endobj +18 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 682.89 176.22 672.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 19 0 R +/H /I +>> +endobj +20 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 671.89 192.88 661.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 21 0 R +/H /I +>> +endobj +22 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 660.89 254.83 650.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 23 0 R +/H /I +>> +endobj +24 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 649.89 172.33 639.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 25 0 R +/H /I +>> +endobj +26 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 168.0 638.89 207.43 628.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 27 0 R +/H /I +>> +endobj +28 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 168.0 627.89 204.67 617.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 29 0 R +/H /I +>> +endobj +30 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 120.0 616.89 210.83 606.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 31 0 R +/H /I +>> +endobj +32 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 605.89 268.43 595.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 33 0 R +/H /I +>> +endobj +34 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 168.0 594.89 211.33 584.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 35 0 R +/H /I +>> +endobj +36 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 168.0 583.89 210.22 573.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 37 0 R +/H /I +>> +endobj +38 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 168.0 572.89 203.56 562.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 39 0 R +/H /I +>> +endobj +40 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 561.89 314.52 551.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 41 0 R +/H /I +>> +endobj +42 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 550.89 263.73 540.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 43 0 R +/H /I +>> +endobj +44 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 168.0 539.89 216.88 529.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 45 0 R +/H /I +>> +endobj +46 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 168.0 528.89 312.72 518.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 47 0 R +/H /I +>> +endobj +48 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 120.0 517.89 178.87 507.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 49 0 R +/H /I +>> +endobj +50 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 506.89 177.32 496.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 51 0 R +/H /I +>> +endobj +52 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 120.0 495.89 195.83 485.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 53 0 R +/H /I +>> +endobj +54 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 484.89 193.43 474.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 55 0 R +/H /I +>> +endobj +56 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 473.89 209.53 463.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 57 0 R +/H /I +>> +endobj +58 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 462.89 188.43 452.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 59 0 R +/H /I +>> +endobj +60 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 120.0 451.89 203.58 441.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 61 0 R +/H /I +>> +endobj +62 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 440.89 182.32 430.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 63 0 R +/H /I +>> +endobj +64 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 429.89 182.32 419.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 65 0 R +/H /I +>> +endobj +66 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 418.89 198.99 408.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 67 0 R +/H /I +>> +endobj +68 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 407.89 205.66 397.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 69 0 R +/H /I +>> +endobj +70 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 396.89 212.3 386.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 71 0 R +/H /I +>> +endobj +72 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 385.89 188.41 375.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 73 0 R +/H /I +>> +endobj +74 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 374.89 182.88 364.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 75 0 R +/H /I +>> +endobj +76 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 120.0 363.89 166.1 353.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 77 0 R +/H /I +>> +endobj +78 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 352.89 235.08 342.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 79 0 R +/H /I +>> +endobj +80 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 341.89 219.52 331.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 81 0 R +/H /I +>> +endobj +82 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 330.89 221.76 320.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 83 0 R +/H /I +>> +endobj +84 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 319.89 223.97 309.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 85 0 R +/H /I +>> +endobj +86 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 308.89 205.65 298.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 87 0 R +/H /I +>> +endobj +88 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 297.89 196.2 287.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 89 0 R +/H /I +>> +endobj +90 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 286.89 230.61 276.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 91 0 R +/H /I +>> +endobj +92 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 275.89 221.74 265.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 93 0 R +/H /I +>> +endobj +94 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 264.89 216.21 254.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 95 0 R +/H /I +>> +endobj +96 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 253.89 199.55 243.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 97 0 R +/H /I +>> +endobj +98 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 242.89 233.05 232.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 99 0 R +/H /I +>> +endobj +100 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 231.89 212.32 221.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 101 0 R +/H /I +>> +endobj +102 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 220.89 205.08 210.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 103 0 R +/H /I +>> +endobj +104 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 120.0 209.89 160.56 199.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 105 0 R +/H /I +>> +endobj +106 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 198.89 227.31 188.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 107 0 R +/H /I +>> +endobj +108 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 187.89 215.65 177.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 109 0 R +/H /I +>> +endobj +110 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 176.89 190.09 166.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 111 0 R +/H /I +>> +endobj +112 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 165.89 192.33 155.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 113 0 R +/H /I +>> +endobj +114 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 154.89 255.08 144.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 115 0 R +/H /I +>> +endobj +116 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 143.89 243.42 133.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 117 0 R +/H /I +>> +endobj +118 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 132.89 233.42 122.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 119 0 R +/H /I +>> +endobj +120 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 120.0 121.89 223.88 111.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 121 0 R +/H /I +>> +endobj +122 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 110.89 193.43 100.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 123 0 R +/H /I +>> +endobj +124 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 99.89 223.42 89.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 125 0 R +/H /I +>> +endobj +126 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 88.89 222.31 78.89 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 127 0 R +/H /I +>> +endobj +128 0 obj +<< /Length 395 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gb"/g:J8Sj&B4,8.H[!;h!T(Rn'RjY'ed^U&eDfr8g#IJ<5ieE/h%+X._W7<-'o^;H'q/FO3Gm$RcOT!_$"S2#cnUAi\(Y'Kqa_='4J\j^ghDA;n-3Ze<=ImDi2+Y2HALbWm[RZ)M\-O,"4O';A9L0\5(uhm*1b;S;.4ZF@qXqp7nVA@^YTnj`8S:;5H.Io"463c^1Cpr/`T^G6a\YMhr/4*9loWi+2[ZDg`I%c.Zs#<6)Ef.8ls?$B/Bu@:fk*7G[Zcd=$=<`l5327uA#Fs3`fLbVj[J/UAEI6&+;P*,!t*-Q-Mg!:e=)K+d"6\_Xm10Y`88*uV93LMnh<@Zg%kmTo'<f0$Ze4E4N:<@bQ9W:W9'EB-cK!`M<P8BfU<j*c7+(IIR::&~> +endstream +endobj +129 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 128 0 R +/Annots 130 0 R +>> +endobj +130 0 obj +[ +131 0 R +133 0 R +135 0 R +137 0 R +] +endobj +131 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 120.0 768.889 177.22 758.889 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 132 0 R +/H /I +>> +endobj +133 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 757.889 210.93 747.889 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 134 0 R +/H /I +>> +endobj +135 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 144.0 746.889 177.33 736.889 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 136 0 R +/H /I +>> +endobj +137 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 120.0 735.889 155.55 725.889 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A 138 0 R +/H /I +>> +endobj +139 0 obj +<< /Length 590 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gasam9lHOU&A@ZcHqY%9q?(6;7d<Uj.@'*Gb/%M'ee/?)Rn\B]c,.IB9fEXs@NI=Djup^HeCh;o"XJk78O9I6"PO7dj=Uj#JI$3u5t25YT>:'Sdj12lj?7_goqSQu!$dijlE3"3/-*^N6q+X%eOOKE_2c)c,smE<43&Nmfe5`:gs5bX5R2"l8\`E$^`J]Pfn_P;7":!n-&%nfP\O%`C5RMj:e"hiP$$&6rVjhH#:O4=B1WPkS(?j%8l*IH:id>GPuA*Odr9IWR8dpqkq&ag2Ic5c&G8D][<u0cEs<$8kn#t\o<!RZVq^(K2]X+[6X7QX4u&!m$7d$]5i6HDFPZG`q_fEi=<@]9Xh_Mc+"3!>DM=$cX<%FcC'^1pfD/f4@2%$FdMVr:aUa@`.cT!W\\E5hk0!;W<8BGEo,Q1.k4lk_>k,f-W!)s?lb[Li(e<7$oH0,NbJj\6fe?_+`]>?_k0oUVEkJP(Vm2F5g"T0JcA]'VWq#P1U\?)5X+_l!\pVQ@H!CE[r9ne%Hi:-RBM68d/LuppI3Y6_"<!RP:ta1]Th^dZpEBO"q7aQXKfnOK(!tdGKB6>;"b2b"9)~> +endstream +endobj +140 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 139 0 R +>> +endobj +141 0 obj +<< /Length 2030 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gatm<968iG&AJ$Cn.oY+AdH-(>HPi7FI^8ibL=Zl4[:8@@8%7a84n#SI?t"+/7m7Mg5IZ>Ks:@G]tj=+in]T,\\9*)T!c]o*,BU]/-gXBMHno@+tp2'0=4bAl]96NQ<"HYDlkNKMX2U3P0gccp6bh]2H"(&g2Kp'[JmO6^T'(046knf-h8;8::s->^M@C,C,YDc/E4HpclV1iN%bHE^8j/o[_2#>KUoVGa`8_2R52\6Zog]d`p-Oo262LB_Ipp!IV4f53=e&-+(%:qL63J\j"1X[.Q*h59crU(+_nHm6-E0m!H:342jL,?YP>7MfT)4+<CZCXGmW?L.98X!@]*(qfJ#u-d&#C^Pb=[R]=d6JAZ/(cn)[P8b>#&-.pa]K'd-WqLfa)RUlr(<4s'kM`)oQdJoV=OfgsMVg%d<EJaF*kRih>t5'?$9U$Z#S,=V>F.I+GE'n8kl6W!BbA'J%bL<bK(a)_R.j=\M6ch1Q>sV1W:<f9_"@lY,:"YGr"T`b^/@ahtATl!7p7*:F`HR@8Me]7Gb8sOFV`!1A'IjOs1BP0-FaQ2aT:65n\+i;Q"ui\NQtcA/HC_R*L$1pHgqbhY=<nQ]QjWhBLbt8oR5JQF()>dpgaG6/iagNOG,85Zu"5dYtj@Wi6*]@=`)!+gn9g_\gEk]eCt][RFXUanG3W'd:IZ&<MP*j&M5:A!%n\QE$V**)i+te;dh12TfEB4tA*%T!effUBFZtZ<mk@I7-WM&SK62nKZeFKCPNB"XD)uW-Y8k<.Ccn!c,Abf/7=PI5I&bc?7(a)YJi?J[]k5N?0dL7S,#]9]9q=98-2dqdZ2GsC4prd.JX)!2#>(t+Pk_NK!ut0j!AlqV5gq2LeG#pC2#G(XXeC"2#)O-$/Gfa\rnGf,X1g`J)Ns7L..e[9>LKf0qGN4/9nanCqEb->caenF?A[C?TX:H7<>hQg\md,7H&=Sp&t2!&W*a>@/p32NXq1.@HeqFMS1$a6UWe'UnNp2)Siufb;MVA.7#NC]M<a@/cl@\Cb]>QF"E*:\[l!;:4:h(?F@[fpBg.<,NW32sL8&N0G$p;o(9/]2p6P-/G]47]L.k$j(A"4W9\IjN:kM,a@5Qe841,Hg2t`)(T$?NQ@Dmpm(-8#'EK;Dh,AuRq&N$_se?_a8#G1<.rO@`:\<;6;3_gdVX<->%M)_\G"_e2^E/1N6S5!V5bTd8el3Pe*+S37e-LkaS9GB]c3mi0-iD8?92ZQgN6M5Cs0Gs,A[g)%;L*#DXjRW%]bpfB:q>BaMQBs0qmMj:#p&06TnEjUlW-\P>N?bLj>ruB:f_#pH`bLm"%-r+DB&\@7J%_=(!PUp52"'YN6-)P)_Z(\rs"MM8>Z%@A00_U-#E_"C::,p\4(tG71N.iNVP+7:%.sF4N#Ya-POP-/SiY5Vk7/J7b(eda3KHQakC'=3q.ZoTnc!S`kmNFom_j[u]B(:\2\$'Xf;q9UUTX!4TcJ:CZtM7#VGu08msT(iLSLWi2*NEXEAZBXb2.sV61A'9N\_*IkcWSldIbW\fCQ,_Kf_m>,lMsa+7De=-IVRTB7!/XpRQcZ(V%r^3BNb%`!OY]Sf>=_&r/c*"QMWMII[!B5+N^f.fUq-?DZe*mPR>7U+>YZ571l0<1]a;QV&h:>q._p<HlLq_C@U/D&X@b=j$"J.aQo#Oat3%NM7uNqZ;'`85GfqL-]+oC1P^&#:G.M07oqsC\/mFBCF&&XBY\F%_QB]_^YgNNf>,I7+LcIs6&I:A+Y<!^HW0r9pl(Fp;%HhBCG"<cjr+u0h[iB>aa/fT^Sct)tc%t*d7B&JIlg,8>0&c=86sF?-Il1;J;u#<<uQq5qT/L2B+udhGT(h[hk)q]]YHh)\VdAgR[E"]Bllq@j;DPE?%`4NL?pqGUT/e&0Stg7`*GN=3%_DE3o_6pPc"X=^9h8G_3n"L!6dmnF5;L`0a+uS#)`.5HHL:;X`"'A&N=No&9cV0$e\aW?'&fafPF"[u9S&l(>l]EG53@K9Ae+%5`Ye]^>%JB4=X8(WdPS<r~> +endstream +endobj +142 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 141 0 R +>> +endobj +143 0 obj +<< /Length 996 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +GasIg95g=S&AIV:i0[&<QhTO/Wf^2Y;Cg-ngOg<d@KgRWbc^05Y;$OuK^C8CBP-V!q;uC_e&/)M^iF7%>A8)]Xn0B6D"ZsnN]RNA^dWF.=D;XNHMHm=_4u,]KAknM1XCp;gl^o+b0H(!+"R;i9SSJI`EX+N-sk[*q==*fW!"2A>h`2$f.(pp9&l-p6sp<tA6]D'af5SiR%\M")5ceiL'pRn,GK<ZOd[t\-0;3s'=^b/4Qfa;;Z&G)M,9kXjVP!lSUlS5L0cr'[LL>l5r3JjOgM!8(G)oj2('l8rlI]A8HeO'V,NnQ@pB(/L2<jUZu)Hqg0"[Jl(EgYkFaQAQ*PNHqLYm?bUgglGCl)1GtW\D]E<qP)nNo>)lRWT])gt#+CtLd9AfK*kH)S5e!>G",!0,3luu'h,e#hr]AOL*kJpNgm>ZgfaB%KRn<?Kg$Ch-Z:<5idj?fkT&m?Nl2iXEpUJSqC6?jkqc]=0+Dfh*2R?eO0BE[FKarZ3::>\,_pOb\-BpacbM#^D>](6\T^K&02#-E42([YlQg*B8L"W8V4VSL"fJ<;D^5A9e,kuP(/N#"gb.NgnI>?h"VE*Z891C#5?kk[Tu=E:'ngPqNc)mU&Q[Sc%qRJ-6L2Dc9@@4h=nJp^Q>+`MAP>V1e!rE,p^4rH@*,TgGj!Y'FL]9Y"]Q$hpMgI=d$Y;'Ri'X3Sk>LHNTb"D%NE7=$V9s0D7AU5^(XK2,<-`qpEN*\.N9j$-VEno!sYS.f-,o4P[+3rs"5"UFeg#p:If(@dl->.RE6&^ch>Ar_'NP"/hjr8"l+qeqSg9N)V-HeB\&4TYOD[]PUJBZm*hRo%R6I-s*9MaRY*e@#/RBYZ'VXS0Rg#LF[[eeRBJt2Qsf_(ZjD0oO&8^L)c.+,"<o=k3e*o=r@T(-MjI,r8'jf:$F2[V*?4c4hn`Snkr3Ao\?Oc'i";RaK:H"BnC]ZWd*HcAEaqjump5`QX`6&>GP[-JW?rr>IB>Z(~> +endstream +endobj +144 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 143 0 R +>> +endobj +145 0 obj +<< /Length 2451 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat%%99\/>&\d_;i([,"%a=Z72bTDf46=CP4??V*E(P#)LbFl1Xk(6N+<*R)32@q$WNBWZ!4j,/IKB?)r:%U&i:nHge%dtF&$Bu!n/PO/4=BZelQed9U*+X)Xn2GEO**Y1I!k+Ir$5]Rl=R<men6o>O0QHYH/"5E(a)LrCMTDA-)q6tGE.nFecZ>cs)'&AX\5lq[KDMNtU]USLqoUY-2\8gN@rGCJHW'k'h>:Emqr:EHL*/?)p6@N_hIMr$D^Sk`;9PL"J94?s9@N&SLn]S9u1J/l-7@>p]h`_p,J$R`U%%*Z@Yi_o,\[ZI!q<RX%GVRt*^\BMRC#:Cc=5(HN7DU@Y8E>#u'MK52quqnhN4GA)r`o&W9/]'IY_=GNk*I-G2A[C%2[j2g(\MeK)S8bW,`Bdu;==R[b#gn0rOVmj4cr$"75sh]lAqB^S^0A!VZ#V%H.nd`1523l.EZY<hT=)Qjt@qK]B*lo^-3a6Cp+-Bm*-CLXjki6S#N:eMWS)_,'(>>VcgBsXFD7$F>3pZGnGMe[p6MaKg:'/TA?Y!_CRuO#Z*!YRHqHM2Rj2iYLC^")_:L)#"n,`Q2Ks*c0D!0c?%bHd5JsXI$ANSOckc8rjmZFhc&l1b]SE+\(g,EN@NJd/!eQ9/0F]>Wu+iG,EhapQc<]"C#V"'A2['AJf2>>Ll*VWM%$MaVO*OD=>\/>1B*8o2:"q4XN0c;n+`9r<,>(%:3/Yj"#Ymmk[ELk$96N1eDlAQHU^RNi_LnK_^&gp$.q,=4lX7l0_O8kHm5BY"XHbg-Ylee<So:q%)n>WqK<DZeHS-;&]C-,DqBfj@Sd\P3JkHJbIW>*`JT>aNL$B9UOXN[F<.3Xj!,c5["+feTTJGH.QplkX;hm%d4M&gX,7*/r8s!#KjEE+,l4(2Lf-qD=Z)->gq)T%^)YL/i*.W>_uL5M!pp_s`6@V1R]aQT]H2%?RoNF;0TAR%cJ6[L!N6>?!\2h:0cnsmo[,!@K<b:o6g/eHMcE"4lQAu%r'=L<W;.OO(CBYH\s`3Tl07BCNDbja/C`ZCjM_oQ?Irb(GM7lr8m)_(`o[[]6fbQf18`E8S[L9`ebM.A,Gh>>F3ca,o:kZkf.5`4QoD<sYgJ3iB8Q6JZiodZGP2S^63nAe?Y6''SYNJVR%Omf*DFo3>I84".an6kkYXl\4Tekepe=DZRQV;?.ac[QeKq*Vr0i-Qd7RBY$44RfJmOt6<9QfgSqVb5/S$aVaHep)0OtH[lg+1VHnW5(4l6WLlp`m?bKk,*eX&4bfXI4"SKl4Q&\\=nq8,(1":aJD<-&$HH)X50,?a`rRi+d<"@/B^V0MCjP/*,t""'#6rOMKZA`g"nMWCBb:ML+.)biM;Q#'l*-ejp__Du^u)PAulJXh*@gF."&1.6TV?hcQ[k5Z+c)o@,iBT;(@)\Q+3>@..`ZXqRH].CJV(Cd7M9+]qN)ISVkNZgg/L9VIHA6NUc27mkX_"X7`-2()+?8QH!+8U0m-dk',,&,,!Aq5k9]$pZ9ZjB*\"nK*;0n'Wp5L^uQ6KZI!ZPI7ZN77eM?6*eG;c?ZE4C4Al3%dt34,`H:3N6UPEhoR@GU#`trD2n3^9l1/fmY@GZ%l9%qna6RTaO"$IM[D["(]*I-j6OjHs9/J+Ou/G(a)0.IjZA6j7<7fH<LpD7o@Ylh>:8u*;NE5+Ea+\-3L=^tc,58kWbD<5Ac`d*qXe/siR>`bZ&@;;(&Agi2JE>pK'YOSN@P0WaqB:?&k^<?M1\T:>g4,lT][5()R2WTa13m$BdO\9J'/Z4C'Z*>IZn"]e)F3k&;$?-WalfK%J/\O_gs7iUr;4is6Hk7Q,3)%QYq?(XR_B^XP3IUX#*mqo):9M[jeG<M026HHcuDJ>@oScJXUV!S<tShc!*G-c!RL>BJ#R:$Y/Q,sD]OuudP\3d;Y+MQ/2s/3&:+^ICfNf/c4<'bo64B'0FCr2;kpa4]:G*\ZB+&cqlD/3k`P=X&YAW#_g6Uq=CXar0b7!V-ro>YZ5lDccX_WI&]9P9DVg$H1tOF9fPb#l_"*Vj>j>[6*bt`Z-ed$jOtP.Hqcf+kgcB\hS&pQ"g8iKA%0CemBqt*kNC-FOb'n@eTQ2giCJfYQN8TVCMC"GTJq>+Z]uX[11cDYqfAb0$L<d3:b6E%7Sfsj7%>ep:,[,Gr;8gk/]&FBVaQFp)K-,k"<X1>31gI8Hk25bV1Y\ROH::5K"N=?G,Y6,A\h>uTT=MO4,G^pC$)0=O=QSF/HYmV=c/9sh;bD#KC@["MPsl#N!G&M1GFKu5fgL[#o_Im^Wl06e>>H_T@b4U=[hF#U3cL6<%L8>YoT"*/^_4u7C&!Vq50I;^;Z;'lh&DC::"'pSbfpjN<N%?bDH'_e8r^TU+25UAZp5.'?BEUZ$/L.-EoX=(:*Xt_LOVL83,^0;]*AQsGPf')@U>-U;9VB"?_mb1pb0+Y\X3~> +endstream +endobj +146 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 145 0 R +>> +endobj +147 0 obj +<< /Length 302 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Garo<4&<aJ&:f!)MVCZ+]=)4ioi_Y+"p@g^_@SS;'.FH2>U9;3%P9+r7(;"<qsFq/g"fdBS8kJIiS]OmSjIrUA4dalRC3m2!M6VYC[p%9!HXn[?Y6U5pkj0RiH1#8I_HtBd9Wd^F]6*$O-c.ncf#&-qnE[gR420ma%5BBMY*\.:Un)TgYu;RFkF0FC^.!4'n9GMp[bY1kqZ;E@W+R&Jk;_g1CXB$OXG0O*i.BmrHLtPR$9@#mMXUmo>`Q\cjW9#qBR3V\%olqEW.%a-L(eVj]Kbq@6g/QR579;Q[Jn6<c-I~> +endstream +endobj +148 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 147 0 R +>> +endobj +149 0 obj +<< /Length 468 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +GarnS9iHZu'YO#fEi_&S#!rq^g8YCU:<+573?GDQ`Jd&9J_'\`%3KG#XhuHsm(Sg7H*bH$H(ZPkE>297Ccm;)cUYp&^1B<b\Nk`Z*/P4Q"aZ`p_(&6'>"_ka/+eRZa1_VkK(?@e_(>^^&<Ag]"RE25/a0<ih9j6(:TS5?nq37dXZ*i@n!\:S$7;_V#9!\[LMGqrRG<gEou@?><)LaWZt!'8b<l3L138s:2bFllpJLO+e^P(4"itNP^YW%"Yf$'%CFJLr595oZV/94">#j_^eeh78XRYOd^2VFU<MaeS*4$[q#<R67](9d16`/DD:0Oe@=@cBXPl<L<a4W`rE"K`6%E9Ao@,)Yq9UFcoEfAUF`]A^;ZEF?VBXpb,0(V?*DQDd3lOaLE7OKLG6%5GN?iB\A>pI3?NFES7g+=G`$u%sGn(F0Vk@,KAqN(3qOp3YY4r&ln*/a_2bh_7pgq:n.~> +endstream +endobj +150 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 149 0 R +>> +endobj +151 0 obj +<< /Length 820 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +GatU29on!^&A@ZcHn/0*l>J&`Z!EHig6F/9?:k_O3,Bk'ck+q%n*;6L*S?HR.k]'(2tQt0_`S'SG;Fu0!pZI%*al>m&;8;`+@Q;U`<@[+;37O@_l#3=,P2'A*t:gbK$=;u3WfYi*/[UTZiR7N4>)[V!ub*8rA\%[WiYllj!<*#lNln0%saW+RC,7*qjk-pW,U^i]!tQ<dVlXC%\k5_+T,GsoSc-e!o1P&If^40K;+T:Ts@jtZ,@HM(VCu794UUSpf'*F8[1:O3\+uGPQG2'DM6-_/c/b^4]K:@1M[[94osaYQWeV3"M[E"XQ'+e]#qM52SkPmj&G)B\'+@MEXLQ#/P%6L(ZCI6o-/=VKV_%`VkYM4gbu4DSl3\bRL0'h[<$bec/s6&;%J<?[hf+8F7)js*%kC^r1JP-\q[%f6Z:EZ`diEAan;V,;3C4fUmd[B!>WW!"?ckeB*,3C$MSj`9c"T%PM.g`n$OV;8Bm+2bXr8kh?I8CEK:._We!kDK^!C?N6hqOTpCV+>6piYW27,S:*UfCLW+L>(=r(h3IGVEpXOiVBK8,M\dHbXbHOoi!-n;N_r)u1_]c>mi]O]iEbMCnjYH-5'.6J\%1DQ4qefHTmYXaF&92cTmWpS/6$Q]<=<q\<g2PM#eks!HD.gl5mQJ<]pY%XV^TB59>0R$6Xm*J-iBY\L^n`<\gH0b)m(Ei#WsYD(Ju:_X7:%G]-us4j8CpKWgpSskP1".]j6r=uRXPrChD1H&K:gEgKDM*nc'%^H`%_@o">VB)BG:uk$m(#d_kte^j5abbp]=!oFX<PJ<8,QG!E#<U+T~> +endstream +endobj +152 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 151 0 R +>> +endobj +153 0 obj +<< /Length 1246 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gau`T?*g"Y&:O;Vd,RhJ<^6`VnWm^SLJF^@-etVq%iBsoK#-QdGPpof/<!W^Lm#3q\T;E%8dCnM]36e8(N&#VTSPS[pF2!*NJ7'F)d3-3N<fhEo3C?R$i?NJU*KO*oVp,sH(1H%/$pUoLBHE@(j_&l-f2L&J"Z!AKkCfmRj."jfTPIUcFc@(r+0"+k(AS.92&qBasP!@>_66Rme<M.^c$LRjaO\Z6OY>P2/Mi(?\#+s>]fm$GgCq"?ofs)U.^%\3Q-'1[(L8VW9fO+h%H'RH8noM.1fULU'&/\eMSUV'GK:,"WU_qcs2UCWXoXR=%r<Ue[Y?>4acFZQ`<fGi=mZsj#tGD2sJj72u-(%3sI%A%h--=KL-_Y/6O&`*O8\h53Mg+"/c'@Qa^&H#/aY&9R4mhrkD,L@b?0P<=5o<2/g+<"L?!3[P>.MV/cHAV)0)7m)nJUhf_:1@P]!+JW@IE'Nd=[:X?q*PQg7r%<'d9WfsebakZ5J0PLN=8V7^NNhp.<WERaEreup)k;@Cq[@0EM\@]+q1#4\-^RK+]ruXlmZ$&>^$tX4.JI!"J"bf@M\N1KS"B4]C24@A;0>t0P[:2EifGpp&25ZKh7"Q7C)VOJSd0$CDi2i`S+dA?eS-]e,YCV[a27*#?>1O5sp<b\<l\Z\3&-dD/0bK+F_VZRF&P?@c@j3NZ*GQ;?baI1#3C?2:<98S6#&4^E\nYK$_oWlU(9Y<)a8X$#1`%ETVX(a)F.[3MRnDR6?,c=jJorQl**ILDmkZKKI(+cc^"^WJlE[iQG3b_dlV/o^HciIKU^T!*(]*4sem)=#FQ9-#4n[-DggnW*>`_&\-90L5Yk]<eq-d1Ba7Zup7MS:7)]Su:ToI1NY,#lNut425RH0_'!#s6K9sNsdn!n+o)B^PS"s)7Mu]O.5#hJ@;VKY0)JT0cEf,e(ipC2\@ab)ujfHqS[]uAR^&/gV[P@K3k_J@DZ:*p\1NbafrY].-o$Oc)Yk3B3+aN)Bq:FH+I,&ktET?_3,H")UXFn_Nf[D28"A=K9#B1JX*F@?k\jg8IV)up(4\D?[<@leAI/rhQEp[:?I+ig]OCpl;gMEKL5jQ>u4e_ojjq^qBTCq4I-AbZ0*F:o*!!@pPgOVAV[AT[PYou`cMuMT$4QFo8ugo;TKq/mX;]_j>@ChWQt[YT;0Z'o#IT-cbAN#rr,3D75==;,W)\bau7"QhF5o4be\C5jVYD@`A[Bchc`(4FOX5Nrrk?/:U0~> +endstream +endobj +154 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 153 0 R +>> +endobj +155 0 obj +<< /Length 961 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gasaoa_oie&A@rkGUh^IAjoTC`SR+C"]D].M?rUCmX^\g=GXE.EYAD#WQh4ab;+J(cnh1ND`6GJZ]AH"5TF5DptM2=Sn86fqM,'kciMpuOActj1&,h]+Cd86It@Vo>>]njXe:YW",+i*:,$4g2V=tq,"RoG+d6@F(7:Bp2_0itO`&'IZT"U8a8I`!Vid+"oW26^!1okR0k_Ci->I3YA<<]:$Sf"rT"\SP6!'QaVD1Ka^_48\B:2`3/XTJqI?Dpn'&PjQUQO&1QKI=T.lEm)0^M,WC&RrbIlbLt.4Q)nLOp^O1R)]:nupL/rY"^h,UsAd!nkZ81X9+[@X0,H4)%^2CD^4SXd+$(%lO&hg5DMu<tPbBLkn+s?c2kB8@HVq0g8TO0+2@MgST6Y(1aos&'GHZ,F#!2':(-W`a7J[`b!p&hPoR6#7(`pf/<(OGnAgts20O%ca-RUdc!,\j,mu+6_5fTZt(q:Q;8fRm>Z&MlP>eAW0a,R!aMbG"mlNdE;t?l3@VhloiQ)#7I>^ib_e)K-:b!"#tS_c48iGR$UFigL8*f]c*>oTM32+cR:RkW2"S<@7RP+s$P?uVc^L]HS/XdAqI3h>NUQb]SD13OK<Y=bdPqUZ[4&nl.U%h3>8eZe(mIm>ZsKk,V9ND/9(!QrSXSe=V$lBrWbE[;AYh@=YJ&c*aZ,4.V93O,+qIR;C9(?a=Z-X2$aC:E2t)`VD5Gd12*Xlij$?EeS?u#"\D!F75../`]dQWH`X*ju6bQoD<0-!-F]R&KG,p4(5M7]C#j(a)B4j5b9aRL1!_+scI(.Y(1rTsQ<-7HU:K7g`!=RNT</E3n,^'hm.`Zg6WsD![F4DjL,bRTr]tQm(+n]mC,ddg[>DO("`/9]&VZLPZ6JAO?TErp4"j&Qn:C%b2e0kTV2^Es`mX6*A"Hp2bECpQ_-Sab](ng^"6!iIE]9G)Kuqrs.CNCSL~> +endstream +endobj +156 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 155 0 R +>> +endobj +157 0 obj +<< /Length 746 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +GauHI9okbt&A@ZcHqZ$Kq@c57=`&J`e<R%%]ki"6^grSCUkEPCs1[XM,`@IZ<L$3>q!m4b]GVd!cKDAF?ic)p[]tJ#_8-,>*sR<^"9da]E!E`gG[<MS9J+(6Yl/01*+3;0(f1IQU^@B"TLTncUgc:.$^D^=>@*<olk3W1>3lM,_s(%;M,pMt+G[^8r>?+4bD&:T<nM1#;jmuH?I3B^0#Jn%&Q\=p]KMlQNd(ZZ>]_FPH;&;$iqX=D)^NI&WOHQ"DW!pUCUgN?m<Y_WEaCN\OSN48?PS?;VK>tm<!X=[bY2/^1ckZ$l+&;@['Z]Zg^m:WCh_?Nn88f<TjO]j[a.mQ]/!%O_<U3AqH3'][<"GYH*%^N(N2ZA,70bi<L1NOZ.uC$l[c&qAZ;CQA9;\f&(b43)5c!s1"#(RW(pc`*6TVZZa7jW"9V=Zi4g/X.@&,PcpN7L[XOFn0t"[icHnE].>G?::qQH[:-1hr`B>WOMBm;)H(mr3%*uYp&be.YU><+$]co3nKEQK18N4f<qc(+GRb)uU8F5g[$-&(S4%R4)=h)N#b$hdSA8tVqGKZRh]'@dTd-l/<-Ag5c6*0*KL#m%".$S-g./uM$TuPBZ2<ChRW5`UiJ!h$FJuY=-Z@'gf*ONc[1C.s_cVW.J,h!@u-7R3DS+qBU#Xcu%i`<pBlhkY7`:Z:NluhRuJ0>8VhuH%Q$3ao%L\%a`^21AP-Z8WbRt*k""lLHgG![l:rrk,-j;%~> +endstream +endobj +158 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 157 0 R +>> +endobj +159 0 obj +<< /Length 1112 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gatm:?#S1G'RfGRY]sT'Ll&n+"::k)6NW6=BRpuBK9s/TUc'Yn3nV413_jH<D&Nta0=IA1F76YHIZr&`]P!$k9Oj;>B-CI'#R]N\OJFj(Op`fE8*L5+]=:i[I>P\5oHU"3+sD=6TKRg%F!)@>&[d-u[pB<mK;sOj,mpS)s'Nu!Q#;rR\uFLd\Y[-AXO3:p>*d]i5<7`$&Mn>"#2F[<\N+.SN>!l?Le"l0Bmd_;0eXul;.:]@<*#7hKVrEXaXH:RKYg(DSr-#93o^U)@Y58C']aq7*KYrp54NTJ1n\p$aWna)f-#AR[\Dr-@&TtD$jGd5A1tHm<kF>DChTZ`M'*e4>:b*tY=@mTS2XJc!<c*C'Af8#_Ub(qip(>XQ/4PT)SOQ6rWA>eE<JXc7]l5ISlPMr\^meM&q-l_^/^(R;b^TnB?S"fhEUsZ)@\b159O2oRjRESEJ`?K1+8Npm!s?@O@tLWVsCG,[nU0EPPp.^+\i;aRPCCAJM+BrDH5*PW.A8a7Ht@dOh.r@90W`oUXE@j8`1W=k@>h@Z<?heSC3OV(a)gmO6ksHE.^#f!2A*ilKRKq1+7D<$l8f*ohIIPgWm95ug<'b0G5[g'?.niW?U,^"&?2T)#S)(M*2r:^cc)rPOr`lm/dporPPBh]rn'Rej+LDZdNT?^k@Sqa;JPCp`O'9I.bX<ZP0G(5lJ>HP%DDitM7S[/49]\Z^s5(66"TkIYPbS$rYUti-eT?Xg%Po\qm7#XAPY%?cRGZDI#q#Nc_ArJ[#-+]Q;pb'G6'<\+I^puoHr]B!4432W-PM[i$)Yi'lEtNb"`sGjCO_tA`M9T)TIBtf-YU"QJ@`#NG98tHpWqugju;?7Ol:rU!+uPNa)3puMZ.tbE88IeHL6`@j.?.NLZA:DGTdUqs+QG9J&`7X!g&'W&,k5n2a[R$0+oU*`H6WP18PgB:U9DZFI+Y&Du<s0heLp"7#%0H5Xb?g\h/h)(cO:GVR#U9BPDSgl#H_[:!8JTd9k96ME)jW'$>;Xj4(Y1I?ulSeb.T%'*r+o!09ja:1lfXCVB[!L:7t00,,Yp/Hp`lM(4LNZd5s:l1!_h@lEnSCV%lpR7*.&qjC/F8,XB[?HaD~> +endstream +endobj +160 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 159 0 R +>> +endobj +161 0 obj +<< /Length 293 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +GarnQ0lFl_%,CL_Nm:IU&g^Br)^$$0'EtiY*J.<M4?-(N_a/e0\5$NYBYfD`h=6<U7((l+(lKOk`(CWk8cr?kK/&$G(5*!H=GSQA(6<U/;n_YK$6G-3Q@VX=7Jo3DdgFqS50\EBOYqcXJ2F6tLQmQ@SZg91c@Mi)XDTM)`eAU@*Lf8Uh$=hqjS(b(o)a:-g1,"ql!n%BeY58Z\6Y^'[Td(KS7nD+)=C5hqYN1NcRH#hLBBQt:kBu_,7Xu"j91`o;4Df+p(mHGjt46oTP";gdE3/Uf!G$.^7]$:~> +endstream +endobj +162 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 161 0 R +>> +endobj +163 0 obj +<< /Length 1766 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat<A?#Sa]m(L0NkQ+&/24F3s&+uN?G9*mg4()a+QXp\fUSPn-]4X4mp"tgrA5c*:V`P"e7#D[C78j,l]_LSi*mfSE1g"WK_I.RRK+NJg8/MYc6pr;W7'M%GrkA5t4fRc*T4%IVE('d:JH2'`#0Jtp_AS2u@G%OG6C!>(lX7Q'DY%V^=G"m9[4P#$+<hbbQRBg0b"3LukC9)NL+u0-:Yr(FlDuS;Opml&PT>^G=;o1DZFm>P<24/_L_EC64LX$#dI:+&/rmG6mGLDQC1h>j[GNeHs7EL@6`<l.);%j;Ml*V7E]6O0_Wcb0AqEPh)+f&F%X_-^g@n0*A4-U2^YF)'?ePG*KkK*Dj/Y^KP"=jV0b]oKR,\YiTQtlf=*oVTa/h_.41]Dj'`t/HS^ob,;1@utF#poq>%\-_%BfCndiqb.ENKa@E7:Y1VdMk'H(X2Z7jLMnK=F$bJ@37:L.h0.eY4*2RoZqFm1]E=kX_GqC9Ma-FR"dKOsmhdd"33)lr8m.ehk@K<#Z'pbEjin&CfFd[>Csgnj?]8<!Q8(a)b#[&KG^V,(-]Y/Z;H1DFZW_!(LQmXlPUYhFcBXoe&h\ie8iW.cO<SC,I0Obn*196`f;cT6%Y"@7UC.kNka6iVS^E-YjJ\;,_cA.>,?($&F"kjIh5G5sj)Gm=,>ERHDb!2BE"9`kJ[*Sk"SM?W4r%@&M[%cN0"W+;6-pAJ")NnL,e*lIX(LKfNtX1.'kg4u(o>A*G8#[h)%$=qO]ja-*07HlIhV[l$J4DE:%3FY'-Dj/]"<3DHGjcZ/-7H,UL0d"?_PT[N$ou'nL^S%T<G+K6MgD\E9b#Xa#f0gJC9.<H`A/_.H#3X/]b5Y\"I%"U?Zd!$,O=#qLgXA;e,2I<;ne^p!_od/j%j?m'(]0(!V]t"gmriqfZ4n\=>9YaRFk8S/iS;PRmkZQR;a,R_18ESV3UV"U,;o4CUH`^<^QC^>k$Fo>;W/5t)XJ]HcRY4dp?,V=5B#R@onICR/8p<7qknC(4$,e8*Gq+p:&6mI\Z.L_i-"oromN(9mUCJA-RY`oP/WWRcK;<)p#0)+PnVo/NO'+0N9XR\;lKKP^\nBO+L9)@,WbJ=+/H$UZ`knh0NVUUQ&^R<`hM4.AnLNFLcp&>-jkATfEL7$80KV9c663bBTrFi'o<+a]h;H9)DFl)5O`D\,%629qNT)[=+R0>o#n+Q@:r<!X?X2U5IN8QDld+0^Rpm9(U^-`GjJ<5.X=V,TuW=<.2Z3&AHVT7upYjaB_M\kV(!TSaqcrO+-/g"S)R=O%^8%U>\u%/Kkrm-/f!jpJ+CM[Pn$,r]'ZpC1nF?J.A0@!-U]+`t>>f(nTWFZl11SAXZJ>7hrA,1#Eq"Y@MB7O\7'jsiVtf/N^&g>-?ggRe8SdrF$jfkZ.5s#M7.!+*][11GgV^&A0sA8T(sZIV@/TZj7==lF\oO?'jkUdW:sE6L^BD6(eeQ(gI`&>Z#cLg0!:jn<f-(lVR%:.1LA7[X+i.!M[EI!,BI)Zo.6KHh2dUS'gcD3cq$`q&g&7,&6l4+]VDYo/<4)5frrLLR%%h=/tSI_/U*485>U<^F\t\G`ji0u6X_rR0oZ6V])MEd-OQEW/H[GO.D$(el5!R/IqFVsR=[-Q2*,3+Wnc]=bHlHG3FVHA>amR\]9XAZkZQQgHrX%n1ilD=P8O.6Ipb-pH2>IX1J.Ht:`KBc%GR6Lt[I4<^F!qEe#Z@!hG,`M_fP0hd7JJoV^pAN(4=>9kPDfr#6Irs+Ukg*Q~> +endstream +endobj +164 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 163 0 R +>> +endobj +165 0 obj +<< /Length 1042 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +GatU29on$O&A(a)7.pse_4$8l4M]sm>uV6/74Wf;==H6<\mO;seEA@qa-Mnq=(=XTK78.dXihE5Bk+1KGHk:\fF'VH^Rk-Hboc<q4K*t0P!@6c%=.#EQ;559Er`:j*ip_>?pl6m:\:f#G(>l[9PK44smA-4_PT@^)(B'MFE,LUtR=s6;)FjG+PH0lTQ:QV.n5S/Pn*b;cB_Zq=fn8PrbF0%@bj64uR&-Quf_nNCW.aJZY8`PUU"AsKVnhpo2V[T>F'IQV3kAb0mnY+sMEb6qKZ)N(8YA]&b`@(d:+r5,pD3'#rPpnGa+=/_i<L0,*rIYhT?D"!-MaC;IBF90jdrL9)EQ#`e\UN;:bJMqIa#oJ@d'`n9H]b3hSE<I3Q[MiI8]H3Q_\gi:OPoDX<J%=\mQC'M?h;FnAa[PbR56d]cBTeh%@m$@A\6>(dEHSo;7eQ(_a52CZrX&$[6r%&qc(5DY3MkeULfX2crphO?3@d8F_4bjjWEo9eo,FW<:*J`\CaCap[-nHED"SGDraH-Hpd:mf3'C0[S@XaU*r_:-E%<r$<C;4Bi3TjVAoB+l?j!.o7:P+(!b2<GF%_a?^N6FSTM#kS40D>%-aJS]P(5]O4L(p8F2(d;N&dJZNk#Uo\#.%V2$88lEHOI&m%XJCW0iH8]&R94fo]G`ML&KLNU&>8+j,.9#?cfII99ic+uEuG13UB?Lo@*,7kim-aB#'(ra'W&[g(0?J5<Sn8f#mih6L:'\fS:n5en9p9Je[b4MtsDN9$eD^F;bot"2UU[B8Wm+hpoJDrc/g5#Oc6"N,YXfeQe_?;-k#K_@T)cfu*bsN,l,7h[`:onkK#^]Ci?bNs8Y<7X*qWh15-qZ&GZe4c`/bY:h4B#lgGgd1^oW\DN8'P>YR2Wb(rq!e>U&GSW)gu-cn_noNS<+OX,20E!]u?U9q%%`_JUmCPbd]YYmA\WKIMV4ibXHWAJX1/+j&6-mbLph2<&F30O8tg7]bFq+1uhEi1_gPlg%X1eE]c@B!1oSB[^CRg@2b4EFB]2`Qhi@)3-gG~> +endstream +endobj +166 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 165 0 R +>> +endobj +167 0 obj +<< /Length 853 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gatm:9lHLT(r#07ppTl-c^u$r2C[1^_k^#\ML&EKTZ!Xt'$-$\[JTVQE<)1fdRk5jr9A]TTD.Zf2p(.ZB*tkn,R-h(6!uRd!4`=:5p-5\E@<dKaTh[UqNc$K2>@?<0+Pr%7aAi$)?;+l5u7V-iW1Q@Vq&Ace&QRDF3lAp[EI*P&CI%t-u629<)mR']@S9@DT^4s?QH%+Q2.YJ27q*#N.Pmf@Or%A@3g7B?dm5`/OH$Qin=qM%%/*\quF_""A?Zf[_2Y-(e88cfKO4RGKR<s0@(3'dIG7(a)I-f4./j\6=/WU0iP&Lr(RFQ2M$G5bd&5[Dk>XaQ^msJ2d\2otQY:5eT$AjBla+l*)!R/,=DG+8;ANGGqK+TPld];ADf>f>OG-hj0nLnkj&HTp]^F_eTBcki/Z":5!h&hYS\fp/-FI0#U7P+`A5&,/g`G8@5b(dhT[:\lI9Nd?L65E(c0OEOSE]q0gRZFQUF!JfdaHQOtWm'\/eR`_t(g.P?aq)WSb;*'t,EgZFZ53mVO@*MN*cqr;Hs`j>R<5S2KtTV8[6J29:p'VF_6+,"J$j\aUI^=e=0@#CQ*U4REj:Fk5[MeRL*:$C]?d+tc#t*udXYs,VP"cH8Ngg.qSR&i[k+F]CHBAFg<s"a[+>sMXd<aA4ZMM%\fmtg6skiVrq6a=1I`sgnJ\uZ6QF(:gT=e^T$#CN>\1(a)T39ZStLhLjB.#Slm'h(m\al/RDgW*1i?d/K?`OJ=c^#ZAR9/qZ#f_JICp7%STH]`6Sh5.OXEot:H)!93pK6]6Jj"FJ\^DLr]A*KkO66\BSO9;7C55@CQ8WK@t2UE&^p'r8%SVmij,M6f4AmOX#,q;Qp~> +endstream +endobj +168 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 167 0 R +>> +endobj +169 0 obj +<< /Length 818 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gatm:9omaW&A@g>pr;`q`ntqL+RP%T!XU.)BJ5T;[WPcK-7Oe`YlC:SBcAFZq]VY(;*:<1Gr,%Sc@%g#qiLq2+]0@W-O;7N(ng`A5SAm'A/n4e5b*BI2d_bBhh%ICr`l3X^o2FT6$iSYc6+QeK!^')[aStsf]f7e\^fdnQkJhWDJ"RCDY7;idc_KQFf(u349DElOc=[u=P]uJa.7%WS_J"\i?9!Tb(X4OU,J>kah0/7M!,\LS3][S=VT#-#KGs59b\J<Ms"G)B7UuHp3!.B<GM/PEInO__p.&On'FE[?Mf)O(PKV\n90GrEk0G:DOV,-#pYI5?.F>M><aG"X_VB*caKu=_GE_S9/J3"L.`%rG=!4Vn75F]g+;iZSI\Y`W/K;oru=NNiGm)2;_oam]@-_;/W73mI<bt[qN1%-/p(Ys^$tg+;>3_I?^'1d)koB.?AkeE%NYF/?C^(/.;tS[cYoWET``/H;)0G$RNHW/0?qM*,!S.5R8B"9h2I:o`Z':(G@`P9:'T\fc_%-oi;VSg$+-a2O;F&G#Rn>\TBnPTD<3;+cUrtmHD4'KnSKnk%G]pTTNM[j`+5@k_qu`oXM%1_;U2^L83n<E(,[&Cch8To.&IsL);[?r5tmk5H_&G`8a3m#[qBDR;88[X&U6,?h4(kaBr^@)3\*0^'i`T[(,,4dl:!F^>j\\T]-`R+&,YPAZZ1h"OE#_D>Ttl?I,Cg3DGF0:mR;R]G+1Jgq92F$3PsdC_*^?\h>Zh!IL:'clZ=#=O@TimjIk!FSU?p^a$XLU+:WQ:%THF-"]5T9J:#[PhM(q6g<))e~> +endstream +endobj +170 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 169 0 R +>> +endobj +171 0 obj +<< /Length 670 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat=)95iQ=%)2U?kh$lVkq-\['[7*i<hQD=bHcccaJj_Yc5[()rdElur(&BK.ss'cIc*_F,^ga>hgSCP,pX(Ydf=r9J,s[$#*M4S,i_^A#3%f@IJ9]7Ac_m]pnpK!J<:4YTF1a`arr3bJi&";8OHbtqA^RIba,,.J<97Ml>B=Pm&^MVB%@rKL[JMfTOg;)="!:X4<5Qi#6R'Md`7kc-re+^QVNFN6`=3W<&oWMO=>+M/K1B'3/O(a)[\?1)s$If[Un,n).g'GQg,.t`FMsY4sCg$L/8uO^]Xs\BKZ=!7l<41E*XD%i>(eTL;eGQUnG)]VtX`*No''4!"_4#keOlhA>[aq@KT=%'MLJ\GmXG;UV88+1(-ORDQ6F/JU.WAE_:+9_9BW+%\@o?im1<](O_K"b9S6UUD72f6(lEW@SYH4>o_X@6"B+]iRaejmE]A=WQK/oLT^UeOL;K,&De9^]@ZjZPQ/rf>SpQIa$WQcb`hK6#/b`bJ5Ft/!,p,Ulpd>k?We0O-q<]B;=8>OnNDZ@$^50B*gaJ8I[/8KuPHl?>;o8G,MN40&T0t3dsM^ZOA,&:ZQOk.-Ak3&g.l,l6J1K'cL/8c?,io"bHpT!6t`$'9b17+S'%c!G%_LOIf$LZs?@)3uY7!A<.\Xse*J.$T>;Cq[o*tS=PV>~> +endstream +endobj +172 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 171 0 R +>> +endobj +173 0 obj +<< /Length 1143 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gatm:>Ar7S'Roe[&Gi]p6*,;I#IK#N\6+J:lPs>%;=?eN-qAe=H'FgOs*gamM3Mkr*\ceHkE+R]hmr6<+-YBi:H3kETK#L5=VRrM0So?+"-,V\E'aT',Y0i0\$u+r7U?7J"j*qd70=Ck%3!^u+>O:a&R`Z]*i5$FQn"B8>Ql:FB)V*(+mu-FRHmRI-ClWg]RPP;K2Xtq'LBNfFo#=2WHpgc@mk,IN'fkK$(;kE7Ro^3d/gJ4N(&*!mE8NkBj3Mb>L_1R<%pPDq#5n%n=5e+QZ''"UC&_DJ3_W$kA%]baJs)N"uup?6=LT(30O:uL7?d][99=-!\WCZf'2Jkp^f3)Fj+VIMtM1#V`F7f)70]68&7\@:\#55?,8S$cFjr7G;3/CSEH[<:\+0UF,sU([;mja;`%^H(&:L"XXAocT>P^:rfq;"+eS^dW-WMVbQhRNfFdP?1rKe9K,Z,L?gRTt\c@e?J/?7GBl0_B$.4/m@V.XXa<jj)p0;b6_%ILc9Ml="rO?UTJMq&I=^=bK4NN0tcI'.CU+E-$bnl%'+G^<4//S>^Rr.C1n.RV)`YQOD$>`Qi4U/MA(iF-<Hch>B/9UtWB2>K^JY$Na/9G[c_."itLKj!rDgXRGX(SEcYcYh2BSMLAjM&=>9lJJKDcTs%47n<QfthY:@QsR6mKT/%;=2L]1k`cKY9%%ES_>IcP94ddb(%WoIkEth#QOg^2e:s>atOJ/;LEjrgu$tZ:(\3@ogMX$FqTN8E22;tpiYo1dF8aoZ-[>U7K\uU+S7A_qK_%q[(DiuVJ*XBFk'7mX3`HWK^1^<Vs/)/-oEC)1K!H_k@*'lHaKk202&iVp%9>E]%c$=^XP=mr()7)G)4lP/8`%boONpmO'P*-=b;do_bBKP[-Cd)bP"j!`EhLs?Z)'7_X%"b&q9iYp-)V17s<MT^t+R@IIb=G`H(Lj,/_mR)0a:@bBF^U?S:MKcOV0e,-C8S1(V@!*'H=uGqQGsJo9#V+f0Sh<q<n5W#IGY?U/rsEr=kkrp%C4mhRY_3+W'2/J`k%fFQe3mVe>s*4^MHg0NU6k9rS"2"6mL,+8CHTB?$!EC9iYGpX-Sqe6TB)CQKaZTi%DPJbY(!'IN-Gh3<$(a)`LU(%.mU,jNdG56ho/Z~> +endstream +endobj +174 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 173 0 R +>> +endobj +175 0 obj +<< /Length 888 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gatm:>Aoub'RnB3YV^'02W<UV<8+-Im2dUVdaVq`@h4fkP_hZFAR#1_N?,50U$4pu']g>346J\,\6:OLIN\[tL]akV(I$J(&Fe5&JABM:Jhe_k"m[3(H#Xelj:_@ll`UZ7!:nYD"mQ*oG7$VijOaGj1A0?F.uP_C0^DIe,)h5@Y%=%:ZF5YCr_:R.Am5LdA>sk09/t91F*'*f4>_/o`CX&>LiA4W3X$<*dVoi7!JUFX%+A]gTbHO-?P@ilah"`dR`TqU%gJTkO##$9Kct'Ji2YM>4'=C$;aS9]+f^]*Ce!uV3,`C,**&19(*Y.njDpeE.d+j.Q*%kGd">;p:3@VJK0oQa@2\5g$f<^!9&V=:(ZVaF1L6%TXF%it,LSlnZUJDX5T4UZi*+]'Q0fO"S`Zf*.5bPD#JScRbjhJ0JNaggh9GtE\'LU73\`(P,ZQI!8.6sd:&CX9)qFbZ!?)@Xm8crA+G56t9-3*8U+\S_>+UH]*sTSK$SO$#+hL]O[%(S7DhK6B"#cJU0N(^4MK,5S8_cl*OD1o2s"+lhn]h>ab+iD2,D^36C>#DcO0*623\MH@D`>N+Ucmt];4=^NVq0K*.raVl]QXjqrJqibGgA&kC@\>UdCq*>kkH?uh8K@[Ad]f@\uhb\W;_X;7TQ]+ZY/!$9%`W0HWZql7p=%1d^>tTf1eRkJjJ9>T0?K+Rj_I2*@QN,;?mDSQYkes;;\1Kipl@:di<=_<MS"6>@=gG-S+.e3rj=/KDl=gdL>74rGqp_Sh]W<Is>bbQGlMp+poda=&1%5JrK;`kI[g0j%b(fB1Om2(4=9_B"dtL5&g/-^h8`3Tc-Y"mPCM:)5nfO(Z-$1lf6/<2.Yk3n.hU2`JFSR_g[`B^q+sr6YJ$S~> +endstream +endobj +176 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 175 0 R +>> +endobj +177 0 obj +<< /Length 305 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +GarnQ]1rG_&FB?1>:'u!r3iegPS>q[aW7+c`u5GA4)h8DrZ7)ii_uXdS)'X'IEXURc!GtNke2QZ)2D9?JH(<'kq$kX_'tE$Ba>gM]R"DNWQiI@]Kg]i<,5>;"kIt[1\!lteC409h!>IU5(W6u&oq_h,LIob2?$pN$!c#;8jPi4F&*0'^X]koD*9G7LVqcqRC^#Y9,&g$l4sKAOuGTOruCnZ;`ZPLp!DMseLYTsM5\>flWmn*B2AP7p"Z52'kjaH3Wg?2,_F+/fJZuuX[[GcH*P&GBU&[0;7j/cU+33n!S9/EoD~> +endstream +endobj +178 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 177 0 R +>> +endobj +179 0 obj +<< /Length 956 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gau0B>AqtE'RoMSY_3.[7#b]sEBM(5:(1i-+JD6::`eEAl%7?ZUb6-Rof/;h-g@oN$.P=:oR,iuq&Ea3P;aR#ncYg5MNS93l\UCQrHUq19T\a((>MF-#(=,YX>YB^^8'ne7<.B#X'e3uJ4D,@?k`jQ!N7P"@V,0_.8$/6o3&?rTjolI1Wh6(MZoroS`['NcA>Ng^=.IB<$#g&.2&<<5$MqjYBGhbZ&>=.WJ:T/`;W?IAT:,Z;aa^o!o[QpNb$nunApFu7fAnjo<>>0$qME6b@588,$10GmF"N'9N]$d\+oC6J[_L=@R8a1/IuYkP4Af>0A$)\c;!+-+gC%!?Zfr13Ib&^^?XEkU.p'HoWXDub]K4Hh!ZJ^HdMYu:ercRT`"jo!8=eS_bLp%Vgs>&<Ee)q>ll4%^\'7L]>^uC)<hOgP3MUY0R\bE="...#mhd)VWG;gUlAY.JJeHm\Q>XYWUg1(QlD:I-9[]"*N)K/=0K5V"n"/\fB`Ni;O`*&T4moCAZ6_s"\>5eGuI!]c_m;Hd_(?KM?Fh^m#Vj24jh60FI=n=K-"Qu2bREXMIf5jrb(li0p779EBP:RP_QIb`kY*,jrG!%!Z?537jmcPd,DnQX>";hH*;F3RF^^G>rTJ'1#qZ8q>Ui`+LhTVE:c<$FFNK"Xd%-p9RP55I.LQZ[M]pq:[G'X9O<OcA.<9nZ-pa1B?GWc(#.Q;QL9)skKk8&D$l1Mr"EaMY)<05du.q:nH?aW@N!1GNe^sEXh@eN3FI]c&;Pk.0!uL6/T\*b$YNUo)$q8[?+SIT'm>cd2NHTAh\_XPOrk`57BXZm`[nU:_m<fYqpF6u\U57e91;iNr\o;*AW"eD7#A<U(XDVXC@$2Lo'srk(a)),_GV\.]PPFp+CZ.99ha"3I`o*eR6;)M9FNKVDMa`Z*7%XcJ)1ljFjg'8q16ScF^g/I!9rrL-(JJe~> +endstream +endobj +180 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 179 0 R +>> +endobj +181 0 obj +<< /Length 597 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat$ubAQ&g&A7<ZGYAV(o!P3:9G$A`TEU2Y]sKrD1?C!i6s$85k3kr8[e4S[\^5%l45?C[+Wo1s_m:IZ!Dc6i7$ML37]?>(;&gu]&j`3:BgoblIEj<`:O\DtUIQJ9e/*AV$,CdV.)@(h*M@))=VS;!jecA:eZ6gJ4]u_4Fa)_'=+0`-9D<j:RE@F+II)Dp"6f2i:mu712U@mrpF5!?n:-Z5U\'D.%5YhgPe'>A1Pg0Dl;O!-p5I@bLa46T`B`^4A2rQd]f8:(klEltS,n7ZNA_Mm$(>?/G\B!jb1*SZ8L`$-UfX9sO5d@rp(0X,5"`j:2$9].jXgH$J4uhjLL0D>/Seu']5`#(@PbLCna`Q3)BKY>LKVk5--.A"k'Sr]]IA'-[.UNB;(rQ+FSWkd,9Bc*+8/&oX1.if\"fJX(:SS#PN<#><!&>bj7#sLc,^jIU@>)IB9eS8m@&ml"(CL7<0o!UVTI4+D'(PlB$b+lYFm#'r3*h6!'B#rje(>8]?[j[eh<j][)1-f(ZD(r]Gt@J7_cO4[&ltLJk1"<T.;0$O>M\+d?j&OSJK6Y`0JJDGHUlP.hof::@$rADuCJg<`dc~> +endstream +endobj +182 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 181 0 R +>> +endobj +183 0 obj +<< /Length 1266 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat%#;3.J1&:Vs/5l8o?V;d*C(fkCJh<Xd.\nfi&g-.?An:F6e,FBD%^$W#,N=@e!Cg'8b11SYS2ri4?cGOPkp%ORb@K9>F=)J*.YR/!.IR4Q4&9p0(!2J3$S\.1q5EZ\np&=T,5=d<cKn8#%NCJO3.KthT8>%kc@GT<a\Y/:cqu#\3RWl64&!>STh*["#oXc5?CW5^4X[&nDkG2V#[Q7_Ulh74_k3Q;?-%bl6Z"j0SMq@V%3A2eJ1<5_:LET2DSbWMR$U.^(k8($p,WGpHp-u0CI2JJ7Lk;IUrUuWbM)bla"^`4[^U<VK-9WSgkp!i$Jd_>1Hu"]fb`a\nf8FtGiNR"8TEN7WK1J)7(PhuXlY\[rN'W38=It(-O@fG2<'>*Ub$Gl(AKeilW*KqU?fksd/.HbT`M>@9:R.]S#I7-Qj:4sf?%Ds*%L4nZ3fWIp>`0I^D8&KaX+Y\ZRu=)P4K<Qpk$5NQ#aoj+KiP\,oN@cE[%GcRA/o4ts,80dbT`k#3I(nap/SSnQO1Xr_kJTmFX9osVfNP.R\/1pOu-O7J?+o(Ts@;_p?u[a$eFP0FJUq9Ba,aa`rdAT)^Pg3j>lpVDE=<8]U4^m7,8H7?p!@L<iL<mlfDgP`A0bGgJ7C!+@F8kh%#m1<TCfE<PU)5EYdP\q"<J?7FW&u`&P0X^LqET_SrDr6^WB`#QcC\=HQ?5B;%6*>K+O$8&lB7D+F.mF4GL9MRcn[S1A8UZCK<'Ig,Ft#H9eVa;OF>aBt6paTC@J<RHHWW`3ca8[,<l6cE.2_u3N++.X08]@eK1_o#)%nW)^HoCG#Pj&hbg=MoC]9MS=D[,R?:VSNKSTI^ud;*cM!mC5.&m`=-XF]<%^qlLc4o1BEi-d"-YO`>R9bKrRZB<VhM0Z*&JB&-CC6&I$l]faiWof(!Gag?I@J%=In&Kurd3:H^TQ):qXo:nBc+\MI;k8D7D_BG<hKG+hr\e4t9JiBhVpRQoH$NkhmeK6L@*VUMuC<Zmf9A-gbrrT8I<NtP.M!!g@H2UE*kEgdmVD?95Tc<MGaI5nh!bdueL#<HP)^dFirmR'_YY*3+)[4dnI$pp1-tg*=X$@b06"`uLa0Lp7gKs9g0MNj5a7h0hl1GtsP>J:(X6>"g6g*p)Vmf-UM&WGBU]2'1H:lS00loC7*)b$*Iq2hL>kI?ML[o?@0KDYm\D-q`rs0&1dK"hhVAfaPJ/EP45b=WT\bUOBYZl!?@Luht3C\dlr-o8d&';P!g'iWmoY5f]!PA~> +endstream +endobj +184 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 183 0 R +>> +endobj +185 0 obj +<< /Length 817 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat%!bDt%*']&L6]OPOcj(E7]"B%aS"Tfs:L^dpX[S@dk4@l!"iTkJiNK^f76'\J&^?7]*4kG,g(9]rA6if(S"jqpprIQ5&IM;h#"G)XOUd.4tIb]>X'6T@bU>Ve48OSCi0VBIP=hOj+@@+BP1B+>E/97Jd;"6_loM]WI3)%nXGAG3+=FF,Z.ai@icj.`PXceYnL347@hn)^?_eSe=Q0"hle]p>u^+E$FTB1On95V)%Mb+n\98?`J1Q#JQ/cBb#/[@1L^I3>>L'n\'s#IAG#F&J<i5D12LdhrVXeV2n9OOL7(:#Lb<MECI0F!&U8VNibh2U"C_dc]1H97O\!9mDj5/!9,'tLgjOQA8M)/H.oeM`Fs<T%:=35ekXo<9ohe[B/X@s'OaKj*m5/7DE`/3LC9n\$E]7@`['94pa\Ef.EoB#2nSf_U>Z^;85VN:[QhID\V5@-JU7ID_:CR-5K*IJ:pVaY&$S#>?o](T6"t[Bo-(;_*JrEL@?<;J1^4EAldtr1A6ApK!ciP:@%lHpNsLcS6$YqH3\&PPf)Cp<*:jObF)dIGU^L(F+1%aX'YBDlU0$qeG<D?!,ukX[WSJJTj<8^)PGk\iD.jK,:HT.X?%_+\`$`aW)0rlgES$``u)g?;$$7=\cLT0IL07IZ1m&pQr`HMG3ecFpb`P0noT5a\k"R9[5ZlqO;T[`)5P6W>>>8>[$kfr_He]E@c@<Tri(L4?SWJ5K;F4)eOT6Eb92Kk.?rtXFeF[p8r2u4<cNSHmB!<$m[Ts7"mtTip5SIQl<T6-T<URkfbt]0F&k/geS(56g0$qj5"2~> +endstream +endobj +186 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 185 0 R +>> +endobj +187 0 obj +<< /Length 611 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat$u9omaW&A@7.pr;`1#CfNs!3%Kk!=:%(BJ7.EgH$KkRhRfHi8<RBZuMO/gJol24jWTA4O;e1dG'_60E`G\,`=(m,=\X3(dSXrTN$G6P%6qohgA!Sp6PV%aX<-IKM`iL5mIDMbm"LbRWj:!<Ksn6GNjG@lu%#?m^R"@DLQPb_s3_npT=pblX+g;9YaXD*"K_H)&sCNS3kLdRnhr*FQKMI_FtP]Z_<M41c%/b=@OZGNqsGp]/*uLSs$d6n+5"M>_a@BfJ^$/Es[T%mXg/9pD[>fD>=aZ-mnmmja+:_9V;(QCar`PP[T)s9lkU=0sk+RJAoI-_"$\Y:UA3s+tj&eT75Np%9H(h3\[1lDH:W\=p23lg-!mNm+1(X$X8kkbe*7`I'];)A[prt&cuUF4!>^4DWQam>u]q)mSeR=W4r4:fiMn_IkLP4)fRDk)%3)M4-:&mg5[671<[>LB?b0iQ-+VcU*!*0Bs/XsAeU/NIp3sUmY%KfQ[,P2M=NO:,3HZN,A6grAQpt>k7RAS;=DtGs)RDAVbVr78m!FfT5KIoEA:H9@cJaBi2?nb7@YZ,oJO3U:4oqW0b\gPBZAY"+Aj$ep2N)hrs*cuERF~> +endstream +endobj +188 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 187 0 R +>> +endobj +189 0 obj +<< /Length 1060 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat%"hf"u<&:Vr4_.3=lMf"FCUeOHcWcdU</k)80AIk"B_F,LKZF'Z1bYK/jP"$i3GMIE"h>)HlPrlOh`>YNPfpWjR$n[u7bn(E8-j#,m9`c^t20Z2$RQbt3I\H_kgb/^t1h[-s!GVWHPmWB\YYYd2nr*hM-B41?B,@"s880ea+@N&J_ZO>5pcOm(:VJ`#ck4_]@K_8$C>uFgT;<Q[m3Csq@8R;(FthDM$&q(rZHN>k;j=gq7MTh2[c'`40sh2LO.R]mT,2Dl>$73KRTRW6%$;GlbJNY8-Uh#t8c^0`'_P+b4o%V43'W^0>slIOTF<;qNN]du#FOn\RT(!c_:9"CN(7;#($Wm`mMFe%Ti+65pSpCqX,<8bM4sXo72..W<dYaaP[A["KYnEReIo6'%5KZ+N2pXn*SS$iZ`0u\[NEhTCpt&54^u%4;O&F2-ej_J"AIRM_nP*?T1,4n8s>GP_R(2rU_sbc?>QqnIqKs?([Y7c^H+8.c;2Qh`4nn0aIH=M]nr"[F'ssVq*5,i__l0`NHl[koKkZlH_Y>g3)4n*i-NjsHC&2Qnj+B6(ZdI>(L0CCLjm/\?d=QpF[$kWc%g`^22.9g0g^U4"#fPf2H^s8TqQ1$L;FPh%*sgjO?51j+mIbc)'?%`l1Ar.WqF2;hkP@Ce8YkUP9#3/#/ms>o.M\[Fr5"5/C\9YA2`2/'#;FlIXZC7j>E-*C8+sY%hk)m;CY**;RjGB/B]Xt*I6c7;d?,-.k-ipjX!fn`A%n0o_KV"h-D/\hpSV@G+KUa]a="Khoh9<hSK%5d6_,)A4Jn;d;DahJsWiAGG"20gksikQ%%T#TCqO'PH-os]6eLfH-^EM#JP@YYu8LZBC=R+8H!Mg[Oi_Jk*Ir52P8<e:Ce+L5lfY<r[D%AhMLS%J`u(Ah1W#B0L4&E@)Cee/3M>RR&anFs#0B;G*3Wp'G,#M6X(V;W9&/.I9rHK?JM<)MMc9*Vl)ks'StXq#`_"B>MiC1451kXgJ!Pp/GP'6!2=%0$RXaY=74F;>i+t+ATtt#iW:WTM$;V.!"hg$+4K\J-i~> +endstream +endobj +190 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 189 0 R +>> +endobj +191 0 obj +<< /Length 1072 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat=*>AqtE'RoMSLrN(8;%qjH(^[!4C_B8]TbUl^%pnOC6#@7)'XiLP01h[EB`fbuPiJ@qF8O8EHG+QGMZ_$#MM$&_#_Uq7#,-KR^^pbR7OVZ/"RAGED>?aCjCRgD=F\[q1k;93cpFi77-9#."<un0A6p:A>U9nIfp>6EW@if<U5!a"6&9gO`\LWpTRIH[VhG**8gRF7b7hGRm,?:W_3b3r"pVb!<h+.17hLQ4,%Znu"08bCd\tGUd,!#CKa9sUEHh@OOf78u'/2<L&VGW'ZU&GGJDkRI+<"N_h#EI-I4fW+N'uO8eZMAMk@uC"6dG`m&L)`MlD1W5mWah=D*u>\i"QeE]mMo7^P`!;!8t47/q0$P^c7kVAHJ/YV^%V!XFBB2F=N:LW0l^(Yh8XEW_t0HqNU*R^V)WV[^(V1a@-kjF'ZF[-t_7*?(D/TWI.O$!Jr%Fj#^Bi.P'hdaCbmLl=3MWC(a)FZL.I7d`6]'TJ]>R\IK3Dfr.G=FUrlKZeU:((b%8@N=!f'h$QSm8p*6MCQS^sN&*OClo(a)pW_.mD*I+*JkWKnPH`0,JA%%-%!QU$4,hoL4**fs-7k=hLm`mHk_?VhlF&>QK*'3%Of@mC9u^=g,FPAIaY5l-Un#-Wd7Y]X0b]$LM9c=b*><2F<N7pQf]0tMQN#&",8m[V(-Y-bXbE+,,*+Pa*;@;FI$'7XaCq'rofhiiA5%JUJNb_:1:/um!NW=O2#hk72o+J6NAQahG7Kp2I\S&R-OMoZ'2oF[W9_UDpm,MgIs>3X>(%9H!]QP*^2R%+:O_oE+S^`@G`tS4JN_GHD:G6(Jt<KLY>/MDC+uYc$*<=']sf"F/8>"E7b+^R;X*.0oQ)?QH-;P4f.=o-SeUTApap:0\^Y-^Dc+@D1ml\dDQUIo1/6`"#I[HhS)5+[P60W![#S+a3nMpA`$P#Ou1\)/JOe(nq:^a2M.J%r`^j`#@6Y:3XWk0TFm-r?!SmQX@[[l]u\G,gLe=2:q9^^I_$!=C6(`^].DS,M#l&O$3:U#%+<,X`V"Q$*9gJm"D@$6id0k,]&uSVD3cU@WrE&VeX]G~> +endstream +endobj +192 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 191 0 R +>> +endobj +193 0 obj +<< /Length 1011 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat=*gQ'`:&:O"K=SpU5M"*>tO?hM7>mVd<ck]q9&)#Is#.7$A;V:sFod0@0%A9Xt`gsB\ba^]=m<\=!NWLaS$,AT)+L#'XJFnJF+:nRi3#%m6o`9GIIZ=p/)Z0U$O#i.#N3n3IC'$(D$\B#T',Mdtnu/?#5=WdgZV'Y]\cs57`c&C27!.#&\sD/=ob^]"'m6]aWFV`Q=Y.$6Rd^Fh,oeZpJFgb\\W?gQ!f"US+ud#YW7)g+.-n"IoO,;E3*.2RTc^l%5=Mj"0B@WcZeu3"=a6X7FZ`-k)56R)q85uG=-r3la=--:4.W70RP`dO*cD7QnHjgki@ampm>_F><OQ^1f9]uZ.^pGNhkL(s2#hqMY'<(I:kX'KPmKeRr]"MT<fd3&p3:.`)T@>@kL6"M<%\OrVoa"KmJ_:l38_l5/#*d^lJUB:H^$<uJo342m9DS0V2tkpg[Dg,A!Ig0RV/sZbk3aQoc228B+J.oQHlY-1m?[3jl(K"R`Esj0\Hl_E/8F][!`dM@fCkccdeHf'I#+iY%1>UU"K*A4Ybj&d#9-h6gCC(bIt!gH/%O1.Jn:YB>::C]INZ=>fh)SH"EgWnS4u&k\>0USh\'["\CSfBR=!Xnf8c5>.u_N/eG/F[$\>4Ca6WrVY)$Zn?tne\D2'@6\O4S&g_+Y@EYWnfBEED4V<F9do5cDrRhZYT0^Hu(OMcljZo\D8YTXXZ_Kl*L(lSUAtI+il=bBt:p%5dp)H*B82E+ZkE=26N;q)3`2A^+N/a[aL1ie2q*(p@O]e=&S7jN2g8[jjZ`TuL`BFuDGq=pF1mZ_Pc:H3eR&_EOo$jbQ]:q4_=P9Z>pnqW)3@+7Q4b3(qmd@t=BqRe"aPegB4r'sDYPMA'4Ohruh;"Rsg_lr#XK>m"5kcmrZBn1IF##5b"J#i*4'Z98m7UKG:Ob(C>\kX->HJ^VgioDS4[9ubXdfes82R`];un:2ZM:`8?&tQLnB`t_9hlt`+'2DAXiHDtRa8e3kSGHuGDu~> +endstream +endobj +194 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 193 0 R +>> +endobj +195 0 obj +<< /Length 691 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat%!9lldX&A@ZcFA*2$l4ZaEA0u$H6RU,P-`!*;#D,B<CP*">gALi*%iYX0\DrJmn'g%cG.$*1hRegW&IDF1+SIL8oa&G.8!'NsOlQS>i$d6PDc`"Yem+sl./7=M!YK5N/Ed'VZoX;-Jkm?$2Z.,%l$fsAm'7lg9n&';<)c^rh^OiHmX8uidWGBU8>A[3PZ+'7_t3[$n1]tAoefP^dH1O$PWU=K'(C#GqA_tM2N\kSeU](a)[E.-;f(/=9X9r/'`nni"dp_XkMDJlS35-@'(PoX)4`(kT+b!B6IC(a)GO.]&/s`/?1a%$!ImX99HBIrRZ"p2oV#A`]0Xu852hb3RKj=%hX"k1Gn%-/rP)BQ_,TSH]_I?rj,@oFmlMVmuC7(jsE!3!>h\t\BD/Gn6&V:5d6h0-`K]^>f9<K'<OM.+<tlSa.,Jdl9V+01\\bSi_dZa&=DiI_&..Q2rPiP&`q-;9X8b`^'K)07/Mq4\PZTi3/H,)R<uc?^Im#0qN+9u_erWD9U*JP=h3tH>JmS:R*16O.9RPOr@R'^p3\U\'<`lW==Z1#0-RJ&,Za:7XEfd%pg;n?H*MKpo)IZ[M?5dHg#_,4e=@.g*9sGtgkXGU]Q@b^@j]2E/-G?bo8Tg2'GeKK[OF#*p61(oT\Q3mqr6E:_dK)=3tlme$/56r,SE9\b"#H%r=;_KVqV~> +endstream +endobj +196 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 195 0 R +>> +endobj +197 0 obj +<< /Length 656 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat$u9okbt&A@ZcI,$k=osaIbQ$1^M:i0:6QM/c#5SB9'7=YH=g4*H38\hP:>B.KSH%'\gbkO@3hL&^e.%h00df?.K5S/)\6&G_5M@374UNhj6h)m$2F,PL?pnL1_7'K='TG)k&2P:lj8UE^OaKi$$Cu1O//8nBV7@S>hSPh>8@T,5YE(l#D,BO3e7<KB=B*,#rJ@2<5n]Shf(!0ER&3f)tOrXt$1$VZ)P^q7HjAW@`MCZ8/e-;]m_"Gmj*2*M]'ri^kCp&)Wq'?"-46N6SSU\'X>O""ne9\=cP&eoKoG?:_]>NLdI?0To/I6Q;b.$7'C[52QXd%[%Ta<,Ak-_iU:n8@4E9GJtZ+GAh'^MB'e'+]PeB<[WkNhrpZRm>cS9HdbCkdl!7?O!K`0=lU%MhbQMueuM:\!;kS'%%V/b6jq&h_B2SQ/oqAns=s1Qp>!h6Hcn#h\clRq,#.pRM$EGBp]_"=APF$QI)>KkLOUXOnj!Gf0T'eRP3;ep-ep8lO@/HI5D=1haad@Z1.A`9hVrUSIi0O7A!RrHFYGCZ(*M%kihhOOKu1qQhp4\0RJ4rFDBbd`.VHB<H@#`*C//%Y"(hI?taY!A)Yo1'=NZ_B;Zd:`=]kmc/#ejM3BYNaGf.'G;$RmA#!#rWbQhF+"~> +endstream +endobj +198 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 197 0 R +>> +endobj +199 0 obj +<< /Length 438 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat$tbAP0N&A70Vp'=!$rJ9k%#^m[BKN'B`Po`9Wcq**A`&[JY)]HL`-pa+O]@P9QG]l62]XoO$<$;Vl8j*4pNrl9k"iZRRnc^N%6aVKTd5'SC0t]mG>b_Eu;A[iU'7dC+L#NLeCB,#HD7@uiZpeRbds[f*X,G(:VG%t%7k;TDb@WA#E`:]EfJ?`V_8^#AZGX+u>q?3@YtuY3!04o9m85$u];TM+A/&V-FLgjUD>DlT;?f;l+r\s`/s@L6gFP9B/X;JC=0r"R#!AS17)cb12dE%C,3qN!Ho^"NT39hc=);-Ieh4*trSb%=03ht/BfdSClJf>(].^&.[OOt_n+uoWA6PCsnb5^S%[cE0KgPd^4@/07jKq%1On[E(Vr&?r6m*",n-MU^":u8DBLofQD]\S0V2tOHV;(-YO1BjgI(j?_3H<P5=BF;c~> +endstream +endobj +200 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 199 0 R +>> +endobj +201 0 obj +<< /Length 1607 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat=,968iG&AII3E,oXZ"&T+Fpi*+$O__Mf:2D3d-QQ"5"%5Ej'9Z2fLo^OO!!F^#%p;Us([N(;rcYjAFZfQcf!Slc:h[i&R:AD+T]PYbZiU@M/+>4uY\1qcp#j9ram#YpQPKPGV6C+DIXqlL!Y>Z-i$.)(.I`MO4$+TcD=:V2e?llqCkTd0M\SR0VZ&!c^=":Sa#2Tk1rZp"S?NIQPV=to?t<F8UT'\V8eq!;\9$;$E""ig'f^f\O(@2C,UqDD+rX+-K&HqGGgYbTq2S/!`DI:j7]K;G%90IY@ZqSRG0uVVe$?.dPp2sQV5Aah8!WQbFYXHn%#t;bM\c:aZ:4r9J6<Cl54UslYS<^rcV7/m\ckG4J-\N'(T,jWkYFNboibC,8T4eu&Ab?QS4#)PcqnbcThld#29QE\mF#NXU+eD&\>CU5)]?R2G4gmhd7K=UD#KbK2>@]e#*/De/bZ^d9nE*j%<J74[]H:hF7F`boce6U5k2LjVSrBI+/H?EERDt8FOdH,8&d4d]lJ7(%3e*3p.N5mUYcelE=nZU]0CbJB.l>MdM$gpQ"h0O388Hp8%0<2dd7uW-"XZk;c]D/m[bL%(TZf7pkL1j/c*h;I44Gh05mF=V+.bbhCn==il.[)W&^rX(1c^cp5M*HIFR4NaJcs+.Xl]Y!/=j)%l\\C^Y'.hqh=10Q0E)=\:t)!eb3sTU[K,TN?$k;Ne9BB%!j9qBMO<aK=,DcM7oM=i"Bm*h,_U-[jX"FOak_j`?QIZ2!L2-Ze9dM0eb]81AY7]?f1P0l_a)+\tg5argfZVXlo$".N"kp#>eQ)B;1IU(9o4]*68SGXZd7fhqb7'H!dk\l%X)+AuVRT.[M7K.G:5SU=Njl>a*'4Ssr=^PArho.m>m\@S\Aj`B#GRp%^`BFDjb9B(<C@[>bZ[CfV%LbT@qi&g<EbB;ed0eI5SfGuf`c`#I+8DbOeSSL$^f\fk4"0SIOa6[GAej@"Lf:#Hk,C/";/I,1kTLKD(^cHJL3$@q.?h&%C44u:cHM05qCch0GO,?IL>jMn&\5k]26+*Y.CrR]]9Y5%2n$WfQ-2\^#3#6Iu+IJ['ggb+q^BMk\Q6m)(,Y[_W/.B"Xi8aE6)jGXs,\5HJ;5:u>AVZ$*K&-g1Z1YN4X`Hr_?jh^"p):PD&_s1.tL>&mcZu_0f:a^BU$WC'^jQhbbAHVIVFV+fh:LoJ&/ug)MD8G3NU<+4H6sg;pdS$YR"#Dn#P*3s]E4n'ph(S2_O&#k9e[5>f!u+K)?Q8ecL*]```5m$^rmeP..ZT.)b]Ko_Tr'4(3Z**Z+3:@O*lI8LFbX_+IpA@;'GX%R?k&M5X4*S>VV9NF2LNKsNf?hWd+D_O)B+>-R0jCU[O<"H4l?"qW9ahap=Y$!$pq%L=t^(/*es^TlJcPtAXnlmcUuu:^U%DV\Ij?u-lr/Ob3/0^dBhJCq1u#qmUums'#<qWc3elH*l=#BZ&X.Hc!*9:s5I3(cJ!ud-p%>[]6qDeittO)]7c?KBDH&[5:;&45'"aA$+g,gK1.p">Q/Q9]bb_e]4#5qNm#[Wb5p6FWO8:FQsIbMbC&Nc-Z82s3!-f5=F?ca*u,T,e)(.i8.0#~> +endstream +endobj +202 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 201 0 R +>> +endobj +203 0 obj +<< /Length 1498 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat%#997gc&AJ$C#jJ%p_3u+<#Gj"mfJG&(U+Oa/kbTm5=f0b<D93Bdc+6@CHV'@JOF!uApqdp?)pWge*0/ln<o<imGaK\<Gai1(H]K]Dq=9;(8s&Mh0L@T'^!4[rlfP\C`,<9'^!4k9'm\Gu)^M?e@%n>l+=JQTY\1qdW+s<obOne7hg0&NWBE1E67>Cn=M[WW5`rl\>Y_or#kBFflO(SM>%`-+`4Qh136ub<"r^gbg:.EG]\5`GF=C%<;4Qo:J(7jC6oma^8eG!\_K:>IK>mfm9P?NiQX(fdZ*-0tS1Wu)mFrk1D^F",CeR0[P"=>SW#sb-/";P]8l6Mc;"@]U*Vn%JfW$JSH`DpZ;N,:HD-*'>-B?-&#Ba]",'fnrC0j)U>h-&BEm[uNcRe5_cS*TCk.n&M6R?HWX/'Y;.$Ub<`1IB=F6b5l6*dc!GP9uuiu/^AT#j#q)idD#aKc\.0dRar"9lO.'<#[,WZPL9(G="9`fuO\l!gsZ]Ok<ap9&F[ETO(C8o`&n9tBr;2r!_TdFN'<A*n#QZ+Y*[?Bn<fSfTdJh4>FmN)S[*bj'>B$-bdtoE2F#s/^Jp==JL4T<)<#QPsp++.9]!P(TbK#la('Vr-$,CB<`0QE$8>5h*b]KS%gm[a;8-<I=\XRA1otJ-LF;qE&1JlG;bKPKl.)Uo'OUSu[4XN%)SR#-C,_PqqYYli!RBMf%k^P8h[soEDoXTKn9MUt9pXNHf]!.as]C<#&b50cK4N4,dZ/^@1`1Cmr,QqQag;]sF'm>T6sUBUpgo1\+SU>9b0aY0Q=Up3$HG(a)2O\u.7R5l_=pWRJsXPBmLT#rjgF>6SPJj.\Jk/di'=.;;cWiBP\X>A]eE2XR)Bp<NetF2B6A@#%Q0q"K7\pO^gUJ>!gK)OjbcmGTGp?::jkCor8=UGXE51=k/sgi.'b\Sa=7TbT\J<cZ=^JG*8(q*l1/VZ5)`6d;F>u8d\XWJL#"LLb=>D>oeTP<@1WM;C,SH21[S-%LK$Xt5A-up$QGo`hD$FO.8")+m/GAX5"U]''B./_(NfFK^-\g8o<Nq@CmY)._AcS]hi@ljL.Ho*)F@Mgdis>'c#.UGpjZcm@An"`-S`GYc9+l4eGqgrK:W,1X&c.B?nV&2P#T.SIDhadHVmcb[$qF_a`Pl7#b.rap:r#d2bqHm1*h&ZT88$eH/\*<7<(.SN-#2Um7hd@?K@K,C8N\^C=]b7l/[6.JO#N(!2R;5PXIFA.#FVMI=5C1.\4Pu`:g&[$@]1m5K3iLp]oVKZrg)(3#^"'"7TXF34.QT-jgPX#LLEkko/=5:6F7GH0Z\9ot"h[>W6LjeLTn\.jpFXd7?D@=FTs?TOQ#WR>I`#oNinG5Fbcio135;<qYG.%o93VF`&gbRm`(V7I,=b6bp"=XFOYNn[2Z+pJ,//kJ#iT53ag"Y.H$d^k*hs/MlTQn588sbUZ`/YMO0:Rq2m/$TmNX:Qc>)#?22jW,KZV!B9u_]/J0h~> +endstream +endobj +204 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 203 0 R +>> +endobj +205 0 obj +<< /Length 476 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat%_92!/f'SZ;W'gl#=+Lgs6N1aRP?+:Ham&WaHcI@@kR\lhYH7)FV=;q])]/021kM1>V@rF-SLg\"H[N7nRO!*d)6%i)_.R?@6NT+Sm2d20Ken/PF@maIb-<oZl>>gJY-uf]8qgS3O*]@$/9e4!-"/gm5)D&n!DMqsWGFItg^Fm)fnPpB[eshOP^gnN6==0ZVca"lR@6hcFm/3SfZX0Z]$oi#mbjs84MdF#c`nC1/Lk/Ac5.ocC15J?aj6$9!.i;su#Bqq9La\onI:n=A[;2mUc(!;=Ch6j-<=6)U*0"R]R^CeU'[^7bEDiJj&D9=OMql+@YE72W-CU7DSW-bmGqVC:D)h\eahN4["Fc.fHV_mZPneT8FC]fh<SO>#LF;9Q/^T<F7[V0OC\']XQfq2#72g14lBOUO"=akdhMjIR>:,UBYZ@nf!dqNRPMaj0QOZ4_f+]K/mc]5&#0g7?qZ9k?h"h~> +endstream +endobj +206 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 205 0 R +>> +endobj +207 0 obj +<< /Length 2198 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +GauHM95iTD&AJ$C#ekCZGSs*&dlB9O%AX7J[,%>=*b^tIe7ch'7."U`lT9JbUn2^[U'M<LAiWWsB0OK,%l\DKYi>s:8[*9WDd;Je`cGD[k;e!]TK#]:(qV2Q"6XWFIbXh<S$IKWh`/A4LEFak-plS(:';cDgA(J;Rr_.SHKX%<aRNO*@m3G/^0j@&O$`1`WF$_g4q84a>U"u#i'q4EJq,q0*+9PYBpq#n]W3hpZ?jCMCdML+N9c<qA6;$?PKpi2@i(u@5PF6WLAQE>bm!eY4.Z^2T.2n1h5XH3De'DL*X\'<X>!S))h-_p8*O-3eB](W!aqho,k!a/B_bPEfEhTb`gt&K_a<Bk[F:?3PD2g^:"N(s)22?h[s[pXDj62L=C#4Aat3+G+-&chOl6jpmS9Q$8'5OUnPjY1[7k1.j:+1S<*u-9n35E8h6J7_<-^T+oLNamL3hDdb]5]26-.b]1VP7o5.aC,iP#h2M`UrKIOls\pXF1M1kZ[P0f2^]pf+[L6ObY_]&YHFEb$#ZCU7V_[ASn$E;/!'(,=!KVL!Mp9eYMILL7'=AV>uYkugAGHH)@bS2JJ=o$YoK&43'@cOWFN5DkR<:b8$5'kE[:Pq#5`%%OkeKN&Lt9kq#3?\t]e_[udG?[(niYdmW",>2">T-2=Cf2Pf;@*p/:b.GZ6JXGPe<#nCH%8nK&9N'qu3a%NU0$h`<B:A;dWrNJO="8UQh7g\4WmA//QgGORn]g\OYa@:VS0Ap_arbgbOV^P]hs2gU^0-Y\;A>p1ra#c/dQ#^[=:&Dt_N5c(6X6/sd.+-L[q#>&Y7&YN65`Nqg1T^EBB`**7#@`XFI!B:7;jm(1MKG_F6(WNA8UW)NupS(U<KaIV;mt@bG=DF^!3`lbAUHELE5LoZ@Z[qp:>H]BaEH)CH5D;+L>B8/so;RMnQ[fFu&eLFN="*dTgi)#gH2>(lpOeX9PW?pS(G:=ib2FBP`R3Z:\nPQH1ff!%PL,RAbT'L9c<6RQ%&(GD9ZIO_.^j;).-6*/NlHY4dnqRei?$e$=DoSd^V$n1I.t'o"9\feRrN8(Lp^7s%NqM`2pf;j2f#dBtaj+I5_`2sW![$rKsVU,AcZXBPAL%*/-!hd*J/el,[[6\EjpltV8cQ>=DieX>3p\:*^IDC>K5M`S;$E"F9A>@tl,1h_##kM9:-o)CgpLi$Q;W1e@u7iN3IV^(AiF!gBc'Sila1BhR)Qkn.Ze+6Xe8DqK98QR:bj6g,eG]\'9.A5"6EP%NkOGjaKE7h$><RgU4^9%.ioFd]--OKA'Xm%..(Fona#n"PWa^sSMNc!%%0EK8/3k3[fdtF"[,u%51Z(27$mE#8Xg[^a/B!BlE\"C*K5E(nk(lJL8!!Eoj_Ah3P'o,lDo>o4U1op^<U,L9kd/OL_>0?90TVF"8M`0p4(m\ej)a:on_$8gq0AMq5C\^j#4rS%nWlH`B\Gh0=]ebi:`Vp5:E2==iC=p)('26WUX'r:l/ZB-d-Ce(1bcLDjc<c=T?U"^!LDTk/VF5@TH3n99PP+O&Dle2DE\fJ0n$lZaV7$!7i9&iI`Wrc`_#&-)D8=;&]\p48K^Edi1@T%t@?mF8RPhs-.L1LTah^26g2*oBQN;ZX(;-h$g0--,X"*g0;8k_,o#+K^D&OA4g9"R:U`fe;<e*AO?]E3U\<956H5OY%!4=WYN20Uh+P]f2SC4c,F+p7_rQJ.EJJ[kdWYp!ABpM&24elCjASihIF"antNP$R+Ts!.g\V8>tHWIWDT8<o*\gZcLq3nNBUh&-8D\VA3+:AWM,t!*3;!XR<onbPrkjMc6UFru%\@&`<'d]ui;\u7,m*A,S:]6\M;<%0LP-pu$$Mt5d<Vtn%^hb)Jo:Ngn!jGic;PO=s^e;8qrYasFEK'hjPt7gH7!LD?3B_G[gNueV!me_Cd'J`[X4_@(X2Q(Q6HE]IJP='CBal,_E%rIf]S9D^:i+\)h)3f35i8gI/&Z>,<hGu/86oYP%\YV]b-EL'W.kp+mHJ]6"U&1e3Z_NncQmf'Kq%J-a^9s$2G_XnO<8??W([X"Z%70-H_X5H,/C2\s'Z"]V]&nE3M[b?La*NJ!8<0kVn*^BK0K#$#J=Y]qA+4m$&Yh)eB$qLLRUNYh`YMT-1I;@8I@-n_]9+*(PPUOSc%WJS+h^&jsWK>A`r(Is3sONNZC*X+BI@W^prnn,Bc86~> +endstream +endobj +208 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 207 0 R +>> +endobj +209 0 obj +<< /Length 163 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Garo9YmS?5&-_t0MH=Q!md8imEc"&L)\KLlbDTJ)Qm2?S:BClT]_9Uoi3[]SP2JeqKa#"4NdX3VaI3RTL8eXX1C[*kK-@mG5-><i/O4C>U>"h&`<uNobN:Y5Bti21M_"`#)sUVi:ZZ(<b$E5qN`08TdD!%*Y1b85~> +endstream +endobj +210 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 209 0 R +>> +endobj +211 0 obj +<< /Length 711 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat%!997OU&AI=/ppb\7&AR6-8(a)q\.#Za82E<-OmFkTB';XB(W^W3=[ERHb):o2;jSSu5fpG%Y6]r)-/+:1Yu-q;qsUY'uKOp#5>)$e8$8e:.Oh,ALDpZO\25<'?I3-GK9oE)h(;b0MG&.ckJlBaERW\F*SQ.s<Ceb1&d#k&2j^(DQAo[_dNTZP(B!o)4+m66j0(aKWD+_3SL1;P)t&,B.iRsI>u9172WKZ([UXX&5u31f^a*%1,:S:P9T3<goqk4P5#r60h&:tV8-Goa;<dUK@=:rYZ\_/.kYY'_1a"N<*:'s9G.q+J/7[Cr!hWN]V=+;eJ3o#^t.GfHD3M]%':]KMJ%HN8b.;5EeCp2YLHAnr)Z:pKNXheARLo%91L[C?[iF[aH%*QB=q-kQ@@qWCLZ?4&-+g!BNqRN3)/*M3^]_Rj&uij-4I6(gnqjXBEaqbZ#o89N>D.Yt4WRiq[dNIO$Y3nMqXZeXdf(iA%+\6*ln[;\QO<``pc#o/WNjgGME0A7oMr>Q6h/o-&LFOQ]Djt0aX)TE%:dI6CB\^?T]=r2n<)nS3u=958sV0K!j]hD+bqsO*S%6F%CklUn[]?!W6!f:Cd`TrhO-iI1Qs2jqJ8$`)HqRLFrXOAi#:2p>oo?.]rC%TmS=.S]@fNg2ObM8Bra\`Hd)3'O;F7bik)[cjl`cB]9=$K!I]0sI2p/)F#rrHj!W.b~> +endstream +endobj +212 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 211 0 R +>> +endobj +213 0 obj +<< /Length 715 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gatm9a_oie&A@B[GYEX6b#K,d/Wd@-U$.(N68*0cMG2\)[(';nk3ks"MR?Sf$5C41oXoIU]G]T&cKbuL&IHrSIcOnDG6l(J8!'NsOlQS>i5e^ApT#r5WisePnin%W5Qi#."*t._g0@0<_5.nYk1MCn<1>ApKOn0%g&;n,W+aDXIS_NkdlV>Jp,>;;q'dqWrFtPqb0PZ#69#-"QNF#e>\+$:*/$b06Duo]our+?$#m;B@L"9*$1Ad%B(6PY,,HD)V1lR-gR1i22uuIZW$ZBe/KV<$-io87$b@e\FfI7P"=ZVC_G*V.h<=bg88;F:9X67NE%+UMc=V>k4#WTPk2rrL?s3]VC5R!$0[Lf+9o4TgBDP`3&S(a)]?CL+[+AQZmk.aGBN8`1XJ4mPSrrs='M.?o.ofU-h3KR'XuiY`)L6N<]3;(;doqc?D0,^9u%H-#;^fCM2kr];U:*rP[mXpu7WifjKhA+,D4fmM'Ij,20UlN6$s!I)07]T78_1b[T3dU?.YX+`EZkdJ@[C`nKq*Rl9.O,7bO1h\^J^)G)R&.d8*eQHQcHBM$djC(mLJPiGr]Qe`gL1UR-F5P8SRue\0Ku^+A"IW6IWTU0)ch'7O',6,OD;+BL:q)&n,U;UO\>jC#ejH);\.J6C[_D@^5(9W)LWs!Z]M76^$A:^<6DMW4F)LrUZ"l2&@+gTtGnZT&q[IeJ'./(k^FG2Q!W~> +endstream +endobj +214 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 213 0 R +>> +endobj +215 0 obj +<< /Length 653 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat$ua_oie&A@B[G]\I^b#K.:$0iLf/gqq)de9?TPcI-//(-lXpSAXp>3n5"!'u[7a*BK4aLaEVJ'S[g5U-tU!Cj\O+RC/$,R',P(E`lOEJ_E5^*KPh5sJ6EdBNfufEF7_O[*Tl+;olpp4TNpHCYu/jONZ&Xf5t9<^/!t*o4FFO%N^/c*PFqUUM:-NW'@@_F]j%,`!'=<A3QWOuDuiTpCWkEXSQd^t#t."sUkk-KX3F3@Bg?4DAe+3@HA'dVZ<PPe+/t/Q>>=JoJ(hWpKpR-H/9?QfRe8$Um<1EaI([!Hrc9UtZ$I]4G53:J?_2u'%?g>mUMf@<me#Y'?$_)nbPg+I>>+DP-Mm(pdi"5_YLjA3a.,q4^49l+I6(a)Au-1`PGJ!JB;IS+g%f[]!6$T0-%2IJRc.D!IXaIQ2`abH]X790DC0<L[KJ!hMl7eZH\j!hHo1=CurZds#q:cOo7-uAtO+MpLpgg27gl3&"5!QR*/gY6b_(aPA[["Vq,+D3Y)rR_M0S<Y4O4WF*G[_BWu0:7o)q%B\4-m&d;P2$_+X!]f*`Rt%F*I%:t8e.9)Q,i(#T8mnfDbf!Dr-4^%IQZ3fX@HYp,FWR;U+:J</)J-aoi%CT+LE+s#8FL`R5:2KuiAa":q:,EF_0BRr~> +endstream +endobj +216 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 215 0 R +>> +endobj +217 0 obj +<< /Length 1048 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat%"?#Q2d'Re<25^>tu`PXURd'm!?UeT[@XjLI@4ZLA*W-i-qBcBeDmkZq26QkX3$blDkHgZY"^0=@hJ&Dhm!!UY'T"*'h!Zb?*d%L`T%eU+#`,h64o5jVjAc0RDjX`VH'QKeH2CMB(J>b5"N.?sGi$FMtGuRCujP(VdN_$Qd[R,e=eQn>V9!`'j2<QXWd4?NYRH,=1TH/ZN&fma#+Rh`mkmND;d3?GKKHDUp:Ef5ETd3Auk`-g7'ang<C1_M\h3tZVYAT<\caqaKs0driAonsM6NUMbBZCLc4_-[AFknGL+b?47?,#R)J$AR\bDVVNnrNj'&4>irTBJP0CH`cc_DJ)OB'UYKR`Md0oAu")FjTtgR.iI&lTKJ[1;7OK]epTFA**9CP^=pe51^g=B(_=_kqI<1=C.l\dC&RV(FFGj9cP(oeHB/RdRGeT/nfL9.Ujp-*>eXU]c4/j\iAbOn&@he\<V+0Rc+KX7O$O/Ur]`3N^lHZ>#1SCXsa1q]\J/J_@qhOZT]3$1DaUsFJt"s5=3.&('duQ9I:?ED5iEsk@LjbUPe/1>ZJ+/K^5P'-p?giY.)Is#f(uUmJ!e8gS^(a)S%&g/nNuJ.X>>a2FGTIst8GBR?_:<A5jc\fQ;e(aJg/R<J*M`:c/$6d!#Qi`V>ub@O%Jhtte92P0p;%FA<cE<qGt4urLH`Gt$W@k7d*Crb-)@Np#sRn>!0aFc==K?`<+u-AAl9NqZeR%&M(%perf-H9M1i!0rm$l<@G\bJH8(7&[b`SXRt=ifo>:@B?^"A_LRG1T-)LppN^lldH/)VP:h^I=!/I(i/tfFkf"4,uFZ_Sn(>&.-YLj!Z0bisF.d,>2*qJ.r?,uWnRO)a@`_QpK4Co"Ed)T\7429qT39H>SY::Jh[gC\n^P\Og5GAEn&2\Tt73./-mfi$8578JJ<fJ7%',LiiGd(&"LtC)"dSAlD6loHA^RdGb-N[0FSAG/Enlt!Ml[==W!"M>l0hMTuERZg+JiiM`gZ38*hs>[iO6g\WUJUoB0NE;ui14s"LF2XXA&Y.H~> +endstream +endobj +218 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 217 0 R +>> +endobj +219 0 obj +<< /Length 990 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat%"8T3'C'Y`a3pk2h-%'u#X!)d$Y<)b>5%30o9e/9VLcFA*Jo\VH2Rdmn-S15?$bM1qKQLee[joYpO!&tC]A-%>U!X6sM:`qHBJY3DW7Y>@nr&D5a>C@Ff$DNS^M?O8h"tT<kJ8dje"9XZGJN,S!\u:odO`-RX?KcKJQ=X'lApkRK0l-P[IUXk`l_5%A*C[Nb?A0V_FettXpI\bijo&9ils^Q*Z![^ElsfddiZd8OaQF0uZihumT^mp&HT_X0.H8o8knH;(*/AAJYC>e-pWBjG<u^llFd=U0?#3H7._T$BcTBGa&>HN,p0H!.@\F&ue?Os!)8O=G&<dM6auYrs@U3o[l09c%O:4uj.'rL$hc*YBnmIX7qCmp17VI:;-?4nL*m:/"@LO78NQo^Cj&7ht]GSdZ)r"[lJj[<Xjm:lMikDH:UN<pmlsTD&S\+>3PJC$XUFVn63ia5D/LRXfF3h`s+!6%d^.uL4ldhq*1Tu!Md>Fb',4p$8I(d6XODTSpK2#,ehP`c[[R18j@k`*6Xl>=H*E.22S_!&6S&E*=]LAQK-@l`fi8cN:1TcU39JX$L.=]gT('BHbT<>C#i^;1,5&"*<I<d36!(9`BiTO+h,mOtf?f:fNO5d-r>/),@2C$6^>TBlHQ@!i6?L@t@Q/M_!H8Q!k&#;d#PguIdfMNS[?hl5cRj@hS012HE5&."X:=1[eTu9[T_ngM@"\qd18gKL[GO")O1+q#P.a?6)*C(4GbG7?*^?DRLbl4HQc`]V<m.,PG/H?!QKGsbm(!;c/ng]-4HZ=0c:i6L;h:_KR*lm!Xq1Ol,!m:BlHCM(E\(NBt7)r:fRm"VK+Jdop2n@=+(q,]]%D<c,XW?f4e[rkI]80TTe!J_+Tj7Y,J+HqEMfjpgQ$K6Fe#HFXI6Mbs)5)pOGMt;\r95i`Q7mpbY%X77&qC,nTNsp=%[+fo`Ha:PjqNm`::F6iiC`I@idgaaUX5G.%qZND('~> +endstream +endobj +220 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 219 0 R +>> +endobj +221 0 obj +<< /Length 667 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat%!9p:c+&A@Zck.#b/bBu)NXibB@=RK3m96jAFKFD"bKNWl)qsPOB^.H1F\M0S'rHR/%LV(o[o8t4JJHRAp4<NrRN-tN?8.tESA/lk--p45B2\4;5hkD2@r+&YE@G`D6:^b(7$:mcS&-n"cp06_AW\gcpj>u+0X.mheCk%@DKNHhch[,GDl+I05I3e)"5GuJAJ!q-&buml\42jL`6XJ2,0F6c^gdc@%3eWqH6sp*`@UNqJGuFnDQc]S,9O4%mB$O*8^_$)1?'@IOatZHO;D,W0^]u(p#bM4h\\kTArTU7:2^0\:EQi7:ZeajC2*.7LEE-f1A6oj=HrfUh?j*ebAprJV0^XR([CtcRb`#,YO/iWRs"Miseo=AL$K7@9kT\=$k;"pJiYF91gPIh(1tW./#Qs'+hEEm8gLDV,%Fgke%bSrC@poqZf12%>$r`bAl*)*0[X)%2f6[5TT<s!W[Q%$`<5$qa6FSa_qbtPs2+pb(/[.>P`X,Ji/Aku/dj+=!P/MAVb9J2<Y\LW7_.<BW`7A'W&2_t?H1Z?$[P*QO<!It*q,P)W)P4?<e)kSMCD00m&bTX;St[^K/=hq(.-C,&fS&*7pCXCr!df"85ZunWLucV^NcL*lmu)B+:6Ph`H6KVa[^+d+.M3K4Rdi,f;uZs1JWr(~> +endstream +endobj +222 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 221 0 R +>> +endobj +223 0 obj +<< /Length 887 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gau0B>AqtE'RoMSn.XM$C4(kJ#772#N!H.Q6Asb&G]6TZ#ts<@$`!WGS6PBV9=#Ga(SB/ts,Okh3aBAo8-.k7#S>!+"El:(OSN>##t0;j%!(K]E"BZggr[7@"@#0Ha`oOjOYJObK**H[Jl;`!dQ,B"dug`]3nB!WGPShOMDX3rJi-trmDX99\<X4Co?sY]7i<a+RQ+?0,CL6_nS8fSA$p]e>(WFiFOf6jW6e%qi7,X\7cACs]jRPK4pFJ(5q"(D+D(CnR-Gr\Dec&<dAmLp0\uQ'mB4`-P>,o?'MB:2KR!7jq()qAc9%5X2Ojpg/VfB(,`$TW=2h?!X1W2`iuA73HNp6m4-IA"XD[Nu+&I_#CD(T6183n)NaQej&LPfOFRFdW@sb@JB&cmlZor=IrIF^pW`!L"2@$S'n-'8iYoh.P_/m%VfB]H/X>!ebcBQPT,0o8p8l'/d=@q6,<lMAi.]`@#i+'`<=L0MI3ASe>NJe.ioK]s:l2Y\0YDI:'W/=cl[c1U/&#Jl9ifs8;e%AS4e"U@*N+N!WFCY!*/a2SP`]?_&E=S-s9RYmlMKN%]^m^ci+Uo!#fl*"uXSe<Y;.@L43g<e1#1YPS(GsQP4Q^Cq`@L<^_Zmj4Q23e3;3=%CWQl;ohdaN2g[kFE+S%g<X7j+a3!P5BZgI@.2(k+TL@,u(n$=_6M8u/D&WZ4\2a:;ASJ_SeoK8-&JsfOG.Hr;V52?^,h(e%d*1Nbc1&sj1*;!KcVfT89QjNtM&3XWB*]9h\c!`=[A__PS]IY^)cl5/u2h*%%Y*dF&WUJ<9QAp@(Fc&/SR%9O^'<Ze,Djo6PR-tb)JJf2VKJS-$",-gHlLX:%S/V8GUbe=&!6eAsEkm(dp$d7FVZ$h'Q7I:~> +endstream +endobj +224 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 223 0 R +>> +endobj +225 0 obj +<< /Length 203 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Garp%]*cD?&;B(lTAif_$R`8BHYik^&0#%>Yu"";Kb:)o^QBY5+B&aI*53o'Z5+9M0a_s%(al/rj([^&'WaY5VALlT);Cm7oZ)<&l#1Vo9F-k,-]_a1rN<cMYTLGgXEMZ8[ERnsD&XfkA4I7G/.7m(^uR1+B[oRPq)A#5jA/q0%f4_7o!d<u6XBha-Q=D=Pn2m]/FYIY~> +endstream +endobj +226 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 225 0 R +>> +endobj +227 0 obj +<< /Length 1437 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat$8gMYb(o\EjtFMNtH0dkh"a]jX75_lMX<b!fS0IS\f'9OT-PgfHs7uEO%b*Ll"JAH<FF2.;EC(a)UmK3.`SE=gY1EEO9#e-rrPLV$P":8gm4ZM,sN;YIi-"T%und8#ou3'ocV&/h!HF!$[Cn0`hY:"<1AnX(,(O]P[)3-)17Qh&<!:5p'33(P556.GSnc#,Bgm:+Uu>ac4s1MGgf+7=J!oBge+N5k7R*>!a'u;'MH'.%B'@b9T!GMlh*JO0@p2TRFF4f%s]K\t`q`ZQ03qJI$jh+9HRONPHpH4mlJ%oaXVnOAe]7i+<Y<Ihq]SqfL[/j#3>nOQOp!ANmgGR8Q-rTbp^i7sD6P]e'?A$?rY`m(Aem<q;-7Vr3$5(a)h/!k`aZ;m^k!RXGNKrb0&=(*.ehjo/%UhQS5Z7!9C%h!,?,G<NaR7h/#u"+a)R&ieFh3b+o$o;6\quRj^F*B%P@o83jo?W0;fBL7+')ekcBj$LEG+5IjS7OZQ%(!A$YEX['FQ*QoGo5[?k0cjN_ng_h!YU=\*$\!E>KB\?l1?jGd]0j;iaADN2pt2#BYbFCc0?m1Qo^-<]];c9"[C0&0<:l[o:V2Ai+H6M_Z_[\)Z*a`,cp7`39(5rt3a\i9jQ,MW>M'lBNO#d:]UN6NCOfrf:FQ"2@ThT+J)_c_:*4He1mV6)nj)m[X'E62dV3hpQ9Ck&ooIBuS?`,RIop/[ON.<Nh.,R)gGV<p_nVQE1pYWXn_DYcrdZHN-@1Mh6i@"^h9A>)bj5CU1Q"=EW.j<9c0Rgh#N,EO)&G.%Cg6A1shSpB^f<RX]''sA9O7<?$[F%Cq>R?@._TdDd>KYtmD&aY$;#FhXm%D@l\^j^i;gp\:WG7GUJ["[+DN`i=C0;9#Uot<^qGE7hUlcO?8358[Vg3`ULNII:_Q!n=VqX+mfouKSZpMKTq?.b`k?%$M-X45:Gb`#mBjHt4nLY<WM(1meMU.:fAkRJIicf0]1fE99^A)2DP:C$?(>Kr6i0+E_FE$iK0T.M]_#tWQ,(0LA,f(.(N`$(Q68MCO/]Sa97%LUN<F)_.U4LVA[_P,hXkH24Q(Uc99Vh(<V+FsZW/2=Fp0Nea3#^4b/D&fTn%9#(p?<ahnE1,IokHr-`nde<OOQV*$4c&4-rS+9*+eUh:dX1OcYY4Q!/aIS^m.?rq2[p/_Kr`0W`?UlFA0YI=rT&LLUY6m"%GNGW>p7enkI#p7IZGWT=ZWjiRA\CVDn:j[]e6SdLR.GWYHi]TVF(rlJ<8"Eq4]o<YhMBD'e?ns1U)'W;EA5G]\V<(47Wg!'Z@8)g-#%K=ST+F3Sfo-1[RC&J)ipr_fSSFP4cq&e:H[6]K;S@HWpT;=p-59)Eb2=?d0h)^R$BjEMco0Mucfpa(fZ//?0K#0A`n0QW94/R@E7.0NW1"S>uN'%-9a1'E'"hF.kM~> +endstream +endobj +228 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 227 0 R +>> +endobj +229 0 obj +<< /Length 1777 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat<ACN$",nGE1lPY,d:h)^qdE`+FLXuWI]>,fcT?b63OK%[QK(a)Y3QZr;.CKj+2p?W/;dEL)G?pO8ZFkh1'Dr*$T$*D6oLE*ELgu`?2NT#ME/Aq'bkuCO<Ad\c"ZTOZVl9C\t0jnh"Yc!l:ZMYgXa^f0Os4)0-Ljl\nhs*f>)8pJkJ+GLkL<42TaCj+IV_'"$GEYrSfl$prd'#$Jeh=WEBP8BUM".?^.*@UK7PO&QTI*qF/TE]pm#*If#QU@X-u*?stVViNKFX_trJfbLY19WuNN:5[o^lbMq2rr.VY#!0#rah_'8PU3AF=rc%EP]64oaHDX--e8Gi!lpd&n`*F7Kd7h3?ah*MOm<2AJqrX<S4HNOILSXYq:H@`/^b7/GFUUF?a>dcVS@,4K:Suq(?87]bD>IM4RBWu'F9EX8smf;X>8roY)ga'R^saNc.Wb"I09["\i#'cZ&CW$Tu@(OV[IG=>3Rf)5K$%jR[d4#kG-,0IAkCN-SYiK.u45iWQ[rs#:!'+hq^In?G<]0L%"F<3f*l3_8*1XLk-2Ui-i$VIUF,b%lB.7cM&MsHt-c!:qpQ'>TYDM`0DII8S(^I&^h7V';+0!0Q4<^ZDO4i:2.*Y^)%[W8Q%?I^dO$p_GKSu$:>W;5mb:A#!+IK^9MKBB)n41,W2OG0a8OXOO$QL@VLqrNTPNT)n0>7'6B3.3IkjVc5H$(a);L^\.1)SgCl\Ui'CN"TSUDZ&Ci!a;qU`eS5PnX+!a/l>$25d8aJo$N(L3@LR>1AhI8e"7&+?-59S5UUg-@gR&Re,b.VFX:Dlf=Bl<g"r88#YM``kaKcYLPZendUM[p/`a"Lo7FuT%fV"U!cLl-!YPh6$S5c$;3Y94pgn%4%D2N+oROkF'P#V49$a.STm>Y4V@7;()1k=>n3_f^bAO=r^gE8>0/T>7L(VU^g_N<!J,%)QuB1[g];?Wgu/A[6T`D$;36kj$M#_g`=50/5rqTRWbUaE9VY[f$5c$J0Z[)'/DLCuXPraG=S@-h:>b#]4W*rXs7Y(-Vfs$9"[-d9H<E'bjSRBqE>UnCKTEW<R8tN-+6FuL@k._II@X="@gjF5'*:M0XN4Jc)P4EJ#tTq#7TT@q)[;q'][k`DD;=[(0dc*Ff:F_Eq?qqso(__5_OTeH\]o<qnJg3jVKJF0\^?dNebVP>Bjq(p.=/q%/(a)cB1RZCui5Rhs.D]&X-"(Y,t\$IgR7\E>jN2Q,flMkn]LTAn.)djB5Tp4nV_NTkCUEsGbMs;Y,0Q\V9?B'8,W2WE2:#7?&.#SH(+:>A)''JVYJ4j"rI0iLFW/"'keu3JXU>T`##>9)"(;-W>*;)%hB;M&r4j#1Iq%#r_,UICO/'_E(^Et'7d\[qJ!O-`f&T^9K:u<<H"HXUlLB'*mMG,=H-*cF(k=7i7&QV)T'Pei&*d2"*o7DrYeDn$J)^"mP-._In]$bM,[Hm:IQ?T_IITPC]2nZ^<+1hJNb?sj/"BnYIc>KLn)K`Tfj)5L[^En8tY-9k`'apP'BM+EL]Y*V1Ye.S?DK^4kT,EmcqQ!"nH*2A*i,5`%'h9*XoZmii2!nR+CpB%(-ME'b@t>%t/?Bi&r]%7Igjf%(8&A0nR23*;cZ&126,die7l0>&H6*if;<(9P$lSNuqt@UA\9!nkrqA7I2$e@Rn2RGgMMlWP]"!l^U'U&rn+KYAXE(om,^uV51Kp1f\#WU+,?HPd`qGP,&\ZF)UKZkch(DeA.pMtWqQue+Mb%q+-taoja?b@rM?OiBWW@@Y&`Z*'8?MU~> +endstream +endobj +230 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 229 0 R +>> +endobj +231 0 obj +<< /Length 257 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +GasJK0aiUf'SQ5YMDshYCQ-9#YsLNo.qC.N'Vc,58u&6ThcCDKK2Al/4-$q#Kd):.LR97heIW'>M1JDTL7$5_i!_'$TUp*1Na2o&j0Kh@kBc=;O0R8CQ1fMXD-'nHHcIsLO,m#bR`^o`]1EK=^UpeWS+,)!n(GFVFc@R"6!_Q'Ok52mi5cUr>XD$rA:anP%SfAYY,"lE3o^8f'2psdn8iNtoM/1EdJD>*O_ibH[icQ#M#a,U.[L&jo5-_R"^Ho~> +endstream +endobj +232 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 231 0 R +>> +endobj +233 0 obj +<< /Length 1328 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gau`SD/\/e&H;*)+_8BS!&Z@BM,Jm68='JC0Eg->m)u[FZ;'!TABC[D[JonF7EVDObAMh39n7n@][u>fj6=I%[WoXiA,sTb17O!6Fp<RqrPF(.&-e(i^aKMTqr"+$kB,&=Jq&F7Db>ol0N8*GWDe=<1DiS(6:N+3`Fb^,P)F03cc&MRnottp&_2KBY6ZjQ4Xo(,Of;Pg"-,+AP_ko_;e0\o1'Bn-R)kkf@U4nt3%9+qoDj\V!bb,af#t=sdk<)>AF(_qN//rX$85gq/\l=9!f,1M7%nSOcpV<3m7'X\Y"L3kk)\B5'`[]KcKgol:SL#o[)-A?P`-U^r/4K<V"O.:>*&eZ,,9Q>\':K\F^%kc5XHVkKe52GqX67Z]XZ60@]Dq.";!sa6mds=$KIi&]fRiH/OcpeF=I0p<Ror$2Uq;Xkdj`k5nlI\oo;+CPu\r+[(#4gjdsnc_``uT"C8=H,B=5>?h$4NeAZb3eprk/"/LDoY!M'JILetk[%?O2<H]DQ>D!(mQZ9c=9S2?+BTTH5'[Qs(dVZ(/D*dH1ZCt=\(d3s3c_P:^SXHs`@Qn_@Vr[@;X8kaSn18Es01Kr\AQg5+h\-RI++M%Y*/]IXXn)[0?QZUI^'FpOLu.2eh<^9H46Q(=aE'j/D6pN9lBW(a)oM.(L&)bN'"N?e+[H4o"YEpH1eobca[a-'0Ee^lLnrfH`^c);..8XR[e^FH43^;3(c*+m&3-YqS@3=D65j54I\o<jpj0:nG'Z$Fr>"d?@3<)$4e5H`2+_ch/T+l;j%39kSM[>pu_#>'HHY<'KS84$p_Gi7+UMF2<,R[OD:)@%+sG3%om]Jou2%X;UM%=!Wd-"IiCDdDm4Y'7<LL/m\QfkbkFN>Kig`MK>(B/]'C=]JpBYd0kDFaL>Bi-9bA\rfGC]CRkj@kkFKMOci#+`XGk6<;!]9Qfg'qHu0SOXN*l+2=WJ(0tZZ-4HtFq[hK/rcMsV\'s51YI?HJ\Na,enoZS7rO['=Vk'=/]4&^4BNLQ&fR62%;iC3C03XWpd^:U_ihEF565RNFN44O8B2"ed$j9FX&f\o=qp,!t<i'_WP>A*PN]+_EV2:==>Q!#1ptugHb4aK!WD,naARmoWs7"(R_u!O.e)m\I.V8QSASnDi#O'O<*ZRQ]og%/*U)1)n]ug1,bLBpCBb2u7,$!Hdfh\F,ZM9:jX*Zn8%HY<H_u!dEX5d3h0\-tphVo=!(dJMAMmDJ^)b]dolPEDWV?^?:!>CP?C`L=PEq[V&9Xf&I.OU5iFn7=Q$E4T`5k6%erAjbZ*"#1=i!INSPGk(r#W"?L"(JqWk$7os>RS4@~> +endstream +endobj +234 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 233 0 R +>> +endobj +235 0 obj +<< /Length 1066 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +Gat%"D/[lW&H:NniGWgo\p!F"ahEbNU`kDE<^6rci2'1a8F;MK/cGE'YE$5W$;Kf5(Z4&4HgW2`=0q!/!<Imo9Y`-I+g@ACJF"?^;#h2a8-2/q^hO+gc#8J+W3uPE"VsB<_'DJV"7mJqbP/"l4O:R#>$Z\$@.gZ3Jm_P>b0C&2$54&[!T*%8au*N:B(Qrs*&/:7Q"TpWmd>P.$3<WIp"1Ui'eHf=B[Bq1eU*4D+:Jo;=$j!ZA@+G%#=ub]XV`7e-]nI^+=!R%lN4X?A<7#F[jcRuMf49,S!A<_,\\_U*6$q@,XQ@bYj["@G@CUcM(k`FinJjm!qitsesPHC\_LhcKT?F5CKSi6+5MG1OEk!kH)7EZhS;.HN$T^qr(uR/@9Q1[m[3;!j<U;,o?G1B46XW[dA'VBXV3`Ls6KNH';ZS;X3k(Hq0kL#/sSLo(DF25+RCK7p@eI0LC*64'\i?ND&dVTkHc/JmW(\_nT]_PhNt4_FL_u[$*u0TrDTMh>,H#ZQ/d6X.&eZ^.Mb'>a*oP7[7r<5gT&d\RHT>ujt8=/e%F>4'L]m[]bXanWf5TH>ZSi*@6c&Mg\"SYU4JP8\Gc=Z_%;W9aKY-WP[^Z%E5E`-^<'MnV2+>-p=#"+4A*"D89(`'>Ic%hafBR8r,aT@hM[^i0Z0$$#M^MKDb6(+F"r)O66O8G@`XKVl_5^<$lum<T3fXig'P(@&`/58T3AL_]-9I6'EKA^>tmME@UEuM`YsbDJjS@lA\3^M93^De4?6EAQ/PW#PO_tV=tl*-pqkMkOY$Q\#"GV$&3fj6?1-ag=k(As^J'>:--mC(fZ;4"VjC?JL1,mXi4D#=;Y%l@m9XT^,Y8W$q3S3[im<cKd^GolUc<C+Hqh4?S_Q1$kf38YZ[7pibQiD:UX\_ZJAf/r2jI_F_=s5i(Rh[8f:0#=A\2q@`=B;VN;=mY>Cpr?8oC(a6VUq%B[h0*(:nJMl[#U\^RD02)EnJU2u24Ym!&=9f3jY:#`7Bs'G3DZ6TYiG:^W</50dK<c7^s\aZjYQKp)Z5gW!:)rESU$]4gOtrrl(X@NY~> +endstream +endobj +236 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 235 0 R +/Annots 237 0 R +>> +endobj +237 0 obj +[ +238 0 R +239 0 R +240 0 R +241 0 R +242 0 R +243 0 R +244 0 R +] +endobj +238 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 352.0 687.572 373.66 677.572 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A << /URI (http://uffi.b9.com) +/S /URI >> +/H /I +>> +endobj +239 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 381.047 687.572 451.607 677.572 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A << /URI (http://uffi.b9.com) +/S /URI >> +/H /I +>> +endobj +240 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 532.89 676.572 564.57 666.572 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A << /URI (http://www.sourceforge.net/projects/cclan) +/S /URI >> +/H /I +>> +endobj +241 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 571.85 676.572 586.29 666.572 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A << /URI (http://www.sourceforge.net/projects/cclan) +/S /URI >> +/H /I +>> +endobj +242 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 120.0 665.572 280.52 655.572 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A << /URI (http://www.sourceforge.net/projects/cclan) +/S /URI >> +/H /I +>> +endobj +243 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 178.61 654.572 194.16 644.572 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A << /URI (http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/asdf.lisp) +/S /URI >> +/H /I +>> +endobj +244 0 obj +<< /Type /Annot +/Subtype /Link +/Rect [ 199.99 654.572 462.73 644.572 ] +/C [ 0 0 0 ] +/Border [ 0 0 0 ] +/A << /URI (http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/asdf.lisp) +/S /URI >> +/H /I +>> +endobj +245 0 obj +<< /Length 293 /Filter [ /ASCII85Decode /FlateDecode ] + >> +stream +GarnQ]2$6t']&^&GAN"?r-jS=&QCY6DnqH(8S'?1_$pKrO41H]6pb4_c9758]^t3e'Yl"u/&8WI_N?OFq(XQC.2_#?#n?k:YFDFBT$LF50&RcJF-\:`1m>67-=V?*%$aAkSQ'/o9fVhMC`.<SG#Nk_oap*qg@msug8]%nhLGL2'+;Qqs&Q47>g%9VrFjO-`BDH52e\$=>g;<H[Z78HC']T4612T5jkb5VIIuTAqPq_]Q7<U"JYW(a)X;*[uEC7lk+AEVS*I&Qgqq-1jYeA?aa.*Y^\\iKTla*(pb~> +endstream +endobj +246 0 obj +<< /Type /Page +/Parent 1 0 R +/MediaBox [ 0 0 595 842 ] +/Resources 3 0 R +/Contents 245 0 R +>> +endobj +249 0 obj +<< + /Title (\376\377\0\125\0\106\0\106\0\111\0\40\0\122\0\145\0\146\0\145\0\162\0\145\0\156\0\143\0\145\0\40\0\107\0\165\0\151\0\144\0\145) + /Parent 247 0 R + /Next 251 0 R + /A 248 0 R +>> endobj +251 0 obj +<< + /Title (\376\377\0\124\0\141\0\142\0\154\0\145\0\40\0\157\0\146\0\40\0\103\0\157\0\156\0\164\0\145\0\156\0\164\0\163) + /Parent 247 0 R + /Prev 249 0 R + /Next 252 0 R + /A 250 0 R +>> endobj +252 0 obj +<< + /Title (\376\377\0\120\0\162\0\145\0\146\0\141\0\143\0\145) + /Parent 247 0 R + /Prev 251 0 R + /Next 253 0 R + /A 15 0 R +>> endobj +253 0 obj +<< + /Title (\376\377\0\103\0\150\0\141\0\160\0\164\0\145\0\162\0\240\0\61\0\56\0\240\0\111\0\156\0\164\0\162\0\157\0\144\0\165\0\143\0\164\0\151\0\157\0\156) + /Parent 247 0 R + /First 254 0 R + /Last 257 0 R + /Prev 252 0 R + /Next 260 0 R + /Count -6 + /A 17 0 R +>> endobj +254 0 obj +<< + /Title (\376\377\0\120\0\165\0\162\0\160\0\157\0\163\0\145) + /Parent 253 0 R + /Next 255 0 R + /A 19 0 R +>> endobj +255 0 obj +<< + /Title (\376\377\0\102\0\141\0\143\0\153\0\147\0\162\0\157\0\165\0\156\0\144) + /Parent 253 0 R + /Prev 254 0 R + /Next 256 0 R + /A 21 0 R +>> endobj +256 0 obj +<< + /Title (\376\377\0\123\0\165\0\160\0\160\0\157\0\162\0\164\0\145\0\144\0\40\0\111\0\155\0\160\0\154\0\145\0\155\0\145\0\156\0\164\0\141\0\164\0\151\0\157\0\156\0\163) + /Parent 253 0 R + /Prev 255 0 R + /Next 257 0 R + /A 23 0 R +>> endobj +257 0 obj +<< + /Title (\376\377\0\104\0\145\0\163\0\151\0\147\0\156) + /Parent 253 0 R + /First 258 0 R + /Last 259 0 R + /Prev 256 0 R + /Count -2 + /A 25 0 R +>> endobj +258 0 obj +<< + /Title (\376\377\0\117\0\166\0\145\0\162\0\166\0\151\0\145\0\167) + /Parent 257 0 R + /Next 259 0 R + /A 27 0 R +>> endobj +259 0 obj +<< + /Title (\376\377\0\120\0\162\0\151\0\157\0\162\0\151\0\164\0\151\0\145\0\163) + /Parent 257 0 R + /Prev 258 0 R + /A 29 0 R +>> endobj +260 0 obj +<< + /Title (\376\377\0\103\0\150\0\141\0\160\0\164\0\145\0\162\0\240\0\62\0\56\0\240\0\120\0\162\0\157\0\147\0\162\0\141\0\155\0\155\0\151\0\156\0\147\0\40\0\116\0\157\0\164\0\145\0\163) + /Parent 247 0 R + /First 261 0 R + /Last 266 0 R + /Prev 253 0 R + /Next 269 0 R + /Count -8 + /A 31 0 R +>> endobj +261 0 obj +<< + /Title (\376\377\0\111\0\155\0\160\0\154\0\145\0\155\0\145\0\156\0\164\0\141\0\164\0\151\0\157\0\156\0\40\0\123\0\160\0\145\0\143\0\151\0\146\0\151\0\143\0\40\0\116\0\157\0\164\0\145\0\163) + /Parent 260 0 R + /First 262 0 R + /Last 264 0 R + /Next 265 0 R + /Count -3 + /A 33 0 R +>> endobj +262 0 obj +<< + /Title (\376\377\0\101\0\154\0\154\0\145\0\147\0\162\0\157\0\103\0\114) + /Parent 261 0 R + /Next 263 0 R + /A 35 0 R +>> endobj +263 0 obj +<< + /Title (\376\377\0\114\0\151\0\163\0\160\0\167\0\157\0\162\0\153\0\163) + /Parent 261 0 R + /Prev 262 0 R + /Next 264 0 R + /A 37 0 R +>> endobj +264 0 obj +<< + /Title (\376\377\0\103\0\115\0\125\0\103\0\114) + /Parent 261 0 R + /Prev 263 0 R + /A 39 0 R +>> endobj +265 0 obj +<< + /Title (\376\377\0\106\0\157\0\162\0\145\0\151\0\147\0\156\0\40\0\117\0\142\0\152\0\145\0\143\0\164\0\40\0\122\0\145\0\160\0\162\0\145\0\163\0\145\0\156\0\164\0\141\0\164\0\151\0\157\0\156\0\40\0\141\0\156\0\144\0\40\0\101\0\143\0\143\0\145\0\163\0\163) + /Parent 260 0 R + /Prev 261 0 R + /Next 266 0 R + /A 41 0 R +>> endobj +266 0 obj +<< + /Title (\376\377\0\117\0\160\0\164\0\151\0\155\0\151\0\172\0\151\0\156\0\147\0\40\0\103\0\157\0\144\0\145\0\40\0\125\0\163\0\151\0\156\0\147\0\40\0\125\0\106\0\106\0\111) + /Parent 260 0 R + /First 267 0 R + /Last 268 0 R + /Prev 265 0 R + /Count -2 + /A 43 0 R +>> endobj +267 0 obj +<< + /Title (\376\377\0\102\0\141\0\143\0\153\0\147\0\162\0\157\0\165\0\156\0\144) + /Parent 266 0 R + /Next 268 0 R + /A 45 0 R +>> endobj +268 0 obj +<< + /Title (\376\377\0\103\0\162\0\157\0\163\0\163\0\55\0\111\0\155\0\160\0\154\0\145\0\155\0\145\0\156\0\164\0\141\0\164\0\151\0\157\0\156\0\40\0\117\0\160\0\164\0\151\0\155\0\151\0\172\0\141\0\164\0\151\0\157\0\156) + /Parent 266 0 R + /Prev 267 0 R + /A 47 0 R +>> endobj +269 0 obj +<< + /Title (\376\377\0\104\0\145\0\143\0\154\0\141\0\162\0\141\0\164\0\151\0\157\0\156\0\163) + /Parent 247 0 R + /First 271 0 R + /Last 272 0 R + /Prev 260 0 R + /Next 273 0 R + /Count -2 + /A 49 0 R +>> endobj +271 0 obj +<< + /Title (\376\377\0\117\0\166\0\145\0\162\0\166\0\151\0\145\0\167) + /Parent 269 0 R + /Next 272 0 R + /A 270 0 R +>> endobj +272 0 obj +<< + /Title (\376\377\0\144\0\145\0\146\0\55\0\164\0\171\0\160\0\145) + /Parent 269 0 R + /Prev 271 0 R + /A 51 0 R +>> endobj +273 0 obj +<< + /Title (\376\377\0\120\0\162\0\151\0\155\0\151\0\164\0\151\0\166\0\145\0\40\0\124\0\171\0\160\0\145\0\163) + /Parent 247 0 R + /First 274 0 R + /Last 276 0 R + /Prev 269 0 R + /Next 277 0 R + /Count -3 + /A 53 0 R +>> endobj +274 0 obj +<< + /Title (\376\377\0\144\0\145\0\146\0\55\0\143\0\157\0\156\0\163\0\164\0\141\0\156\0\164) + /Parent 273 0 R + /Next 275 0 R + /A 55 0 R +>> endobj +275 0 obj +<< + /Title (\376\377\0\144\0\145\0\146\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\164\0\171\0\160\0\145) + /Parent 273 0 R + /Prev 274 0 R + /Next 276 0 R + /A 57 0 R +>> endobj +276 0 obj +<< + /Title (\376\377\0\156\0\165\0\154\0\154\0\55\0\143\0\150\0\141\0\162\0\55\0\160) + /Parent 273 0 R + /Prev 275 0 R + /A 59 0 R +>> endobj +277 0 obj +<< + /Title (\376\377\0\101\0\147\0\147\0\162\0\145\0\147\0\141\0\164\0\145\0\40\0\124\0\171\0\160\0\145\0\163) + /Parent 247 0 R + /First 278 0 R + /Last 284 0 R + /Prev 273 0 R + /Next 285 0 R + /Count -7 + /A 61 0 R +>> endobj +278 0 obj +<< + /Title (\376\377\0\144\0\145\0\146\0\55\0\145\0\156\0\165\0\155) + /Parent 277 0 R + /Next 279 0 R + /A 63 0 R +>> endobj +279 0 obj +<< + /Title (\376\377\0\144\0\145\0\146\0\55\0\163\0\164\0\162\0\165\0\143\0\164) + /Parent 277 0 R + /Prev 278 0 R + /Next 280 0 R + /A 65 0 R +>> endobj +280 0 obj +<< + /Title (\376\377\0\147\0\145\0\164\0\55\0\163\0\154\0\157\0\164\0\55\0\166\0\141\0\154\0\165\0\145) + /Parent 277 0 R + /Prev 279 0 R + /Next 281 0 R + /A 67 0 R +>> endobj +281 0 obj +<< + /Title (\376\377\0\147\0\145\0\164\0\55\0\163\0\154\0\157\0\164\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162) + /Parent 277 0 R + /Prev 280 0 R + /Next 282 0 R + /A 69 0 R +>> endobj +282 0 obj +<< + /Title (\376\377\0\144\0\145\0\146\0\55\0\141\0\162\0\162\0\141\0\171\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162) + /Parent 277 0 R + /Prev 281 0 R + /Next 283 0 R + /A 71 0 R +>> endobj +283 0 obj +<< + /Title (\376\377\0\144\0\145\0\162\0\145\0\146\0\55\0\141\0\162\0\162\0\141\0\171) + /Parent 277 0 R + /Prev 282 0 R + /Next 284 0 R + /A 73 0 R +>> endobj +284 0 obj +<< + /Title (\376\377\0\144\0\145\0\146\0\55\0\165\0\156\0\151\0\157\0\156) + /Parent 277 0 R + /Prev 283 0 R + /A 75 0 R +>> endobj +285 0 obj +<< + /Title (\376\377\0\117\0\142\0\152\0\145\0\143\0\164\0\163) + /Parent 247 0 R + /First 286 0 R + /Last 298 0 R + /Prev 277 0 R + /Next 299 0 R + /Count -13 + /A 77 0 R +>> endobj +286 0 obj +<< + /Title (\376\377\0\141\0\154\0\154\0\157\0\143\0\141\0\164\0\145\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\157\0\142\0\152\0\145\0\143\0\164) + /Parent 285 0 R + /Next 287 0 R + /A 79 0 R +>> endobj +287 0 obj +<< + /Title (\376\377\0\146\0\162\0\145\0\145\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\157\0\142\0\152\0\145\0\143\0\164) + /Parent 285 0 R + /Prev 286 0 R + /Next 288 0 R + /A 81 0 R +>> endobj +288 0 obj +<< + /Title (\376\377\0\167\0\151\0\164\0\150\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\157\0\142\0\152\0\145\0\143\0\164) + /Parent 285 0 R + /Prev 287 0 R + /Next 289 0 R + /A 83 0 R +>> endobj +289 0 obj +<< + /Title (\376\377\0\163\0\151\0\172\0\145\0\55\0\157\0\146\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\164\0\171\0\160\0\145) + /Parent 285 0 R + /Prev 288 0 R + /Next 290 0 R + /A 85 0 R +>> endobj +290 0 obj +<< + /Title (\376\377\0\160\0\157\0\151\0\156\0\164\0\145\0\162\0\55\0\141\0\144\0\144\0\162\0\145\0\163\0\163) + /Parent 285 0 R + /Prev 289 0 R + /Next 291 0 R + /A 87 0 R +>> endobj +291 0 obj +<< + /Title (\376\377\0\144\0\145\0\162\0\145\0\146\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162) + /Parent 285 0 R + /Prev 290 0 R + /Next 292 0 R + /A 89 0 R +>> endobj +292 0 obj +<< + /Title (\376\377\0\145\0\156\0\163\0\165\0\162\0\145\0\55\0\143\0\150\0\141\0\162\0\55\0\143\0\150\0\141\0\162\0\141\0\143\0\164\0\145\0\162) + /Parent 285 0 R + /Prev 291 0 R + /Next 293 0 R + /A 91 0 R +>> endobj +293 0 obj +<< + /Title (\376\377\0\145\0\156\0\163\0\165\0\162\0\145\0\55\0\143\0\150\0\141\0\162\0\55\0\151\0\156\0\164\0\145\0\147\0\145\0\162) + /Parent 285 0 R + /Prev 292 0 R + /Next 294 0 R + /A 93 0 R +>> endobj +294 0 obj +<< + /Title (\376\377\0\155\0\141\0\153\0\145\0\55\0\156\0\165\0\154\0\154\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162) + /Parent 285 0 R + /Prev 293 0 R + /Next 295 0 R + /A 95 0 R +>> endobj +295 0 obj +<< + /Title (\376\377\0\156\0\165\0\154\0\154\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162\0\55\0\160) + /Parent 285 0 R + /Prev 294 0 R + /Next 296 0 R + /A 97 0 R +>> endobj +296 0 obj +<< + /Title (\376\377\0\53\0\156\0\165\0\154\0\154\0\55\0\143\0\163\0\164\0\162\0\151\0\156\0\147\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162\0\53) + /Parent 285 0 R + /Prev 295 0 R + /Next 297 0 R + /A 99 0 R +>> endobj +297 0 obj +<< + /Title (\376\377\0\167\0\151\0\164\0\150\0\55\0\143\0\141\0\163\0\164\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162) + /Parent 285 0 R + /Prev 296 0 R + /Next 298 0 R + /A 101 0 R +>> endobj +298 0 obj +<< + /Title (\376\377\0\144\0\145\0\146\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\166\0\141\0\162) + /Parent 285 0 R + /Prev 297 0 R + /A 103 0 R +>> endobj +299 0 obj +<< + /Title (\376\377\0\123\0\164\0\162\0\151\0\156\0\147\0\163) + /Parent 247 0 R + /First 300 0 R + /Last 306 0 R + /Prev 285 0 R + /Next 307 0 R + /Count -7 + /A 105 0 R +>> endobj +300 0 obj +<< + /Title (\376\377\0\143\0\157\0\156\0\166\0\145\0\162\0\164\0\55\0\146\0\162\0\157\0\155\0\55\0\143\0\163\0\164\0\162\0\151\0\156\0\147) + /Parent 299 0 R + /Next 301 0 R + /A 107 0 R +>> endobj +301 0 obj +<< + /Title (\376\377\0\143\0\157\0\156\0\166\0\145\0\162\0\164\0\55\0\164\0\157\0\55\0\143\0\163\0\164\0\162\0\151\0\156\0\147) + /Parent 299 0 R + /Prev 300 0 R + /Next 302 0 R + /A 109 0 R +>> endobj +302 0 obj +<< + /Title (\376\377\0\146\0\162\0\145\0\145\0\55\0\143\0\163\0\164\0\162\0\151\0\156\0\147) + /Parent 299 0 R + /Prev 301 0 R + /Next 303 0 R + /A 111 0 R +>> endobj +303 0 obj +<< + /Title (\376\377\0\167\0\151\0\164\0\150\0\55\0\143\0\163\0\164\0\162\0\151\0\156\0\147) + /Parent 299 0 R + /Prev 302 0 R + /Next 304 0 R + /A 113 0 R +>> endobj +304 0 obj +<< + /Title (\376\377\0\143\0\157\0\156\0\166\0\145\0\162\0\164\0\55\0\146\0\162\0\157\0\155\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\163\0\164\0\162\0\151\0\156\0\147) + /Parent 299 0 R + /Prev 303 0 R + /Next 305 0 R + /A 115 0 R +>> endobj +305 0 obj +<< + /Title (\376\377\0\143\0\157\0\156\0\166\0\145\0\162\0\164\0\55\0\164\0\157\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\163\0\164\0\162\0\151\0\156\0\147) + /Parent 299 0 R + /Prev 304 0 R + /Next 306 0 R + /A 117 0 R +>> endobj +306 0 obj +<< + /Title (\376\377\0\141\0\154\0\154\0\157\0\143\0\141\0\164\0\145\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\163\0\164\0\162\0\151\0\156\0\147) + /Parent 299 0 R + /Prev 305 0 R + /A 119 0 R +>> endobj +307 0 obj +<< + /Title (\376\377\0\106\0\165\0\156\0\143\0\164\0\151\0\157\0\156\0\163\0\40\0\46\0\40\0\114\0\151\0\142\0\162\0\141\0\162\0\151\0\145\0\163) + /Parent 247 0 R + /First 308 0 R + /Last 310 0 R + /Prev 299 0 R + /Next 311 0 R + /Count -3 + /A 121 0 R +>> endobj +308 0 obj +<< + /Title (\376\377\0\144\0\145\0\146\0\55\0\146\0\165\0\156\0\143\0\164\0\151\0\157\0\156) + /Parent 307 0 R + /Next 309 0 R + /A 123 0 R +>> endobj +309 0 obj +<< + /Title (\376\377\0\154\0\157\0\141\0\144\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\154\0\151\0\142\0\162\0\141\0\162\0\171) + /Parent 307 0 R + /Prev 308 0 R + /Next 310 0 R + /A 125 0 R +>> endobj +310 0 obj +<< + /Title (\376\377\0\146\0\151\0\156\0\144\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\154\0\151\0\142\0\162\0\141\0\162\0\171) + /Parent 307 0 R + /Prev 309 0 R + /A 127 0 R +>> endobj +311 0 obj +<< + /Title (\376\377\0\101\0\160\0\160\0\145\0\156\0\144\0\151\0\170\0\240\0\101\0\56\0\240\0\111\0\156\0\163\0\164\0\141\0\154\0\154\0\141\0\164\0\151\0\157\0\156) + /Parent 247 0 R + /First 312 0 R + /Last 313 0 R + /Prev 307 0 R + /Next 314 0 R + /Count -2 + /A 132 0 R +>> endobj +312 0 obj +<< + /Title (\376\377\0\104\0\157\0\167\0\156\0\154\0\157\0\141\0\144\0\40\0\125\0\106\0\106\0\111) + /Parent 311 0 R + /Next 313 0 R + /A 134 0 R +>> endobj +313 0 obj +<< + /Title (\376\377\0\114\0\157\0\141\0\144\0\151\0\156\0\147) + /Parent 311 0 R + /Prev 312 0 R + /A 136 0 R +>> endobj +314 0 obj +<< + /Title (\376\377\0\107\0\154\0\157\0\163\0\163\0\141\0\162\0\171) + /Parent 247 0 R + /Prev 311 0 R + /A 138 0 R +>> endobj +315 0 obj +<< /Type /Font +/Subtype /Type1 +/Name /F3 +/BaseFont /Helvetica-Bold +/Encoding /WinAnsiEncoding >> +endobj +316 0 obj +<< /Type /Font +/Subtype /Type1 +/Name /F5 +/BaseFont /Times-Roman +/Encoding /WinAnsiEncoding >> +endobj +317 0 obj +<< /Type /Font +/Subtype /Type1 +/Name /F10 +/BaseFont /Courier-Oblique +/Encoding /WinAnsiEncoding >> +endobj +318 0 obj +<< /Type /Font +/Subtype /Type1 +/Name /F1 +/BaseFont /Helvetica +/Encoding /WinAnsiEncoding >> +endobj +319 0 obj +<< /Type /Font +/Subtype /Type1 +/Name /F6 +/BaseFont /Times-Italic +/Encoding /WinAnsiEncoding >> +endobj +320 0 obj +<< /Type /Font +/Subtype /Type1 +/Name /F4 +/BaseFont /Helvetica-BoldOblique +/Encoding /WinAnsiEncoding >> +endobj +321 0 obj +<< /Type /Font +/Subtype /Type1 +/Name /F9 +/BaseFont /Courier +/Encoding /WinAnsiEncoding >> +endobj +322 0 obj +<< /Type /Font +/Subtype /Type1 +/Name /F7 +/BaseFont /Times-Bold +/Encoding /WinAnsiEncoding >> +endobj +1 0 obj +<< /Type /Pages +/Count 55 +/Kids [6 0 R 8 0 R 10 0 R 12 0 R 129 0 R 140 0 R 142 0 R 144 0 R 146 0 R 148 0 R 150 0 R 152 0 R 154 0 R 156 0 R 158 0 R 160 0 R 162 0 R 164 0 R 166 0 R 168 0 R 170 0 R 172 0 R 174 0 R 176 0 R 178 0 R 180 0 R 182 0 R 184 0 R 186 0 R 188 0 R 190 0 R 192 0 R 194 0 R 196 0 R 198 0 R 200 0 R 202 0 R 204 0 R 206 0 R 208 0 R 210 0 R 212 0 R 214 0 R 216 0 R 218 0 R 220 0 R 222 0 R 224 0 R 226 0 R 228 0 R 230 0 R 232 0 R 234 0 R 236 0 R 246 0 R ] >> +endobj +2 0 obj +<< /Type /Catalog +/Pages 1 0 R + /Outlines 247 0 R + /PageMode /UseOutlines + /Names << /Dests << /Names [ (preface) [ 140 0 R /XYZ 115.0 774.889 null ] (introduction) [ 142 0 R /XYZ 115.0 774.889 null ] (notes) [ 146 0 R /XYZ 115.0 774.889 null ] (ref_declarations) [ 150 0 R /XYZ 115.0 774.889 null ] (primitives) [ 154 0 R /XYZ 115.0 774.889 null ] (aggregates) [ 162 0 R /XYZ 115.0 774.889 null ] (objects) [ 178 0 R /XYZ 115.0 774.889 null ] (strings) [ 208 0 R /XYZ 115.0 774.889 null ] (func_libr) [ 226 0 R /XYZ 115.0 774.889 null ] (installation) [ 236 0 R /XYZ 115.0 774.889 null ] (glossary) [ 246 0 R /XYZ 115.0 774.889 null ] (id2463880) [ 10 0 R /XYZ 115.0 774.889 null ] ] >> >> + >> +endobj +3 0 obj +<< +/Font << /F3 315 0 R /F5 316 0 R /F10 317 0 R /F6 319 0 R /F1 318 0 R /F4 320 0 R /F9 321 0 R /F7 322 0 R >> +/ProcSet [ /PDF /ImageC /Text ] >> +endobj +15 0 obj +<< +/S /GoTo +/D [140 0 R /XYZ 115.0 774.889 null] +>> +endobj +17 0 obj +<< +/S /GoTo +/D [142 0 R /XYZ 115.0 774.889 null] +>> +endobj +19 0 obj +<< +/S /GoTo +/D [142 0 R /XYZ 115.0 736.898 null] +>> +endobj +21 0 obj +<< +/S /GoTo +/D [142 0 R /XYZ 115.0 671.572 null] +>> +endobj +23 0 obj +<< +/S /GoTo +/D [142 0 R /XYZ 115.0 509.246 null] +>> +endobj +25 0 obj +<< +/S /GoTo +/D [142 0 R /XYZ 115.0 246.92 null] +>> +endobj +27 0 obj +<< +/S /GoTo +/D [142 0 R /XYZ 115.0 213.594 null] +>> +endobj +29 0 obj +<< +/S /GoTo +/D [142 0 R /XYZ 115.0 130.155 null] +>> +endobj +31 0 obj +<< +/S /GoTo +/D [146 0 R /XYZ 115.0 774.889 null] +>> +endobj +33 0 obj +<< +/S /GoTo +/D [146 0 R /XYZ 115.0 736.898 null] +>> +endobj +35 0 obj +<< +/S /GoTo +/D [146 0 R /XYZ 115.0 693.572 null] +>> +endobj +37 0 obj +<< +/S /GoTo +/D [146 0 R /XYZ 115.0 654.133 null] +>> +endobj +39 0 obj +<< +/S /GoTo +/D [146 0 R /XYZ 115.0 614.694 null] +>> +endobj +41 0 obj +<< +/S /GoTo +/D [146 0 R /XYZ 115.0 575.255 null] +>> +endobj +43 0 obj +<< +/S /GoTo +/D [146 0 R /XYZ 115.0 443.929 null] +>> +endobj +45 0 obj +<< +/S /GoTo +/D [146 0 R /XYZ 115.0 410.603 null] +>> +endobj +47 0 obj +<< +/S /GoTo +/D [146 0 R /XYZ 115.0 252.164 null] +>> +endobj +49 0 obj +<< +/S /GoTo +/D [150 0 R /XYZ 115.0 774.889 null] +>> +endobj +51 0 obj +<< +/S /GoTo +/D [152 0 R /XYZ 115.0 774.889 null] +>> +endobj +53 0 obj +<< +/S /GoTo +/D [154 0 R /XYZ 115.0 774.889 null] +>> +endobj +55 0 obj +<< +/S /GoTo +/D [156 0 R /XYZ 115.0 774.889 null] +>> +endobj +57 0 obj +<< +/S /GoTo +/D [158 0 R /XYZ 115.0 774.889 null] +>> +endobj +59 0 obj +<< +/S /GoTo +/D [160 0 R /XYZ 115.0 774.889 null] +>> +endobj +61 0 obj +<< +/S /GoTo +/D [162 0 R /XYZ 115.0 774.889 null] +>> +endobj +63 0 obj +<< +/S /GoTo +/D [164 0 R /XYZ 115.0 774.889 null] +>> +endobj +65 0 obj +<< +/S /GoTo +/D [166 0 R /XYZ 115.0 774.889 null] +>> +endobj +67 0 obj +<< +/S /GoTo +/D [168 0 R /XYZ 115.0 774.889 null] +>> +endobj +69 0 obj +<< +/S /GoTo +/D [170 0 R /XYZ 115.0 774.889 null] +>> +endobj +71 0 obj +<< +/S /GoTo +/D [172 0 R /XYZ 115.0 774.889 null] +>> +endobj +73 0 obj +<< +/S /GoTo +/D [174 0 R /XYZ 115.0 774.889 null] +>> +endobj +75 0 obj +<< +/S /GoTo +/D [176 0 R /XYZ 115.0 774.889 null] +>> +endobj +77 0 obj +<< +/S /GoTo +/D [178 0 R /XYZ 115.0 774.889 null] +>> +endobj +79 0 obj +<< +/S /GoTo +/D [180 0 R /XYZ 115.0 774.889 null] +>> +endobj +81 0 obj +<< +/S /GoTo +/D [182 0 R /XYZ 115.0 774.889 null] +>> +endobj +83 0 obj +<< +/S /GoTo +/D [184 0 R /XYZ 115.0 774.889 null] +>> +endobj +85 0 obj +<< +/S /GoTo +/D [186 0 R /XYZ 115.0 774.889 null] +>> +endobj +87 0 obj +<< +/S /GoTo +/D [188 0 R /XYZ 115.0 774.889 null] +>> +endobj +89 0 obj +<< +/S /GoTo +/D [190 0 R /XYZ 115.0 774.889 null] +>> +endobj +91 0 obj +<< +/S /GoTo +/D [192 0 R /XYZ 115.0 774.889 null] +>> +endobj +93 0 obj +<< +/S /GoTo +/D [194 0 R /XYZ 115.0 774.889 null] +>> +endobj +95 0 obj +<< +/S /GoTo +/D [196 0 R /XYZ 115.0 774.889 null] +>> +endobj +97 0 obj +<< +/S /GoTo +/D [198 0 R /XYZ 115.0 774.889 null] +>> +endobj +99 0 obj +<< +/S /GoTo +/D [200 0 R /XYZ 115.0 774.889 null] +>> +endobj +101 0 obj +<< +/S /GoTo +/D [202 0 R /XYZ 115.0 774.889 null] +>> +endobj +103 0 obj +<< +/S /GoTo +/D [204 0 R /XYZ 115.0 774.889 null] +>> +endobj +105 0 obj +<< +/S /GoTo +/D [208 0 R /XYZ 115.0 774.889 null] +>> +endobj +107 0 obj +<< +/S /GoTo +/D [212 0 R /XYZ 115.0 774.889 null] +>> +endobj +109 0 obj +<< +/S /GoTo +/D [214 0 R /XYZ 115.0 774.889 null] +>> +endobj +111 0 obj +<< +/S /GoTo +/D [216 0 R /XYZ 115.0 774.889 null] +>> +endobj +113 0 obj +<< +/S /GoTo +/D [218 0 R /XYZ 115.0 774.889 null] +>> +endobj +115 0 obj +<< +/S /GoTo +/D [220 0 R /XYZ 115.0 774.889 null] +>> +endobj +117 0 obj +<< +/S /GoTo +/D [222 0 R /XYZ 115.0 774.889 null] +>> +endobj +119 0 obj +<< +/S /GoTo +/D [224 0 R /XYZ 115.0 774.889 null] +>> +endobj +121 0 obj +<< +/S /GoTo +/D [226 0 R /XYZ 115.0 774.889 null] +>> +endobj +123 0 obj +<< +/S /GoTo +/D [228 0 R /XYZ 115.0 774.889 null] +>> +endobj +125 0 obj +<< +/S /GoTo +/D [230 0 R /XYZ 115.0 774.889 null] +>> +endobj +127 0 obj +<< +/S /GoTo +/D [234 0 R /XYZ 115.0 774.889 null] +>> +endobj +132 0 obj +<< +/S /GoTo +/D [236 0 R /XYZ 115.0 774.889 null] +>> +endobj +134 0 obj +<< +/S /GoTo +/D [236 0 R /XYZ 115.0 736.898 null] +>> +endobj +136 0 obj +<< +/S /GoTo +/D [236 0 R /XYZ 115.0 649.572 null] +>> +endobj +138 0 obj +<< +/S /GoTo +/D [246 0 R /XYZ 115.0 774.889 null] +>> +endobj +247 0 obj +<< + /First 249 0 R + /Last 314 0 R +>> endobj +248 0 obj +<< +/S /GoTo +/D [10 0 R /XYZ 115.0 774.889 null] +>> +endobj +250 0 obj +<< +/S /GoTo +/D [12 0 R /XYZ 115.0 764.889 null] +>> +endobj +270 0 obj +<< +/S /GoTo +/D [150 0 R /XYZ 115.0 728.236 null] +>> +endobj +xref +0 323 +0000000000 65535 f +0000085208 00000 n +0000085695 00000 n +0000086406 00000 n +0000000015 00000 n +0000000071 00000 n +0000000363 00000 n +0000000469 00000 n +0000001525 00000 n +0000001631 00000 n +0000001802 00000 n +0000001909 00000 n +0000004069 00000 n +0000004192 00000 n +0000004625 00000 n +0000086571 00000 n +0000004759 00000 n +0000086639 00000 n +0000004893 00000 n +0000086707 00000 n +0000005027 00000 n +0000086775 00000 n +0000005161 00000 n +0000086843 00000 n +0000005295 00000 n +0000086911 00000 n +0000005429 00000 n +0000086978 00000 n +0000005563 00000 n +0000087046 00000 n +0000005697 00000 n +0000087114 00000 n +0000005831 00000 n +0000087182 00000 n +0000005965 00000 n +0000087250 00000 n +0000006099 00000 n +0000087318 00000 n +0000006233 00000 n +0000087386 00000 n +0000006367 00000 n +0000087454 00000 n +0000006501 00000 n +0000087522 00000 n +0000006635 00000 n +0000087590 00000 n +0000006769 00000 n +0000087658 00000 n +0000006903 00000 n +0000087726 00000 n +0000007037 00000 n +0000087794 00000 n +0000007171 00000 n +0000087862 00000 n +0000007305 00000 n +0000087930 00000 n +0000007439 00000 n +0000087998 00000 n +0000007573 00000 n +0000088066 00000 n +0000007707 00000 n +0000088134 00000 n +0000007841 00000 n +0000088202 00000 n +0000007975 00000 n +0000088270 00000 n +0000008109 00000 n +0000088338 00000 n +0000008243 00000 n +0000088406 00000 n +0000008377 00000 n +0000088474 00000 n +0000008510 00000 n +0000088542 00000 n +0000008644 00000 n +0000088610 00000 n +0000008778 00000 n +0000088678 00000 n +0000008911 00000 n +0000088746 00000 n +0000009045 00000 n +0000088814 00000 n +0000009179 00000 n +0000088882 00000 n +0000009313 00000 n +0000088950 00000 n +0000009447 00000 n +0000089018 00000 n +0000009581 00000 n +0000089086 00000 n +0000009714 00000 n +0000089154 00000 n +0000009848 00000 n +0000089222 00000 n +0000009982 00000 n +0000089290 00000 n +0000010116 00000 n +0000089358 00000 n +0000010250 00000 n +0000089426 00000 n +0000010384 00000 n +0000089494 00000 n +0000010520 00000 n +0000089563 00000 n +0000010656 00000 n +0000089632 00000 n +0000010792 00000 n +0000089701 00000 n +0000010928 00000 n +0000089770 00000 n +0000011064 00000 n +0000089839 00000 n +0000011200 00000 n +0000089908 00000 n +0000011336 00000 n +0000089977 00000 n +0000011472 00000 n +0000090046 00000 n +0000011608 00000 n +0000090115 00000 n +0000011744 00000 n +0000090184 00000 n +0000011880 00000 n +0000090253 00000 n +0000012016 00000 n +0000090322 00000 n +0000012150 00000 n +0000090391 00000 n +0000012284 00000 n +0000012772 00000 n +0000012898 00000 n +0000012951 00000 n +0000090460 00000 n +0000013089 00000 n +0000090529 00000 n +0000013227 00000 n +0000090598 00000 n +0000013365 00000 n +0000090667 00000 n +0000013503 00000 n +0000014186 00000 n +0000014296 00000 n +0000016420 00000 n +0000016530 00000 n +0000017619 00000 n +0000017729 00000 n +0000020274 00000 n +0000020384 00000 n +0000020779 00000 n +0000020889 00000 n +0000021450 00000 n +0000021560 00000 n +0000022473 00000 n +0000022583 00000 n +0000023923 00000 n +0000024033 00000 n +0000025087 00000 n +0000025197 00000 n +0000026036 00000 n +0000026146 00000 n +0000027352 00000 n +0000027462 00000 n +0000027848 00000 n +0000027958 00000 n +0000029818 00000 n +0000029928 00000 n +0000031064 00000 n +0000031174 00000 n +0000032120 00000 n +0000032230 00000 n +0000033141 00000 n +0000033251 00000 n +0000034014 00000 n +0000034124 00000 n +0000035361 00000 n +0000035471 00000 n +0000036452 00000 n +0000036562 00000 n +0000036960 00000 n +0000037070 00000 n +0000038119 00000 n +0000038229 00000 n +0000038919 00000 n +0000039029 00000 n +0000040389 00000 n +0000040499 00000 n +0000041409 00000 n +0000041519 00000 n +0000042223 00000 n +0000042333 00000 n +0000043487 00000 n +0000043597 00000 n +0000044763 00000 n +0000044873 00000 n +0000045978 00000 n +0000046088 00000 n +0000046872 00000 n +0000046982 00000 n +0000047731 00000 n +0000047841 00000 n +0000048372 00000 n +0000048482 00000 n +0000050183 00000 n +0000050293 00000 n +0000051885 00000 n +0000051995 00000 n +0000052564 00000 n +0000052674 00000 n +0000054966 00000 n +0000055076 00000 n +0000055332 00000 n +0000055442 00000 n +0000056246 00000 n +0000056356 00000 n +0000057164 00000 n +0000057274 00000 n +0000058020 00000 n +0000058130 00000 n +0000059272 00000 n +0000059382 00000 n +0000060465 00000 n +0000060575 00000 n +0000061335 00000 n +0000061445 00000 n +0000062425 00000 n +0000062535 00000 n +0000062831 00000 n +0000062941 00000 n +0000064472 00000 n +0000064582 00000 n +0000066453 00000 n +0000066563 00000 n +0000066913 00000 n +0000067023 00000 n +0000068445 00000 n +0000068555 00000 n +0000069715 00000 n +0000069841 00000 n +0000069918 00000 n +0000070088 00000 n +0000070261 00000 n +0000070455 00000 n +0000070649 00000 n +0000070842 00000 n +0000071062 00000 n +0000071282 00000 n +0000071668 00000 n +0000090736 00000 n +0000090790 00000 n +0000071778 00000 n +0000090858 00000 n +0000071982 00000 n +0000072183 00000 n +0000072325 00000 n +0000072603 00000 n +0000072730 00000 n +0000072890 00000 n +0000073139 00000 n +0000073302 00000 n +0000073435 00000 n +0000073580 00000 n +0000073887 00000 n +0000074186 00000 n +0000074325 00000 n +0000074479 00000 n +0000074594 00000 n +0000074930 00000 n +0000075210 00000 n +0000075355 00000 n +0000075636 00000 n +0000090926 00000 n +0000075850 00000 n +0000075984 00000 n +0000076116 00000 n +0000076347 00000 n +0000076503 00000 n +0000076697 00000 n +0000076846 00000 n +0000077077 00000 n +0000077209 00000 n +0000077368 00000 n +0000077550 00000 n +0000077744 00000 n +0000077944 00000 n +0000078109 00000 n +0000078247 00000 n +0000078432 00000 n +0000078653 00000 n +0000078865 00000 n +0000079077 00000 n +0000079294 00000 n +0000079483 00000 n +0000079660 00000 n +0000079884 00000 n +0000080096 00000 n +0000080296 00000 n +0000080478 00000 n +0000080706 00000 n +0000080907 00000 n +0000081081 00000 n +0000081266 00000 n +0000081470 00000 n +0000081677 00000 n +0000081849 00000 n +0000082021 00000 n +0000082281 00000 n +0000082529 00000 n +0000082751 00000 n +0000083017 00000 n +0000083174 00000 n +0000083393 00000 n +0000083597 00000 n +0000083883 00000 n +0000084046 00000 n +0000084174 00000 n +0000084308 00000 n +0000084422 00000 n +0000084533 00000 n +0000084649 00000 n +0000084758 00000 n +0000084870 00000 n +0000084991 00000 n +0000085098 00000 n +trailer +<< +/Size 323 +/Root 2 0 R +/Info 4 0 R +>> +startxref +90995 +%%EOF Added: branches/trunk-reorg/thirdparty/uffi/doc/uffi.xml ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/uffi.xml Mon Feb 11 09:06:27 2008 @@ -0,0 +1,24 @@ +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" + "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ +<!ENTITY % myents SYSTEM "entities.inc"> +<!ENTITY % xinclude SYSTEM "xinclude.mod"> +%myents; +%xinclude; +]> + + +<book lang="en"> + <xi:include href="bookinfo.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="preface.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="intro.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="notes.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="ref_declare.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="ref_primitive.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="ref_aggregate.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="ref_object.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="ref_string.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="ref_func_libr.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="appendix.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> + <xi:include href="glossary.xml" xmlns:xi="http://www.w3.org/2001/XInclude" /> +</book> Added: branches/trunk-reorg/thirdparty/uffi/doc/xinclude.mod ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/doc/xinclude.mod Mon Feb 11 09:06:27 2008 @@ -0,0 +1,24 @@ +<!ELEMENT xi:include (xi:fallback?) > +<!ATTLIST xi:include + xmlns:xi CDATA #FIXED "http://www.w3.org/2001/XInclude" + href CDATA #REQUIRED + parse (xml|text) "xml" + encoding CDATA #IMPLIED > + +<!ELEMENT xi:fallback ANY> +<!ATTLIST xi:fallback + xmlns:xi CDATA #FIXED "http://www.w3.org/2001/XInclude" > + +<!ENTITY % local.book.class "| xi:include"> + + +<!ENTITY % local.chapter.class "| xi:include"> + +<!ENTITY % local.divcomponent.mix "| xi:include"> + +<!ENTITY % local.para.char.mix "| xi:include"> + +<!ENTITY % local.info.class "| xi:include"> + + +<!ENTITY % local.common.attrib "xml:base CDATA #IMPLIED"> Added: branches/trunk-reorg/thirdparty/uffi/examples/Makefile ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/examples/Makefile Mon Feb 11 09:06:27 2008 @@ -0,0 +1,45 @@ +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for UFFI examples +# Programer: Kevin M. Rosenberg +# Date Started: Mar 2002 +# +# CVS Id: $Id$ +# +# This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +# + +SUBDIRS:= + +include ../Makefile.common + +.PHONY: distclean +distclean: clean + + +base=c-test-fns +source=$(base).c +object=$(base).o +shared_lib=$(base).so + +.PHONY: all +all: $(shared_lib) + +linux: $(source) Makefile + gcc -fPIC -DPIC -c $(source) -o $(object) + gcc -shared $(object) -o $(shared_lib) + rm $(object) + +mac: + cc -dynamic -c $(source) -o $(object) + ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress -o $(base).dylib $(object) + ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress /usr/lib/libz.dylib -o z.dylib + +solaris: + cc -KPIC -c $(source) -o $(object) + cc -G $(object) -o $(shared_lib) + +aix-acl: + gcc -c -D_BSD -D_NO_PROTO -D_NONSTD_TYPES -D_MBI=void $(source) + make_shared -o $(shared_lib) $(object) Added: branches/trunk-reorg/thirdparty/uffi/examples/Makefile.msvc ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/examples/Makefile.msvc Mon Feb 11 09:06:27 2008 @@ -0,0 +1,27 @@ +# FILE IDENTIFICATION +# +# Name: Makefile.msvc +# Purpose: Makefile for the CLSQL UFFI helper package (MSVC) +# Programer: Kevin M. Rosenberg +# Date Started: Mar 2002 +# +# CVS Id: $Id: Makefile.msvc,v 1.1 2002/03/23 10:26:03 kevin Exp $ +# +# This file, part of CLSQL, is Copyright (c) 2002-2005 by Kevin M. Rosenberg + +BASE=c-test-fns + +# Nothing to configure beyond here + +SRC=$(BASE).c +OBJ=$(BASE).obj +DLL=$(BASE).dll + +$(DLL): $(SRC) + cl /MD /LD -D_MT /DWIN32=1 $(SRC) + del $(OBJ) $(BASE).exp + +clean: + del /q $(DLL) + + Added: branches/trunk-reorg/thirdparty/uffi/examples/acl-compat-tester.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/examples/acl-compat-tester.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,600 @@ +;; tester.cl +;; A test harness for Allegro CL. +;; +;; copyright (c) 1985-1986 Franz Inc, Alameda, CA +;; copyright (c) 1986-2001 Franz Inc, Berkeley, CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the Franz +;; preamble to the LGPL found in +;; http://opensource.franz.com/preamble.html. +;; +;; This code 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 +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License can be +;; found at http://opensource.franz.com/license.html. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple +;; Place, Suite 330, Boston, MA 02111-1307 USA +;; +;;;; from the original ACL 6.1 sources: +;; $Id$ + + +(defpackage :util.test + (:use :common-lisp) + (:shadow #:test) + (:export +;;;; Control variables: + #:*break-on-test-failures* + #:*error-protect-tests* + #:*test-errors* + #:*test-successes* + #:*test-unexpected-failures* + +;;;; The test macros: + #:test + #:test-error + #:test-no-error + #:test-warning + #:test-no-warning + + #:with-tests + )) + +(in-package :util.test) + +#+cmu +(unless (find-class 'break nil) + (define-condition break (simple-condition) ())) + +(define-condition simple-break (error simple-condition) ()) + +;; the if* macro used in Allegro: +;; +;; This is in the public domain... please feel free to put this definition +;; in your code or distribute it with your version of lisp. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar if*-keyword-list '("then" "thenret" "else" "elseif"))) + +(defmacro if* (&rest args) + (do ((xx (reverse args) (cdr xx)) + (state :init) + (elseseen nil) + (totalcol nil) + (lookat nil nil) + (col nil)) + ((null xx) + (cond ((eq state :compl) + `(cond ,@totalcol)) + (t (error "if*: illegal form ~s" args)))) + (cond ((and (symbolp (car xx)) + (member (symbol-name (car xx)) + if*-keyword-list + :test #'string-equal)) + (setq lookat (symbol-name (car xx))))) + + (cond ((eq state :init) + (cond (lookat (cond ((string-equal lookat "thenret") + (setq col nil + state :then)) + (t (error + "if*: bad keyword ~a" lookat)))) + (t (setq state :col + col nil) + (push (car xx) col)))) + ((eq state :col) + (cond (lookat + (cond ((string-equal lookat "else") + (cond (elseseen + (error + "if*: multiples elses"))) + (setq elseseen t) + (setq state :init) + (push `(t ,@col) totalcol)) + ((string-equal lookat "then") + (setq state :then)) + (t (error "if*: bad keyword ~s" + lookat)))) + (t (push (car xx) col)))) + ((eq state :then) + (cond (lookat + (error + "if*: keyword ~s at the wrong place " (car xx))) + (t (setq state :compl) + (push `(,(car xx) ,@col) totalcol)))) + ((eq state :compl) + (cond ((not (string-equal lookat "elseif")) + (error "if*: missing elseif clause "))) + (setq state :init))))) + + + + +(defvar *break-on-test-failures* nil + "When a test failure occurs, common-lisp:break is called, allowing +interactive debugging of the failure.") + +(defvar *test-errors* 0 + "The value is the number of test errors which have occurred.") +(defvar *test-successes* 0 + "The value is the number of test successes which have occurred.") +(defvar *test-unexpected-failures* 0 + "The value is the number of unexpected test failures which have occurred.") + +(defvar *error-protect-tests* nil + "Protect each test from errors. If an error occurs, then that will be +taken as a test failure unless test-error is being used.") + +(defmacro test-values-errorset (form &optional announce catch-breaks) + ;; internal macro + (let ((g-announce (gensym)) + (g-catch-breaks (gensym))) + `(let* ((,g-announce ,announce) + (,g-catch-breaks ,catch-breaks)) + (handler-case (cons t (multiple-value-list ,form)) + (condition (condition) + (if* (and (null ,g-catch-breaks) + (typep condition 'simple-break)) + then (break condition) + elseif ,g-announce + then (format *error-output* "~&Condition type: ~a~%" + (class-of condition)) + (format *error-output* "~&Message: ~a~%" condition)) + condition))))) + +(defmacro test-values (form &optional announce catch-breaks) + ;; internal macro + (if* *error-protect-tests* + then `(test-values-errorset ,form ,announce ,catch-breaks) + else `(cons t (multiple-value-list ,form)))) + +(defmacro test (expected-value test-form + &key (test #'eql test-given) + (multiple-values nil multiple-values-given) + (fail-info nil fail-info-given) + (known-failure nil known-failure-given) + +;;;;;;;;;; internal, undocumented keywords: +;;;; Note about these keywords: if they were documented, we'd have a +;;;; problem, since they break the left-to-right order of evaluation. +;;;; Specifically, errorset breaks it, and I don't see any way around +;;;; that. `errorset' is used by the old test.cl module (eg, +;;;; test-equal-errorset). + errorset + reported-form + (wanted-message nil wanted-message-given) + (got-message nil got-message-given)) + "Perform a single test. `expected-value' is the reference value for the +test. `test-form' is a form that will produce the value to be compared to +the expected-value. If the values are not the same, then an error is +logged, otherwise a success is logged. + +Normally the comparison of values is done with `eql'. The `test' keyword +argument can be used to specify other comparison functions, such as eq, +equal,equalp, string=, string-equal, etc. + +Normally, only the first return value from the test-form is considered, +however if `multiple-values' is t, then all values returned from test-form +are considered. + +`fail-info' allows more information to be printed with a test failure. + +`known-failure' marks the test as a known failure. This allows for +programs that do regression analysis on the output from a test run to +discriminate on new versus known failures." + `(test-check + :expected-result ,expected-value + :test-results + (,(if errorset 'test-values-errorset 'test-values) ,test-form t) + ,@(when test-given `(:predicate ,test)) + ,@(when multiple-values-given `(:multiple-values ,multiple-values)) + ,@(when fail-info-given `(:fail-info ,fail-info)) + ,@(when known-failure-given `(:known-failure ,known-failure)) + :test-form ',(if reported-form reported-form test-form) + ,@(when wanted-message-given `(:wanted-message ,wanted-message)) + ,@(when got-message-given `(:got-message ,got-message)))) + +(defmethod conditionp ((thing condition)) t) +(defmethod conditionp ((thing t)) nil) + +(defmacro test-error (form &key announce + catch-breaks + (fail-info nil fail-info-given) + (known-failure nil known-failure-given) + (condition-type ''simple-error) + (include-subtypes nil include-subtypes-given) + (format-control nil format-control-given) + (format-arguments nil format-arguments-given)) + "Test that `form' signals an error. The order of evaluation of the +arguments is keywords first, then test form. + +If `announce' is non-nil, then cause the error message to be printed. + +The `catch-breaks' is non-nil then consider a call to common-lisp:break an +`error'. + +`fail-info' allows more information to be printed with a test failure. + +`known-failure' marks the test as a known failure. This allows for +programs that do regression analysis on the output from a test run to +discriminate on new versus known failures. + +If `condition-type' is non-nil, it should be a symbol naming a condition +type, which is used to check against the signalled condition type. The +test will fail if they do not match. + +`include-subtypes', used with `condition-type', can be used to match a +condition to an entire subclass of the condition type hierarchy. + +`format-control' and `format-arguments' can be used to check the error +message itself." + (let ((g-announce (gensym)) + (g-catch-breaks (gensym)) + (g-fail-info (gensym)) + (g-known-failure (gensym)) + (g-condition-type (gensym)) + (g-include-subtypes (gensym)) + (g-format-control (gensym)) + (g-format-arguments (gensym)) + (g-c (gensym))) + `(let* ((,g-announce ,announce) + (,g-catch-breaks ,catch-breaks) + ,@(when fail-info-given `((,g-fail-info ,fail-info))) + ,@(when known-failure-given `((,g-known-failure ,known-failure))) + (,g-condition-type ,condition-type) + ,@(when include-subtypes-given + `((,g-include-subtypes ,include-subtypes))) + ,@(when format-control-given + `((,g-format-control ,format-control))) + ,@(when format-arguments-given + `((,g-format-arguments ,format-arguments))) + (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks))) + (test-check + :predicate #'eq + :expected-result t + :test-results + (test-values (and (conditionp ,g-c) + ,@(if* include-subtypes-given + then `((if* ,g-include-subtypes + then (typep ,g-c ,g-condition-type) + else (eq (class-of ,g-c) + (find-class + ,g-condition-type)))) + else `((eq (class-of ,g-c) + (find-class ,g-condition-type)))) + ,@(when format-control-given + `((or + (null ,g-format-control) + (string= + (concatenate 'simple-string + "~1@<" ,g-format-control "~:@>") + (simple-condition-format-control ,g-c))))) + ,@(when format-arguments-given + `((or + (null ,g-format-arguments) + (equal + ,g-format-arguments + (simple-condition-format-arguments ,g-c)))))) + t) + :test-form ',form + ,@(when fail-info-given `(:fail-info ,g-fail-info)) + ,@(when known-failure-given `(:known-failure ,g-known-failure)) + :condition-type ,g-condition-type + :condition ,g-c + ,@(when include-subtypes-given + `(:include-subtypes ,g-include-subtypes)) + ,@(when format-control-given + `(:format-control ,g-format-control)) + ,@(when format-arguments-given + `(:format-arguments ,g-format-arguments)))))) + +(defmacro test-no-error (form &key announce + catch-breaks + (fail-info nil fail-info-given) + (known-failure nil known-failure-given)) + "Test that `form' does not signal an error. The order of evaluation of +the arguments is keywords first, then test form. + +If `announce' is non-nil, then cause the error message to be printed. + +The `catch-breaks' is non-nil then consider a call to common-lisp:break an +`error'. + +`fail-info' allows more information to be printed with a test failure. + +`known-failure' marks the test as a known failure. This allows for +programs that do regression analysis on the output from a test run to +discriminate on new versus known failures." + (let ((g-announce (gensym)) + (g-catch-breaks (gensym)) + (g-fail-info (gensym)) + (g-known-failure (gensym)) + (g-c (gensym))) + `(let* ((,g-announce ,announce) + (,g-catch-breaks ,catch-breaks) + ,@(when fail-info-given `((,g-fail-info ,fail-info))) + ,@(when known-failure-given `((,g-known-failure ,known-failure))) + (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks))) + (test-check + :predicate #'eq + :expected-result t + :test-results (test-values (not (conditionp ,g-c))) + :test-form ',form + :condition ,g-c + ,@(when fail-info-given `(:fail-info ,g-fail-info)) + ,@(when known-failure-given `(:known-failure ,g-known-failure)))))) + +(defvar *warn-cookie* (cons nil nil)) + +(defmacro test-warning (form &key fail-info known-failure) + "Test that `form' signals a warning. The order of evaluation of +the arguments is keywords first, then test form. + +`fail-info' allows more information to be printed with a test failure. + +`known-failure' marks the test as a known failure. This allows for +programs that do regression analysis on the output from a test run to +discriminate on new versus known failures." + (let ((g-fail-info (gensym)) + (g-known-failure (gensym)) + (g-value (gensym))) + `(let* ((,g-fail-info ,fail-info) + (,g-known-failure ,known-failure) + (,g-value (test-values-errorset ,form nil t))) + (test + *warn-cookie* + (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning)) + then *warn-cookie* + else ;; test produced no warning + nil) + :test #'eq + :reported-form ,form ;; quoted by test macro + :wanted-message "a warning" + :got-message "no warning" + :fail-info ,g-fail-info + :known-failure ,g-known-failure)))) + +(defmacro test-no-warning (form &key fail-info known-failure) + "Test that `form' does not signal a warning. The order of evaluation of +the arguments is keywords first, then test form. + +`fail-info' allows more information to be printed with a test failure. + +`known-failure' marks the test as a known failure. This allows for +programs that do regression analysis on the output from a test run to +discriminate on new versus known failures." + (let ((g-fail-info (gensym)) + (g-known-failure (gensym)) + (g-value (gensym))) + `(let* ((,g-fail-info ,fail-info) + (,g-known-failure ,known-failure) + (,g-value (test-values-errorset ,form nil t))) + (test + *warn-cookie* + (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning)) + then nil ;; test produced warning + else *warn-cookie*) + :test #'eq + :reported-form ',form + :wanted-message "no warning" + :got-message "a warning" + :fail-info ,g-fail-info + :known-failure ,g-known-failure)))) + +(defvar *announce-test* nil) ;; if true announce each test that was done + +(defmacro errorset (form &optional announce catch-breaks) + ;; Evaluate FORM, and if there are no errors and FORM returns + ;; values v1,v2,...,vn, then return values t,v1,v2,...,vn. If an + ;; error occurs while evaluating FORM, then return nil immediately. + ;; If ANNOUNCE is t, then the error message will be printed out. + (if catch-breaks + `(handler-case (values-list (cons t (multiple-value-list ,form))) + (error (condition) + (declare (ignorable condition)) + ,@(if announce `((format *error-output* "~&Error: ~a~%" condition))) + nil) + (simple-break (condition) + (declare (ignorable condition)) + ,@(if announce `((format *error-output* "~&Warning: ~a~%" condition)) +) + nil)) + `(handler-case (values-list (cons t (multiple-value-list ,form))) + (error (condition) + (declare (ignorable condition)) + ,@(if announce `((format *error-output* "~&Error: ~a~%" condition))) + nil)))) + +(defun test-check (&key (predicate #'eql) + expected-result test-results test-form + multiple-values fail-info known-failure + wanted-message got-message condition-type condition + include-subtypes format-control format-arguments + &aux fail predicate-failed got wanted) + ;; for debugging large/complex test sets: + (when *announce-test* + (format t "Just did test ~s~%" test-form) + (force-output)) + + ;; this is an internal function + (flet ((check (expected-result result) + (let* ((results + (multiple-value-list + (errorset (funcall predicate expected-result result) t))) + (failed (null (car results)))) + (if* failed + then (setq predicate-failed t) + nil + else (cadr results))))) + (when (conditionp test-results) + (setq condition test-results) + (setq test-results nil)) + (when (null (car test-results)) + (setq fail t)) + (if* (and (not fail) (not multiple-values)) + then ;; should be a single result + ;; expected-result is the single result wanted + (when (not (and (cdr test-results) + (check expected-result (cadr test-results)))) + (setq fail t)) + (when (and (not fail) (cddr test-results)) + (setq fail 'single-got-multiple)) + else ;; multiple results wanted + ;; expected-result is a list of results, each of which + ;; should be checked against the corresponding test-results + ;; using the predicate + (do ((got (cdr test-results) (cdr got)) + (want expected-result (cdr want))) + ((or (null got) (null want)) + (when (not (and (null want) (null got))) + (setq fail t))) + (when (not (check (car got) (car want))) + (return (setq fail t))))) + (if* fail + then (when (not known-failure) + (format *error-output* + "~& * * * UNEXPECTED TEST FAILURE * * *~%") + (incf *test-unexpected-failures*)) + (format *error-output* "~&Test failed: ~@[known failure: ~*~]~s~%" + known-failure test-form) + (if* (eq 'single-got-multiple fail) + then (format + *error-output* + "~ +Reason: additional value were returned from test form.~%") + elseif predicate-failed + then (format *error-output* "Reason: predicate error.~%") + elseif (null (car test-results)) + then (format *error-output* "~ +Reason: an error~@[ (of type `~s')~] was detected.~%" + (when condition (class-of condition))) + elseif condition + then (if* (not (conditionp condition)) + then (format *error-output* "~ +Reason: expected but did not detect an error of type `~s'.~%" + condition-type) + elseif (null condition-type) + then (format *error-output* "~ +Reason: detected an unexpected error of type `~s': + ~a.~%" + (class-of condition) + condition) + elseif (not (if* include-subtypes + then (typep condition condition-type) + else (eq (class-of condition) + (find-class condition-type)))) + then (format *error-output* "~ +Reason: detected an incorrect condition type.~%") + (format *error-output* + " wanted: ~s~%" condition-type) + (format *error-output* + " got: ~s~%" (class-of condition)) + elseif (and format-control + (not (string= + (setq got + (concatenate 'simple-string + "~1@<" format-control "~:@>")) + (setq wanted + (simple-condition-format-control + condition))))) + then ;; format control doesn't match + (format *error-output* "~ +Reason: the format-control was incorrect.~%") + (format *error-output* " wanted: ~s~%" wanted) + (format *error-output* " got: ~s~%" got) + elseif (and format-arguments + (not (equal + (setq got format-arguments) + (setq wanted + (simple-condition-format-arguments + condition))))) + then (format *error-output* "~ +Reason: the format-arguments were incorrect.~%") + (format *error-output* " wanted: ~s~%" wanted) + (format *error-output* " got: ~s~%" got) + else ;; what else???? + (error "internal-error")) + else (let ((*print-length* 50) + (*print-level* 10)) + (if* wanted-message + then (format *error-output* + " wanted: ~a~%" wanted-message) + else (if* (not multiple-values) + then (format *error-output* + " wanted: ~s~%" + expected-result) + else (format + *error-output* + " wanted values: ~{~s~^, ~}~%" + expected-result))) + (if* got-message + then (format *error-output* + " got: ~a~%" got-message) + else (if* (not multiple-values) + then (format *error-output* " got: ~s~%" + (second test-results)) + else (format + *error-output* + " got values: ~{~s~^, ~}~%" + (cdr test-results)))))) + (when fail-info + (format *error-output* "Additional info: ~a~%" fail-info)) + (incf *test-errors*) + (when *break-on-test-failures* + (break "~a is non-nil." '*break-on-test-failures*)) + else (when known-failure + (format *error-output* + "~&Expected test failure for ~s did not occur.~%" + test-form) + (when fail-info + (format *error-output* "Additional info: ~a~%" fail-info)) + (setq fail t)) + (incf *test-successes*)) + (not fail))) + +(defmacro with-tests ((&key (name "unnamed")) &body body) + (let ((g-name (gensym))) + `(flet ((doit () ,@body)) + (let ((,g-name ,name) + (*test-errors* 0) + (*test-successes* 0) + (*test-unexpected-failures* 0)) + (format *error-output* "Begin ~a test~%" ,g-name) + (if* *break-on-test-failures* + then (doit) + else (handler-case (doit) + (error (c) + (format + *error-output* + "~ +~&Test ~a aborted by signalling an uncaught error:~%~a~%" + ,g-name c)))) + #+allegro + (let ((state (sys:gsgc-switch :print))) + (setf (sys:gsgc-switch :print) nil) + (format t "~&**********************************~%" ,g-name) + (format t "End ~a test~%" ,g-name) + (format t "Errors detected in this test: ~s " *test-errors*) + (unless (zerop *test-unexpected-failures*) + (format t "UNEXPECTED: ~s" *test-unexpected-failures*)) + (format t "~%Successes this test:~s~%" *test-successes*) + (setf (sys:gsgc-switch :print) state)) + #-allegro + (progn + (format t "~&**********************************~%" ,g-name) + (format t "End ~a test~%" ,g-name) + (format t "Errors detected in this test: ~s " *test-errors*) + (unless (zerop *test-unexpected-failures*) + (format t "UNEXPECTED: ~s" *test-unexpected-failures*)) + (format t "~%Successes this test:~s~%" *test-successes*)) + )))) + +(provide :tester #+module-versions 1.1) Added: branches/trunk-reorg/thirdparty/uffi/examples/arrays.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/examples/arrays.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,63 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: arrays.cl +;;;; Purpose: UFFI Example file to test arrays +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package :cl-user) + +(uffi:def-constant +column-length+ 10) +(uffi:def-constant +row-length+ 10) + +(uffi:def-foreign-type long-ptr (* :long)) + +(defun test-array-1d () + "Tests vector" + (let ((a (uffi:allocate-foreign-object :long +column-length+))) + (dotimes (i +column-length+) + (setf (uffi:deref-array a '(:array :long) i) (* i i))) + (dotimes (i +column-length+) + (format t "~&~D => ~D" i (uffi:deref-array a '(:array :long) i))) + (uffi:free-foreign-object a)) + (values)) + +(defun test-array-2d () + "Tests 2d array" + (let ((a (uffi:allocate-foreign-object 'long-ptr +row-length+))) + (dotimes (r +row-length+) + (declare (fixnum r)) + (setf (uffi:deref-array a '(:array (* :long)) r) + (uffi:allocate-foreign-object :long +column-length+)) + (let ((col (uffi:deref-array a '(:array (* :long)) r))) + (dotimes (c +column-length+) + (declare (fixnum c)) + (setf (uffi:deref-array col '(:array :long) c) (+ (* r +column-length+) c))))) + + (dotimes (r +row-length+) + (declare (fixnum r)) + (format t "~&Row ~D: " r) + (let ((col (uffi:deref-array a '(:array (* :long)) r))) + (dotimes (c +column-length+) + (declare (fixnum c)) + (let ((result (uffi:deref-array col '(:array :long) c))) + (format t "~d " result))))) + + (uffi:free-foreign-object a)) + (values)) + +#+examples-uffi +(test-array-1d) + +#+examples-uffi +(test-array-2d) + + Added: branches/trunk-reorg/thirdparty/uffi/examples/atoifl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/examples/atoifl.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,56 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: atoifl.cl +;;;; Purpose: UFFI Example file to atoi/atof/atol +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package :cl-user) + +(uffi:def-function ("atoi" c-atoi) + ((str :cstring)) + :returning :int) + +(uffi:def-function ("atol" c-atol) + ((str :cstring)) + :returning :long) + +(uffi:def-function ("atof" c-atof) + ((str :cstring)) + :returning :double) + +(defun atoi (str) + "Returns a int from a string." + (uffi:with-cstring (str-cstring str) + (c-atoi str-cstring))) + +(defun atof (str) + "Returns a double float from a string." + (uffi:with-cstring (str-cstring str) + (c-atof str-cstring))) + +#+examples-uffi +(progn + (flet ((print-results (str) + (format t "~&(atoi ~S) => ~S" str (atoi str)))) + (print-results "55"))) + + +#+test-uffi +(progn + (util.test:test (atoi "123") 123 :test #'eql + :fail-info "Error with atoi") + (util.test:test (atoi "") 0 :test #'eql + :fail-info "Error with atoi") + (util.test:test (atof "2.23") 2.23d0 :test #'eql + :fail-info "Error with atof") + ) + Added: branches/trunk-reorg/thirdparty/uffi/examples/c-test-fns.c ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/examples/c-test-fns.c Mon Feb 11 09:06:27 2008 @@ -0,0 +1,91 @@ +/*************************************************************************** + * FILE IDENTIFICATION + * + * Name: c-test-fns.c + * Purpose: Test functions in C for UFFI library + * Programer: Kevin M. Rosenberg + * Date Started: Mar 2002 + * + * CVS Id: $Id$ + * + * This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg + * + * These variables are correct for GCC + * you'll need to modify these for other compilers + ***************************************************************************/ + +#ifdef WIN32 +#include <windows.h> + +BOOL WINAPI DllEntryPoint(HINSTANCE hinstdll, + DWORD fdwReason, + LPVOID lpvReserved) +{ + return 1; +} + +#define DLLEXPORT __declspec(dllexport) + +#else +#define DLLEXPORT +#endif + +#include <ctype.h> +#include <stdlib.h> +#include <math.h> + + +/* Test of constant input string */ +DLLEXPORT +int +cs_count_upper (char* psz) +{ + int count = 0; + + if (psz) { + while (*psz) { + if (isupper (*psz)) + ++count; + ++psz; + } + return count; + } else + return -1; +} + +/* Test of input and output of a string */ +DLLEXPORT +void +cs_to_upper (char* psz) +{ + if (psz) { + while (*psz) { + *psz = toupper (*psz); + ++psz; + } + } +} + +/* Test of an output only string */ +DLLEXPORT +void +cs_make_random (int size, char* buffer) +{ + int i; + for (i = 0; i < size; i++) + buffer[i] = 'A' + (rand() % 26); +} + + +/* Test of input/output vector */ +DLLEXPORT +void +half_double_vector (int size, double* vec) +{ + int i; + for (i = 0; i < size; i++) + vec[i] /= 2.; +} + + + Added: branches/trunk-reorg/thirdparty/uffi/examples/c-test-fns.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/examples/c-test-fns.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,118 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: c-test-fns.cl +;;;; Purpose: UFFI Example file for zlib compression +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package :cl-user) + +(unless (uffi:load-foreign-library + (uffi:find-foreign-library "c-test-fns" + (list *load-truename* "/home/kevin/debian/src/uffi/examples/")) + :supporting-libraries '("c")) + (warn "Unable to load c-test-fns library")) + +(uffi:def-function ("cs_to_upper" cs-to-upper) + ((input (* :unsigned-char))) + :returning :void + ) + +(defun string-to-upper (str) + (uffi:with-foreign-string (str-foreign str) + (cs-to-upper str-foreign) + (uffi:convert-from-foreign-string str-foreign))) + +(uffi:def-function ("cs_count_upper" cs-count-upper) + ((input :cstring)) + :returning :int + ) + +(defun string-count-upper (str) + (uffi:with-cstring (str-cstring str) + (cs-count-upper str-cstring))) + +(uffi:def-function ("half_double_vector" half-double-vector) + ((size :int) + (vec (* :double))) + :returning :void) + +(uffi:def-constant +double-vec-length+ 10) +(defun test-half-double-vector () + (let ((vec (uffi:allocate-foreign-object :double +double-vec-length+)) + results) + (dotimes (i +double-vec-length+) + (setf (uffi:deref-array vec '(:array :double) i) + (coerce i 'double-float))) + (half-double-vector +double-vec-length+ vec) + (dotimes (i +double-vec-length+) + (push (uffi:deref-array vec '(:array :double) i) results)) + (uffi:free-foreign-object vec) + (nreverse results))) + +(defun t2 () + (let ((vec (make-array +double-vec-length+ :element-type 'double-float))) + (dotimes (i +double-vec-length+) + (setf (aref vec i) (coerce i 'double-float))) + (half-double-vector +double-vec-length+ vec) + vec)) + +#+(or cmu scl) +(defun t3 () + (let ((vec (make-array +double-vec-length+ :element-type 'double-float))) + (dotimes (i +double-vec-length+) + (setf (aref vec i) (coerce i 'double-float))) + (system:without-gcing + (half-double-vector +double-vec-length+ (system:vector-sap vec))) + vec)) + +#+examples-uffi +(format t "~&(string-to-upper \"this is a test\") => ~A" + (string-to-upper "this is a test")) + +#+examples-uffi +(format t "~&(string-to-upper nil) => ~A" + (string-to-upper nil)) + +#+examples-uffi +(format t "~&(string-count-upper \"This is a Test\") => ~A" + (string-count-upper "This is a Test")) + +#+examples-uffi +(format t "~&(string-count-upper nil) => ~A" + (string-count-upper nil)) + +#+examples-uffi +(format t "~&Half vector: ~S" (test-half-double-vector)) + + + +#+test-uffi +(progn + (util.test:test (string= (string-to-upper "this is a test") "THIS IS A TEST") + t + :test #'eql + :fail-info "Error with string-to-upper") + (util.test:test (string-to-upper nil) nil + :fail-info "string-to-upper with nil failed") + (util.test:test (string-count-upper "This is a Test") + 2 + :test #'eql + :fail-info "Error with string-count-upper") + (util.test:test (string-count-upper nil) -1 + :test #'eql + :fail-info "string-count-upper with nil failed") + + (util.test:test (test-half-double-vector) + '(0.0d0 0.5d0 1.0d0 1.5d0 2.0d0 2.5d0 3.0d0 3.5d0 4.0d0 4.5d0) + :test #'equal + :fail-info "Error comparing half-double-vector") + ) Added: branches/trunk-reorg/thirdparty/uffi/examples/compress.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/examples/compress.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,116 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: compress.cl +;;;; Purpose: UFFI Example file for zlib compression +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package :cl-user) + +(eval-when (:load-toplevel :execute) + (unless (uffi:load-foreign-library + #-(or macosx darwin) + (uffi:find-foreign-library + "libz" + '("/usr/local/lib/" "/usr/lib/" "/zlib/") + :types '("so" "a")) + #+(or macosx darwin) + (uffi:find-foreign-library "z" + `(,(pathname-directory *load-pathname*))) + :module "zlib" + :supporting-libraries '("c")) + (warn "Unable to load zlib"))) + +(uffi:def-function ("compress" c-compress) + ((dest (* :unsigned-char)) + (destlen (* :long)) + (source :cstring) + (source-len :long)) + :returning :int + :module "zlib") + +(defun compress (source) + "Returns two values: array of bytes containing the compressed data + and the numbe of compressed bytes" + (let* ((sourcelen (length source)) + (destsize (+ 12 (ceiling (* sourcelen 1.01)))) + (dest (uffi:allocate-foreign-string destsize :unsigned t)) + (destlen (uffi:allocate-foreign-object :long))) + (setf (uffi:deref-pointer destlen :long) destsize) + (uffi:with-cstring (source-native source) + (let ((result (c-compress dest destlen source-native sourcelen)) + (newdestlen (uffi:deref-pointer destlen :long))) + (unwind-protect + (if (zerop result) + (values (uffi:convert-from-foreign-string + dest + :length newdestlen + :null-terminated-p nil) + newdestlen) + (error "zlib error, code ~D" result)) + (progn + (uffi:free-foreign-object destlen) + (uffi:free-foreign-object dest))))))) + +(uffi:def-function ("uncompress" c-uncompress) + ((dest (* :unsigned-char)) + (destlen (* :long)) + (source :cstring) + (source-len :long)) + :returning :int + :module "zlib") + +(defun uncompress (source) + (let* ((sourcelen (length source)) + (destsize 200000) ;adjust as needed + (dest (uffi:allocate-foreign-string destsize :unsigned t)) + (destlen (uffi:allocate-foreign-object :long))) + (setf (uffi:deref-pointer destlen :long) destsize) + (uffi:with-cstring (source-native source) + (let ((result (c-uncompress dest destlen source-native sourcelen)) + (newdestlen (uffi:deref-pointer destlen :long))) + (unwind-protect + (if (zerop result) + (uffi:convert-from-foreign-string + dest + :length newdestlen + :null-terminated-p nil) + (error "zlib error, code ~D" result)) + (progn + (uffi:free-foreign-object destlen) + (uffi:free-foreign-object dest))))))) + +#+examples-uffi +(progn + (flet ((print-results (str) + (multiple-value-bind (compressed len) (compress str) + (let ((*print-length* nil)) + (format t "~&(compress ~S) => " str) + (format t "~S~%" (map 'list #'char-code compressed)))))) + (print-results "") + (print-results "test") + (print-results "test2"))) + +#+test-uffi +(progn + (flet ((test-compress (str) + (multiple-value-bind (compressed len) (compress str) + (multiple-value-bind (uncompressed len2) (uncompress compressed) + (util.test:test str uncompressed :test #'string= + :fail-info "Error uncompressing a compressed string"))))) + (test-compress "") + (test-compress "test") + (test-compress "test2"))) + +;; Results of the above on my system: +;; (compress "") => 789c300001,8 +;; (compress "test") => 789c2b492d2e1045d1c1,12 +;; (compress "test2") => 789c2b492d2e31206501f3,13 Added: branches/trunk-reorg/thirdparty/uffi/examples/file-socket.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/examples/file-socket.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,39 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: file-socket.cl +;;;; Purpose: UFFI Example file to get a socket on a file +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Jul 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package :cl-user) + +;; Values for linux +(uffi:def-constant PF_UNIX 1) +(uffi:def-constant SOCK_STREAM 1) + +(uffi:def-function ("socket" c-socket) + ((family :int) + (type :int) + (protocol :int)) + :returning :int) + +(uffi:def-function ("connect" c-connect) + ((sockfd :int) + (serv-addr :void-pointer) + (addr-len :int)) + :returning :int) + +(defun connect-to-file-socket (filename) + (let ((socket (c-socket PF_UNIX SOCK_STREAM 0))) + (if (plusp socket) + (let ((stream (c-connect socket filename (length filename)))) + stream) + (error "Unable to create socket")))) Added: branches/trunk-reorg/thirdparty/uffi/examples/getenv.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/examples/getenv.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,44 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: getenv.cl +;;;; Purpose: UFFI Example file to get environment variable +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package :cl-user) + + +(uffi:def-function ("getenv" c-getenv) + ((name :cstring)) + :returning :cstring) + +(defun my-getenv (key) + "Returns an environment variable, or NIL if it does not exist" + (check-type key string) + (uffi:with-cstring (key-native key) + (uffi:convert-from-cstring (c-getenv key-native)))) + +#+examples-uffi +(progn + (flet ((print-results (str) + (format t "~&(getenv ~S) => ~S" str (my-getenv str)))) + (print-results "USER") + (print-results "_FOO_"))) + + +#+test-uffi +(progn + (util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv") + (util.test:test (and (stringp (my-getenv "USER")) + (< 0 (length (my-getenv "USER")))) + t :fail-info "Error retrieving getenv") +) + Added: branches/trunk-reorg/thirdparty/uffi/examples/gethostname.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/examples/gethostname.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,63 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: gethostname.cl +;;;; Purpose: UFFI Example file to get hostname of system +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package :cl-user) + + +;;; This example is inspired by the example on the CL-Cookbook web site + +(uffi:def-function ("gethostname" c-gethostname) + ((name (* :unsigned-char)) + (len :int)) + :returning :int) + +(defun gethostname () + "Returns the hostname" + (let* ((name (uffi:allocate-foreign-string 256)) + (result-code (c-gethostname name 256)) + (hostname (when (zerop result-code) + (uffi:convert-from-foreign-string name)))) + (uffi:free-foreign-object name) + (unless (zerop result-code) + (error "gethostname() failed.")) + hostname)) + +(defun gethostname2 () + "Returns the hostname" + (uffi:with-foreign-object (name '(:array :unsigned-char 256)) + (if (zerop (c-gethostname (uffi:char-array-to-pointer name) 256)) + (uffi:convert-from-foreign-string name) + (error "gethostname() failed.")))) + +#+examples-uffi +(progn + (format t "~&Hostname (technique 1): ~A" (gethostname)) + (format t "~&Hostname (technique 2): ~A" (gethostname2))) + +#+test-uffi +(progn + (let ((hostname1 (gethostname)) + (hostname2 (gethostname2))) + + (util.test:test (and (stringp hostname1) (stringp hostname2)) t + :fail-info "gethostname not string") + (util.test:test (and (not (zerop (length hostname1))) + (not (zerop (length hostname2)))) t + :fail-info "gethostname length 0") + (util.test:test (string= hostname1 hostname1) t + :fail-info "gethostname techniques don't match")) + ) + + Added: branches/trunk-reorg/thirdparty/uffi/examples/getshells.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/examples/getshells.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,44 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: getshells.cl +;;;; Purpose: UFFI Example file to get lisp of legal shells +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package :cl-user) + + +(uffi:def-function "setusershell" + nil + :returning :void) + +(uffi:def-function "endusershell" + nil + :returning :void) + +(uffi:def-function "getusershell" + nil + :returning :cstring) + +(defun getshells () + "Returns list of valid shells" + (setusershell) + (let (shells) + (do ((shell (uffi:convert-from-cstring (getusershell)) + (uffi:convert-from-cstring (getusershell)))) + ((null shell)) + (push shell shells)) + (endusershell) + (nreverse shells))) + +#+examples-uffi +(format t "~&Shells: ~S" (getshells)) + Added: branches/trunk-reorg/thirdparty/uffi/examples/gettime.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/examples/gettime.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,73 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: gettime +;;;; Purpose: UFFI Example file to get time, use C structures +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package :cl-user) + +(uffi:def-foreign-type time-t :unsigned-long) + +(uffi:def-struct tm + (sec :int) + (min :int) + (hour :int) + (mday :int) + (mon :int) + (year :int) + (wday :int) + (yday :int) + (isdst :int)) + +(uffi:def-function ("time" c-time) + ((time (* time-t))) + :returning time-t) + +(uffi:def-function ("localtime" c-localtime) + ((time (* time-t))) + :returning (* tm)) + +(uffi:def-type time-t :unsigned-long) +(uffi:def-type tm-pointer (* tm)) + +(defun gettime () + "Returns the local time" + (uffi:with-foreign-object (time 'time-t) +;; (declare (type time-t time)) + (c-time time) + (let ((tm-ptr (the tm-pointer (c-localtime time)))) + (declare (type tm-pointer tm-ptr)) + (let ((time-string (format nil "~2d/~2,'0d/~d ~2d:~2,'0d:~2,'0d" + (1+ (uffi:get-slot-value tm-ptr 'tm 'mon)) + (uffi:get-slot-value tm-ptr 'tm 'mday) + (+ 1900 (uffi:get-slot-value tm-ptr 'tm 'year)) + (uffi:get-slot-value tm-ptr 'tm 'hour) + (uffi:get-slot-value tm-ptr 'tm 'min) + (uffi:get-slot-value tm-ptr 'tm 'sec) + ))) + time-string)))) + + + + +#+examples-uffi +(format t "~&~A" (gettime)) + +#+test-uffi +(progn + (let ((time (gettime))) + (util.test:test (stringp time) t :fail-info "Time is not a string") + (util.test:test (plusp (parse-integer time :junk-allowed t)) + t + :fail-info "time string does not start with a number"))) + + Added: branches/trunk-reorg/thirdparty/uffi/examples/run-examples.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/examples/run-examples.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,36 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: run-examples.cl +;;;; Purpose: Load and execute all examples for UFFI +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +#-uffi (asdf:oos 'asdf:load-op :uffi) + +(pushnew :examples-uffi cl:*features*) + +(flet ((load-test (name) + (load (make-pathname :defaults *load-truename* :name name)))) + (load-test "c-test-fns") + (load-test "arrays") + (load-test "union") + (load-test "strtol") + (load-test "atoifl") + (load-test "gettime") + (load-test "getenv") + (load-test "gethostname") + (load-test "getshells") + (load-test "compress")) + +(setq cl:*features* (remove :examples-uffi cl:*features*)) + + + Added: branches/trunk-reorg/thirdparty/uffi/examples/strtol.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/examples/strtol.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,80 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: strtol.cl +;;;; Purpose: UFFI Example file to strtol, uses pointer arithmetic +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package :cl-user) + +(uffi:def-foreign-type char-ptr (* :unsigned-char)) + +;; This example does not use :cstring to pass the input string since +;; the routine needs to do pointer arithmetic to see how many characters +;; were parsed + +(uffi:def-function ("strtol" c-strtol) + ((nptr char-ptr) + (endptr (* char-ptr)) + (base :int)) + :returning :long) + +(defun strtol (str &optional (base 10)) + "Returns a long int from a string. Returns number and condition flag. +Condition flag is T if all of string parses as a long, NIL if +their was no string at all, or an integer indicating position in string +of first non-valid character" + (let* ((str-native (uffi:convert-to-foreign-string str)) + (endptr (uffi:allocate-foreign-object 'char-ptr)) + (value (c-strtol str-native endptr base)) + (endptr-value (uffi:deref-pointer endptr 'char-ptr))) + + (unwind-protect + (if (uffi:null-pointer-p endptr-value) + (values value t) + (let ((next-char-value (uffi:deref-pointer endptr-value :unsigned-char)) + (chars-parsed (- (uffi:pointer-address endptr-value) + (uffi:pointer-address str-native)))) + (cond + ((zerop chars-parsed) + (values nil nil)) + ((uffi:null-char-p next-char-value) + (values value t)) + (t + (values value chars-parsed))))) + (progn + (uffi:free-foreign-object str-native) + (uffi:free-foreign-object endptr))))) + + + +#+examples-uffi +(progn + (flet ((print-results (str) + (multiple-value-bind (result flag) (strtol str) + (format t "~&(strtol ~S) => ~S,~S" str result flag)))) + (print-results "55") + (print-results "55.3") + (print-results "a"))) + +#+test-uffi +(progn + (flet ((test-strtol (str results) + (util.test:test (multiple-value-list (strtol str)) results + :test #'equal + :fail-info "Error testing strtol"))) + (test-strtol "123" '(123 t)) + (test-strtol "0" '(0 t)) + (test-strtol "55a" '(55 2)) + (test-strtol "a" '(nil nil)))) + + + Added: branches/trunk-reorg/thirdparty/uffi/examples/test-examples.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/examples/test-examples.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,40 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: test-examples.cl +;;;; Purpose: Load and execute all examples for UFFI +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +#-uffi (asdf:oos 'asdf:load-op :uffi) + +(unless (ignore-errors (find-package :util.test)) + (load (make-pathname :name "acl-compat-tester" :defaults *load-truename*))) + +(defun do-tests () + (pushnew :test-uffi cl:*features*) + (util.test:with-tests (:name "UFFI-Tests") + (setq util.test:*break-on-test-failures* nil) + (flet ((load-test (name) + (load (make-pathname :name name :defaults *load-truename*)))) + (load-test "c-test-fns") + (load-test "arrays") + (load-test "union") + (load-test "strtol") + (load-test "atoifl") + (load-test "gettime") + (load-test "getenv") + (load-test "gethostname") + (load-test "getshells") + (load-test "compress")) + (setq cl:*features* (remove :test-uffi cl:*features*)))) + +(do-tests) + Added: branches/trunk-reorg/thirdparty/uffi/examples/union.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/examples/union.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,86 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: union.cl +;;;; Purpose: UFFI Example file to test unions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package :cl-user) + +(uffi:def-union tunion1 + (char :char) + (int :int) + (uint :unsigned-int) + (sf :float) + (df :double)) + +(defun run-union-1 () + (let ((u (uffi:allocate-foreign-object 'tunion1))) + (setf (uffi:get-slot-value u 'tunion1 'uint) + ;; little endian + #-(or sparc sparc-v9 powerpc ppc big-endian) + (+ (* 1 (char-code #\A)) + (* 256 (char-code #\B)) + (* 65536 (char-code #\C)) + (* 16777216 255)) + ;; big endian + #+(or sparc sparc-v9 powerpc ppc big-endian) + (+ (* 16777216 (char-code #\A)) + (* 65536 (char-code #\B)) + (* 256 (char-code #\C)) + (* 1 255))) + (format *standard-output* "~&Should be #\A: ~S" + (uffi:ensure-char-character + (uffi:get-slot-value u 'tunion1 'char))) +;; (format *standard-output* "~&Should be negative number: ~D" +;; (uffi:get-slot-value u 'tunion1 'int)) + (format *standard-output* "~&Should be positive number: ~D" + (uffi:get-slot-value u 'tunion1 'uint)) + (uffi:free-foreign-object u)) + (values)) + +#+test-uffi +(defun test-union-1 () + (let ((u (uffi:allocate-foreign-object 'tunion1))) + (setf (uffi:get-slot-value u 'tunion1 'uint) + #-(or sparc sparc-v9 powerpc ppc) + (+ (* 1 (char-code #\A)) + (* 256 (char-code #\B)) + (* 65536 (char-code #\C)) + (* 16777216 128)) + #+(or sparc sparc-v9 powerpc ppc) + (+ (* 16777216 (char-code #\A)) + (* 65536 (char-code #\B)) + (* 256 (char-code #\C)) + (* 1 128))) ;set signed bit + (util.test:test (uffi:ensure-char-character + (uffi:get-slot-value u 'tunion1 'char)) + #\A + :test #'eql + :fail-info "Error with union character") + #-(or sparc sparc-v9 openmcl digitool) +;; (util.test:test (> 0 (uffi:get-slot-value u 'tunion1 'int)) +;; t +;; :fail-info +;; "Error with negative int in union") + (util.test:test (plusp (uffi:get-slot-value u 'tunion1 'uint)) + t + :fail-info + "Error with unsigned int in union") + (uffi:free-foreign-object u)) + (values)) + +#+examples-uffi +(run-union-1) + + +#+test-uffi +(test-union-1) Added: branches/trunk-reorg/thirdparty/uffi/src/Makefile ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/src/Makefile Mon Feb 11 09:06:27 2008 @@ -0,0 +1,6 @@ +SUBDIRS := + +include ../Makefile.common + +.PHONY: distclean +distclean: clean Added: branches/trunk-reorg/thirdparty/uffi/src/aggregates.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/src/aggregates.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,262 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: aggregates.lisp +;;;; Purpose: UFFI source to handle aggregate types +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:uffi) + +(defmacro def-enum (enum-name args &key (separator-string "#")) + "Creates a constants for a C type enum list, symbols are created +in the created in the current package. The symbol is the concatenation +of the enum-name name, separator-string, and field-name" + (let ((counter 0) + (cmds nil) + (constants nil)) + (declare (fixnum counter)) + (dolist (arg args) + (let ((name (if (listp arg) (car arg) arg)) + (value (if (listp arg) + (prog1 + (setq counter (cadr arg)) + (incf counter)) + (prog1 + counter + (incf counter))))) + (setq name (intern (concatenate 'string + (symbol-name enum-name) + separator-string + (symbol-name name)))) + (push `(uffi:def-constant ,name ,value) constants))) + (setf cmds (append '(progn) + #+allegro `((ff:def-foreign-type ,enum-name :int)) + #+lispworks `((fli:define-c-typedef ,enum-name :int)) + #+(or cmu scl) `((alien:def-alien-type ,enum-name alien:signed)) + #+sbcl `((sb-alien:define-alien-type ,enum-name sb-alien:signed)) + #+digitool `((def-mcl-type ,enum-name :integer)) + #+openmcl `((ccl::def-foreign-type ,enum-name :int)) + (nreverse constants))) + cmds)) + + +(defmacro def-array-pointer (name-array type) + #+allegro + `(ff:def-foreign-type ,name-array + (:array ,(convert-from-uffi-type type :array))) + #+lispworks + `(fli:define-c-typedef ,name-array + (:c-array ,(convert-from-uffi-type type :array))) + #+(or cmu scl) + `(alien:def-alien-type ,name-array + (* ,(convert-from-uffi-type type :array))) + #+sbcl + `(sb-alien:define-alien-type ,name-array + (* ,(convert-from-uffi-type type :array))) + #+digitool + `(def-mcl-type ,name-array '(:array ,type)) + #+openmcl + `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array))) + ) + +(defun process-struct-fields (name fields &optional (variant nil)) + (let (processed) + (dolist (field fields) + (let* ((field-name (car field)) + (type (cadr field)) + (def (append (list field-name) + (if (eq type :pointer-self) + #+(or cmu scl) `((* (alien:struct ,name))) + #+sbcl `((* (sb-alien:struct ,name))) + #+(or openmcl digitool) `((:* (:struct ,name))) + #+lispworks `((:pointer ,name)) + #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name)) + `(,(convert-from-uffi-type type :struct)))))) + (if variant + (push (list def) processed) + (push def processed)))) + (nreverse processed))) + + +(defmacro def-struct (name &rest fields) + #+(or cmu scl) + `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields))) + #+sbcl + `(sb-alien:define-alien-type ,name (sb-alien:struct ,name ,@(process-struct-fields name fields))) + #+allegro + `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields))) + #+lispworks + `(fli:define-c-struct ,name ,@(process-struct-fields name fields)) + #+digitool + `(ccl:defrecord ,name ,@(process-struct-fields name fields)) + #+openmcl + `(ccl::def-foreign-type + nil + (:struct ,name ,@(process-struct-fields name fields))) + ) + + +(defmacro get-slot-value (obj type slot) + #+(or lispworks cmu sbcl scl) (declare (ignore type)) + #+allegro + `(ff:fslot-value-typed ,type :c ,obj ,slot) + #+lispworks + `(fli:foreign-slot-value ,obj ,slot) + #+(or cmu scl) + `(alien:slot ,obj ,slot) + #+sbcl + `(sb-alien:slot ,obj ,slot) + #+(or openmcl digitool) + `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) + ) + +#+(or openmcl digitool) +(defmacro set-slot-value (obj type slot value) ;use setf to set values + `(setf (ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ,value)) + +#+(or openmcl digitool) +(defsetf get-slot-value set-slot-value) + + +(defmacro get-slot-pointer (obj type slot) + #+(or lispworks cmu sbcl scl) (declare (ignore type)) + #+allegro + `(ff:fslot-value-typed ,type :c ,obj ,slot) + #+lispworks + `(fli:foreign-slot-pointer ,obj ,slot) + #+(or cmu scl) + `(alien:slot ,obj ,slot) + #+sbcl + `(sb-alien:slot ,obj ,slot) + #+digitool + `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot)))) + #+openmcl + `(let ((field (ccl::%find-foreign-record-type-field ,type ,slot))) + (ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field))))) +) + +;; necessary to eval at compile time for openmcl to compile convert-from-foreign-usb8 +;; below +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; so we could allow '(:array :long) or deref with other type like :long only + #+(or openmcl digitool) + (defun array-type (type) + (let ((result type)) + (when (listp type) + (let ((type-list (if (eq (car type) 'quote) (nth 1 type) type))) + (when (and (listp type-list) (eq (car type-list) :array)) + (setf result (cadr type-list))))) + result)) + + + (defmacro deref-array (obj type i) + "Returns a field from a row" + #+(or lispworks cmu sbcl scl) (declare (ignore type)) + #+(or cmu scl) `(alien:deref ,obj ,i) + #+sbcl `(sb-alien:deref ,obj ,i) + #+lispworks `(fli:dereference ,obj :index ,i :copy-foreign-object nil) + #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i) + #+openmcl + (let* ((array-type (array-type type)) + (local-type (convert-from-uffi-type array-type :allocation)) + (element-size-in-bits (ccl::%foreign-type-or-record-size local-type :bits))) + (ccl::%foreign-access-form + obj + (ccl::%foreign-type-or-record local-type) + `(* ,i ,element-size-in-bits) + nil)) + #+digitool + (let* ((array-type (array-type type)) + (local-type (convert-from-uffi-type array-type :allocation)) + (accessor (first (macroexpand `(ccl:pref obj ,local-type))))) + `(,accessor + ,obj + (* (the fixnum ,i) ,(size-of-foreign-type local-type)))) + )) + +; this expands to the %set-xx functions which has different params than %put-xx +#+digitool +(defmacro deref-array-set (obj type i value) + (let* ((array-type (array-type type)) + (local-type (convert-from-uffi-type array-type :allocation)) + (accessor (first (macroexpand `(ccl:pref obj ,local-type)))) + (settor (first (macroexpand `(setf (,accessor obj ,local-type) value))))) + `(,settor + ,obj + (* (the fixnum ,i) ,(size-of-foreign-type local-type)) + ,value))) + +#+digitool +(defsetf deref-array deref-array-set) + +(defmacro def-union (name &rest fields) + #+allegro + `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields))) + #+lispworks + `(fli:define-c-union ,name ,@(process-struct-fields name fields)) + #+(or cmu scl) + `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields))) + #+sbcl + `(sb-alien:define-alien-type ,name (sb-alien:union ,name ,@(process-struct-fields name fields))) + #+digitool + `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t))) + #+openmcl + `(ccl::def-foreign-type nil + (:union ,name ,@(process-struct-fields name fields))) +) + + +#-(or sbcl cmu) +(defun convert-from-foreign-usb8 (s len) + (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0)) + (fixnum len)) + (let ((a (make-array len :element-type '(unsigned-byte 8)))) + (dotimes (i len a) + (declare (fixnum i)) + (setf (aref a i) (uffi:deref-array s '(:array :unsigned-byte) i))))) + +#+sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (sb-ext:without-package-locks + (defvar *system-copy-fn* (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")) + (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL") + (intern "COPY-UB8-FROM-SYSTEM-AREA" "SB-KERNEL"))) + (defconstant +system-copy-offset+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")) + (* sb-vm:vector-data-offset sb-vm:n-word-bits) + 0)) + (defconstant +system-copy-multiplier+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")) + sb-vm:n-byte-bits + 1)))) + + +#+sbcl +(defun convert-from-foreign-usb8 (s len) + (let ((sap (sb-alien:alien-sap s))) + (declare (type sb-sys:system-area-pointer sap)) + (locally + (declare (optimize (speed 3) (safety 0))) + (let ((result (make-array len :element-type '(unsigned-byte 8)))) + (funcall *system-copy-fn* sap 0 result +system-copy-offset+ + (* len +system-copy-multiplier+)) + result)))) + +#+cmu +(defun convert-from-foreign-usb8 (s len) + (let ((sap (alien:alien-sap s))) + (declare (type system:system-area-pointer sap)) + (locally + (declare (optimize (speed 3) (safety 0))) + (let ((result (make-array len :element-type '(unsigned-byte 8)))) + (kernel:copy-from-system-area sap 0 + result (* vm:vector-data-offset + vm:word-bits) + (* len vm:byte-bits)) + result)))) Added: branches/trunk-reorg/thirdparty/uffi/src/corman/corman-notes.txt ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/src/corman/corman-notes.txt Mon Feb 11 09:06:27 2008 @@ -0,0 +1,17 @@ +some notes: + we need the :pascal (:stdcall) calling conventions for + (def-function names args &key module returning calling-convention) + so I added this. calling-convention defaults to :cdecl + but on win32 we mostly use :stdcall + + #+corman is invalid, #+cormanlisp instead + + cormanlisp doesn't need to load and register the dll, since the underlying + LoadLibrary() call does this. we need the module keyword for def-function +instead. + (should probably default to kernel32.dll) + I'll think about library.cl, but we'll need more real-world win32 examples. + (ideally the complete winapi :) + I also have to look at valentina. + +patch -p0 < corman.diff Added: branches/trunk-reorg/thirdparty/uffi/src/corman/getenv-ccl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/src/corman/getenv-ccl.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,81 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: getenv-ccl.cl +;;;; Purpose: cormanlisp version +;;;; Programmer: "Joe Marshall" <prunesquallor(a)attbi.com> +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; ************************************************************************* + +(in-package :cl-user) + +(ct:defun-dll c-getenv ((lpname LPSTR) + (lpbuffer LPSTR) + (nsize LPDWORD)) + :library-name "kernel32.dll" + :return-type DWORD + :entry-name "GetEnvironmentVariableA" + :linkage-type :pascal) + +(defun getenv (name) + (let ((nsizebuf (ct:malloc (sizeof :long))) + (buffer (ct:malloc 1)) + (cname (ct:lisp-string-to-c-string name))) + (setf (ct:cref lpdword nsizebuf 0) 0) + (let* ((needed-size (c-getenv cname buffer nsizebuf)) + (buffer1 (ct:malloc (1+ needed-size)))) + (setf (ct:cref lpdword nsizebuf 0) needed-size) + (prog1 (if (zerop (c-getenv cname buffer1 nsizebuf)) + nil + (ct:c-string-to-lisp-string buffer1)) + (ct:free buffer1) + (ct:free nsizebuf))))) + +(defun cl:user-homedir-pathname (&optional host) + (cond ((or (stringp host) + (and (consp host) + (every #'stringp host))) nil) + ((or (eq host :unspecific) + (null host)) + (let ((homedrive (getenv "HOMEDRIVE")) + (homepath (getenv "HOMEPATH"))) + (parse-namestring + (if (and (stringp homedrive) + (stringp homepath) + (= (length homedrive) 2) + (> (length homepath) 0)) + (concatenate 'string homedrive homepath "\\") + "C:\\")))) + (t (error "HOST must be a string, list of strings, NIL or :unspecific")))) + +;| +(uffi:def-function ("getenv" c-getenv) + ((name :cstring)) + :returning :cstring) + +(defun my-getenv (key) + "Returns an environment variable, or NIL if it does not exist" + (check-type key string) + (uffi:with-cstring (key-native key) + (uffi:convert-from-cstring (c-getenv key-native)))) + +#examples-uffi +(progn + (flet ((print-results (str) + (format t "~&(getenv ~S) => ~S" str (my-getenv str)))) + (print-results "USER") + (print-results "_FOO_"))) + + +#test-uffi +(progn + (util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv") + (util.test:test (and (stringp (my-getenv "USER")) + (< 0 (length (my-getenv "USER")))) + t :fail-info "Error retrieving getenv") +) + Added: branches/trunk-reorg/thirdparty/uffi/src/functions.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/src/functions.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,239 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: function.lisp +;;;; Purpose: UFFI source to C function definitions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:uffi) + +(defun process-function-args (args) + (if (null args) + #+(or lispworks cmu sbcl scl cormanlisp digitool) nil + #+allegro '(:void) + #+openmcl (values nil nil) + + ;; args not null + #+(or lispworks allegro cmu sbcl scl digitool cormanlisp) + (let (processed) + (dolist (arg args) + (push (process-one-function-arg arg) processed)) + (nreverse processed)) + #+openmcl + (let ((processed nil) + (params nil)) + (dolist (arg args) + (let ((name (car arg)) + (type (convert-from-uffi-type (cadr arg) :routine))) + ;;(when (and (listp type) (eq (car type) :address)) + ;;(setf type :address)) + (push name params) + (push type processed) + (push name processed))) + (values (nreverse params) (nreverse processed))) + )) + +(defun process-one-function-arg (arg) + (let ((name (car arg)) + (type (convert-from-uffi-type (cadr arg) :routine))) + #+(or cmu sbcl scl) + ;(list name type :in) + `(,name ,type ,@(if (= (length arg) 3) (list (third arg)) (values))) + #+(or allegro lispworks digitool) + (if (and (listp type) (listp (car type))) + (append (list name) type) + (list name type)) + #+openmcl + (declare (ignore name type)) + )) + + +(defun allegro-convert-return-type (type) + (if (and (listp type) (not (listp (car type)))) + (list type) + type)) + +(defun funcallable-lambda-list (args) + (let ((ll nil)) + (dolist (arg args) + (push (car arg) ll)) + (nreverse ll))) + +#| +(defmacro def-funcallable (name args &key returning) + (let ((result-type (convert-from-uffi-type returning :return)) + (function-args (process-function-args args))) + #+lispworks + `(fli:define-foreign-funcallable ,name ,function-args + :result-type ,result-type + :language :ansi-c + :calling-convention :cdecl) + #+(or cmu scl sbcl) + ;; requires the type of the function pointer be declared correctly! + (let* ((ptrsym (gensym)) + (ll (funcallable-lambda-list args))) + `(defun ,name ,(cons ptrsym ll) + (alien::alien-funcall ,ptrsym ,@ll))) + #+openmcl + (multiple-value-bind (params args) (process-function-args args) + (let ((ptrsym (gensym))) + `(defun ,name ,(cons ptrsym params) + (ccl::ff-call ,ptrsym ,@args ,result-type)))) + #+allegro + ;; this is most definitely wrong + (let* ((ptrsym (gensym)) + (ll (funcallable-lambda-list args))) + `(defun ,name ,(cons ptrsym ll) + (system::ff-funcall ,ptrsym ,@ll))) + )) +|# + +(defun convert-lispworks-args (args) + (loop for arg in args + with processed = nil + do + (if (and (= (length arg) 3) (eq (third arg) :out)) + (push (list (first arg) + (list :reference-return (second arg))) processed) + (push (subseq arg 0 2) processed)) + finally (return (nreverse processed)))) + +(defun preprocess-names (names) + (let ((fname (gensym))) + (if (atom names) + (values (list names fname) fname (uffi::make-lisp-name names)) + (values (list (first names) fname) fname (second names))))) + +(defun preprocess-args (args) + (loop for arg in args + with lisp-args = nil and out = nil and processed = nil + do + (if (= (length arg) 3) + (ecase (third arg) + (:in + (progn + (push (first arg) lisp-args) + (push (list (first arg) (second arg)) processed))) + (:out + (progn + (push (list (first arg) (second arg)) out) + (push (list (first arg) (list '* (second arg))) processed)))) + (progn + (push (first arg) lisp-args) + (push arg processed))) + finally (return (values (nreverse lisp-args) + (nreverse out) + (nreverse processed))))) + + +(defmacro def-function (names args &key module returning) + (multiple-value-bind (lisp-args out processed) + (preprocess-args args) + (declare (ignorable lisp-args processed)) + (if (= (length out) 0) + `(%def-function ,names ,args + ,@(if module (list :module module) (values)) + ,@(if returning (list :returning returning) (values))) + + #+(or cmu scl sbcl) + `(%def-function ,names ,args + ,@(if returning (list :returning returning) (values))) + #+(and lispworks lispworks5) + (multiple-value-bind (name-pair fname lisp-name) + (preprocess-names names) + `(progn + (%def-function ,name-pair ,(convert-lispworks-args args) + ,@(if module (list :module module) (values)) + ,@(if returning (list :returning returning) (values))) + (defun ,lisp-name ,lisp-args + (,fname ,@(mapcar + #'(lambda (arg) + (cond ((member (first arg) lisp-args) + (first arg)) + ((member (first arg) out :key #'first) + t))) + args))))) + #+(and lispworks (not lispworks5)) + `(%def-function ,names ,(convert-lispworks-args args) + ,@(if module (list :module module) (values)) + ,@(if returning (list :returning returning) (values))) + #-(or cmu scl sbcl lispworks) + (multiple-value-bind (name-pair fname lisp-name) + (preprocess-names names) + `(progn + (%def-function ,name-pair ,processed + :module ,module :returning ,returning) + ;(declaim (inline ,fname)) + (defun ,lisp-name ,lisp-args + (with-foreign-objects ,out + (values (,fname ,@(mapcar #'first args)) + ,@(mapcar #'(lambda (arg) + (list 'deref-pointer + (first arg) + (second arg))) out)))))) + ))) + + +;; name is either a string representing foreign name, or a list +;; of foreign-name as a string and lisp name as a symbol +(defmacro %def-function (names args &key module returning) + #+(or cmu sbcl scl allegro openmcl digitool cormanlisp) (declare (ignore module)) + + (let* ((result-type (convert-from-uffi-type returning :return)) + (function-args (process-function-args args)) + (foreign-name (if (atom names) names (car names))) + (lisp-name (if (atom names) (make-lisp-name names) (cadr names)))) + ;; todo: calling-convention :stdcall for cormanlisp + #+allegro + `(ff:def-foreign-call (,lisp-name ,foreign-name) + ,function-args + :returning ,(allegro-convert-return-type result-type) + :call-direct t + :strings-convert nil) + #+(or cmu scl) + `(alien:def-alien-routine (,foreign-name ,lisp-name) + ,result-type + ,@function-args) + #+sbcl + `(sb-alien:define-alien-routine (,foreign-name ,lisp-name) + ,result-type + ,@function-args) + #+lispworks + `(fli:define-foreign-function (,lisp-name ,foreign-name :source) + ,function-args + ,@(if module (list :module module) (values)) + :result-type ,result-type + :language :ansi-c + #+:win32 :calling-convention #+:win32 :cdecl) + #+digitool + `(eval-when (:compile-toplevel :load-toplevel :execute) + (ccl:define-entry-point (,lisp-name ,foreign-name) + ,function-args + ,result-type)) + #+openmcl + (declare (ignore function-args)) + #+(and openmcl darwinppc-target) + (setf foreign-name (concatenate 'string "_" foreign-name)) + #+openmcl + (multiple-value-bind (params args) (process-function-args args) + `(defun ,lisp-name ,params + (ccl::external-call ,foreign-name ,@args ,result-type))) + #+cormanlisp + `(ct:defun-dll ,lisp-name (,function-args) + :return-type ,result-type + ,@(if module (list :library-name module) (values)) + :entry-name ,foreign-name + :linkage-type ,calling-convention) ; we need :pascal + )) + + + + Added: branches/trunk-reorg/thirdparty/uffi/src/libraries.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/src/libraries.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,134 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: libraries.lisp +;;;; Purpose: UFFI source to load foreign libraries +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:uffi) + +(defvar *loaded-libraries* nil + "List of foreign libraries loaded. Used to prevent reloading a library") + +(defun default-foreign-library-type () + "Returns string naming default library type for platform" + #+(or win32 cygwin mswindows) "dll" + #+(or macosx darwin ccl-5.0) "dylib" + #-(or win32 cygwin mswindows macosx darwin ccl-5.0) "so" +) + +(defun foreign-library-types () + "Returns list of string naming possible library types for platform, sorted by preference" + #+(or win32 mswindows) '("dll" "lib") + #+(or macosx darwin ccl-5.0) '("dylib" "bundle") + #-(or win32 mswindows macosx darwin ccl-5.0) '("so" "a" "o") +) + +(defun find-foreign-library (names directories &key types drive-letters) + "Looks for a foreign library. directories can be a single +string or a list of strings of candidate directories. Use default +library type if type is not specified." + (unless types + (setq types (foreign-library-types))) + (unless (listp types) + (setq types (list types))) + (unless (listp names) + (setq names (list names))) + (unless (listp directories) + (setq directories (list directories))) + #+(or win32 mswindows) + (unless (listp drive-letters) + (setq drive-letters (list drive-letters))) + #-(or win32 mswindows) + (setq drive-letters '(nil)) + (dolist (drive-letter drive-letters) + (dolist (name names) + (dolist (dir directories) + (dolist (type types) + (let ((path (make-pathname + #+lispworks :host + #+lispworks (when drive-letter drive-letter) + #-lispworks :device + #-lispworks (when drive-letter drive-letter) + :name name + :type type + :directory + (etypecase dir + (pathname + (pathname-directory dir)) + (list + dir) + (string + (pathname-directory + (parse-namestring dir))))))) + (when (probe-file path) + (return-from find-foreign-library path))))))) + nil) + + +(defun load-foreign-library (filename &key module supporting-libraries + force-load) + #+(or allegro openmcl digitool sbcl) (declare (ignore module supporting-libraries)) + #+(or cmu scl) (declare (ignore module)) + #+lispworks (declare (ignore supporting-libraries)) + + (flet ((load-failure () + (error "Unable to load foreign library \"~A\"." filename))) + (when (and filename (or (null (pathname-directory filename)) + (probe-file filename))) + (if (pathnamep filename) ;; ensure filename is a string to check if already loaded + (setq filename (namestring (if (null (pathname-directory filename)) + filename + ;; lispworks treats as UNC, so use truename + #+(and lispworks win32) (truename filename) + #-(and lispworks win32) filename)))) + + (if (and (not force-load) + (find filename *loaded-libraries* :test #'string-equal)) + t ;; return T, but don't reload library + (progn + #+cmu + (let ((type (pathname-type (parse-namestring filename)))) + (if (string-equal type "so") + (unless + (sys::load-object-file filename) + (load-failure)) + (alien:load-foreign filename + :libraries + (convert-supporting-libraries-to-string + supporting-libraries)))) + #+scl + (let ((type (pathname-type (parse-namestring filename)))) + (alien:load-foreign filename + :libraries + (convert-supporting-libraries-to-string + supporting-libraries))) + #+sbcl + (handler-case (sb-alien::load-1-foreign filename) + (sb-int:unsupported-operator (c) + (if (fboundp (intern "LOAD-SHARED-OBJECT" :sb-alien)) + (funcall (intern "LOAD-SHARED-OBJECT" :sb-alien) filename) + (error c)))) + + #+lispworks (fli:register-module module :real-name filename + :connection-style :immediate) + #+allegro (load filename) + #+openmcl (ccl:open-shared-library filename) + #+digitool (ccl:add-to-shared-library-search-path filename t) + + (push filename *loaded-libraries*) + t))))) + +(defun convert-supporting-libraries-to-string (libs) + (let (lib-load-list) + (dolist (lib libs) + (push (format nil "-l~A" lib) lib-load-list)) + (nreverse lib-load-list))) Added: branches/trunk-reorg/thirdparty/uffi/src/objects.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/src/objects.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,291 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: objects.lisp +;;;; Purpose: UFFI source to handle objects and pointers +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:uffi) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun size-of-foreign-type (type) + #+lispworks (fli:size-of type) + #+allegro (ff:sizeof-fobject type) + #+(or cmu scl) (ash (eval `(alien:alien-size ,type)) -3) ;; convert from bits to bytes + #+sbcl (ash (eval `(sb-alien:alien-size ,type)) -3) ;; convert from bits to bytes + #+clisp (values (ffi:size-of type)) + #+digitool + (let ((mcl-type (ccl:find-mactype type nil t))) + (if mcl-type + (ccl::mactype-record-size mcl-type) + (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)))) ;error if not a record + #+openmcl (ccl::%foreign-type-or-record-size type :bytes) + )) + +(defmacro allocate-foreign-object (type &optional (size :unspecified)) + "Allocates an instance of TYPE. If size is specified, then allocate +an array of TYPE with size SIZE. The TYPE parameter is evaluated." + (if (eq size :unspecified) + (progn + #+(or cmu scl) + `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation)) + #+sbcl + `(sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation)) + #+lispworks + `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate)) + #+allegro + `(ff:allocate-fobject ',(convert-from-uffi-type type :allocate) :c) + #+(or openmcl digitool) + `(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation))) + ) + (progn + #+(or cmu scl) + `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size) + #+sbcl + `(sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size) + #+lispworks + `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate) :nelems ,size) + #+allegro + `(ff:allocate-fobject (list :array (quote ,(convert-from-uffi-type type :allocate)) ,size) :c) + #+(or openmcl digitool) + `(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))) + ))) + +(defmacro free-foreign-object (obj) + #+(or cmu scl) + `(alien:free-alien ,obj) + #+sbcl + `(sb-alien:free-alien ,obj) + #+lispworks + `(fli:free-foreign-object ,obj) + #+allegro + `(ff:free-fobject ,obj) + #+(or openmcl digitool) + `(dispose-ptr ,obj) + ) + +(defmacro null-pointer-p (obj) + #+lispworks `(fli:null-pointer-p ,obj) + #+allegro `(zerop ,obj) + #+(or cmu scl) `(alien:null-alien ,obj) + #+sbcl `(sb-alien:null-alien ,obj) + #+(or openmcl digitool) `(ccl:%null-ptr-p ,obj) + ) + +(defmacro make-null-pointer (type) + #+(or allegro openmcl digitool) (declare (ignore type)) + #+(or cmu scl) `(alien:sap-alien (system:int-sap 0) (* ,(convert-from-uffi-type (eval type) :type))) + #+sbcl `(sb-alien:sap-alien (sb-sys:int-sap 0) (* ,(convert-from-uffi-type (eval type) :type))) + #+lispworks `(fli:make-pointer :address 0 :type (quote ,(convert-from-uffi-type (eval type) :type))) + #+allegro 0 + #+(or openmcl digitool) `(ccl:%null-ptr) + ) + +(defmacro make-pointer (addr type) + #+(or allegro openmcl digitool) (declare (ignore type)) + #+(or cmu scl) `(alien:sap-alien (system:int-sap ,addr) (* ,(convert-from-uffi-type (eval type) :type))) + #+sbcl `(sb-alien:sap-alien (sb-sys:int-sap ,addr) (* ,(convert-from-uffi-type (eval type) :type))) + #+lispworks `(fli:make-pointer :address ,addr :type (quote ,(convert-from-uffi-type (eval type) :type))) + #+allegro addr + #+(or openmcl digitool) `(ccl:%int-to-ptr ,addr) + ) + + +(defmacro char-array-to-pointer (obj) + #+(or cmu scl) `(alien:cast ,obj (* (alien:unsigned 8))) + #+sbcl `(sb-alien:cast ,obj (* (sb-alien:unsigned 8))) + #+lispworks `(fli:make-pointer :type '(:unsigned :char) + :address (fli:pointer-address ,obj)) + #+allegro obj + #+(or openmcl digitool) obj + ) + +(defmacro deref-pointer (ptr type) + "Returns a object pointed" + #+(or cmu sbcl lispworks scl) (declare (ignore type)) + #+(or cmu scl) `(alien:deref ,ptr) + #+sbcl `(sb-alien:deref ,ptr) + #+lispworks `(fli:dereference ,ptr) + #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :deref)) :c ,ptr) + #+(or openmcl digitool) `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) + ) + +#+digitool +(defmacro deref-pointer-set (ptr type value) + `(setf (ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ,value)) + +#+digitool +(defsetf deref-pointer deref-pointer-set) + +(defmacro ensure-char-character (obj) + #+(or digitool) obj + #+(or allegro cmu sbcl scl openmcl) `(code-char ,obj) + ;; lispworks varies whether deref'ing array vs. slot access of a char + #+lispworks `(if (characterp ,obj) ,obj (code-char ,obj))) + +(defmacro ensure-char-integer (obj) + #+(or digitool) `(char-code ,obj) + #+(or allegro cmu sbcl scl openmcl) obj + ;; lispworks varies whether deref'ing array vs. slot access of a char + #+lispworks + `(if (integerp ,obj) ,obj (char-code ,obj))) + +(defmacro ensure-char-storable (obj) + #+(or digitool (and lispworks (not lispworks5))) obj + #+(or allegro cmu lispworks5 openmcl sbcl scl) + `(char-code ,obj)) + +(defmacro pointer-address (obj) + #+(or cmu scl) + `(system:sap-int (alien:alien-sap ,obj)) + #+sbcl + `(sb-sys:sap-int (sb-alien:alien-sap ,obj)) + #+lispworks + `(fli:pointer-address ,obj) + #+allegro + obj + #+(or openmcl digitool) + `(ccl:%ptr-to-int ,obj) + ) + +;; TYPE is evaluated. +#-(or openmcl digitool) +(defmacro with-foreign-object ((var type) &rest body) + #-(or cmu sbcl lispworks scl) ; default version + `(let ((,var (allocate-foreign-object ,type))) + (unwind-protect + (progn ,@body) + (free-foreign-object ,var))) + #+(or cmu scl) + (let ((obj (gensym)) + (ctype (convert-from-uffi-type (eval type) :allocate))) + (if (and (consp ctype) (eq 'array (car ctype))) + `(alien:with-alien ((,obj ,ctype)) + (let* ((,var ,obj)) + ,@body)) + `(alien:with-alien ((,obj ,ctype)) + (let* ((,var (alien:addr ,obj))) + ,@body)))) + #+sbcl + (let ((obj (gensym)) + (ctype (convert-from-uffi-type (eval type) :allocate))) + (if (and (consp ctype) (eq 'array (car ctype))) + `(sb-alien:with-alien ((,obj ,ctype)) + (let* ((,var ,obj)) + ,@body)) + `(sb-alien:with-alien ((,obj ,ctype)) + (let* ((,var (sb-alien:addr ,obj))) + ,@body)))) + #+lispworks + `(fli:with-dynamic-foreign-objects ((,var ,(convert-from-uffi-type + (eval type) :allocate))) + ,@body) + ) + +#-(or openmcl digitool) +(defmacro with-foreign-objects (bindings &rest body) + (if bindings + `(with-foreign-object ,(car bindings) + (with-foreign-objects ,(cdr bindings) + ,@body)) + `(progn ,@body))) + +#+(or openmcl digitool) +(defmacro with-foreign-objects (bindings &rest body) + (let ((params nil) type count) + (dolist (spec (reverse bindings)) ;keep order - macroexpands to let* + (setf type (convert-from-uffi-type (eval (nth 1 spec)) :allocate)) + (setf count 1) + (when (and (listp type) (eq (first type) :array)) + (setf count (nth 2 type)) + (unless (integerp count) (error "Invalid size for array: ~a" type)) + (setf type (nth 1 type))) + (push (list (first spec) (* count (size-of-foreign-type type))) params)) + `(ccl:%stack-block ,params ,@body))) + +#+(or openmcl digitool) +(defmacro with-foreign-object ((var type) &rest body) + `(with-foreign-objects ((,var ,type)) + ,@body)) + +#+lispworks +(defmacro with-cast-pointer ((binding-name pointer type) &body body) + `(fli:with-coerced-pointer (,binding-name + :type ',(convert-from-uffi-type (eval type) :type)) + ,pointer + ,@body)) + +#+(or cmu scl sbcl) +(defmacro with-cast-pointer ((binding-name pointer type) &body body) + `(let ((,binding-name + (#+(or cmu scl) alien:cast + #+sbcl sb-alien:cast + ,pointer (* ,(convert-from-uffi-type (eval type) :type))))) + ,@body)) + +#+(or allegro openmcl) +(defmacro with-cast-pointer ((binding-name pointer type) &body body) + (declare (ignore type)) + `(let ((,binding-name ,pointer)) + ,@body)) + +#-(or lispworks cmu scl sbcl allegro openmcl) +(defmacro with-cast-pointer ((binding-name pointer type) &body body) + (declare (ignore binding-name pointer type body)) + '(error "WITH-CAST-POINTER not (yet) implemented for ~A" + (lisp-implementation-type))) + +#+(or allegro openmcl) +(defun convert-external-name (name) + "Add an underscore to NAME if necessary for the ABI." + #+(or macosx darwinppc-target) (concatenate 'string "_" name) + #-(or macosx darwinppc-target) name) + +(defmacro def-foreign-var (names type module) + #-lispworks (declare (ignore module)) + (let ((foreign-name (if (atom names) names (first names))) + (lisp-name (if (atom names) (make-lisp-name names) (second names))) + #-allegro + (var-type (convert-from-uffi-type type :type))) + #+(or cmu scl) + `(alien:def-alien-variable (,foreign-name ,lisp-name) ,var-type) + #+sbcl + `(sb-alien:define-alien-variable (,foreign-name ,lisp-name) ,var-type) + #+allegro + `(define-symbol-macro ,lisp-name + (ff:fslot-value-typed (quote ,(convert-from-uffi-type type :deref)) + :c (ff:get-entry-point ,(convert-external-name foreign-name)))) + #+lispworks + `(progn + (fli:define-foreign-variable (,lisp-name ,foreign-name) + :accessor :address-of + :type ,var-type + :module ,module) + (define-symbol-macro ,lisp-name (fli:dereference (,lisp-name) + :copy-foreign-object nil))) + #+openmcl + `(define-symbol-macro ,lisp-name + (deref-pointer (ccl:foreign-symbol-address + ,(convert-external-name foreign-name)) ,var-type)) + #-(or allegro cmu scl sbcl lispworks openmcl) + `(define-symbol-macro ,lisp-name + '(error "DEF-FOREIGN-VAR not (yet) defined for ~A" + (lisp-implementation-type))))) + + +;;; Define a special variable, like DEFVAR, that will be initialized +;;; to a pointer which may need to be reset when a saved image is +;;; loaded. This is needed for OpenMCL, which sets pointers to "dead +;;; macptrs" when a saved image is loaded. +;; This may possibly be needed for sbcl's SAVE-LISP-AND-DIE +(defmacro def-pointer-var (name value &optional doc) + #-openmcl `(defvar ,name ,value ,@(if doc (list doc))) + #+openmcl `(ccl::defloadvar ,name ,value ,doc)) Added: branches/trunk-reorg/thirdparty/uffi/src/os.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/src/os.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,79 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: os.lisp +;;;; Purpose: Operating system interface for UFFI +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Sep 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg. +;;;; +;;;; ************************************************************************* + +(in-package #:uffi) + + +(defun getenv (var) + "Return the value of the environment variable." + #+allegro (sys::getenv (string var)) + #+clisp (sys::getenv (string var)) + #+cmu (cdr (assoc (string var) ext:*environment-list* :test #'equalp + :key #'string)) + #+gcl (si:getenv (string var)) + #+lispworks (lw:environment-variable (string var)) + #+lucid (lcl:environment-variable (string var)) + #+(or openmcl digitool) (ccl::getenv var) + #+sbcl (sb-ext:posix-getenv var) + #-(or allegro clisp cmu gcl lispworks lucid openmcl digitool sbcl) + (error 'not-implemented :proc (list 'getenv var))) + + +;; modified from function ASDF -- Copyright Dan Barlow and Contributors + +(defun run-shell-command (control-string &rest args &key output) + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and +synchronously execute the result using a Bourne-compatible shell, with +output to *trace-output*. Returns the shell's exit code." + (unless output + (setq output *trace-output*)) + + (let ((command (apply #'format nil control-string args))) + #+sbcl + (sb-impl::process-exit-code + (sb-ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output output)) + + #+(or cmu scl) + (ext:process-exit-code + (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output output)) + + #+allegro + (excl:run-shell-command command :input nil :output output) + + #+lispworks + (system:call-system-showing-output + command + :shell-type "/bin/sh" + :output-stream output) + + #+clisp ;XXX not exactly *trace-output*, I know + (ext:run-shell-command command :output :terminal :wait t) + + #+openmcl + (nth-value 1 + (ccl:external-process-status + (ccl:run-program "/bin/sh" (list "-c" command) + :input nil :output output + :wait t))) + + #-(or openmcl clisp lispworks allegro scl cmu sbcl) + (error "RUN-SHELL-PROGRAM not implemented for this Lisp.") + )) Added: branches/trunk-reorg/thirdparty/uffi/src/package.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/src/package.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,84 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: package.lisp +;;;; Purpose: Defines UFFI package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:cl-user) + +(defpackage #:uffi + (:use #:cl) + (:export + + ;; immediate types + #:def-constant + #:def-foreign-type + #:def-type + #:null-char-p + + ;; aggregate types + #:def-enum + #:def-struct + #:get-slot-value + #:get-slot-pointer + #:def-array-pointer + #:deref-array + #:def-union + + ;; objects + #:allocate-foreign-object + #:free-foreign-object + #:with-foreign-object + #:with-foreign-objects + #:size-of-foreign-type + #:pointer-address + #:deref-pointer + #:ensure-char-character + #:ensure-char-integer + #:ensure-char-storable + #:null-pointer-p + #:make-null-pointer + #:make-pointer + #:pointer-address + #:+null-cstring-pointer+ + #:char-array-to-pointer + #:with-cast-pointer + #:def-foreign-var + #:convert-from-foreign-usb8 + #:def-pointer-var + + ;; string functions + #:convert-from-cstring + #:convert-to-cstring + #:free-cstring + #:with-cstring + #:with-cstrings + #:convert-from-foreign-string + #:convert-to-foreign-string + #:allocate-foreign-string + #:with-foreign-string + #:with-foreign-strings + #:foreign-string-length + + ;; function call + #:def-function + + ;; Libraries + #:find-foreign-library + #:load-foreign-library + #:default-foreign-library-type + #:foreign-library-types + + ;; OS + #:run-shell-command + #:getenv + )) + + Added: branches/trunk-reorg/thirdparty/uffi/src/primitives.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/src/primitives.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,311 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: primitives.lisp +;;;; Purpose: UFFI source to handle immediate types +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:uffi) + +#+(or openmcl digitool) +(defvar *keyword-package* (find-package "KEYWORD")) + +#+(or openmcl digitool) +; MCL and OpenMCL expect a lot of FFI elements to be keywords (e.g. struct field names in OpenMCL) +; So this provides a function to convert any quoted symbols to keywords. +(defun keyword (obj) + (cond ((keywordp obj) + obj) + ((null obj) + nil) + ((symbolp obj) + (intern (symbol-name obj) *keyword-package*)) + ((and (listp obj) (eq (car obj) 'cl:quote)) + (keyword (cadr obj))) + ((stringp obj) + (intern obj *keyword-package*)) + (t + obj))) + +; Wrapper for unexported function we have to use +#+digitool +(defmacro def-mcl-type (name type) + `(ccl::def-mactype ,(keyword name) (ccl:find-mactype ,type))) + +(defmacro def-constant (name value &key (export nil)) + "Macro to define a constant and to export it" + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant ,name ,value) + ,(when export (list 'export `(quote ,name))) + ',name)) + +(defmacro def-type (name type) + "Generates a (deftype) statement for CL. Currently, only CMUCL +supports takes advantage of this optimization." + #+(or lispworks allegro openmcl digitool cormanlisp) (declare (ignore type)) + #+(or lispworks allegro openmcl digitool cormanlisp) `(deftype ,name () t) + #+(or cmu scl) + `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare))) + #+sbcl + `(deftype ,name () '(sb-alien:alien ,(convert-from-uffi-type type :declare))) + ) + +(defmacro null-char-p (val) + "Returns T if character is NULL" + `(zerop ,val)) + +(defmacro def-foreign-type (name type) + #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type)) + #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type)) + #+(or cmu scl) `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type)) + #+sbcl `(sb-alien:define-alien-type ,name ,(convert-from-uffi-type type :type)) + #+cormanlisp `(ct:defctype ,name ,(convert-from-uffi-type type :type)) + #+(or openmcl digitool) + (let ((mcl-type (convert-from-uffi-type type :type))) + (unless (or (keywordp mcl-type) (consp mcl-type)) + (setf mcl-type `(quote ,mcl-type))) + #+digitool + `(def-mcl-type ,(keyword name) ,mcl-type) + #+openmcl + `(ccl::def-foreign-type ,(keyword name) ,mcl-type)) + ) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar +type-conversion-hash+ (make-hash-table :size 20 :test #'eq)) + #+(or cmu sbcl scl) (defvar *cmu-def-type-hash* + (make-hash-table :size 20 :test #'eq)) + ) + +#+(or cmu scl) +(defvar *cmu-sbcl-def-type-list* + '((:char . (alien:signed 8)) + (:unsigned-char . (alien:unsigned 8)) + (:byte . (alien:signed 8)) + (:unsigned-byte . (alien:unsigned 8)) + (:short . (alien:signed 16)) + (:unsigned-short . (alien:unsigned 16)) + (:int . (alien:signed 32)) + (:unsigned-int . (alien:unsigned 32)) + #-x86-64 (:long . (alien:signed 32)) + #-x86-64 (:unsigned-long . (alien:unsigned 32)) + #+x86-64 (:long . (alien:signed 64)) + #+x86-64 (:unsigned-long . (alien:unsigned 64)) + (:float . alien:single-float) + (:double . alien:double-float) + (:void . t) + ) + "Conversions in CMUCL for def-foreign-type are different than in def-function") + +#+sbcl +(defvar *cmu-sbcl-def-type-list* + '((:char . (sb-alien:signed 8)) + (:unsigned-char . (sb-alien:unsigned 8)) + (:byte . (sb-alien:signed 8)) + (:unsigned-byte . (sb-alien:unsigned 8)) + (:short . (sb-alien:signed 16)) + (:unsigned-short . (sb-alien:unsigned 16)) + (:int . (sb-alien:signed 32)) + (:unsigned-int . (sb-alien:unsigned 32)) + #-x86-64 (:long . (sb-alien:signed 32)) + #-x86-64 (:unsigned-long . (sb-alien:unsigned 32)) + #+x86-64 (:long . (sb-alien:signed 64)) + #+x86-64 (:unsigned-long . (sb-alien:unsigned 64)) + (:float . sb-alien:single-float) + (:double . sb-alien:double-float) + (:void . t) + ) + "Conversions in SBCL for def-foreign-type are different than in def-function") + +(defvar *type-conversion-list* nil) + +#+(or cmu scl) +(setq *type-conversion-list* + '((* . *) (:void . c-call:void) + (:pointer-void . (* t)) + (:cstring . c-call:c-string) + (:char . c-call:char) + (:unsigned-char . (alien:unsigned 8)) + (:byte . (alien:signed 8)) + (:unsigned-byte . (alien:unsigned 8)) + (:short . c-call:short) + (:unsigned-short . c-call:unsigned-short) + (:int . alien:integer) (:unsigned-int . c-call:unsigned-int) + (:long . c-call:long) (:unsigned-long . c-call:unsigned-long) + (:float . c-call:float) (:double . c-call:double) + (:array . alien:array))) + +#+sbcl +(setq *type-conversion-list* + '((* . *) (:void . sb-alien:void) + (:pointer-void . (* t)) + #-sb-unicode(:cstring . sb-alien:c-string) + #+sb-unicode(:cstring . sb-alien:utf8-string) + (:char . sb-alien:char) + (:unsigned-char . (sb-alien:unsigned 8)) + (:byte . (sb-alien:signed 8)) + (:unsigned-byte . (sb-alien:unsigned 8)) + (:short . sb-alien:short) + (:unsigned-short . sb-alien:unsigned-short) + (:int . sb-alien:int) (:unsigned-int . sb-alien:unsigned-int) + (:long . sb-alien:long) (:unsigned-long . sb-alien:unsigned-long) + (:float . sb-alien:float) (:double . sb-alien:double) + (:array . sb-alien:array))) + +#+(or allegro cormanlisp) +(setq *type-conversion-list* + '((* . *) (:void . :void) + (:short . :short) + (:pointer-void . (* :void)) + (:cstring . (* :unsigned-char)) + (:byte . :char) + (:unsigned-byte . :unsigned-char) + (:char . :char) + (:unsigned-char . :unsigned-char) + (:int . :int) (:unsigned-int . :unsigned-int) + (:long . :long) (:unsigned-long . :unsigned-long) + (:float . :float) (:double . :double) + (:array . :array))) + +#+lispworks +(setq *type-conversion-list* + '((* . :pointer) (:void . :void) + (:short . :short) + (:pointer-void . (:pointer :void)) + (:cstring . (:reference-pass (:ef-mb-string :external-format + (:latin-1 :eol-style :lf)) + :allow-null t)) + (:cstring-returning . (:reference (:ef-mb-string :external-format + (:latin-1 :eol-style :lf)) + :allow-null t)) + (:byte . :byte) + (:unsigned-byte . (:unsigned :byte)) + (:char . :char) + (:unsigned-char . (:unsigned :char)) + (:int . :int) (:unsigned-int . (:unsigned :int)) + (:long . :long) (:unsigned-long . (:unsigned :long)) + (:float . :float) (:double . :double) + (:array . :c-array))) + +#+digitool +(setq *type-conversion-list* + '((* . :pointer) (:void . :void) + (:short . :short) (:unsigned-short . :unsigned-short) + (:pointer-void . :pointer) + (:cstring . :string) + (:char . :character) + (:unsigned-char . :unsigned-byte) + (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte) + (:int . :long) (:unsigned-int . :unsigned-long) + (:long . :long) (:unsigned-long . :unsigned-long) + (:float . :single-float) (:double . :double-float) + (:array . :array))) + +#+openmcl +(setq *type-conversion-list* + '((* . :address) (:void . :void) + (:short . :short) (:unsigned-short . :unsigned-short) + (:pointer-void . :address) + (:cstring . :address) + (:char . :signed-char) + (:unsigned-char . :unsigned-char) + (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte) + (:int . :int) (:unsigned-int . :unsigned-int) + (:long . :long) (:unsigned-long . :unsigned-long) + (:long-long . :signed-doubleword) (:unsigned-long-long . :unsigned-doubleword) + (:float . :single-float) (:double . :double-float) + (:array . :array))) + +(dolist (type *type-conversion-list*) + (setf (gethash (car type) +type-conversion-hash+) (cdr type))) + +#+(or cmu sbcl scl) +(dolist (type *cmu-sbcl-def-type-list*) + (setf (gethash (car type) *cmu-def-type-hash*) (cdr type))) + +(defun basic-convert-from-uffi-type (type) + (let ((found-type (gethash type +type-conversion-hash+))) + (if found-type + found-type + #-(or openmcl digitool) type + #+(or openmcl digitool) (keyword type)))) + +(defun %convert-from-uffi-type (type context) + "Converts from a uffi type to an implementation specific type" + (if (atom type) + (cond + #+(or allegro cormanlisp) + ((and (or (eq context :routine) (eq context :return)) + (eq type :cstring)) + (setq type '((* :char) integer))) + #+(or cmu sbcl scl) + ((eq context :type) + (let ((cmu-type (gethash type *cmu-def-type-hash*))) + (if cmu-type + cmu-type + (basic-convert-from-uffi-type type)))) + #+lispworks + ((and (eq context :return) + (eq type :cstring)) + (basic-convert-from-uffi-type :cstring-returning)) + #+digitool + ((and (eq type :void) (eq context :return)) nil) + (t + (basic-convert-from-uffi-type type))) + (let ((sub-type (car type))) + (case sub-type + (cl:quote + (convert-from-uffi-type (cadr type) context)) + (:struct-pointer + #+(or openmcl digitool) `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct))) + #-(or openmcl digitool) (%convert-from-uffi-type (list '* (cadr type)) :struct) + ) + (:struct + #+(or openmcl digitool) `(:struct ,(%convert-from-uffi-type (cadr type) :struct)) + #-(or openmcl digitool) (%convert-from-uffi-type (cadr type) :struct) + ) + (:union + #+(or openmcl digitool) `(:union ,(%convert-from-uffi-type (cadr type) :union)) + #-(or openmcl digitool) (%convert-from-uffi-type (cadr type) :union) + ) + (t + (cons (%convert-from-uffi-type (first type) context) + (%convert-from-uffi-type (rest type) context))))))) + +(defun convert-from-uffi-type (type context) + (let ((result (%convert-from-uffi-type type context))) + (cond + ((atom result) result) + #+openmcl + ((eq (car result) :address) + (if (eq context :struct) + (append '(:*) (cdr result)) + :address)) + #+digitool + ((and (eq (car result) :pointer) (eq context :allocation) :pointer)) + (t result)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (char= #\a (schar (symbol-name '#:a) 0)) + (pushnew :uffi-lowercase-reader *features*)) + (when (not (string= (symbol-name '#:a) + (symbol-name '#:A))) + (pushnew :uffi-case-sensitive *features*))) + +(defun make-lisp-name (name) + (let ((converted (substitute #\- #\_ name))) + (intern + #+uffi-case-sensitive converted + #+(and (not uffi-lowercase-reader) (not uffi-case-sensitive)) (string-upcase converted) + #+(and uffi-lowercase-reader (not uffi-case-sensitive)) (string-downcase converted)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (setq cl:*features* (delete :uffi-lowercase-reader *features*)) + (setq cl:*features* (delete :uffi-case-sensitive *features*))) Added: branches/trunk-reorg/thirdparty/uffi/src/readmacros-mcl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/src/readmacros-mcl.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,35 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: readmacros-mcl.lisp +;;;; Purpose: This file holds functions using read macros for MCL +;;;; Programmer: Kevin M. Rosenberg/John Desoi +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:uffi) + + +;; trap macros don't work right directly in the macros +#+digitool +(defun new-ptr (size) + (#_NewPtr size)) + +#+digitool +(defun dispose-ptr (ptr) + (#_DisposePtr ptr)) + +#+openmcl +(defmacro new-ptr (size) + `(ccl::malloc ,size)) + +#+openmcl +(defmacro dispose-ptr (ptr) + `(ccl::free ,ptr)) + Added: branches/trunk-reorg/thirdparty/uffi/src/strings.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/src/strings.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,412 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: strings.lisp +;;;; Purpose: UFFI source to handle strings, cstring and foreigns +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; ************************************************************************* + +(in-package #:uffi) + + +(def-pointer-var +null-cstring-pointer+ + #+(or cmu sbcl scl) nil + #+allegro 0 + #+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char)) + #+(or openmcl digitool) (ccl:%null-ptr) +) + +(defmacro convert-from-cstring (obj) + "Converts a string from a c-call. Same as convert-from-foreign-string, except +that LW/CMU automatically converts strings from c-calls." + #+(or cmu sbcl lispworks scl) obj + #+allegro + (let ((stored (gensym))) + `(let ((,stored ,obj)) + (if (zerop ,stored) + nil + (values (excl:native-to-string ,stored))))) + #+(or openmcl digitool) + (let ((stored (gensym))) + `(let ((,stored ,obj)) + (if (ccl:%null-ptr-p ,stored) + nil + (values (ccl:%get-cstring ,stored))))) + ) + +(defmacro convert-to-cstring (obj) + #+(or cmu sbcl scl lispworks) obj + #+allegro + (let ((stored (gensym))) + `(let ((,stored ,obj)) + (if (null ,stored) + 0 + (values (excl:string-to-native ,stored))))) + #+(or openmcl digitool) + (let ((stored (gensym))) + `(let ((,stored ,obj)) + (if (null ,stored) + +null-cstring-pointer+ + (let ((ptr (new-ptr (1+ (length ,stored))))) + (ccl::%put-cstring ptr ,stored) + ptr)))) + ) + +(defmacro free-cstring (obj) + #+(or cmu sbcl scl lispworks) (declare (ignore obj)) + #+allegro + (let ((stored (gensym))) + `(let ((,stored ,obj)) + (unless (zerop ,stored) + (ff:free-fobject ,stored)))) + #+(or openmcl digitool) + (let ((stored (gensym))) + `(let ((,stored ,obj)) + (unless (ccl:%null-ptr-p ,stored) + (dispose-ptr ,stored)))) + ) + +(defmacro with-cstring ((cstring lisp-string) &body body) + #+(or cmu sbcl scl lispworks) + `(let ((,cstring ,lisp-string)) ,@body) + #+allegro + (let ((acl-native (gensym)) + (stored-lisp-string (gensym))) + `(let ((,stored-lisp-string ,lisp-string)) + (excl:with-native-string (,acl-native ,stored-lisp-string) + (let ((,cstring (if ,stored-lisp-string ,acl-native 0))) + ,@body)))) + #+(or openmcl digitool) + (let ((stored-lisp-string (gensym))) + `(let ((,stored-lisp-string ,lisp-string)) + (if (stringp ,stored-lisp-string) + (ccl:with-cstrs ((,cstring ,stored-lisp-string)) + ,@body) + (let ((,cstring +null-cstring-pointer+)) + ,@body)))) + ) + +(defmacro with-cstrings (bindings &rest body) + (if bindings + `(with-cstring ,(car bindings) + (with-cstrings ,(cdr bindings) + ,@body)) + `(progn ,@body))) + +;;; Foreign string functions + +(defmacro convert-to-foreign-string (obj) + #+lispworks + (let ((stored (gensym))) + `(let ((,stored ,obj)) + (if (null ,stored) + +null-cstring-pointer+ + (fli:convert-to-foreign-string + ,stored + :external-format '(:latin-1 :eol-style :lf))))) + #+allegro + (let ((stored (gensym))) + `(let ((,stored ,obj)) + (if (null ,stored) + 0 + (values (excl:string-to-native ,stored))))) + #+(or cmu scl) + (let ((size (gensym)) + (storage (gensym)) + (stored-obj (gensym)) + (i (gensym))) + `(let ((,stored-obj ,obj)) + (etypecase ,stored-obj + (null + (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8)))) + (string + (let* ((,size (length ,stored-obj)) + (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size)))) + (setq ,storage (alien:cast ,storage (* (alien:unsigned 8)))) + (locally + (declare (optimize (speed 3) (safety 0))) + (dotimes (,i ,size) + (declare (fixnum ,i)) + (setf (alien:deref ,storage ,i) + (char-code (char ,stored-obj ,i)))) + (setf (alien:deref ,storage ,size) 0)) + ,storage))))) + #+sbcl + (let ((size (gensym)) + (storage (gensym)) + (stored-obj (gensym)) + (i (gensym))) + `(let ((,stored-obj ,obj)) + (etypecase ,stored-obj + (null + (sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8)))) + (string + (let* ((,size (length ,stored-obj)) + (,storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ ,size)))) + (setq ,storage (sb-alien:cast ,storage (* (sb-alien:unsigned 8)))) + (locally + (declare (optimize (speed 3) (safety 0))) + (dotimes (,i ,size) + (declare (fixnum ,i)) + (setf (sb-alien:deref ,storage ,i) + (char-code (char ,stored-obj ,i)))) + (setf (sb-alien:deref ,storage ,size) 0)) + ,storage))))) + #+(or openmcl digitool) + (let ((stored-obj (gensym))) + `(let ((,stored-obj ,obj)) + (if (null ,stored-obj) + +null-cstring-pointer+ + (let ((ptr (new-ptr (1+ (length ,stored-obj))))) + (ccl::%put-cstring ptr ,stored-obj) + ptr)))) + ) + +;; Either length or null-terminated-p must be non-nil +(defmacro convert-from-foreign-string (obj &key + length + (locale :default) + (null-terminated-p t)) + #+allegro + (let ((stored-obj (gensym))) + `(let ((,stored-obj ,obj)) + (if (zerop ,stored-obj) + nil + (if (eq ,locale :none) + (fast-native-to-string ,stored-obj ,length) + (values + (excl:native-to-string + ,stored-obj + ,@(when length (list :length length)) + :truncate (not ,null-terminated-p))))))) + #+lispworks + (let ((stored-obj (gensym))) + `(let ((,stored-obj ,obj)) + (if (fli:null-pointer-p ,stored-obj) + nil + (if (eq ,locale :none) + (fast-native-to-string ,stored-obj ,length) + (fli:convert-from-foreign-string + ,stored-obj + ,@(when length (list :length length)) + :null-terminated-p ,null-terminated-p + :external-format '(:latin-1 :eol-style :lf)))))) + #+(or cmu scl) + (let ((stored-obj (gensym))) + `(let ((,stored-obj ,obj)) + (if (null-pointer-p ,stored-obj) + nil + (cmucl-naturalize-cstring (alien:alien-sap ,stored-obj) + :length ,length + :null-terminated-p ,null-terminated-p)))) + + #+sbcl + (let ((stored-obj (gensym))) + `(let ((,stored-obj ,obj)) + (if (null-pointer-p ,stored-obj) + nil + (sbcl-naturalize-cstring (sb-alien:alien-sap ,stored-obj) + :length ,length + :null-terminated-p ,null-terminated-p)))) + #+(or openmcl digitool) + (declare (ignore null-terminated-p)) + #+(or openmcl digitool) + (let ((stored-obj (gensym))) + `(let ((,stored-obj ,obj)) + (if (ccl:%null-ptr-p ,stored-obj) + nil + #+digitool (ccl:%get-cstring + ,stored-obj 0 + ,@(if length (list length) nil)) + #+openmcl ,@(if length + `((ccl:%str-from-ptr ,stored-obj ,length)) + `((ccl:%get-cstring ,stored-obj)))))) + ) + + +(defmacro allocate-foreign-string (size &key (unsigned t)) + #+ignore + (let ((array-def (gensym))) + `(let ((,array-def (list 'alien:array 'c-call:char ,size))) + (eval `(alien:cast (alien:make-alien ,,array-def) + ,(if ,unsigned + '(* (alien:unsigned 8)) + '(* (alien:signed 8))))))) + + #+(or cmu scl) + `(alien:make-alien ,(if unsigned + '(alien:unsigned 8) + '(alien:signed 8)) + ,size) + + #+sbcl + `(sb-alien:make-alien ,(if unsigned + '(sb-alien:unsigned 8) + '(sb-alien:signed 8)) + ,size) + + #+lispworks + `(fli:allocate-foreign-object :type + ,(if unsigned + ''(:unsigned :char) + :char) + :nelems ,size) + #+allegro + (declare (ignore unsigned)) + #+allegro + `(ff:allocate-fobject :char :c ,size) + #+(or openmcl digitool) + (declare (ignore unsigned)) + #+(or openmcl digitool) + `(new-ptr ,size) + ) + +(defun foreign-string-length (foreign-string) + #+allegro `(ff:foreign-strlen ,foreign-string) + #-allegro + `(loop with size = 0 + until (char= (deref-array ,foreign-string '(:array :unsigned-char) size) #\Null) + do (incf size) + finally return size)) + + +(defmacro with-foreign-string ((foreign-string lisp-string) &body body) + (let ((result (gensym))) + `(let* ((,foreign-string (convert-to-foreign-string ,lisp-string)) + (,result (progn ,@body))) + (declare (dynamic-extent ,foreign-string)) + (free-foreign-object ,foreign-string) + ,result))) + +(defmacro with-foreign-strings (bindings &body body) + `(with-foreign-string ,(car bindings) + ,@(if (cdr bindings) + `((with-foreign-strings ,(cdr bindings) ,@body)) + body))) + +;; Modified from CMUCL's source to handle non-null terminated strings +#+cmu +(defun cmucl-naturalize-cstring (sap &key length (null-terminated-p t)) + (declare (type system:system-area-pointer sap)) + (locally + (declare (optimize (speed 3) (safety 0))) + (let ((null-terminated-length + (when null-terminated-p + (loop + for offset of-type fixnum upfrom 0 + until (zerop (system:sap-ref-8 sap offset)) + finally (return offset))))) + (if length + (if (and null-terminated-length + (> (the fixnum length) (the fixnum null-terminated-length))) + (setq length null-terminated-length)) + (setq length null-terminated-length))) + (let ((result (make-string length))) + (kernel:copy-from-system-area sap 0 + result (* vm:vector-data-offset + vm:word-bits) + (* length vm:byte-bits)) + result))) + +#+scl +;; kernel:copy-from-system-area doesn't work like it does on CMUCL or SBCL, +;; so have to iteratively copy from sap +(defun cmucl-naturalize-cstring (sap &key length (null-terminated-p t)) + (declare (type system:system-area-pointer sap)) + (locally + (declare (optimize (speed 3) (safety 0))) + (let ((null-terminated-length + (when null-terminated-p + (loop + for offset of-type fixnum upfrom 0 + until (zerop (system:sap-ref-8 sap offset)) + finally (return offset))))) + (if length + (if (and null-terminated-length + (> (the fixnum length) (the fixnum null-terminated-length))) + (setq length null-terminated-length)) + (setq length null-terminated-length))) + (let ((result (make-string length))) + (dotimes (i length) + (declare (type fixnum i)) + (setf (char result i) (code-char (system:sap-ref-8 sap i)))) + result))) + +#+(and sbcl (not sb-unicode)) +(defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t)) + (declare (type sb-sys:system-area-pointer sap) + (type (or null fixnum) length)) + (locally + (declare (optimize (speed 3) (safety 0))) + (let ((null-terminated-length + (when null-terminated-p + (loop + for offset of-type fixnum upfrom 0 + until (zerop (sb-sys:sap-ref-8 sap offset)) + finally (return offset))))) + (if length + (if (and null-terminated-length + (> (the fixnum length) (the fixnum null-terminated-length))) + (setq length null-terminated-length)) + (setq length null-terminated-length))) + (let ((result (make-string length))) + (funcall *system-copy-fn* sap 0 result +system-copy-offset+ + (* length +system-copy-multiplier+)) + result))) + +#+(and sbcl sb-unicode) +(defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t)) + (declare (type sb-sys:system-area-pointer sap) + (type (or null fixnum) length)) + (locally + (declare (optimize (speed 3) (safety 0))) + (cond + (null-terminated-p + (let ((casted (sb-alien:cast (sb-alien:sap-alien sap (* char)) + #+sb-unicode sb-alien:utf8-string + #-sb-unicode sb-alien:c-string))) + (if length + (copy-seq (subseq casted 0 length)) + (copy-seq casted)))) + (t + (let ((result (make-string length))) + ;; this will not work in sb-unicode + (funcall *system-copy-fn* sap 0 result +system-copy-offset+ + (* length +system-copy-multiplier+)) + result))))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-function "strlen" + ((str (* :unsigned-char))) + :returning :unsigned-int)) + +(def-type char-ptr-def (* :unsigned-char)) + +#+(or (and allegro (not ics)) (and lispworks (not lispworks5))) +(defun fast-native-to-string (s len) + (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0)) + (type char-ptr-def s)) + (let* ((len (or len (strlen s))) + (str (make-string len))) + (declare (fixnum len) + (type (simple-array #+lispworks base-char + #-lispworks (signed-byte 8) (*)) str)) + (dotimes (i len str) + (setf (aref str i) + (uffi:deref-array s '(:array :char) i))))) + +#+(or (and allegro ics) lispworks5) +(defun fast-native-to-string (s len) + (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0)) + (type char-ptr-def s)) + (let* ((len (or len (strlen s))) + (str (make-string len))) + (dotimes (i len str) + (setf (schar str i) (code-char (uffi:deref-array s '(:array :unsigned-byte) i)))))) Added: branches/trunk-reorg/thirdparty/uffi/tests/Makefile ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/Makefile Mon Feb 11 09:06:27 2008 @@ -0,0 +1,30 @@ +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for UFFI examples +# Programer: Kevin M. Rosenberg +# Date Started: Mar 2002 +# +# CVS Id: $Id$ +# +# This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg + +SUBDIRS= + +include ../Makefile.common + +base=uffi-c-test +source=$(base).c +object=$(base).o +shared_lib=$(base).so + +.PHONY: all +all: $(shared_lib) + +$(shared_lib): $(source) Makefile + BASE=$(base) OBJECT=$(object) SOURCE=$(source) SHARED_LIB=$(shared_lib) sh make.sh + rm $(object) + +.PHONY: distclean +distclean: clean + rm -f $(base).dylib $(base).dylib $(base).so $(base).o Added: branches/trunk-reorg/thirdparty/uffi/tests/Makefile.msvc ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/Makefile.msvc Mon Feb 11 09:06:27 2008 @@ -0,0 +1,28 @@ +# FILE IDENTIFICATION +# +# Name: Makefile.msvc +# Purpose: Makefile for the CLSQL UFFI helper package (MSVC) +# Programer: Kevin M. Rosenberg +# Date Started: Mar 2002 +# +# CVS Id: $Id: Makefile.msvc,v 1.1 2002/03/23 10:26:03 kevin Exp $ +# +# This file, part of CLSQL, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +# + +BASE=c-test-fns + +# Nothing to configure beyond here + +SRC=$(BASE).c +OBJ=$(BASE).obj +DLL=$(BASE).dll + +$(DLL): $(SRC) + cl /MD /LD -D_MT /DWIN32=1 $(SRC) + del $(OBJ) $(BASE).exp + +clean: + del /q $(DLL) + + Added: branches/trunk-reorg/thirdparty/uffi/tests/arrays.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/arrays.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,57 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: arrays.lisp +;;;; Purpose: UFFI test arrays +;;;; Author: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:uffi-tests) + +(uffi:def-constant +column-length+ 10) +(uffi:def-constant +row-length+ 10) + +(uffi:def-foreign-type long-ptr (* :long)) + +(deftest :array.1 + (let ((a (uffi:allocate-foreign-object :long +column-length+)) + (results nil)) + (dotimes (i +column-length+) + (setf (uffi:deref-array a '(:array :long) i) (* i i))) + (dotimes (i +column-length+) + (push (uffi:deref-array a '(:array :long) i) results)) + (uffi:free-foreign-object a) + (nreverse results)) + (0 1 4 9 16 25 36 49 64 81)) + + +(deftest :array.2 + (let ((a (uffi:allocate-foreign-object 'long-ptr +row-length+)) + (results nil)) + (dotimes (r +row-length+) + (declare (fixnum r)) + (setf (uffi:deref-array a '(:array (* :long)) r) + (uffi:allocate-foreign-object :long +column-length+)) + (let ((col (uffi:deref-array a '(:array (* :long)) r))) + (dotimes (c +column-length+) + (declare (fixnum c)) + (setf (uffi:deref-array col '(:array :long) c) (+ (* r +column-length+) c))))) + + (dotimes (r +row-length+) + (declare (fixnum r)) + (let ((col (uffi:deref-array a '(:array (* :long)) r))) + (dotimes (c +column-length+) + (declare (fixnum c)) + (push (uffi:deref-array col '(:array :long) c) results)))) + (uffi:free-foreign-object a) + (nreverse results)) + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99)) + + Added: branches/trunk-reorg/thirdparty/uffi/tests/atoifl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/atoifl.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,42 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: atoifl.lisp +;;;; Purpose: UFFI Example file to atoi/atof/atol +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:uffi-tests) + +(uffi:def-function ("atoi" c-atoi) + ((str :cstring)) + :returning :int) + +(uffi:def-function ("atol" c-atol) + ((str :cstring)) + :returning :long) + +(uffi:def-function ("atof" c-atof) + ((str :cstring)) + :returning :double) + +(defun atoi (str) + "Returns a int from a string." + (uffi:with-cstring (str-cstring str) + (c-atoi str-cstring))) + +(defun atof (str) + "Returns a double float from a string." + (uffi:with-cstring (str-cstring str) + (c-atof str-cstring))) + +(deftest :atoi.1 (atoi "123") 123) +(deftest :atoi.2 (atoi "") 0) +(deftest :atof.3 (atof "2.23") 2.23d0) Added: branches/trunk-reorg/thirdparty/uffi/tests/casts.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/casts.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,51 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICAION +;;;; +;;;; Name: casts.lisp +;;;; Purpose: Tests of with-cast-pointer +;;;; Programmer: Kevin M. Rosenberg / Edi Weitz +;;;; Date Started: Aug 2003 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2003-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:uffi-tests) + +(uffi:def-function ("cast_test_int" cast-test-int) + () + :module "uffi_tests" + :returning :pointer-void) + +(uffi:def-function ("cast_test_float" cast-test-float) + () + :module "uffi_tests" + :returning :pointer-void) + +(deftest :cast.1 + (progn + (uffi:with-cast-pointer (temp (cast-test-int) :int) + (assert (= (uffi:deref-pointer temp :int) 23))) + (let ((result (cast-test-int))) + (uffi:with-cast-pointer (result2 result :int) + (assert (= (uffi:deref-pointer result2 :int) 23))) + (uffi:with-cast-pointer (temp result :int) + (assert (= (uffi:deref-pointer temp :int) 23)))) + t) + t) + +(deftest :cast.2 + (progn + (uffi:with-cast-pointer (temp (cast-test-float) :double) + (assert (= (uffi:deref-pointer temp :double) 3.21d0))) + (let ((result (cast-test-float))) + (uffi:with-cast-pointer (result2 result :double) + (assert (= (uffi:deref-pointer result2 :double) 3.21d0))) + (uffi:with-cast-pointer (temp result :double) + (assert (= (uffi:deref-pointer temp :double) 3.21d0)))) + t) + t) + Added: branches/trunk-reorg/thirdparty/uffi/tests/compress.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/compress.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,92 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: compress.lisp +;;;; Purpose: UFFI Example file for zlib compression +;;;; Author: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:uffi-tests) + +(uffi:def-function ("compress" c-compress) + ((dest (* :unsigned-char)) + (destlen (* :long)) + (source :cstring) + (source-len :long)) + :returning :int + :module "zlib") + +(defun compress (source) + "Returns two values: array of bytes containing the compressed data + and the numbe of compressed bytes" + (let* ((sourcelen (length source)) + (destsize (+ 12 (ceiling (* sourcelen 1.01)))) + (dest (uffi:allocate-foreign-string destsize :unsigned t)) + (destlen (uffi:allocate-foreign-object :long))) + (setf (uffi:deref-pointer destlen :long) destsize) + (uffi:with-cstring (source-native source) + (let ((result (c-compress dest destlen source-native sourcelen)) + (newdestlen (uffi:deref-pointer destlen :long))) + (unwind-protect + (if (zerop result) + (values (uffi:convert-from-foreign-usb8 + dest newdestlen) + newdestlen) + (error "zlib error, code ~D" result)) + (progn + (uffi:free-foreign-object destlen) + (uffi:free-foreign-object dest))))))) + +(uffi:def-function ("uncompress" c-uncompress) + ((dest (* :unsigned-char)) + (destlen (* :long)) + (source :cstring) + (source-len :long)) + :returning :int + :module "zlib") + +(defun uncompress (source) + (let* ((sourcelen (length source)) + (destsize 200000) ;adjust as needed + (dest (uffi:allocate-foreign-string destsize :unsigned t)) + (destlen (uffi:allocate-foreign-object :long))) + (setf (uffi:deref-pointer destlen :long) destsize) + (uffi:with-cstring (source-native source) + (let ((result (c-uncompress dest destlen source-native sourcelen)) + (newdestlen (uffi:deref-pointer destlen :long))) + (unwind-protect + (if (zerop result) + (uffi:convert-from-foreign-string + dest + :length newdestlen + :null-terminated-p nil) + (error "zlib error, code ~D" result)) + (progn + (uffi:free-foreign-object destlen) + (uffi:free-foreign-object dest))))))) + +(deftest :compress.1 (compress "") + #(120 156 3 0 0 0 0 1) 8) +(deftest :compress.2 (compress "test") + #(120 156 43 73 45 46 1 0 4 93 1 193) 12) +(deftest :compress.3 (compress "test2") + #(120 156 43 73 45 46 49 2 0 6 80 1 243) 13) + +(defun compress-uncompress (str) + (multiple-value-bind (compressed len) (compress str) + (declare (ignore len)) + (multiple-value-bind (uncompressed len2) (uncompress compressed) + (declare (ignore len2)) + uncompressed))) + + +(deftest :uncompress.1 "" "") +(deftest :uncompress.2 "test" "test") +(deftest :uncompress.3 "test2" "test2") Added: branches/trunk-reorg/thirdparty/uffi/tests/foreign-loader.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/foreign-loader.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,47 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: foreign-loader.lisp +;;;; Purpose: Loads foreign libraries +;;;; Author: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +;;; For CMUCL, it's necessary to load foreign files separate from their +;;; usage + +(in-package uffi-tests) + +#+clisp (uffi:load-foreign-library "/usr/lib/libz.so" :module "z") +#-clisp +(unless (uffi:load-foreign-library + (uffi:find-foreign-library + #-(or macosx darwin) + "libz" + #+(or macosx darwin) + "z" + (list (pathname-directory *load-pathname*) + "/usr/local/lib/" #+(or 64bit x86-64) "/usr/lib64/" + "/usr/lib/" "/zlib/")) + :module "zlib" + :supporting-libraries '("c")) + (warn "Unable to load zlib")) + +#+clisp (uffi:load-foreign-library "/home/kevin/debian/src/uffi/tests/uffi-c-test.so" :module "uffi_tests") +#-clisp +(unless (uffi:load-foreign-library + (uffi:find-foreign-library + '(#+(or 64bit x86-64) "uffi-c-test64" "uffi-c-test") + (list (pathname-directory *load-truename*) + "/usr/lib/uffi/" + "/home/kevin/debian/src/uffi/tests/")) + :supporting-libraries '("c") + :module "uffi_tests") + (warn "Unable to load uffi-c-test library")) + Added: branches/trunk-reorg/thirdparty/uffi/tests/foreign-var.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/foreign-var.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,88 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: foreign-var +;;;; Purpose: Tests of foreign variables +;;;; Authors: Kevin M. Rosenberg and Edi Weitz +;;;; Date Started: Aug 2003 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2003-2005 by Kevin M. Rosenberg +;;; +;;;; ************************************************************************* + +(in-package #:uffi-tests) + +(def-foreign-var "uchar_13" :unsigned-byte "uffi_tests") +(def-foreign-var "schar_neg_120" :byte "uffi_tests") +(def-foreign-var "uword_257" :unsigned-short "uffi_tests") +(def-foreign-var "sword_neg_321" :short "uffi_tests") +(def-foreign-var "uint_1234567" :int "uffi_tests") +(def-foreign-var "sint_neg_123456" :int "uffi_tests") +(def-foreign-var "float_neg_4_5" :float "uffi_tests") +(def-foreign-var "double_3_1" :double "uffi_tests") + +(deftest :fvar.1 uchar-13 13) +(deftest :fvar.2 schar-neg-120 -120) +(deftest :fvar.3 uword-257 257) +(deftest :fvar.4 sword-neg-321 -321) +(deftest :fvar.5 uint-1234567 1234567) +(deftest :fvar.6 sint-neg-123456 -123456) +(deftest :fvar.7 float-neg-4-5 -4.5f0) +(deftest :fvar.8 double-3-1 3.1d0) + +(uffi:def-foreign-var ("fvar_addend" *fvar-addend*) :int "uffi_tests") + +(uffi:def-struct fvar-struct + (i :int) + (d :double)) + +(uffi:def-foreign-var ("fvar_struct" *fvar-struct*) fvar-struct + "uffi_tests") + +(uffi:def-function ("fvar_struct_int" fvar-struct-int) + () + :returning :int + :module "uffi_tests") + + (uffi:def-function ("fvar_struct_double" fvar-struct-double) + () + :returning :double + :module "uffi_tests") + +(deftest :fvarst.1 *fvar-addend* 3) +(deftest :fvarst.2 (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i) 42) +(deftest :fvarst.3 (= (+ *fvar-addend* + (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i)) + (fvar-struct-int)) + t) +(deftest :fvarst.4 (uffi:get-slot-value *fvar-struct* 'fvar-struct 'd) 3.2d0) +(deftest :fvarst.5 (= (uffi:get-slot-value *fvar-struct* 'fvar-struct 'd) + (fvar-struct-double)) + t) + +(deftest fvarst.6 + (let ((orig *fvar-addend*)) + (incf *fvar-addend* 3) + (prog1 + *fvar-addend* + (setf *fvar-addend* orig))) + 6) + +(deftest fvarst.7 + (let ((orig *fvar-addend*)) + (incf *fvar-addend* 3) + (prog1 + (fvar-struct-int) + (setf *fvar-addend* orig))) + 48) + +(deftest fvarst.8 + (let ((orig (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i))) + (decf (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i) 10) + (prog1 + (fvar-struct-int) + (setf (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i) orig))) + 35) Added: branches/trunk-reorg/thirdparty/uffi/tests/getenv.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/getenv.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,64 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: getenv.lisp +;;;; Purpose: UFFI Example file to get environment variable +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:uffi-tests) + + +(uffi:def-function ("getenv" c-getenv) + ((name :cstring)) + :returning :cstring) + +(uffi:def-function ("setenv" c-setenv) + ((name :cstring) + (value :cstring) + (overwrite :int)) + :returning :int) + +(uffi:def-function ("unsetenv" c-unsetenv) + ((name :cstring)) + :returning :void) + +(defun my-getenv (key) + "Returns an environment variable, or NIL if it does not exist" + (check-type key string) + (uffi:with-cstring (key-native key) + (uffi:convert-from-cstring (c-getenv key-native)))) + +(defun my-setenv (key name &optional (overwrite t)) + "Returns an environment variable, or NIL if it does not exist" + (check-type key string) + (check-type name string) + (setq overwrite (if overwrite 1 0)) + (uffi:with-cstrings ((key-native key) + (name-native name)) + (c-setenv key-native name-native (if overwrite 1 0)))) + +(defun my-unsetenv (key) + "Returns an environment variable, or NIL if it does not exist" + (check-type key string) + (uffi:with-cstrings ((key-native key)) + (c-unsetenv key-native))) + +(deftest :getenv.1 (progn + (my-unsetenv "__UFFI_FOO1__") + (my-getenv "__UFFI_FOO1__")) + nil) +(deftest :getenv.2 (progn + (my-setenv "__UFFI_FOO1__" "UFFI-TEST") + (my-getenv "__UFFI_FOO1__")) + "UFFI-TEST") + + + Added: branches/trunk-reorg/thirdparty/uffi/tests/gethostname.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/gethostname.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,52 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: gethostname.lisp +;;;; Purpose: UFFI Example file to get hostname of system +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:uffi-tests) + + +;;; This example is inspired by the example on the CL-Cookbook web site + +(eval-when (:compile-toplevel :load-toplevel :execute) + (uffi:def-function ("gethostname" c-gethostname) + ((name (* :unsigned-char)) + (len :int)) + :returning :int) + + (defun gethostname () + "Returns the hostname" + (let* ((name (uffi:allocate-foreign-string 256)) + (result-code (c-gethostname name 256)) + (hostname (when (zerop result-code) + (uffi:convert-from-foreign-string name)))) + (uffi:free-foreign-object name) + (unless (zerop result-code) + (error "gethostname() failed.")) + hostname)) + + (defun gethostname2 () + "Returns the hostname" + (uffi:with-foreign-object (name '(:array :unsigned-char 256)) + (if (zerop (c-gethostname (uffi:char-array-to-pointer name) 256)) + (uffi:convert-from-foreign-string name) + (error "gethostname() failed."))))) + +(deftest :gethostname.1 (stringp (gethostname)) t) +(deftest :gethostname.2 (stringp (gethostname2)) t) +(deftest :gethostname.3 (plusp (length (gethostname))) t) +(deftest :gethostname.4 (plusp (length (gethostname2))) t) +(deftest :gethostname.5 (string= (gethostname) (gethostname2)) t) + + + Added: branches/trunk-reorg/thirdparty/uffi/tests/make.sh ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/make.sh Mon Feb 11 09:06:27 2008 @@ -0,0 +1,45 @@ +#!/bin/sh + +case "`uname`" in + Linux) os_linux=1 ;; + FreeBSD) os_freebsd=1 ;; + GNU/kFreeBSD) os_gnukfreebsd=1;; + Darwin) os_darwin=1 ;; + SunOS) os_sunos=1 ;; + AIX) os_aix=1 ;; + GNU) os_gnu=1 ;; + *) echo "Unable to identify uname " `uname` + exit 1 ;; +esac + +if [ "$os_linux" ]; then + gcc -fPIC -DPIC -c $SOURCE -o $OBJECT + gcc -shared $OBJECT -o $SHARED_LIB + +elif [ "$os_gnu" ]; then + gcc -fPIC -DPIC -c $SOURCE -o $OBJECT + gcc -shared $OBJECT -o $SHARED_LIB + +elif [ "$os_freebsd" ]; then + gcc -fPIC -DPIC -c $SOURCE -o $OBJECT + gcc -shared $OBJECT -o $SHARED_LIB + +elif [ "$os_gnukfreebsd" ]; then + gcc -fPIC -DPIC -c $SOURCE -o $OBJECT + gcc -shared $OBJECT -o $SHARED_LIB + +elif [ "$os_darwin" ]; then + cc -dynamic -c $SOURCE -o $OBJECT + ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress -o $BASE.dylib $OBJECT + ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress /usr/lib/libz.dylib -o z.dylib + +elif [ "$os_sunos" ]; then + cc -KPIC -c $SOURCE -o $OBJECT + cc -G $OBJECT -o $SHARED_LIB + +elif [ "$os_aix" ]; then + gcc -c -D_BSD -D_NO_PROTO -D_NONSTD_TYPES -D_MBI=void $SOURCE + make_shared -o $SHARED_LIB $OBJECT +fi + +exit 0 Added: branches/trunk-reorg/thirdparty/uffi/tests/objects.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/objects.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,70 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: pointers.lisp +;;;; Purpose: Test file for UFFI pointers +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Aug 2003 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2003-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:uffi-tests) + +(deftest :chptr.1 + (let ((native-string "test string")) + (uffi:with-foreign-string (fs native-string) + (ensure-char-character + (deref-pointer fs :char)))) + #\t) + +(deftest :chptr.2 + (let ((native-string "test string")) + (uffi:with-foreign-string (fs native-string) + (ensure-char-character + (deref-pointer fs :unsigned-char)))) + #\t) + +(deftest :chptr.3 + (let ((native-string "test string")) + (uffi:with-foreign-string (fs native-string) + (ensure-char-integer + (deref-pointer fs :unsigned-char)))) + 116) + +(deftest :chptr.4 + (let ((native-string "test string")) + (uffi:with-foreign-string (fs native-string) + (integerp + (ensure-char-integer + (deref-pointer fs :unsigned-char))))) + t) + +(deftest :chptr.5 + (let ((fs (uffi:allocate-foreign-object :unsigned-char 128))) + (setf (uffi:deref-array fs '(:array :unsigned-char) 0) + (uffi:ensure-char-storable #\a)) + (setf (uffi:deref-array fs '(:array :unsigned-char) 1) + (uffi:ensure-char-storable (code-char 0))) + (uffi:convert-from-foreign-string fs)) + "a") + +;; This produces an array which needs fli:foreign-aref to access +;; rather than fli:dereference + +#-lispworks +(deftest :chptr.6 + (uffi:with-foreign-object (fs '(:array :unsigned-char 128)) + (setf (uffi:deref-array fs '(:array :unsigned-char) 0) + (uffi:ensure-char-storable #\a)) + (setf (uffi:deref-array fs '(:array :unsigned-char) 1) + (uffi:ensure-char-storable (code-char 0))) + (uffi:convert-from-foreign-string fs)) + "a") + + + Added: branches/trunk-reorg/thirdparty/uffi/tests/package.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/package.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,20 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: package.lisp +;;;; Purpose: Package file uffi testing suite +;;;; Author: Kevin M. Rosenberg +;;;; Date Started: Apr 2003 +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2003-2005 by Kevin M. Rosenberg +;;;; +;;;; $Id$ +;;;; ************************************************************************* + +(defpackage #:uffi-tests + (:use #:asdf #:cl #:uffi #:rtest) + (:shadowing-import-from #:uffi #:run-shell-command)) + +(in-package #:uffi-tests) + Added: branches/trunk-reorg/thirdparty/uffi/tests/rt.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/rt.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,254 @@ +#|----------------------------------------------------------------------------| + | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | + | | + | Permission to use, copy, modify, and distribute this software and its | + | documentation for any purpose and without fee is hereby granted, provided | + | that this copyright and permission notice appear in all copies and | + | supporting documentation, and that the name of M.I.T. not be used in | + | advertising or publicity pertaining to distribution of the software | + | without specific, written prior permission. M.I.T. makes no | + | representations about the suitability of this software for any purpose. | + | It is provided "as is" without express or implied warranty. | + | | + | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | + | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | + | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | + | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | + | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | + | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | + | SOFTWARE. | + |----------------------------------------------------------------------------|# + +(defpackage #:regression-test + (:nicknames #:rtest #-lispworks #:rt) + (:use #:cl) + (:export #:*do-tests-when-defined* #:*test* #:continue-testing + #:deftest #:do-test #:do-tests #:get-test #:pending-tests + #:rem-all-tests #:rem-test) + (:documentation "The MIT regression tester with pfdietz's modifications")) + +(in-package :regression-test) + +(defvar *test* nil "Current test name") +(defvar *do-tests-when-defined* nil) +(defvar *entries* '(nil) "Test database") +(defvar *in-test* nil "Used by TEST") +(defvar *debug* nil "For debugging") +(defvar *catch-errors* t + "When true, causes errors in a test to be caught.") +(defvar *print-circle-on-failure* nil + "Failure reports are printed with *PRINT-CIRCLE* bound to this value.") +(defvar *compile-tests* nil + "When true, compile the tests before running them.") +(defvar *optimization-settings* '((safety 3))) +(defvar *expected-failures* nil + "A list of test names that are expected to fail.") + +(defstruct (entry (:conc-name nil) + (:type list)) + pend name form) + +(defmacro vals (entry) `(cdddr ,entry)) + +(defmacro defn (entry) `(cdr ,entry)) + +(defun pending-tests () + (do ((l (cdr *entries*) (cdr l)) + (r nil)) + ((null l) (nreverse r)) + (when (pend (car l)) + (push (name (car l)) r)))) + +(defun rem-all-tests () + (setq *entries* (list nil)) + nil) + +(defun rem-test (&optional (name *test*)) + (do ((l *entries* (cdr l))) + ((null (cdr l)) nil) + (when (equal (name (cadr l)) name) + (setf (cdr l) (cddr l)) + (return name)))) + +(defun get-test (&optional (name *test*)) + (defn (get-entry name))) + +(defun get-entry (name) + (let ((entry (find name (cdr *entries*) + :key #'name + :test #'equal))) + (when (null entry) + (report-error t + "~%No test with name ~:@(~S~)." + name)) + entry)) + +(defmacro deftest (name form &rest values) + `(add-entry '(t ,name ,form .,values))) + +(defun add-entry (entry) + (setq entry (copy-list entry)) + (do ((l *entries* (cdr l))) (nil) + (when (null (cdr l)) + (setf (cdr l) (list entry)) + (return nil)) + (when (equal (name (cadr l)) + (name entry)) + (setf (cadr l) entry) + (report-error nil + "Redefining test ~:@(~S~)" + (name entry)) + (return nil))) + (when *do-tests-when-defined* + (do-entry entry)) + (setq *test* (name entry))) + +(defun report-error (error? &rest args) + (cond (*debug* + (apply #'format t args) + (if error? (throw '*debug* nil))) + (error? (apply #'error args)) + (t (apply #'warn args)))) + +(defun do-test (&optional (name *test*)) + (do-entry (get-entry name))) + +(defun equalp-with-case (x y) + "Like EQUALP, but doesn't do case conversion of characters." + (cond + ((eq x y) t) + ((consp x) + (and (consp y) + (equalp-with-case (car x) (car y)) + (equalp-with-case (cdr x) (cdr y)))) + ((and (typep x 'array) + (= (array-rank x) 0)) + (equalp-with-case (aref x) (aref y))) + ((typep x 'vector) + (and (typep y 'vector) + (let ((x-len (length x)) + (y-len (length y))) + (and (eql x-len y-len) + (loop + for e1 across x + for e2 across y + always (equalp-with-case e1 e2)))))) + ((and (typep x 'array) + (typep y 'array) + (not (equal (array-dimensions x) + (array-dimensions y)))) + nil) + ((typep x 'array) + (and (typep y 'array) + (let ((size (array-total-size x))) + (loop for i from 0 below size + always (equalp-with-case (row-major-aref x i) + (row-major-aref y i)))))) + (t (eql x y)))) + +(defun do-entry (entry &optional + (s *standard-output*)) + (catch '*in-test* + (setq *test* (name entry)) + (setf (pend entry) t) + (let* ((*in-test* t) + ;; (*break-on-warnings* t) + (aborted nil) + r) + ;; (declare (special *break-on-warnings*)) + + (block aborted + (setf r + (flet ((%do + () + (if *compile-tests* + (multiple-value-list + (funcall (compile + nil + `(lambda () + (declare + (optimize ,@*optimization-settings*)) + ,(form entry))))) + (multiple-value-list + (eval (form entry)))))) + (if *catch-errors* + (handler-bind + ((style-warning #'muffle-warning) + (error #'(lambda (c) + (setf aborted t) + (setf r (list c)) + (return-from aborted nil)))) + (%do)) + (%do))))) + + (setf (pend entry) + (or aborted + (not (equalp-with-case r (vals entry))))) + + (when (pend entry) + (let ((*print-circle* *print-circle-on-failure*)) + (format s "~&Test ~:@(~S~) failed~ + ~%Form: ~S~ + ~%Expected value~P: ~ + ~{~S~^~%~17t~}~%" + *test* (form entry) + (length (vals entry)) + (vals entry)) + (format s "Actual value~P: ~ + ~{~S~^~%~15t~}.~%" + (length r) r))))) + (when (not (pend entry)) *test*)) + +(defun continue-testing () + (if *in-test* + (throw '*in-test* nil) + (do-entries *standard-output*))) + +(defun do-tests (&optional + (out *standard-output*)) + (dolist (entry (cdr *entries*)) + (setf (pend entry) t)) + (if (streamp out) + (do-entries out) + (with-open-file + (stream out :direction :output) + (do-entries stream)))) + +(defun do-entries (s) + (format s "~&Doing ~A pending test~:P ~ + of ~A tests total.~%" + (count t (cdr *entries*) + :key #'pend) + (length (cdr *entries*))) + (dolist (entry (cdr *entries*)) + (when (pend entry) + (format s "~@[~<~%~:; ~:@(~S~)~>~]" + (do-entry entry s)))) + (let ((pending (pending-tests)) + (expected-table (make-hash-table :test #'equal))) + (dolist (ex *expected-failures*) + (setf (gethash ex expected-table) t)) + (let ((new-failures + (loop for pend in pending + unless (gethash pend expected-table) + collect pend))) + (if (null pending) + (format s "~&No tests failed.") + (progn + (format s "~&~A out of ~A ~ + total tests failed: ~ + ~:@(~{~<~% ~1:;~S~>~ + ~^, ~}~)." + (length pending) + (length (cdr *entries*)) + pending) + (if (null new-failures) + (format s "~&No unexpected failures.") + (when *expected-failures* + (format s "~&~A unexpected failures: ~ + ~:@(~{~<~% ~1:;~S~>~ + ~^, ~}~)." + (length new-failures) + new-failures))) + )) + (null pending)))) Added: branches/trunk-reorg/thirdparty/uffi/tests/strtol.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/strtol.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,64 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: strtol.lisp +;;;; Purpose: UFFI Example file to strtol, uses pointer arithmetic +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:uffi-tests) + +(uffi:def-foreign-type char-ptr (* :unsigned-char)) + +;; This example does not use :cstring to pass the input string since +;; the routine needs to do pointer arithmetic to see how many characters +;; were parsed + +(uffi:def-function ("strtol" c-strtol) + ((nptr char-ptr) + (endptr (* char-ptr)) + (base :int)) + :returning :long) + +(defun strtol (str &optional (base 10)) + "Returns a long int from a string. Returns number and condition flag. +Condition flag is T if all of string parses as a long, NIL if +their was no string at all, or an integer indicating position in string +of first non-valid character" + (let* ((str-native (uffi:convert-to-foreign-string str)) + (endptr (uffi:allocate-foreign-object 'char-ptr)) + (value (c-strtol str-native endptr base)) + (endptr-value (uffi:deref-pointer endptr 'char-ptr))) + + (unwind-protect + (if (uffi:null-pointer-p endptr-value) + (values value t) + (let ((next-char-value (uffi:deref-pointer endptr-value :unsigned-char)) + (chars-parsed (- (uffi:pointer-address endptr-value) + (uffi:pointer-address str-native)))) + (cond + ((zerop chars-parsed) + (values nil nil)) + ((uffi:null-char-p next-char-value) + (values value t)) + (t + (values value chars-parsed))))) + (progn + (uffi:free-foreign-object str-native) + (uffi:free-foreign-object endptr))))) + +(deftest :strtol.1 (strtol "123") 123 t) +(deftest :strtol.2 (strtol "0") 0 t) +(deftest :strtol.3 (strtol "55a") 55 2) +(deftest :strtol.4 (strtol "a") nil nil) + + + + Added: branches/trunk-reorg/thirdparty/uffi/tests/structs.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/structs.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,36 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: structs.lisp +;;;; Purpose: Test file for UFFI structures +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:uffi-tests) + +;; Compilation failure as reported by Edi Weitz + + +(uffi:def-struct foo + (bar :pointer-self)) + +(uffi:def-foreign-type foo-ptr (* foo)) + +;; tests that compilation worked +(deftest :structs.1 + (with-foreign-object (p 'foo) + t) + t) + +(deftest :structs.2 + (progn + (uffi:def-foreign-type foo-struct (:struct foo)) + t) + t) Added: branches/trunk-reorg/thirdparty/uffi/tests/time.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/time.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,110 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: time.lisp +;;;; Purpose: UFFI test file, time, use C structures +;;;; Author: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:uffi-tests) + +(uffi:def-foreign-type time-t :unsigned-long) + +(uffi:def-struct tm + (sec :int) + (min :int) + (hour :int) + (mday :int) + (mon :int) + (year :int) + (wday :int) + (yday :int) + (isdst :int) + ;; gmoffset present on SusE SLES9 + (gmoffset :long)) + +(uffi:def-function ("time" c-time) + ((time (* time-t))) + :returning time-t) + +(uffi:def-function "gmtime" + ((time (* time-t))) + :returning (:struct-pointer tm)) + +(uffi:def-function "asctime" + ((time (:struct-pointer tm))) + :returning :cstring) + +(uffi:def-type time-t :unsigned-long) +(uffi:def-type tm-pointer (:struct-pointer tm)) + +(deftest :time.1 + (uffi:with-foreign-object (time 'time-t) + (setf (uffi:deref-pointer time :unsigned-long) 7381) + (uffi:deref-pointer time :unsigned-long)) + 7381) + +(deftest :time.2 + (uffi:with-foreign-object (time 'time-t) + (setf (uffi:deref-pointer time :unsigned-long) 7381) + (let ((tm-ptr (the tm-pointer (gmtime time)))) + (values (1+ (uffi:get-slot-value tm-ptr 'tm 'mon)) + (uffi:get-slot-value tm-ptr 'tm 'mday) + (+ 1900 (uffi:get-slot-value tm-ptr 'tm 'year)) + (uffi:get-slot-value tm-ptr 'tm 'hour) + (uffi:get-slot-value tm-ptr 'tm 'min) + (uffi:get-slot-value tm-ptr 'tm 'sec) + ))) + 1 1 1970 2 3 1) + + +(uffi:def-struct timeval + (secs :long) + (usecs :long)) + +(uffi:def-struct timezone + (minutes-west :int) + (dsttime :int)) + +(uffi:def-function ("gettimeofday" c-gettimeofday) + ((tv (* timeval)) + (tz (* timezone))) + :returning :int) + +(defun get-utime () + (uffi:with-foreign-object (tv 'timeval) + (let ((res (c-gettimeofday tv (uffi:make-null-pointer 'timezone)))) + (values + (+ (* 1000000 (uffi:get-slot-value tv 'timeval 'secs)) + (uffi:get-slot-value tv 'timeval 'usecs)) + res)))) + +(deftest :timeofday.1 + (multiple-value-bind (t1 res1) (get-utime) + (multiple-value-bind (t2 res2) (get-utime) + (and (or (= t2 t1) (> t2 t1)) + (> t1 1000000000) + (> t2 1000000000) + (zerop res1) + (zerop res2)))) + t) + +(defun posix-time-to-asctime (secs) + "Converts number of seconds elapsed since 00:00:00 on January 1, 1970, Coordinated Universal Time (UTC)" + (string-right-trim + '(#\newline #\return) + (uffi:convert-from-cstring + (uffi:with-foreign-object (time 'time-t) + (setf (uffi:deref-pointer time :unsigned-long) secs) + (asctime (gmtime time)))))) + +(deftest :time.3 + (posix-time-to-asctime 0) + "Thu Jan 1 00:00:00 1970") Added: branches/trunk-reorg/thirdparty/uffi/tests/uffi-c-test-lib.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/uffi-c-test-lib.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,98 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: uffi-c-test-lib.lisp +;;;; Purpose: UFFI Example file for zlib compression +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:uffi-tests) + + +(uffi:def-function ("cs_to_upper" cs-to-upper) + ((input (* :unsigned-char))) + :returning :void + :module "uffi_tests") + +(defun string-to-upper (str) + (uffi:with-foreign-string (str-foreign str) + (cs-to-upper str-foreign) + (uffi:convert-from-foreign-string str-foreign))) + +(uffi:def-function ("cs_count_upper" cs-count-upper) + ((input :cstring)) + :returning :int + :module "uffi_tests") + +(defun string-count-upper (str) + (uffi:with-cstring (str-cstring str) + (cs-count-upper str-cstring))) + +(uffi:def-function ("half_double_vector" half-double-vector) + ((size :int) + (vec (* :double))) + :returning :void + :module "uffi_tests") + +(uffi:def-function ("return_long_negative_one" return-long-negative-one) + () + :returning :long + :module "uffi_tests") + +(uffi:def-function ("return_int_negative_one" return-int-negative-one) + () + :returning :int + :module "uffi_tests") + +(uffi:def-function ("return_short_negative_one" return-short-negative-one) + () + :returning :short + :module "uffi_tests") + + +(uffi:def-constant +double-vec-length+ 10) +(defun test-half-double-vector () + (let ((vec (uffi:allocate-foreign-object :double +double-vec-length+)) + results) + (dotimes (i +double-vec-length+) + (setf (uffi:deref-array vec '(:array :double) i) + (coerce i 'double-float))) + (half-double-vector +double-vec-length+ vec) + (dotimes (i +double-vec-length+) + (push (uffi:deref-array vec '(:array :double) i) results)) + (uffi:free-foreign-object vec) + (nreverse results))) + +(defun t2 () + (let ((vec (make-array +double-vec-length+ :element-type 'double-float))) + (dotimes (i +double-vec-length+) + (setf (aref vec i) (coerce i 'double-float))) + (half-double-vector +double-vec-length+ vec) + vec)) + +#+(or cmu scl) +(defun t3 () + (let ((vec (make-array +double-vec-length+ :element-type 'double-float))) + (dotimes (i +double-vec-length+) + (setf (aref vec i) (coerce i 'double-float))) + (system:without-gcing + (half-double-vector +double-vec-length+ (system:vector-sap vec))) + vec)) + +(deftest :c-test.1 (string-to-upper "this is a test") "THIS IS A TEST") +(deftest :c-test.2 (string-to-upper nil) nil) +(deftest :c-test.3 (string-count-upper "This is a Test") 2) +(deftest :c-test.4 (string-count-upper nil) -1) +(deftest :c-test.5 (test-half-double-vector) + (0.0d0 0.5d0 1.0d0 1.5d0 2.0d0 2.5d0 3.0d0 3.5d0 4.0d0 4.5d0)) +(deftest :c-test.6 (return-long-negative-one) -1) +(deftest :c-test.7 (return-int-negative-one) -1) +(deftest :c-test.8 (return-short-negative-one) -1) + Added: branches/trunk-reorg/thirdparty/uffi/tests/uffi-c-test.c ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/uffi-c-test.c Mon Feb 11 09:06:27 2008 @@ -0,0 +1,158 @@ +/*************************************************************************** + * FILE IDENTIFICATION + * + * Name: c-test-fns.c + * Purpose: Test functions in C for UFFI library + * Programer: Kevin M. Rosenberg + * Date Started: Mar 2002 + * + * CVS Id: $Id$ + * + * This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg + * + * These variables are correct for GCC + * you'll need to modify these for other compilers + ***************************************************************************/ + +#ifdef WIN32 +#include <windows.h> + +BOOL WINAPI DllEntryPoint(HINSTANCE hinstdll, + DWORD fdwReason, + LPVOID lpvReserved) +{ + return 1; +} + +#define DLLEXPORT __declspec(dllexport) + +#else +#define DLLEXPORT +#endif + +#include <ctype.h> +#include <stdlib.h> +#include <math.h> + + +DLLEXPORT unsigned char uchar_13 = 13; +DLLEXPORT signed char schar_neg_120 = -120; +DLLEXPORT unsigned short uword_257 = 257; +DLLEXPORT signed short sword_neg_321 = -321; +DLLEXPORT unsigned int uint_1234567 = 1234567; +DLLEXPORT signed int sint_neg_123456 = -123456; +DLLEXPORT double double_3_1 = 3.1; +DLLEXPORT float float_neg_4_5 = -4.5; + +/* Test of constant input string */ +DLLEXPORT +int +cs_count_upper (char* psz) +{ + int count = 0; + + if (psz) { + while (*psz) { + if (isupper (*psz)) + ++count; + ++psz; + } + return count; + } else + return -1; +} + +/* Test of input and output of a string */ +DLLEXPORT +void +cs_to_upper (char* psz) +{ + if (psz) { + while (*psz) { + *psz = toupper (*psz); + ++psz; + } + } +} + +/* Test of an output only string */ +DLLEXPORT +void +cs_make_random (int size, char* buffer) +{ + int i; + for (i = 0; i < size; i++) + buffer[i] = 'A' + (rand() % 26); +} + + +/* Test of input/output vector */ +DLLEXPORT +void +half_double_vector (int size, double* vec) +{ + int i; + for (i = 0; i < size; i++) + vec[i] /= 2.; +} + + + +DLLEXPORT +void * +cast_test_int () { + int *x = (int *) malloc(sizeof(int)); + *x = 23; + return x; +} + +DLLEXPORT +void * +cast_test_float () +{ + double *y = (double *) malloc(sizeof(double)); + *y = 3.21; + return y; +} + +DLLEXPORT +long +return_long_negative_one () +{ + return -1; +} + +DLLEXPORT +int +return_int_negative_one () +{ + return -1; +} + +DLLEXPORT +short +return_short_negative_one () +{ + return -1; +} + +DLLEXPORT int fvar_addend = 3; + +typedef struct { + int i; + double d; +} fvar_struct_type; + +fvar_struct_type fvar_struct = {42, 3.2}; + +DLLEXPORT +int fvar_struct_int () { + return (fvar_addend + fvar_struct.i); +} + +DLLEXPORT +double fvar_struct_double () { + return fvar_struct.d; +} + + Added: branches/trunk-reorg/thirdparty/uffi/tests/union.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/tests/union.lisp Mon Feb 11 09:06:27 2008 @@ -0,0 +1,71 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: union.lisp +;;;; Purpose: UFFI Example file to test unions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:uffi-tests) + +(uffi:def-union tunion1 + (char :char) + (int :int) + (uint :unsigned-int) + (sf :float) + (df :double)) + +(defvar *u* (uffi:allocate-foreign-object 'tunion1)) +(setf (uffi:get-slot-value *u* 'tunion1 'uint) + #-(or sparc sparc-v9 powerpc ppc) + (+ (* 1 (char-code #\A)) + (* 256 (char-code #\B)) + (* 65536 (char-code #\C)) + (* 16777216 128)) + #+(or sparc sparc-v9 powerpc ppc) + (+ (* 16777216 (char-code #\A)) + (* 65536 (char-code #\B)) + (* 256 (char-code #\C)) + (* 1 128))) + +(deftest :union.1 + (uffi:ensure-char-character + (uffi:get-slot-value *u* 'tunion1 'char)) + #\A) + +(deftest :union.2 + (uffi:ensure-char-integer + (uffi:get-slot-value *u* 'tunion1 'char)) + 65) + +#-(or sparc sparc-v9 openmcl digitool) +(deftest :union.3 (plusp (uffi:get-slot-value *u* 'tunion1 'uint)) t) + + +(uffi:def-union foo-u + (bar :pointer-self)) + +(uffi:def-foreign-type foo-u-ptr (* foo-u)) + +;; tests that compilation worked +(deftest :unions.4 + (with-foreign-object (p 'foo-u) + t) + t) + +(deftest :unions.5 + (progn + (uffi:def-foreign-type foo-union (:union foo-u)) + t) + t) + + + + Added: branches/trunk-reorg/thirdparty/uffi/uffi-tests.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/uffi-tests.asd Mon Feb 11 09:06:27 2008 @@ -0,0 +1,95 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: uffi-tests.asd +;;;; Purpose: ASDF system definitionf for uffi testing package +;;;; Author: Kevin M. Rosenberg +;;;; Date Started: Apr 2003 +;;;; +;;;; $Id$ +;;;; ************************************************************************* + +(defpackage #:uffi-tests-system + (:use #:asdf #:cl)) +(in-package #:uffi-tests-system) + +(operate 'load-op 'uffi) + +(defvar *library-file-dir* (append (pathname-directory *load-truename*) + (list "tests"))) + +(defclass uffi-test-source-file (c-source-file) + ()) + +(defmethod output-files ((o compile-op) (c uffi-test-source-file)) + (let* ((library-file-type + (funcall (intern (symbol-name'#:default-foreign-library-type) + (symbol-name '#:uffi)))) + (found + (some #'(lambda (dir) + (probe-file (make-pathname + :directory dir + :name (component-name c) + :type library-file-type))) + '((:absolute "usr" "lib" "uffi"))))) + (list (if found + found + (make-pathname :name (component-name c) + :type library-file-type + :directory *library-file-dir*))))) + +(defmethod perform ((o load-op) (c uffi-test-source-file)) + nil) ;;; library will be loaded by a loader file + +(defmethod operation-done-p ((o load-op) (c uffi-test-source-file)) + (and (symbol-function (intern (symbol-name '#:cs-count-upper) + (find-package '#:uffi-tests))) + t)) + +(defmethod perform ((o compile-op) (c uffi-test-source-file)) + (unless (operation-done-p o c) + #-(or win32 mswindows) + (unless (zerop (run-shell-command + #-freebsd "cd ~A; make" + #+freebsd "cd ~A; gmake" + (namestring (make-pathname :name nil + :type nil + :directory *library-file-dir*)))) + (error 'operation-error :component c :operation o)))) + +(defmethod operation-done-p ((o compile-op) (c uffi-test-source-file)) + (or (and (probe-file #p"/usr/lib/uffi/uffi-c-test.so") t) + (let ((lib (make-pathname :defaults (component-pathname c) + :type (uffi:default-foreign-library-type)))) + (and (probe-file lib) + (> (file-write-date lib) (file-write-date (component-pathname c))))))) + +(defsystem uffi-tests + :depends-on (:uffi) + :components + ((:module tests + :components + ((:file "rt") + (:file "package" :depends-on ("rt")) + (:uffi-test-source-file "uffi-c-test" :depends-on ("package")) + (:file "strtol" :depends-on ("package")) + (:file "atoifl" :depends-on ("package")) + (:file "getenv" :depends-on ("package")) + (:file "gethostname" :depends-on ("package")) + (:file "union" :depends-on ("package")) + (:file "arrays" :depends-on ("package")) + (:file "structs" :depends-on ("package")) + (:file "objects" :depends-on ("package")) + (:file "time" :depends-on ("package")) + (:file "foreign-loader" :depends-on ("package" "uffi-c-test")) + (:file "uffi-c-test-lib" :depends-on ("foreign-loader")) + (:file "compress" :depends-on ("foreign-loader")) + (:file "casts" :depends-on ("foreign-loader")) + (:file "foreign-var" :depends-on ("foreign-loader")) + )))) + +(defmethod perform ((o test-op) (c (eql (find-system :uffi-tests)))) + (or (funcall (intern (symbol-name '#:do-tests) + (find-package '#:regression-test))) + (error "test-op failed"))) Added: branches/trunk-reorg/thirdparty/uffi/uffi.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/uffi/uffi.asd Mon Feb 11 09:06:27 2008 @@ -0,0 +1,48 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: uffi.asd +;;;; Purpose: ASDF system definition file for UFFI package +;;;; Author: Kevin M. Rosenberg +;;;; Date Started: Aug 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(defpackage #:uffi-system (:use #:asdf #:cl)) +(in-package #:uffi-system) + +#+(or allegro lispworks cmu openmcl digitool cormanlisp sbcl scl) +(defsystem uffi + :name "uffi" + :author "Kevin Rosenberg <kevin(a)rosenberg.net>" + :version "1.2.x" + :maintainer "Kevin M. Rosenberg <kmr(a)debian.org>" + :licence "Lessor Lisp General Public License" + :description "Universal Foreign Function Library for Common Lisp" + :long-description "UFFI provides a universal foreign function interface (FFI) for Common Lisp. UFFI supports CMUCL, Lispworks, and AllegroCL." + + :components + ((:module :src + :components + ((:file "package") + (:file "primitives" :depends-on ("package")) + #+(or openmcl digitool) (:file "readmacros-mcl" :depends-on ("package")) + (:file "objects" :depends-on ("primitives")) + (:file "aggregates" :depends-on ("primitives")) + (:file "strings" :depends-on ("primitives" "functions" "aggregates" "objects")) + (:file "functions" :depends-on ("primitives")) + (:file "libraries" :depends-on ("package")) + (:file "os" :depends-on ("package")))) + )) + +#+(or allegro lispworks cmu openmcl digitool cormanlisp sbcl scl) +(defmethod perform ((o test-op) (c (eql (find-system 'uffi)))) + (oos 'load-op 'uffi-tests) + (oos 'test-op 'uffi-tests :force t)) + +

1 0

[bknr-cvs] r2469 - in branches/trunk-reorg/thirdparty/arnesi: . docs src src/call-cc t
by ksprotte＠common-lisp.net 11 Feb '08

11 Feb '08

Author: ksprotte Date: Mon Feb 11 08:38:43 2008 New Revision: 2469 Added: branches/trunk-reorg/thirdparty/arnesi/ branches/trunk-reorg/thirdparty/arnesi/COPYING branches/trunk-reorg/thirdparty/arnesi/arnesi.asd branches/trunk-reorg/thirdparty/arnesi/docs/ branches/trunk-reorg/thirdparty/arnesi/docs/Makefile branches/trunk-reorg/thirdparty/arnesi/docs/print.css branches/trunk-reorg/thirdparty/arnesi/docs/style.css branches/trunk-reorg/thirdparty/arnesi/src/ branches/trunk-reorg/thirdparty/arnesi/src/accumulation.lisp branches/trunk-reorg/thirdparty/arnesi/src/asdf.lisp branches/trunk-reorg/thirdparty/arnesi/src/bracket-reader.lisp branches/trunk-reorg/thirdparty/arnesi/src/call-cc/ branches/trunk-reorg/thirdparty/arnesi/src/call-cc/apply.lisp branches/trunk-reorg/thirdparty/arnesi/src/call-cc/common-lisp-cc.lisp branches/trunk-reorg/thirdparty/arnesi/src/call-cc/generic-functions.lisp branches/trunk-reorg/thirdparty/arnesi/src/call-cc/handlers.lisp branches/trunk-reorg/thirdparty/arnesi/src/call-cc/interpreter.lisp branches/trunk-reorg/thirdparty/arnesi/src/cl-ppcre-extras.lisp branches/trunk-reorg/thirdparty/arnesi/src/compat.lisp branches/trunk-reorg/thirdparty/arnesi/src/csv.lisp branches/trunk-reorg/thirdparty/arnesi/src/debug.lisp branches/trunk-reorg/thirdparty/arnesi/src/decimal-arithmetic.lisp branches/trunk-reorg/thirdparty/arnesi/src/defclass-struct.lisp branches/trunk-reorg/thirdparty/arnesi/src/flow-control.lisp branches/trunk-reorg/thirdparty/arnesi/src/hash.lisp branches/trunk-reorg/thirdparty/arnesi/src/http.lisp branches/trunk-reorg/thirdparty/arnesi/src/io.lisp branches/trunk-reorg/thirdparty/arnesi/src/lambda-list.lisp branches/trunk-reorg/thirdparty/arnesi/src/lambda.lisp branches/trunk-reorg/thirdparty/arnesi/src/lexenv.lisp branches/trunk-reorg/thirdparty/arnesi/src/lisp1.lisp branches/trunk-reorg/thirdparty/arnesi/src/list.lisp branches/trunk-reorg/thirdparty/arnesi/src/log.lisp branches/trunk-reorg/thirdparty/arnesi/src/matcher.lisp branches/trunk-reorg/thirdparty/arnesi/src/mop.lisp branches/trunk-reorg/thirdparty/arnesi/src/mopp.lisp branches/trunk-reorg/thirdparty/arnesi/src/numbers.lisp branches/trunk-reorg/thirdparty/arnesi/src/one-liners.lisp branches/trunk-reorg/thirdparty/arnesi/src/packages.lisp branches/trunk-reorg/thirdparty/arnesi/src/pf-reader.lisp branches/trunk-reorg/thirdparty/arnesi/src/posixenv.lisp branches/trunk-reorg/thirdparty/arnesi/src/queue.lisp branches/trunk-reorg/thirdparty/arnesi/src/sequence.lisp branches/trunk-reorg/thirdparty/arnesi/src/sharpl-reader.lisp branches/trunk-reorg/thirdparty/arnesi/src/specials.lisp branches/trunk-reorg/thirdparty/arnesi/src/string.lisp branches/trunk-reorg/thirdparty/arnesi/src/time.lisp branches/trunk-reorg/thirdparty/arnesi/src/unwalk.lisp branches/trunk-reorg/thirdparty/arnesi/src/vector.lisp branches/trunk-reorg/thirdparty/arnesi/src/walk.lisp branches/trunk-reorg/thirdparty/arnesi/t/ branches/trunk-reorg/thirdparty/arnesi/t/accumulation.lisp branches/trunk-reorg/thirdparty/arnesi/t/call-cc.lisp branches/trunk-reorg/thirdparty/arnesi/t/csv.lisp branches/trunk-reorg/thirdparty/arnesi/t/flow-control.lisp branches/trunk-reorg/thirdparty/arnesi/t/http.lisp branches/trunk-reorg/thirdparty/arnesi/t/list.lisp branches/trunk-reorg/thirdparty/arnesi/t/log.lisp branches/trunk-reorg/thirdparty/arnesi/t/matcher.lisp branches/trunk-reorg/thirdparty/arnesi/t/numbers.lisp branches/trunk-reorg/thirdparty/arnesi/t/queue.lisp branches/trunk-reorg/thirdparty/arnesi/t/read-macros.lisp branches/trunk-reorg/thirdparty/arnesi/t/sequence.lisp branches/trunk-reorg/thirdparty/arnesi/t/sharpl.lisp branches/trunk-reorg/thirdparty/arnesi/t/string.lisp branches/trunk-reorg/thirdparty/arnesi/t/suite.lisp branches/trunk-reorg/thirdparty/arnesi/t/walk.lisp Log: added arnesi to thirdparty Added: branches/trunk-reorg/thirdparty/arnesi/COPYING ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/COPYING Mon Feb 11 08:38:43 2008 @@ -0,0 +1,30 @@ +Copyright (c) 2002-2006, Edward Marco Baringer +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +- Neither the name of Edward Marco Baringer, nor BESE, nor the names +of its contributors may be used to endorse or promote products derived +from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + Added: branches/trunk-reorg/thirdparty/arnesi/arnesi.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/arnesi.asd Mon Feb 11 08:38:43 2008 @@ -0,0 +1,131 @@ +;;; -*- lisp -*- + +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package :it.bese.arnesi.system) + (defpackage :it.bese.arnesi.system + (:documentation "ASDF System package for ARNESI.") + (:use :common-lisp :asdf)))) + +(in-package :it.bese.arnesi.system) + +(defsystem :arnesi + :components ((:static-file "arnesi.asd") + (:module :src + :components ((:file "accumulation" :depends-on ("packages" "one-liners")) + (:file "asdf" :depends-on ("packages" "io")) + (:file "csv" :depends-on ("packages" "string")) + (:file "compat" :depends-on ("packages")) + (:module :call-cc + :components ((:file "interpreter") + (:file "handlers") + (:file "apply") + (:file "generic-functions") + (:file "common-lisp-cc")) + :serial t + :depends-on ("packages" "walk" "flow-control" "lambda-list" "list" "string" "defclass-struct")) + (:file "debug" :depends-on ("accumulation")) + (:file "decimal-arithmetic" :depends-on ("packages")) + (:file "defclass-struct" :depends-on ("packages" "list")) + (:file "flow-control" :depends-on ("packages" "one-liners")) + (:file "hash" :depends-on ("packages" "list" "one-liners" "string")) + (:file "http" :depends-on ("packages" "vector" "string")) + (:file "io" :depends-on ("packages" "flow-control" "string")) + (:file "lambda" :depends-on ("packages")) + (:file "lambda-list" :depends-on ("packages" "walk")) + (:file "lisp1" :depends-on ("packages" "lambda-list" "one-liners" "walk" "unwalk")) + (:file "lexenv" :depends-on ("packages" "one-liners")) + (:file "list" :depends-on ("packages" "one-liners" "accumulation" "flow-control")) + (:file "log" :depends-on ("packages" "numbers" "hash" "io")) + (:file "matcher" :depends-on ("packages" "hash" "list" "flow-control" "one-liners")) + (:file "mop" :depends-on ("packages" "mopp")) + (:file "mopp" :depends-on ("packages" "list" "flow-control")) + (:file "numbers" :depends-on ("packages")) + (:file "one-liners" :depends-on ("packages")) + (:file "packages") + (:file "pf-reader" :depends-on ("packages")) + (:file "posixenv" :depends-on ("packages")) + (:file "queue" :depends-on ("packages")) + (:file "sequence" :depends-on ("packages")) + (:file "bracket-reader" :depends-on ("list")) + (:file "sharpl-reader" :depends-on ("packages" "flow-control" "mopp")) + (:file "specials" :depends-on ("packages" "hash")) + (:file "string" :depends-on ("packages" "list")) + (:file "time" :depends-on ("packages")) + (:file "unwalk" :depends-on ("packages" "walk")) + (:file "vector" :depends-on ("packages" "flow-control")) + (:file "walk" :depends-on ("packages" "list" "mopp" "lexenv" "one-liners"))))) + :properties ((:features "v1.4.0" "v1.4.1" "v1.4.2" "cc-interpreter" + "join-strings-return-value" "getenv")) + :depends-on (:swank)) + +(defsystem :arnesi.test + :components ((:module :t + :components ((:file "accumulation" :depends-on ("suite")) + (:file "call-cc" :depends-on ("suite")) + (:file "http" :depends-on ("suite")) + (:file "log" :depends-on ("suite")) + (:file "matcher" :depends-on ("suite")) + (:file "numbers" :depends-on ("suite")) + (:file "queue" :depends-on ("suite")) + (:file "read-macros" :depends-on ("suite")) + (:file "string" :depends-on ("suite")) + (:file "sequence" :depends-on ("suite")) + (:file "sharpl" :depends-on ("suite")) + (:file "flow-control" :depends-on ("suite")) + (:file "walk" :depends-on ("suite")) + (:file "csv" :depends-on ("suite")) + (:file "suite")))) + :depends-on (:arnesi :FiveAM) + :in-order-to ((compile-op (load-op :arnesi)))) + +(defsystem :arnesi.cl-ppcre-extras + :components ((:module :src + :components ((:file "cl-ppcre-extras")))) + :depends-on (:cl-ppcre :arnesi)) + +(defmethod perform ((op asdf:test-op) (system (eql (find-system :arnesi)))) + (asdf:oos 'asdf:load-op :arnesi.test) + (funcall (intern (string :run!) (string :it.bese.FiveAM)) + :it.bese.arnesi)) + +(defmethod operation-done-p ((op test-op) (system (eql (find-system :arnesi)))) + nil) + +;;;; * Introduction + +;;;; A collection of various common lisp utilites. + +;;;;@include "src/packages.lisp" + + +;; Copyright (c) 2002-2006 Edward Marco Baringer +;; Copyright (c) 2006 Luca Capello http://luca.pca.it <luca(a)pca.it> +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, Luca Capello, nor +;; BESE, nor the names of its contributors may be used to endorse +;; or promote products derived from this software without specific +;; prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/docs/Makefile ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/docs/Makefile Mon Feb 11 08:38:43 2008 @@ -0,0 +1,30 @@ +# Change this to whatever lisp you'r using +LISP=sbcl +EVAL=--eval +QUIT=(sb-ext:quit) +SYSTEM=ARNESI + +docs: pdf html + +html: + mkdir -p html/ + ${LISP} ${EVAL} "(asdf:oos 'asdf:load-op :qbook)" \ + ${EVAL} "(asdf:oos 'asdf:load-op :${SYSTEM})" \ + ${EVAL} "(asdf:oos 'qbook:publish-op :${SYSTEM} \ + :generator (make-instance 'qbook:html-generator \ + :output-directory \"./html/\" \ + :title \"${SYSTEM}\"))" \ + ${EVAL} "${QUIT}" + +pdf: + mkdir -p pdf/ + ${LISP} ${EVAL} "(asdf:oos 'asdf:load-op :qbook)" \ + ${EVAL} "(asdf:oos 'asdf:load-op :${SYSTEM})" \ + ${EVAL} "(asdf:oos 'qbook:publish-op :${SYSTEM} \ + :generator (make-instance 'qbook:latex-generator \ + :output-file \"./pdf/${SYSTEM}.tex\" \ + :title \"${SYSTEM}\"))" \ + ${EVAL} "${QUIT}" + (cd pdf && pdflatex ${SYSTEM}.tex) + (cd pdf && pdflatex ${SYSTEM}.tex) + rm pdf/${SYSTEM}.aux pdf/${SYSTEM}.log pdf/${SYSTEM}.toc pdf/${SYSTEM}.tex Added: branches/trunk-reorg/thirdparty/arnesi/docs/print.css ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/docs/print.css Mon Feb 11 08:38:43 2008 @@ -0,0 +1,94 @@ +body { + background-color: #FFFFFF; + padding: 0px; margin: 0px; +} + +.qbook { + width: 600px; + background-color: #FFFFFF; + padding: 0em; + margin: 0px; +} + +h1, h2, h3, h4, h5, h6 { + font-family: verdana; +} + +h1 { + text-align: center; + padding: 0px; + margin: 0px; +} + +h2 { + text-align: center; + border-top: 1px solid #000000; + border-bottom: 1px solid #000000; +} + +h3, h4, h5, h6 { + border-bottom: 1px solid #000000; + padding-left: 1em; +} + +h3 { border-top: 1px solid #000000; } + +p { padding-left: 1em; } + +pre.code { + border: solid 1px #FFFFFF; + padding: 2px; + overflow: visible; +} + +pre .first-line-more-link { display: none; } + +pre.code * .paren { color: #666666; } + +pre.code a:active { color: #000000; } +pre.code a:link { color: #000000; } +pre.code a:visited { color: #000000; } + +pre.code .first-line { font-weight: bold; } + +pre.code .body, pre.code * .body { display: inline; } + +div.contents { + font-family: verdana; + border-bottom: 1em solid #333333; + margin-left: -0.5em; +} + +div.contents a:active { color: #000000; } +div.contents a:link { color: #000000; } +div.contents a:visited { color: #000000; } + +div.contents div.contents-heading-1 { padding-left: 0.5em; font-weight: bold; } +div.contents div.contents-heading-1 a:active { color: #333333; } +div.contents div.contents-heading-1 a:link { color: #333333; } +div.contents div.contents-heading-1 a:visited { color: #333333; } + +div.contents div.contents-heading-2 { padding-left: 1.0em; } +div.contents div.contents-heading-2 a:active { color: #333333; } +div.contents div.contents-heading-2 a:link { color: #333333; } +div.contents div.contents-heading-2 a:visited { color: #333333; } + +div.contents div.contents-heading-3 { padding-left: 1.5em; } +div.contents div.contents-heading-3 a:active { color: #333333; } +div.contents div.contents-heading-3 a:link { color: #333333; } +div.contents div.contents-heading-3 a:visited { color: #333333; } + +div.contents div.contents-heading-4 { padding-left: 2em; } +div.contents div.contents-heading-4 a:active { color: #333333; } +div.contents div.contents-heading-4 a:link { color: #333333; } +div.contents div.contents-heading-4 a:visited { color: #333333; } + +div.contents div.contents-heading-5 { padding-left: 2.5em; } +div.contents div.contents-heading-5 a:active { color: #333333; } +div.contents div.contents-heading-5 a:link { color: #333333; } +div.contents div.contents-heading-5 a:visited { color: #333333; } + +.footer { float: bottom-right; color: #000000; font-family: arial; font-size: small; } +.footer a:active { color: #000000; } +.footer a:link { color: #000000; } +.footer a:visited { color: #000000; } Added: branches/trunk-reorg/thirdparty/arnesi/docs/style.css ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/docs/style.css Mon Feb 11 08:38:43 2008 @@ -0,0 +1,107 @@ +body { + background-color: #FFFFFF; + padding: 0px; + margin: 0px; +} + +.qbook { + margin: auto; + background-color: #FFFFFF; + width: 40em; +} + +h1, h2, h3, h4, h5, h6 { + font-family: verdana; +} + +h1 { + text-align: center; + color: #000000; + padding: 0px; + margin: 0px; +} + +h2 { + text-align: center; + border-top: 1px solid #000000; + border-bottom: 1px solid #000000; + margin-top: 2em; +} + +h3, h4, h5, h6 { + padding-left: 1em; + margin-top: 2em; +} + +h3 { + border-top: 1px solid #000000; + border-bottom: 1px solid #000000; +} + +h4 { + border-bottom: 1px solid #000000; +} + +h5 { + border-bottom: 1px solid #000000; +} + +h6 { + border-bottom: 1px solid #000000; +} + +pre.code { + background-color: #eeeeee; + border: solid 1px #d0d0d0; + overflow: auto; +} + +pre.code * .paren { color: #666666; } + +pre.code a:active { color: #000000; } +pre.code a:link { color: #000000; } +pre.code a:visited { color: #000000; } + +pre.code .first-line { font-weight: bold; } + +pre.code .body, pre.code * .body { display: none; } + +div.contents { + font-family: verdana; +} + +div.contents a:active { color: #000000; } +div.contents a:link { color: #000000; } +div.contents a:visited { color: #000000; } + +div.contents div.contents-heading-1 { padding-left: 0.5em; font-weight: bold; } +div.contents div.contents-heading-1 a:active { color: #333333; } +div.contents div.contents-heading-1 a:link { color: #333333; } +div.contents div.contents-heading-1 a:visited { color: #333333; } + +div.contents div.contents-heading-2 { padding-left: 1.0em; } +div.contents div.contents-heading-2 a:active { color: #333333; } +div.contents div.contents-heading-2 a:link { color: #333333; } +div.contents div.contents-heading-2 a:visited { color: #333333; } + +div.contents div.contents-heading-3 { padding-left: 1.5em; } +div.contents div.contents-heading-3 a:active { color: #333333; } +div.contents div.contents-heading-3 a:link { color: #333333; } +div.contents div.contents-heading-3 a:visited { color: #333333; } + +div.contents div.contents-heading-4 { padding-left: 2em; } +div.contents div.contents-heading-4 a:active { color: #333333; } +div.contents div.contents-heading-4 a:link { color: #333333; } +div.contents div.contents-heading-4 a:visited { color: #333333; } + +div.contents div.contents-heading-5 { padding-left: 2.5em; } +div.contents div.contents-heading-5 a:active { color: #333333; } +div.contents div.contents-heading-5 a:link { color: #333333; } +div.contents div.contents-heading-5 a:visited { color: #333333; } + +.footer { color: #000000; font-family: arial; font-size: small; } +.footer a:active { color: #000000; } +.footer a:link { color: #000000; } +.footer a:visited { color: #000000; } + +.nav-links { font-size: x-small; float: right; margin-top: -2em; } \ No newline at end of file Added: branches/trunk-reorg/thirdparty/arnesi/src/accumulation.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/accumulation.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,150 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Reducing and Collecting + +;;;; ** Reducing + +;;;; reducing is the act of taking values, two at a time, and +;;;; combining them, with the aid of a reducing function, into a +;;;; single final value. + +(defun make-reducer (function &optional (initial-value nil initial-value-p)) + "Create a function which, starting with INITIAL-VALUE, reduces +any other values into a single final value. + +FUNCTION will be called with two values: the current value and +the new value, in that order. FUNCTION should return exactly one +value. + +The reducing function can be called with n arguments which will +be applied to FUNCTION one after the other (left to right) and +will return the new value. + +If the reducing function is called with no arguments it will +return the current value. + +Example: + + (setf r (make-reducer #'+ 5)) + (funcall r 0) => 5 + (funcall r 1 2) => 8 + (funcall r) => 8" + (let ((value initial-value)) + (lambda (&rest next) + (when next + ;; supplied a value, reduce + (if initial-value-p + ;; have a value to test against + (dolist (n next) + (setf value (funcall function value n))) + ;; nothing to test againts yet + (setf initial-value-p t + value next))) + ;; didn't supply a value, return the current value + value))) + +(defmacro with-reducer ((name function &optional (initial-value nil)) + &body body) + "Locally bind NAME to a reducing function. The arguments +FUNCTION and INITIAL-VALUE are passed directly to MAKE-REDUCER." + (with-unique-names (reducer) + `(let ((,reducer (make-reducer ,function ,@(list initial-value)))) + (flet ((,name (&rest items) + (if items + (dolist (i items) + (funcall ,reducer i)) + (funcall ,reducer)))) + ,@body)))) + +;;;; ** Collecting +;;;; +;;;; Building up a list from multiple values. + +(defun make-collector (&optional initial-value) + "Create a collector function. + +A Collector function will collect, into a list, all the values +passed to it in the order in which they were passed. If the +callector function is called without arguments it returns the +current list of values." + (let ((value initial-value) + (cdr (last initial-value))) + (lambda (&rest items) + (if items + (progn + (if value + (if cdr + (setf (cdr cdr) items + cdr (last items)) + (setf cdr (last items))) + (setf value items + cdr (last items))) + items) + value)))) + +(defun make-pusher (&optional initial-value) + "Create a function which collects values as by PUSH." + (let ((value initial-value)) + (lambda (&rest items) + (if items + (progn + (dolist (i items) + (push i value)) + items) + value)))) + +(defmacro with-collector ((name &optional initial-value from-end) &body body) + "Bind NAME to a collector function and execute BODY. If + FROM-END is true the collector will actually be a pusher, (see + MAKE-PUSHER), otherwise NAME will be bound to a collector, + (see MAKE-COLLECTOR)." + (with-unique-names (collector) + `(let ((,collector ,(if from-end + `(make-pusher ,initial-value) + `(make-collector ,initial-value)))) + (flet ((,name (&rest items) + (if items + (dolist (i items) + (funcall ,collector i)) + (funcall ,collector)))) + ,@body)))) + +(defmacro with-collectors (names &body body) + "Bind multiple collectors. Each element of NAMES should be a + list as per WITH-COLLECTOR's first orgument." + (if names + `(with-collector ,(ensure-list (car names)) + (with-collectors ,(cdr names) ,@body)) + `(progn ,@body))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/asdf.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/asdf.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,100 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * ASDF extras + +;;;; ** CLEAN-OP - An intelligent make clean for ASDF + +(defclass clean-op (asdf:operation) + ((for-op :accessor for-op :initarg :for-op :initform 'asdf:compile-op)) + (:documentation "Removes any files generated by an asdf component.")) + +(defmethod asdf:perform ((op clean-op) (c asdf:component)) + "Delete all the output files generated by the component C." + (dolist (f (asdf:output-files (make-instance (for-op op)) c)) + (when (probe-file f) + (delete-file f)))) + +(defmethod asdf:operation-done-p ((op clean-op) (c asdf:component)) + "Returns T when the output-files of (for-op OP) C don't exist." + (dolist (f (asdf:output-files (make-instance (for-op op)) c)) + (when (probe-file f) (return-from asdf:operation-done-p nil))) + t) + +;;;; ** Creating a single .fas or .fasl file + +;;;; Instead of creating images another way to distribute systems is +;;;; to create a single compiled file containing all the code. This is +;;;; only possible on some lisps, sbcl and clisp are the only ones +;;;; supported for now. + +;;;; NB: Unlike the CLEAN-OP this is experimental (its now to have +;;;; problems on multiple systems with non-trivial dependencies). + +(defun make-single-fasl (system-name + &key (op (make-instance 'asdf:load-op)) + output-file) + (let* ((system (asdf:find-system system-name)) + (steps (asdf::traverse op system)) + (output-file (or output-file + (compile-file-pathname + (make-pathname + :name (asdf:component-name system) + :defaults (asdf:component-pathname system))))) + (*buffer* (make-array 4096 :element-type '(unsigned-byte 8) + :adjustable t))) + (declare (special *buffer*)) + (with-output-to-file (*fasl* output-file + :if-exists :error + :element-type '(unsigned-byte 8)) + (declare (special *fasl*)) + (dolist (s steps) + (process-step (car s) (cdr s) output-file))))) + +(defgeneric process-step (op comp output-file)) + +(defmethod process-step + ((op asdf:load-op) (file asdf:cl-source-file) output-file) + (declare (ignore output-file) + (special *buffer* *fasl*)) + (dolist (fasl (asdf:output-files (make-instance 'asdf:compile-op) file)) + (with-input-from-file (input (truename fasl) + :element-type '(unsigned-byte 8)) + (setf *buffer* (adjust-array *buffer* (file-length input))) + (read-sequence *buffer* input) + (write-sequence *buffer* *fasl*)))) + +(defmethod process-step ((op asdf:operation) (comp asdf:component) output-file) + (declare (ignore output-file)) + (format t "Ignoring step ~S on ~S.~%" op comp)) + +;; Copyright (c) 2002-2003, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/bracket-reader.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/bracket-reader.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,88 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * {} syntax for local readtable modifications + +(defun |{-reader| (stream char) + (declare (ignore char)) + "A utility read macro for modifying the read table. + +The syntax is: + + {SPECIFIER ...} + +SPECIFIER is either a symbol naming a function (available at read +time) or a list (SPECIFIER &rest ARGUMENTS). SPECIFIER is applied +to ARGUMENTS to produce a function, this is then called and +passed another function which reads until the #\} +character. During the executen of the function *readtable* is +bound to a copy of the current read table. + +See WITH-PACKAGE for an example of a specifier function." + (let ((*readtable* (copy-readtable *readtable* nil))) + (destructuring-bind (specifier &rest arguments) + (ensure-list (read stream t nil t)) + (funcall (apply specifier arguments) + (lambda () + (read-delimited-list #\} stream t)))))) + +(defmacro enable-bracket-syntax () + "Enable bracket reader for the rest of the file (being loaded or compiled). +Be careful when using in different situations, because it modifies *readtable*." + ;; The standard sais that *readtable* is restored after loading/compiling a file, + ;; so we make a copy and alter that. The effect is that it will be enabled + ;; for the rest of the file being processed. + `(eval-when (:compile-toplevel :execute) + (setf *readtable* (copy-readtable *readtable*)) + (set-macro-character #\{ #'|{-reader| t *readtable*) + (set-syntax-from-char #\} #\) *readtable*))) + +(defmacro enable-bracket-reader () + "TODO Obsolete, use the enable-bracket-syntax macro." + ;; (warn "Use the enable-bracket-syntax macro instead of enable-bracket-reader") + `(enable-bracket-syntax)) + +(defun with-package (package-name) + "When used as a specifier for the #\{ reader locally rebinds, +at read time, the current package to PACKAGE-NAME. + +For example, this: + + {(with-package :cl-user) t} + +Will always read cl:t, no matter what the current package +actually is." + (lambda (reader) + (let ((*package* (find-package package-name))) + `(progn ,@(funcall reader))))) + +;; Copyright (c) 2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/call-cc/apply.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/call-cc/apply.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,354 @@ +;; -*- lisp -*- + +(in-package :arnesi) + +;;;; FUNCTION + +(defmethod evaluate/cc ((func free-function-object-form) lex-env dyn-env k) + (declare (ignore lex-env dyn-env)) + (multiple-value-bind (definition cc-boundp) + (fdefinition/cc (name func)) + (if cc-boundp + (kontinue k definition) + (if (fboundp (name func)) + (kontinue k (fdefinition (name func))) + (error "Unbound function ~S." (name func)))))) + +(defmethod evaluate/cc ((func local-function-object-form) lex-env dyn-env k) + (declare (ignore dyn-env)) + (kontinue k (lookup lex-env :flet (name func) :error-p t))) + +(defclass closure/cc () + ((code :accessor code :initarg :code) + (env :accessor env :initarg :env)) + #+sbcl (:metaclass mopp:funcallable-standard-class)) + +#+sbcl +(defmethod initialize-instance :after ((fun closure/cc) &rest initargs) + (declare (ignore initargs)) + (mopp:set-funcallable-instance-function + fun + #'(lambda (&rest args) + (drive-interpreter/cc + (apply-lambda/cc fun + args + '() + *toplevel-k*))))) + +;;;; LAMBDA + +(defmethod evaluate/cc ((lambda lambda-function-form) lex-env dyn-env k) + (declare (ignore dyn-env)) + (kontinue k (make-instance 'closure/cc :code lambda :env lex-env))) + +;;;; APPLY and FUNCALL + +(defk k-for-call/cc (k) + (value) + (if *call/cc-returns* + (kontinue k value) + (throw 'done value))) + +;;;; apply'ing a free (global) function + +(defmethod evaluate/cc ((func free-application-form) lex-env dyn-env k) + (cond + ((eql 'call/cc (operator func)) + (evaluate/cc (make-instance 'free-application-form + :operator 'funcall + :arguments (list (first (arguments func)) + (make-instance 'constant-form :value k :source k)) + :source (source func)) + lex-env dyn-env `(k-for-call/cc ,k))) + + ((eql 'kall (operator func)) + (evaluate-arguments-then-apply + (lambda (arguments) + (trace-statement "KALL'ing ~S on ~S" (first arguments) (rest arguments)) + (apply #'kontinue (first arguments) (cdr arguments))) + (arguments func) '() + lex-env dyn-env)) + + ((and (eql 'call-next-method (operator func)) + (second (multiple-value-list (lookup lex-env :next-method t)))) + (aif (lookup lex-env :next-method t) + (evaluate-arguments-then-apply + (lambda (arguments) + (apply-lambda/cc it arguments dyn-env k)) + (arguments func) '() lex-env dyn-env) + (error "no next method"))) + + ((and (eql 'next-method-p (operator func)) + (second (multiple-value-list (lookup lex-env :next-method t)))) + (kontinue k (lookup lex-env :next-method t))) + + ((eql 'funcall (operator func)) + (evaluate-funcall/cc (arguments func) lex-env dyn-env k)) + + ((eql 'apply (operator func)) + (evaluate-apply/cc (arguments func) '() lex-env dyn-env k)) + + ((and (symbolp (operator func)) + (eql 'defun/cc (nth-value 1 (fdefinition/cc (operator func))))) + (evaluate-arguments-then-apply + (lambda (arguments) + (trace-statement "Calling cc function ~S with arguments ~S" (operator func) arguments) + (apply-lambda/cc (fdefinition/cc (operator func)) arguments dyn-env k)) + (arguments func) '() + lex-env dyn-env)) + + ((and (symbolp (operator func)) + (eql 'defmethod/cc (nth-value 1 (fdefinition/cc (operator func))))) + (evaluate-arguments-then-apply + (lambda (arguments) + (trace-statement "Calling cc method ~S with arguments ~S" (operator func) arguments) + (apply-lambda/cc (apply (operator func) arguments) arguments dyn-env k)) + (arguments func) '() + lex-env dyn-env)) + + (t + (evaluate-arguments-then-apply + (lambda (arguments) + (multiple-value-bind (vars vals) + (export-specials dyn-env) + (progv vars vals + (trace-statement "Calling function ~S with arguments ~S" + (operator func) arguments) + (apply #'kontinue k (multiple-value-list + (apply (fdefinition (operator func)) arguments)))))) + (arguments func) '() + lex-env dyn-env)))) + +;; returns a list of variables and values from the dynamic environment that should be exported +;; these variables will be visible in normal lisp code that is called from cc code +(defun export-specials (dyn-env) + ;; TODO: here we could check each special whether it has to be exported or not + ;; this could be based on something like (declare (export var)) in the cc code + (let ((dyn-env (remove-duplicates dyn-env + :test (lambda (x y) (eq (second x) (second y))) + :from-end t))) + (values (mapcar 'second dyn-env) + (mapcar 'cddr dyn-env)))) + +;;;; apply'ing a local function + +(defmethod evaluate/cc ((func local-application-form) lex-env dyn-env k) + (evaluate-arguments-then-apply + (lambda (arguments) + (apply-lambda/cc (lookup lex-env :flet (operator func) :error-p t) arguments dyn-env k)) + (arguments func) '() + lex-env dyn-env)) + +;;;; apply'ing a lambda + +(defmethod evaluate/cc ((lambda lambda-application-form) lex-env dyn-env k) + (evaluate-funcall/cc (cons (operator lambda) (arguments lambda)) lex-env dyn-env k)) + +;;;; Utility methods which do the actual argument evaluation, parsing +;;;; and control transfer. + +(defun evaluate-funcall/cc (arguments lex-env dyn-env k) + (evaluate-apply/cc (append (butlast arguments) + (list (make-instance 'free-application-form + :operator 'list + :source `(list ,(source (car (last arguments)))) + :arguments (last arguments)))) + '() + lex-env dyn-env k)) + +(defk k-for-apply/cc (remaining-arguments evaluated-arguments lex-env dyn-env k) + (value) + (evaluate-apply/cc (cdr remaining-arguments) (cons value evaluated-arguments) + lex-env dyn-env k)) + +(defun evaluate-apply/cc (remaining-arguments evaluated-arguments lex-env dyn-env k) + (if remaining-arguments + (evaluate/cc (car remaining-arguments) lex-env dyn-env + `(k-for-apply/cc ,remaining-arguments ,evaluated-arguments ,lex-env ,dyn-env ,k)) + (let ((arg-list (apply #'list* (reverse evaluated-arguments)))) + (apply-lambda/cc (first arg-list) (rest arg-list) dyn-env k)))) + +;;;; Finally this is the function which, given a closure/cc object and +;;;; a list of (evaluated) arguments parses them, setup the +;;;; environment and transfers control. + +(defmethod apply-lambda/cc ((operator closure/cc) effective-arguments dyn-env k) + (trace-statement "Applying cc closure ~S to ~S" (source (code operator)) effective-arguments) + (let ((lex-env (env operator)) + (remaining-arguments effective-arguments) + (remaining-parameters (arguments (code operator)))) + ;; in this code ARGUMENT refers to the values passed to the + ;; function. PARAMETER refers to the lambda of the closure + ;; object. we walk down the parameters and put the arguments in + ;; the environment under the proper names. + + ;; first the required arguments + (loop + for parameter = (first remaining-parameters) + while remaining-parameters + do (typecase parameter + (required-function-argument-form + (if remaining-arguments + (setf lex-env (register lex-env :let (name parameter) (pop remaining-arguments))) + (error "Missing required arguments, expected ~S, got ~S." + (arguments (code operator)) effective-arguments)) + (pop remaining-parameters)) + (t (return)))) + + ;; handle special variables + (setf dyn-env (import-specials (code operator) dyn-env)) + + ;; now we start the chain optional->keyword->evaluate-body. We do + ;; this because optional and keyword parameters may have default + ;; values which may use call/cc. + (apply-lambda/cc/optional operator + remaining-parameters remaining-arguments + lex-env dyn-env k))) + +(defun apply-lambda/cc/optional (operator remaining-parameters remaining-arguments lex-env dyn-env k) + (flet ((done (remaining-parameters) + (return-from apply-lambda/cc/optional + (apply-lambda/cc/keyword + operator remaining-parameters remaining-arguments lex-env dyn-env k)))) + (loop + for head on remaining-parameters + for parameter = (first head) + do + (etypecase parameter + (rest-function-argument-form + (setf lex-env (register lex-env :let (name parameter) remaining-arguments))) + (optional-function-argument-form + (if remaining-arguments + (progn + (setf lex-env (register lex-env :let (name parameter) (pop remaining-arguments))) + (when (supplied-p-parameter parameter) + (setf lex-env (register lex-env :let (supplied-p-parameter parameter) t)))) + (return-from apply-lambda/cc/optional + ;; we need to evaluate a default-value, since this may + ;; contain call/cc we need to setup the continuation + ;; and let things go from there (hence the return-from) + (evaluate/cc (default-value parameter) lex-env dyn-env + `(k-for-apply/cc/optional-argument-default-value + ;; remaining-arguments is, by + ;; definition, NIL so we needn't pass + ;; it here. + ,operator ,head ,lex-env ,dyn-env ,k))))) + ((or keyword-function-argument-form allow-other-keys-function-argument-form) + ;; done with the optional args + (done head))) + finally (done head)))) + +(defk k-for-apply/cc/optional-argument-default-value + (operator remaining-parameters lex-env dyn-env k) + (value) + (apply-lambda/cc/optional + operator (cdr remaining-parameters) + ;; nb: if we're evaluating the default value of an optional + ;; arguments then we can't have anything left in the arguments + ;; list. + nil + (register lex-env :let (name (first remaining-parameters)) value) + dyn-env + k)) + +(defun apply-lambda/cc/keyword (operator remaining-parameters remaining-arguments lex-env dyn-env k) + ;; now any keyword parameters + (loop + for head on remaining-parameters + for parameter = (first head) + do (typecase parameter + (keyword-function-argument-form + (assert (evenp (length remaining-arguments)) + (remaining-arguments) + "Odd number of arguments in ~S being applied to ~S." + remaining-arguments + (source (code operator))) + (let ((value (getf remaining-arguments + (effective-keyword-name parameter) + parameter))) + (if (eql parameter value) + ;; no such keyword. need to evaluate the default value + (return-from apply-lambda/cc/keyword + (evaluate/cc (default-value parameter) lex-env dyn-env + `(k-for-apply-lambda/cc/keyword-default-value + ,operator ,head ,remaining-arguments + ,lex-env ,dyn-env ,k))) + ;; keyword passed in explicitly. + (progn + (let ((value (getf remaining-arguments (effective-keyword-name parameter)))) + (remf remaining-arguments (effective-keyword-name parameter)) + (setf lex-env (register lex-env :let (name parameter) value)) + (when (supplied-p-parameter parameter) + (setf lex-env (register lex-env :let (supplied-p-parameter parameter) t)))))))) + (allow-other-keys-function-argument-form + (when (cdr remaining-parameters) + (error "Bad lambda list: ~S" (arguments (code operator)))) + (return)) + (t (unless (null remaining-parameters) + (error "Bad lambda list: ~S" (arguments (code operator))))))) + (evaluate-progn/cc (body (code operator)) lex-env dyn-env k)) + +(defk k-for-apply-lambda/cc/keyword-default-value + (operator remaining-parameters remaining-arguments lex-env dyn-env k) + (value) + (apply-lambda/cc/keyword operator + (cdr remaining-parameters) remaining-arguments + (register lex-env :let (name (first remaining-parameters)) value) + dyn-env + k)) + +(defmethod apply-lambda/cc ((operator function) effective-arguments dyn-env k) + "Method used when we're applying a regular, non cc, function object." + (declare (ignore dyn-env)) + (trace-statement "Applying function ~S to ~S" operator effective-arguments) + (apply #'kontinue k (multiple-value-list (apply operator effective-arguments)))) + +(defmethod apply-lambda/cc ((operator symbol) effective-arguments dyn-env k) + "Method used when we're applying a regular, non cc, function object." + (apply-lambda/cc (symbol-function operator) effective-arguments dyn-env k)) + +;;;; Small helper function + +(defk k-for-evaluate-arguments-then-apply (handler remaining-arguments evaluated-arguments lex-env dyn-env) + (value) + (evaluate-arguments-then-apply + handler + remaining-arguments (cons value evaluated-arguments) + lex-env dyn-env)) + +(defun evaluate-arguments-then-apply (handler remaining-arguments evaluated-arguments lex-env dyn-env) + (if remaining-arguments + (evaluate/cc (car remaining-arguments) lex-env dyn-env + `(k-for-evaluate-arguments-then-apply ,handler ,(cdr remaining-arguments) + ,evaluated-arguments ,lex-env ,dyn-env)) + (funcall handler (reverse evaluated-arguments)))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/call-cc/common-lisp-cc.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/call-cc/common-lisp-cc.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,456 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; ** CC Version of some common lisp functions. + +(defmacro redefun/cc (name args &body body) + `(progn + (setf (fdefinition/cc ',name) + (make-instance 'closure/cc + :code (walk-form '(lambda ,args ,@body) nil '()) + :env '())) + ',name)) + +(defmacro apply-key (key element) + `(if ,key + (funcall ,key ,element) + ,element)) + +(redefun/cc assoc (item alist &key key (test #'eql) test-not) + "Return the cons in ALIST whose car is equal (by TEST) to ITEM." + (when test-not + (setq test (complement test-not))) + (dolist (pair alist nil) + (when (and pair (funcall test item (apply-key key (car pair)))) + (return pair)))) + +(redefun/cc assoc-if (predicate alist &key key) + "Return the cons in ALIST whose car satisfies PREDICATE." + (dolist (pair alist nil) + (when (and pair (funcall predicate (apply-key key (car pair)))) + (return pair)))) + +(redefun/cc assoc-if-not (predicate alist &key key) + "Return the cons in ALIST whose car does not satisfy PREDICATE." + (assoc-if (complement predicate) alist :key key)) + +(redefun/cc rassoc (item alist &key key (test #'eql) test-not) + "Return the cons in ALIST whose cdr is equal (by TEST) to ITEM." + (when test-not + (setq test (complement test-not))) + (dolist (pair alist nil) + (when (and pair (funcall test item (apply-key key (cdr pair)))) + (return pair)))) + +(redefun/cc rassoc-if (predicate alist &key key) + "Return the cons in ALIST whose cdr satisfies PREDICATE." + (dolist (pair alist nil) + (when (and pair (funcall predicate (apply-key key (cdr pair)))) + (return pair)))) + +(redefun/cc rassoc-if-not (predicate alist &key key) + "Return the cons in ALIST whose cdr does not satisfy PREDICATE." + (rassoc-if (complement predicate) alist :key key)) + +(redefun/cc sublis (alist tree &key key (test #'eql) test-not) + "Substitute data of ALIST for subtrees matching keys of ALIST." + (when test-not + (setq test (complement test-not))) + (labels ((sub (subtree) + (let ((assoc (assoc (apply-key key subtree) alist :test test))) + (cond + (assoc (cdr assoc)) + ((atom subtree) subtree) + (t (let ((car (sub (car subtree))) + (cdr (sub (cdr subtree)))) + (if (and (eq car (car subtree)) (eq cdr (cdr subtree))) + subtree + (cons car cdr)))))))) + (sub tree))) + +(redefun/cc nsublis (alist tree &key key (test #'eql) test-not) + "Substitute data of ALIST for subtrees matching keys of ALIST destructively." + (when test-not + (setq test (complement test-not))) + (labels ((sub (subtree) + (let ((assoc (assoc (apply-key key subtree) alist :test test))) + (cond + (assoc (cdr assoc)) + ((atom subtree) subtree) + (t + (rplaca subtree (sub (car subtree))) + (rplacd subtree (sub (cdr subtree))) + subtree))))) + (sub tree))) + +(redefun/cc subst (new old tree &key key (test #'eql) test-not) + "Substitute NEW for subtrees matching OLD." + (when test-not + (setq test (complement test-not))) + (labels ((sub (subtree) + (cond + ((funcall test old (apply-key key subtree)) new) + ((atom subtree) subtree) + (t (let ((car (sub (car subtree))) + (cdr (sub (cdr subtree)))) + (if (and (eq car (car subtree)) (eq cdr (cdr subtree))) + subtree + (cons car cdr))))))) + (sub tree))) + +(redefun/cc nsubst (new old tree &key key (test #'eql) test-not) + "Substitute NEW for subtrees matching OLD destructively." + (when test-not + (setq test (complement test-not))) + (labels ((sub (subtree) + (cond + ((funcall test old (apply-key key subtree)) new) + ((atom subtree) subtree) + (t (rplaca subtree (sub (car subtree))) + (rplacd subtree (sub (cdr subtree))) + subtree)))) + (sub tree))) + +(redefun/cc subst-if (new predicate tree &key key) + "Substitute NEW for subtrees for which PREDICATE is true." + (labels ((sub (subtree) + (cond + ((funcall predicate (apply-key key subtree)) new) + ((atom subtree) subtree) + (t (let ((car (sub (car subtree))) + (cdr (sub (cdr subtree)))) + (if (and (eq car (car subtree)) (eq cdr (cdr subtree))) + subtree + (cons car cdr))))))) + (sub tree))) + +(redefun/cc subst-if-not (new predicate tree &key key) + "Substitute NEW for subtrees for which PREDICATE is false." + (subst-if new (complement predicate) tree :key key)) + +(redefun/cc nsubst-if (new predicate tree &key key) + "Substitute NEW for subtrees for which PREDICATE is true destructively." + (labels ((sub (subtree) + (cond + ((funcall predicate (apply-key key subtree)) new) + ((atom subtree) subtree) + (t (rplaca subtree (sub (car subtree))) + (rplacd subtree (sub (cdr subtree))) + subtree)))) + (sub tree))) + +(redefun/cc nsubst-if-not (new predicate tree &key key) + "Substitute NEW for subtrees for which PREDICATE is false destructively." + (nsubst-if new (complement predicate) tree :key key)) + +(redefun/cc tree-equal (a b &key (test #'eql) test-not) + "Test whether two trees are of the same shape and have the same leaves." + (when test-not + (setq test (complement test-not))) + (labels ((teq (a b) + (if (atom a) + (and (atom b) (funcall test a b)) + (and (consp b) + (teq (car a) (car b)) + (teq (cdr a) (cdr b)))))) + (teq a b))) + +(redefun/cc member (item list &key key (test #'eql) test-not) + "Return the tail of LIST beginning with an element equal to ITEM." + (when test-not + (setq test (complement test-not))) + (do ((here list (cdr here))) + ((or (null here) (funcall test item (apply-key key (car here)))) here))) + +(redefun/cc member-if (predicate list &key key) + "Return the tail of LIST beginning with an element satisfying PREDICATE." + (do ((here list (cdr here))) + ((or (endp here) (funcall predicate (apply-key key (car here)))) here))) + +(redefun/cc member-if-not (predicate list &key key) + "Return the tail of LIST beginning with an element not satisfying PREDICATE." + (member-if (complement predicate) list :key key)) + +(redefun/cc adjoin (item list &key key (test #'eql) test-not) + "Add ITEM to LIST unless it is already a member." + (when test-not + (setq test (complement test-not))) + (if (member (apply-key key item) list :key key :test test) + list + (cons item list))) + +(redefun/cc intersection (list-1 list-2 &key key (test #'eql) test-not) + "Return the intersection of LIST-1 and LIST-2." + (when test-not + (setq test (complement test-not))) + (let (result) + (dolist (element list-1) + (when (member (apply-key key element) list-2 :key key :test test) + (push element result))) + result)) + +(redefun/cc nintersection (list-1 list-2 &key key (test #'eql) test-not) + "Return the intersection of LIST-1 and LIST-2 destructively modifying LIST-1." + (when test-not + (setq test (complement test-not))) + (let* ((result (list nil)) + (splice result)) + (do ((list list-1 (cdr list))) + ((endp list) (rplacd splice nil) (cdr result)) + (when (member (apply-key key (car list)) list-2 :key key :test test) + (setq splice (cdr (rplacd splice list))))))) + +(redefun/cc union (list-1 list-2 &key key (test #'eql) test-not) + "Return the union of LIST-1 and LIST-2." + (when test-not + (setq test (complement test-not))) + (let ((result list-2)) + (dolist (element list-1) + (unless (member (apply-key key element) list-2 :key key :test test) + (push element result))) + result)) + +(redefun/cc nunion (list-1 list-2 &key key (test #'eql) test-not) + "Return the union of LIST-1 and LIST-2 destructively modifying them." + (when test-not + (setq test (complement test-not))) + (do* ((result list-2) + (list-1 list-1) + tmp) + ((endp list-1) result) + (if (member (apply-key key (car list-1)) list-2 :key key :test test) + (setq list-1 (cdr list-1)) + (setq tmp (cdr list-1) + result (rplacd list-1 result) + list-1 tmp)))) + +(redefun/cc subsetp (list-1 list-2 &key key (test #'eql) test-not) + "Return T if every element in LIST-1 is also in LIST-2." + (when test-not + (setq test (complement test-not))) + (dolist (element list-1 t) + (unless (member (apply-key key element) list-2 :key key :test test) + (return nil)))) + +(redefun/cc set-difference (list-1 list-2 &key key (test #'eql) test-not) + "Return the elements of LIST-1 which are not in LIST-2." + (when test-not + (setq test (complement test-not))) + (let ((result nil)) + (dolist (element list-1) + (unless (member (apply-key key element) list-2 :key key :test test) + (push element result))) + result)) + +(redefun/cc nset-difference (list-1 list-2 &key key (test #'eql) test-not) + "Return the elements of LIST-1 which are not in LIST-2, modifying LIST-1." + (when test-not + (setq test (complement test-not))) + (do* ((result nil) + (list-1 list-1) + tmp) + ((endp list-1) result) + (if (member (apply-key key (car list-1)) list-2 :key key :test test) + (setq list-1 (cdr list-1)) + (setq tmp (cdr list-1) + result (rplacd list-1 result) + list-1 tmp)))) + +(redefun/cc set-exclusive-or (list-1 list-2 &key key (test #'eql) test-not) + "Return a list of elements that appear in exactly one of LIST-1 and LIST-2." + (when test-not + (setq test (complement test-not))) + (let ((result nil)) + (dolist (element list-1) + (unless (member (apply-key key element) list-2 :key key :test test) + (push element result))) + (dolist (element list-2) + (unless (member (apply-key key element) list-1 :key key :test test) + (push element result))) + result)) + +(redefun/cc nset-exclusive-or (list-1 list-2 &key key (test #'eql) test-not) + "The destructive version of set-exclusive-or." + (when test-not + (setq test (complement test-not))) + (do* ((head-1 (cons nil list-1)) + (head-2 (cons nil list-2)) + (p-1 head-1)) + ((or (endp (cdr p-1)) (endp (cdr head-2))) + (progn (rplacd (last p-1) (cdr head-2)) + (cdr head-1))) + (do ((p-2 head-2 (cdr p-2))) + ((endp (cdr p-2)) (setq p-1 (cdr p-1))) + (when (funcall test (apply-key key (cadr p-1)) (apply-key key (cadr p-2))) + (rplacd p-1 (cddr p-1)) + (rplacd p-2 (cddr p-2)) + (return))))) + +(redefun/cc mapc (function list &rest more-lists) + "Apply FUNCTION to successive elements of lists, return LIST." + (do* ((lists (cons list more-lists)) + (args (make-list (length lists)))) + ((do ((l lists (cdr l)) + (a args (cdr a))) + ((or (null l) (endp (car l))) l) + (rplaca a (caar l)) + (rplaca l (cdar l))) + list) + (apply function args))) + +(redefun/cc mapcar (function list &rest more-lists) + "Apply FUNCTION to successive elements of lists, return list of results." + (do* ((lists (cons list more-lists)) + (len (length lists)) + (args (make-list len) (make-list len)) + (result (list nil)) + (splice result)) + ((do ((l lists (cdr l)) + (a args (cdr a))) + ((or (null l) (endp (car l))) l) + (rplaca a (caar l)) + (rplaca l (cdar l))) + (cdr result)) + (setq splice (cdr (rplacd splice (list (apply function args))))))) + +(redefun/cc mapcan (function list &rest more-lists) + "Apply FUNCTION to successive elements of lists, return nconc of results." + (apply #'nconc (apply #'mapcar function list more-lists))) + +(redefun/cc mapl (function list &rest more-lists) + "Apply FUNCTION to successive sublists of list, return LIST." + (do* ((lists (cons list more-lists))) + ((member nil lists) list) + (apply function lists) + (do ((l lists (cdr l))) + ((endp l)) + (rplaca l (cdar l))))) + +(redefun/cc maplist (function list &rest more-lists) + "Apply FUNCTION to successive sublists of list, return list of results." + (do* ((lists (cons list more-lists)) + (result (list nil)) + (splice result)) + ((member nil lists) (cdr result)) + (setq splice (cdr (rplacd splice (list (apply function lists))))) + (do ((l lists (cdr l))) + ((endp l)) + (rplaca l (cdar l))))) + +(redefun/cc mapcon (function list &rest more-lists) + "Apply FUNCTION to successive sublists of lists, return nconc of results." + (apply #'nconc (apply #'maplist function list more-lists))) + +(redefun/cc complement (function) + (lambda (&rest arguments) + (not (apply function arguments)))) + +(redefun/cc list-delete-if (test list start end count key) + (let* ((head (cons nil list)) + (splice head)) + (do ((i 0 (1+ i)) + (x list (cdr x))) + ((endp x) (rplacd splice nil) (cdr head)) + (when (and count (<= count 0)) + (rplacd splice x) + (return (cdr head))) + (if (and (<= start i) (or (null end) (< i end)) + (funcall test (apply-key key (car x)))) + (when count (decf count)) + (setq splice (cdr (rplacd splice x))))))) + +(redefun/cc vector-delete-if (test vector start end count key) + (let* ((length (length vector)) + (end (or end length)) + (count (or count length)) + (i 0)) + (do* ((j 0 (1+ j)) + element) + ((>= j length)) + (setq element (aref vector j)) + (if (and (<= start j) (< j end) + (plusp count) + (funcall test (apply-key key element))) + (when count (decf count)) + (progn + (setf (aref vector i) element) + (incf i)))) + (cond + ((array-has-fill-pointer-p vector) + (setf (fill-pointer vector) i) + vector) + ((adjustable-array-p vector) (adjust-array vector i)) + (t (subseq vector 0 i))))) + +(redefun/cc delete-if (predicate sequence &key from-end (start 0) end count key) + "Modify SEQUENCE by deleting elements satisfying PREDICATE." + (if from-end + (let ((length (length sequence))) + (nreverse (delete-if predicate (nreverse sequence) + :start (- length (or end length)) + :end (- length start) + :count count :key key))) + (etypecase sequence + (null nil) + (cons (list-delete-if predicate sequence start end count key)) + (vector (vector-delete-if predicate sequence start end count key))))) + +(redefun/cc delete (item sequence &key from-end (test #'eql) test-not (start 0) end + count key) + "Modify SEQUENCE by deleting elements equal to ITEM." + (when test-not (setq test (complement test-not))) + (delete-if #'(lambda (arg) (funcall test item arg)) sequence + :from-end from-end :start start :end end :count count :key key)) + +(redefun/cc delete-if-not (predicate sequence &key from-end (start 0) end count key) + "Modify SEQUENCE by deleting elements not satisfying PREDICATE." + (delete-if (complement predicate) sequence :from-end from-end + :start start :end end :count count :key key)) + +(redefun/cc remove-if (predicate sequence &key from-end (start 0) end count key) + "Return a copy of SEQUENCE with elements satisfying PREDICATE removed." + (delete-if predicate (copy-seq sequence) :from-end from-end :start start :end end + :count count :key key)) + +(redefun/cc remove (item sequence &key from-end (test #'eql) test-not (start 0) + end count key) + "Return a copy of SEQUENCE with elements equal to ITEM removed." + (when test-not (setq test (complement test-not))) + (remove-if #'(lambda (arg) (funcall test item arg)) sequence + :from-end from-end :start start :end end :count count :key key)) + +(redefun/cc remove-if-not (predicate sequence &key from-end (start 0) end count key) + "Return a copy of SEQUENCE with elements not satisfying PREDICATE removed." + (remove-if (complement predicate) sequence :from-end from-end + :start start :end end :count count :key key)) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/call-cc/generic-functions.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/call-cc/generic-functions.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,154 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; ** Functions, Generic Functions, Methods and standard-combination + +;;;; DEFUN/CC + +(defmacro defun/cc (name arguments &body body) + `(progn + (setf (fdefinition/cc ',name 'defun/cc) + (make-instance 'closure/cc + :code (walk-form '(lambda ,arguments + (block ,name ,@body)) + nil nil) + :env nil)) + (defun ,name ,arguments + (declare (ignore ,@(extract-argument-names arguments))) + (error "Sorry, /CC function are not callable outside of with-call/cc.")))) + +;;;; DEFGENERIC/CC + +(defmacro defgeneric/cc (name args &rest options) + "Trivial wrapper around defgeneric designed to alert readers that these methods are cc methods." + (assert (not (find :method options :key #'first)) () "TODO: defgeneric/cc does not walk the :method entries yet, use standalone defmethod/cc's") + `(progn + (defgeneric ,name ,args + ,@options + (:method-combination cc-standard)) + (setf (fdefinition/cc ',name 'defmethod/cc) t))) + +;;;; DEFMETHOD/CC + +; for emacs: (setf (get 'defmethod/cc 'common-lisp-indent-function) 'lisp-indent-defmethod) + +(defmacro defmethod/cc (name &rest args) + (let ((qlist (list (if (and (symbolp (car args)) + (not (null (car args)))) + (pop args) + :primary)))) + (let ((arguments (car args)) + (body (cdr args))) + `(progn + (unless (eq 'defmethod/cc (second (multiple-value-list (fdefinition/cc ',name)))) + (setf (fdefinition/cc ',name 'defmethod/cc) t) + (defgeneric/cc ,name ,(if arguments + (convert-to-generic-lambda-list arguments) + '()))) + (defmethod ,name ,@qlist ,arguments + ,(when arguments + `(declare (ignorable ,@(extract-argument-names arguments :allow-specializers t)))) + ,@(when (stringp (first body)) + (list (pop body))) + (make-instance 'closure/cc + :code (walk-form '(lambda ,(clean-argument-list arguments) + (block ,name ,@body)) + nil nil) + :env nil)))))) + +;;;; CC-STANDARD (standard-combination for cc methods) + +(defun closure-with-nextmethod (closure next) + (make-instance 'closure/cc + :code (code closure) + :env (register (env closure) :next-method t next))) + +(defun closure-with-befores (closure befores) + (make-instance 'closure/cc + :code (walk-form `(lambda (&rest args) + ,@(loop + for before in befores + collect `(apply ,before args)) + (apply ,closure args))) + :env nil)) + +(defun closure-with-afters (closure afters) + (make-instance 'closure/cc + :code (walk-form `(lambda (&rest args) + (prog1 + (apply ,closure args) + ,@(loop + for after in afters + collect `(apply ,after args))))) + :env nil)) + +(define-method-combination cc-standard + (&key (around-order :most-specific-first) + (before-order :most-specific-first) + (primary-order :most-specific-first) + (after-order :most-specific-last)) + ((around (:around)) + (before (:before)) + (primary (:primary) :required t) + (after (:after))) + + (labels ((effective-order (methods order) + (ecase order + (:most-specific-first methods) + (:most-specific-last (reverse methods)))) + (primary-wrap (methods &optional nextmethod) + (case (length methods) + (1 `(closure-with-nextmethod + (call-method ,(first methods)) + ,nextmethod)) + (t `(closure-with-nextmethod + (call-method ,(first methods)) + ,(primary-wrap (cdr methods) nextmethod))))) + (call-methods (methods) + `(list ,@(loop + for m in methods + collect `(call-method ,m))))) + (let* (;; reorder the methods based on the -order arguments + (around (effective-order around around-order)) + (before (effective-order before before-order)) + (primary (effective-order primary primary-order)) + (after (effective-order after after-order)) + (form (primary-wrap primary))) + (when after + (setf form `(closure-with-afters ,form ,(call-methods after)))) + (when before + (setf form `(closure-with-befores ,form ,(call-methods before)))) + (when around + (setf form (primary-wrap around form))) + form))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/call-cc/handlers.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/call-cc/handlers.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,334 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; ** Handlres for common-lisp special operators + +;;;; Variable References + +(defmethod evaluate/cc ((var local-variable-reference) lex-env dyn-env k) + (declare (ignore dyn-env)) + (kontinue k (lookup lex-env :let (name var) :error-p t))) + +(defmethod evaluate/cc ((var local-lexical-variable-reference) lex-env dyn-env k) + (declare (ignore dyn-env)) + (kontinue k (funcall (first (lookup lex-env :lexical-let (name var) :error-p t))))) + +(defmethod evaluate/cc ((var free-variable-reference) lex-env dyn-env k) + (declare (ignore lex-env)) + (multiple-value-bind (value foundp) + (lookup dyn-env :let (name var)) + (if foundp + (kontinue k value) + (kontinue k (symbol-value (name var)))))) + +;;;; Constants + +(defmethod evaluate/cc ((c constant-form) lex-env dyn-env k) + (declare (ignore lex-env dyn-env)) + (kontinue k (value c))) + +;;;; BLOCK/RETURN-FROM + +(defmethod evaluate/cc ((block block-form) lex-env dyn-env k) + (evaluate-progn/cc (body block) + (register lex-env :block (name block) k) + dyn-env k)) + +(defmethod evaluate/cc ((return return-from-form) lex-env dyn-env k) + (declare (ignore k)) + (evaluate/cc (result return) + lex-env dyn-env + (lookup lex-env :block (name (target-block return)) :error-p t))) + +;;;; CATCH/THROW + +(defmethod evaluate/cc ((catch catch-form) lex-env dyn-env k) + (evaluate/cc (tag catch) lex-env dyn-env + `(catch-tag-k ,catch ,lex-env ,dyn-env ,k))) + +(defk catch-tag-k (catch lex-env dyn-env k) + (tag) + (evaluate-progn/cc (body catch) lex-env (register dyn-env :catch tag k) k)) + +(defmethod evaluate/cc ((throw throw-form) lex-env dyn-env k) + (evaluate/cc (tag throw) lex-env dyn-env + `(throw-tag-k ,throw ,lex-env ,dyn-env ,k))) + +(defk throw-tag-k (throw lex-env dyn-env k) + (tag) + (evaluate/cc (value throw) lex-env dyn-env + (lookup dyn-env :catch tag :error-p t))) + +;;;; FLET/LABELS + +(defmethod evaluate/cc ((flet flet-form) lex-env dyn-env k) + (let ((new-env lex-env)) + (dolist* ((name . form) (binds flet)) + (setf new-env (register new-env :flet name (make-instance 'closure/cc + :code form + :env lex-env)))) + (evaluate-progn/cc (body flet) new-env dyn-env k))) + +(defmethod evaluate/cc ((labels labels-form) lex-env dyn-env k) + (let ((closures '())) + (dolist* ((name . form) (binds labels)) + (let ((closure (make-instance 'closure/cc :code form))) + (setf lex-env (register lex-env :flet name closure)) + (push closure closures))) + (dolist (closure closures) + (setf (env closure) lex-env)) + (evaluate-progn/cc (body labels) lex-env dyn-env k))) + +;;;; LET/LET* + +;; returns a dynamic environment that holds the special variables imported for let +;; these variables are captured from the caller normal lisp code and stored within +;; the continuation. The mixin might be a binding-form-mixin and implicit-progn-with-declare-mixin. +(defun import-specials (mixin dyn-env) + (dolist (declaration (declares mixin)) + (let ((name (name declaration))) + (if (and (typep declaration 'special-declaration-form) + (or (not (typep mixin 'binding-form-mixin)) + (not (find name (binds mixin) :key 'first))) + (not (lookup dyn-env :let name))) + (setf dyn-env (register dyn-env :let name (symbol-value name)))))) + dyn-env) + +(defmethod evaluate/cc ((let let-form) lex-env dyn-env k) + (evaluate-let/cc (binds let) nil (body let) lex-env (import-specials let dyn-env) k)) + +(defk k-for-evaluate-let/cc (var remaining-bindings evaluated-bindings body lex-env dyn-env k) + (value) + (evaluate-let/cc remaining-bindings + (cons (cons var value) evaluated-bindings) + body lex-env dyn-env k)) + +(defun evaluate-let/cc (remaining-bindings evaluated-bindings body lex-env dyn-env k) + (if remaining-bindings + (destructuring-bind (var . initial-value) + (car remaining-bindings) + (evaluate/cc + initial-value + lex-env dyn-env + `(k-for-evaluate-let/cc + ,var + ,(cdr remaining-bindings) + ,evaluated-bindings + ,body + ,lex-env ,dyn-env ,k))) + (dolist* ((var . value) evaluated-bindings + (evaluate-progn/cc body lex-env dyn-env k)) + (if (special-var-p var (parent (first body))) + (setf dyn-env (register dyn-env :let var value)) + (setf lex-env (register lex-env :let var value)))))) + +(defun special-var-p (var declares-mixin) + (or (find-if (lambda (declaration) + (and (typep declaration 'special-declaration-form) + (eq (name declaration) var))) + (declares declares-mixin)) + (boundp var) + ;; This is the only portable way to check if a symbol is + ;; declared special, without being boundp, i.e. (defvar 'foo). + ;; Maybe we should make it optional with a compile-time flag? + #+nil(eval `((lambda () + (flet ((func () + (symbol-value ',var))) + (let ((,var t)) + (declare (ignorable ,var)) + (ignore-errors (func))))))))) + +(defmethod evaluate/cc ((let* let*-form) lex-env dyn-env k) + (evaluate-let*/cc (binds let*) (body let*) lex-env (import-specials let* dyn-env) k)) + +(defk k-for-evaluate-let*/cc (var bindings body lex-env dyn-env k) + (value) + (if (special-var-p var (parent (first body))) + (evaluate-let*/cc bindings body + lex-env + (register dyn-env :let var value) + k) + (evaluate-let*/cc bindings body + (register lex-env :let var value) + dyn-env + k))) + +(defun evaluate-let*/cc (bindings body lex-env dyn-env k) + (if bindings + (destructuring-bind (var . initial-value) + (car bindings) + (evaluate/cc initial-value lex-env dyn-env + `(k-for-evaluate-let*/cc ,var ,(cdr bindings) ,body ,lex-env ,dyn-env ,k))) + (evaluate-progn/cc body lex-env dyn-env k))) + +;;;; IF + +(defk k-for-evaluate-if/cc (then else lex-env dyn-env k) + (value) + (if value + (evaluate/cc then lex-env dyn-env k) + (evaluate/cc else lex-env dyn-env k))) + +(defmethod evaluate/cc ((if if-form) lex-env dyn-env k) + (evaluate/cc (consequent if) lex-env dyn-env + `(k-for-evaluate-if/cc ,(then if) ,(else if) ,lex-env ,dyn-env ,k))) + +;;;; LOCALLY + +(defmethod evaluate/cc ((locally locally-form) lex-env dyn-env k) + (evaluate-progn/cc (body locally) lex-env dyn-env k)) + +;;;; MACROLET + +(defmethod evaluate/cc ((macrolet macrolet-form) lex-env dyn-env k) + ;; since the walker already performs macroexpansion there's nothing + ;; left to do here. + (evaluate-progn/cc (body macrolet) lex-env dyn-env k)) + +;;;; multiple-value-call + +(defk k-for-m-v-c (remaining-arguments evaluated-arguments lex-env dyn-env k) + (value other-values) + (evaluate-m-v-c + remaining-arguments (append evaluated-arguments (list value) other-values) + lex-env dyn-env k)) + +(defun evaluate-m-v-c (remaining-arguments evaluated-arguments lex-env dyn-env k) + (if remaining-arguments + (evaluate/cc (car remaining-arguments) lex-env dyn-env + `(k-for-m-v-c ,(cdr remaining-arguments) ,evaluated-arguments ,lex-env ,dyn-env ,k)) + (destructuring-bind (function &rest arguments) + evaluated-arguments + (etypecase function + (closure/cc (apply-lambda/cc function arguments dyn-env k)) + (function (apply #'kontinue k (multiple-value-list + (multiple-value-call function (values-list arguments))))))))) + +(defmethod evaluate/cc ((m-v-c multiple-value-call-form) lex-env dyn-env k) + (evaluate-m-v-c (list* (func m-v-c) (arguments m-v-c)) '() lex-env dyn-env k)) + +;;;; PROGN + +(defmethod evaluate/cc ((progn progn-form) lex-env dyn-env k) + (evaluate-progn/cc (body progn) lex-env dyn-env k)) + +(defk k-for-evaluate-progn/cc (rest-of-body lex-env dyn-env k) + () + (evaluate-progn/cc rest-of-body lex-env dyn-env k)) + +(defun evaluate-progn/cc (body lex-env dyn-env k) + (cond + ((cdr body) + (evaluate/cc (first body) lex-env dyn-env + `(k-for-evaluate-progn/cc ,(cdr body) ,lex-env ,dyn-env ,k))) + (body + (evaluate/cc (first body) lex-env dyn-env k)) + (t + (kontinue k nil)))) + +;;;; SETQ + +(defk k-for-local-setq (var lex-env dyn-env k) + (value) + (setf (lookup lex-env :let var :error-p t) value) + (kontinue k value)) + +(defk k-for-free-setq (var lex-env dyn-env k) + (value) + (setf (symbol-value var) value) + (kontinue k value)) + +(defk k-for-local-lexical-setq (var lex-env dyn-env k) + (value) + (funcall (second (lookup lex-env :lexical-let var :error-p t)) value) + (kontinue k value)) + +(defmethod evaluate/cc ((setq setq-form) lex-env dyn-env k) + (macrolet ((if-found (&key in-env of-type kontinue-with) + `(multiple-value-bind (value foundp) + (lookup ,in-env ,of-type (var setq)) + (declare (ignore value)) + (when foundp + (return-from evaluate/cc + (evaluate/cc (value setq) lex-env dyn-env + `(,',kontinue-with ,(var setq) ,lex-env ,dyn-env ,k))))))) + (if-found :in-env lex-env + :of-type :let + :kontinue-with k-for-local-setq) + (if-found :in-env dyn-env + :of-type :let + :kontinue-with k-for-special-setq) + (if-found :in-env lex-env + :of-type :lexical-let + :kontinue-with k-for-local-lexical-setq) + (evaluate/cc (value setq) + lex-env dyn-env + `(k-for-free-setq ,(var setq) ,lex-env ,dyn-env ,k)))) + +;;;; SYMBOL-MACROLET + +(defmethod evaluate/cc ((symbol-macrolet symbol-macrolet-form) lex-env dyn-env k) + ;; like macrolet the walker has already done all the work needed for this. + (evaluate-progn/cc (body symbol-macrolet) lex-env dyn-env k)) + +;;;; TAGBODY/GO + +(defk tagbody-k (k) + () + (kontinue k nil)) + +(defmethod evaluate/cc ((tagbody tagbody-form) lex-env dyn-env k) + (evaluate-progn/cc (body tagbody) + (register lex-env :tag tagbody k) dyn-env + `(tagbody-k ,k))) + +(defmethod evaluate/cc ((go-tag go-tag-form) lex-env dyn-env k) + (declare (ignore go-tag lex-env dyn-env)) + (kontinue k nil)) + +(defmethod evaluate/cc ((go go-form) lex-env dyn-env k) + (declare (ignore k)) + (evaluate-progn/cc (target-progn go) lex-env dyn-env + (lookup lex-env :tag (enclosing-tagbody go) :error-p t))) + +;;;; THE + +(defmethod evaluate/cc ((the the-form) lex-env dyn-env k) + (evaluate/cc (value the) lex-env dyn-env k)) + +;;;; LOAD-TIME-VALUE + +(defmethod evaluate/cc ((c load-time-value-form) lex-env dyn-env k) + (declare (ignore lex-env dyn-env)) + (kontinue k (value c))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/call-cc/interpreter.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/call-cc/interpreter.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,206 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * A Common Lisp interpreter with support for continuations. + +;;;; Notes: + +;;;; This interpreter is dependent on the object tree built up by the +;;;; code walker in walk.lisp. + +;;;; One of the, final, goals of this interpeter was to allow +;;;; continuations to be serializable. Due to this constraint we +;;;; represent continuations as regular lists which, when the cdr +;;;; (which must be clos objects or literals) is applied to the car +;;;; (which must be a symbol) the actual contiunation (a regular +;;;; common lisp function) is returned. + +(defvar *call/cc-returns* nil) + +(defmacro with-call/cc (&environment e &body body) + "Execute BODY with delimited partial continuations. + + Within the code of BODY almost all common lisp forms maintain + their normal semantics. The following special forms are + allowed: + + (call/cc LAMBDA) - LAMBDA, a one argument function, will be + passed a continuation. This object may then be passed to the + function KALL which will cause execution to resume around the + call/cc form. " + (let ((walk-env (make-walk-env e)) + (evaluate-env nil)) + (dolist* ((type name &rest data) (car walk-env)) + (declare (ignore data)) + (when (eql :lexical-let type) + (push (list 'list + :lexical-let + `(quote ,name) + ;; NB: this makes the environment, and therefore + ;; continuations, unserializable. we would need to + ;; change this to a regular :let and not allow the + ;; setting of lexical variables. + `(lambda () ,name) + (with-unique-names (v) + `(lambda (,v) (setf ,name ,v)))) + evaluate-env))) + (setf evaluate-env `(list ,@(nreverse evaluate-env))) + `(drive-interpreter/cc + (evaluate/cc ,(walk-form (if (rest body) + `(progn ,@body) + (first body)) + nil walk-env) + ,evaluate-env nil + *toplevel-k*)))) + +(defun kall (k &optional (primary-value nil primary-value-p) + &rest other-values) + "Continue the continuation K. + +This function can be used within the lexical scope of +with-call/cc and outside, though it has slightly different +semantics." + (drive-interpreter/cc + (lambda () + (let ((k (apply (car k) (cdr k)))) + (cond + (other-values (apply k primary-value other-values)) + (primary-value-p (funcall k primary-value)) + (t (funcall k nil))))))) + +(defvar *cc-functions* (make-hash-table :test 'eql)) + +(defun fmkunbound/cc (function-name) + (remhash function-name *cc-functions*)) + +(defun fdefinition/cc (function-name) + (values-list (gethash function-name *cc-functions*))) + +(defun (setf fdefinition/cc) (closure-object function-name &optional (type 'defun/cc)) + (setf (gethash function-name *cc-functions*) (list closure-object type))) + +(defvar *debug-evaluate/cc* nil + "When non NIL the evaluator will print, at each evaluation + step, what it's evaluating and the value passed in from the + previous step. + +If set to :FULL then at each step we print the form, the +environment and the continuation. If set to T we just print the +form being evaluated.") + +;;;; Implementation + +(defun drive-interpreter/cc (code) + (catch 'done + (loop for thunk = code then (funcall thunk)))) + +(defmacro let/cc (k &body body) + `(call/cc (lambda (,k) ,@body))) + +(defmacro retk () + `(let/cc k k)) + +(defmacro klambda ((&optional (value (gensym) valuep) (other-values (gensym) other-values-p)) + &body body) + (cond + (other-values-p `(lambda (&optional ,value &rest ,other-values) + (lambda () + ,@body))) + (valuep `(lambda (&optional ,value &rest ,other-values) + (declare (ignore ,other-values)) + (lambda () + ,@body))) + (t `(lambda (&optional ,value &rest ,other-values) + (declare (ignore ,value ,other-values)) + (lambda () + ,@body))))) + +(defvar *trace-cc* nil + "Variable which controls the tracing of WITH-CALL/CC code. + +When not NIL the interepreter will report what code it is +evaluating and what it returns.") + +(defmacro trace-statement (format-control &rest format-args) + `(when *trace-cc* + (format *trace-output* ,(strcat "~&" format-control "~%") ,@format-args))) + +(defun kontinue (k &optional (primary-value nil primary-value-p) &rest other-values) + (trace-statement "Got ~S~{; ~S~}" primary-value other-values) + (let ((k (apply (car k) (cdr k)))) + (cond + (other-values (apply k primary-value other-values)) + (primary-value-p (funcall k primary-value)) + (t (funcall k))))) + +(defmacro defk (name args k-args &body body) + `(defun ,name ,args + (declare (ignorable ,@args)) + (klambda ,k-args + (when *debug-evaluate/cc* + (format *debug-io* "~&(~S~{~^ ~S~}) Got (values~{~^ ~S~}).~%" ',name (list ,@args) (list ,@k-args))) + ,@body))) + +(defgeneric evaluate/cc (form lexical-environment dynamic-environment k)) + +(defmethod evaluate/cc ((form t) lex-env dyn-env k) + (declare (ignore lex-env dyn-env k)) + (error "No EVALUATE/CC method defined for ~S." form)) + +(defmethod evaluate/cc :around ((form form) lex-env dyn-env k) + (declare (ignore lex-env dyn-env k)) + (trace-statement "Evaluating ~S." (source form)) + (call-next-method)) + +(defun print-debug-step (form lex-env dyn-env k) + (let ((*print-pretty* nil)) + (ecase *debug-evaluate/cc* + (:full + (format *debug-io* + "~&Evaluating: ~S~%~3TLex Env: ~S~%~3TDyn Env: ~S~%~3TK: ~S~%" + form lex-env dyn-env k)) + ((t) + (format *debug-io* "~&Evaluating: ~S~%" form)) + ((nil) ;; do nothing + nil)))) + +(defmethod evaluate/cc :before (form lex-env dyn-env k) + (when *debug-evaluate/cc* + (print-debug-step form lex-env dyn-env k))) + +(defun toplevel-k () + (klambda (value other-values) + (throw 'done (values-list (cons value other-values))))) + +(defparameter *toplevel-k* '(toplevel-k)) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/cl-ppcre-extras.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/cl-ppcre-extras.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,107 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +(defpackage :it.bese.arnesi.cl-ppcre-extras + (:use) + (:nicknames :rx) + (:export + #:=~ + #:!~ + #:$1 + #:$2 + #:$3 + #:$4 + #:$5 + #:$6 + #:$7 + #:$8 + #:$9)) + +(defparameter rx::$_ nil + "The current default target for regexp matching.") +(defparameter rx::$1 nil "The string matched by the first group in the last regexp match.") +(defparameter rx::$2 nil "The string matched by the second group in the last regexp match.") +(defparameter rx::$3 nil "The string matched by the third group in the last regexp match.") +(defparameter rx::$4 nil "The string matched by the fourth group in the last regexp match.") +(defparameter rx::$5 nil "The string matched by the fifth group in the last regexp match.") +(defparameter rx::$6 nil "The string matched by the sixth group in the last regexp match.") +(defparameter rx::$7 nil "The string matched by the seventh group in the last regexp match.") +(defparameter rx::$8 nil "The string matched by the eight group in the last regexp match.") +(defparameter rx::$9 nil "The string matched by the ninth group in the last regexp match.") + +(defmacro rx::=~ (regexp &optional (target 'rx::$_) (then t) (else nil)) + "Equivalent to perl's if (TARGET =~ REGEXP) { THEN } else { ELSE }. + +Attempt to match REGEXP agains TARGET, if the match succedes THEN +is evaluated with $1, .. $9 bound to the groups in +REGEXP. Otherwise ELSE is executed." + (destructuring-bind (regexp &rest create-scanner-args) (if (listp regexp) + regexp + (list regexp)) + (destructuring-bind (trgt &key start end) (if (listp target) + target + (list target)) + (let ((match-start (gensym)) + (match-end (gensym)) + (register-starts (gensym)) + (register-ends (gensym)) + (num-registers (gensym)) + (target (gensym))) + (flet ((gen-$-var (index) + `(if (< ,num-registers ,index) + nil + (let ((start (aref ,register-starts (1- ,index))) + (end (aref ,register-ends (1- ,index)))) + (if (null start) + nil + (make-array (- end start) :displaced-to ,target :displaced-index-offset start)))))) + `(let ((,target ,trgt)) + (multiple-value-bind (,match-start ,match-end ,register-starts ,register-ends) + (cl-ppcre:scan (cl-ppcre:create-scanner ,regexp ,@create-scanner-args) + ,trgt ,@(when start `(:start ,start)) + ,@(when end `(:end ,end))) + (declare (ignore ,match-end)) + (if (not (null ,match-start)) + (let* ((,num-registers (length ,register-starts))) + (setf rx::$1 ,(gen-$-var 1) + rx::$2 ,(gen-$-var 2) + rx::$3 ,(gen-$-var 3) + rx::$4 ,(gen-$-var 4) + rx::$5 ,(gen-$-var 5) + rx::$6 ,(gen-$-var 6) + rx::$7 ,(gen-$-var 7) + rx::$8 ,(gen-$-var 8) + rx::$9 ,(gen-$-var 9)) + ,then) + ,else)))))))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/compat.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/compat.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,47 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * A Trivial Compatibility Layer + +;;;; Here we only have the QUIT function, see mopp.lisp for a MOP +;;;; compatibility layer. + +(defun quit (&optional (exit-code 0)) + #+openmcl (ccl:quit exit-code) + #+sbcl (sb-ext:quit :unix-status exit-code) + #+clisp (ext:quit exit-code) + #+(or cmu allegro) (declare (ignore exit-code)) + #+cmu (ext:quit) + #+lispworks (lispworks:quit :status exit-code) + #+allegro (excl:exit)) + +;; Copyright (c) 2002-2003, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/csv.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/csv.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,117 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Reading and Writing files in Comma-Seperated-Values format + +;;;; Generating CSV files from lisp data + +(defun princ-csv (items csv-stream + &key (quote #\") + (separator #\,) + (ignore-nulls t) + (newline +CR-LF+) + (princ #'princ-to-string)) + "Write the list ITEMS to csv-stream." + (flet ((write-word (word) + (write-char quote csv-stream) + (loop + for char across (funcall princ word) + if (char= quote char) do + (progn + (write-char quote csv-stream) + (write-char quote csv-stream)) + else do + (write-char char csv-stream)) + (write-char quote csv-stream))) + (when items + (write-word (car items)) + (dolist (i (cdr items)) + (write-char separator csv-stream) + (if ignore-nulls + (when (not (null i)) + (write-word i)) + (write-word i))) + (write-sequence newline csv-stream)))) + +(defun princ-csv-to-string (items) + (with-output-to-string (csv) + (princ-csv items csv))) + +;;;; Reading in CSV files + +(defun parse-csv-string (line &key (separator #\,) (quote #\")) + "Parse a csv line into a list of strings using seperator as the + column seperator and quote as the string quoting character." + (let ((items '()) + (offset 0) + (current-word (make-array 20 + :element-type 'character + :adjustable t + :fill-pointer 0)) + (state :read-word)) + (loop + (when (= offset (length line)) + ;; all done + (ecase state + (:in-string + (error "Unterminated string.")) + (:read-word + (return-from parse-csv-string + (nreverse (cons current-word items)))))) + (cond + ((char= separator (aref line offset)) + (ecase state + (:in-string + (vector-push-extend (aref line offset) current-word)) + (:read-word + (push current-word items) + (setf current-word (make-array 20 + :element-type 'character + :adjustable t + :fill-pointer 0))))) + ((char= quote (aref line offset)) + (ecase state + (:in-string + (let ((offset+1 (1+ offset))) + (cond + ((and (/= offset+1 (length line)) + (char= quote (aref line offset+1))) + (vector-push-extend quote current-word) + (incf offset)) + (t (setf state :read-word))))) + (:read-word + (setf state :in-string)))) + (t + (vector-push-extend (aref line offset) current-word))) + (incf offset)))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/debug.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/debug.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,108 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Debugging Utilties + +;;;; (These were far more useful in the pre-slime days.) + +(defmacro ppm1 (form) + "(pprint (macroexpand-1 ',form)). + +NB: C-RET is even shorter." + `(pprint (macroexpand-1 ',form))) + +(defmacro ppm (form) + `(pprint (macroexpand ',form))) + +;;;; A portable flexible APROPOS implementation + +(defun apropos-list* (string &key (fbound nil fbound-supplied-p) + (bound nil bound-supplied-p) + (package nil package-supplied-p) + (distance 0 distance-supplied-p)) + (let ((symbols '())) + (do-all-symbols (sym) + (block collect-symbol + (when fbound-supplied-p + (when (xor fbound (fboundp sym)) + (return-from collect-symbol))) + (when bound-supplied-p + (when (xor bound (boundp sym)) + (return-from collect-symbol))) + (when package-supplied-p + (unless (eql package (symbol-package sym)) + (return-from collect-symbol))) + (when distance-supplied-p + (unless (and + (<= (abs (- (length (symbol-name sym)) + (length string))) + distance) + (<= (levenshtein-distance string (symbol-name sym)) + distance)) + (return-from collect-symbol))) + (when (not distance-supplied-p) + ;; regular string= test + (unless (search string (symbol-name sym) :test #'char-equal) + (return-from collect-symbol))) + ;; all the checks we wanted to perform passed. + (push sym symbols))) + symbols)) + +(defun apropos* (&rest apropos-args) + (flet ((princ-length (sym) + (if (keywordp sym) + (+ 1 (length (symbol-name sym))) + (+ (length (package-name (symbol-package sym))) + 1 + (length (symbol-name sym)))))) + (let* ((syms (apply #'apropos-list* apropos-args)) + (longest (apply #'max (mapcar #'princ-length syms)))) + (dolist (sym syms) + (if (keywordp sym) + (progn + (princ ":" *debug-io*) + (princ (symbol-name sym) *debug-io*)) + (progn + (princ (package-name (symbol-package sym)) *debug-io*) + (princ ":" *debug-io*) + (princ (symbol-name sym) *debug-io*))) + (princ (make-string (- longest (princ-length sym)) + :initial-element #\Space) + *debug-io*) + (when (fboundp sym) + (princ " [FUNC] " *debug-io*)) + (when (boundp sym) + (princ " [VAR] " *debug-io*)) + (terpri *debug-io*)))) + (values)) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/decimal-arithmetic.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/decimal-arithmetic.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,120 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Decimal Arithmetic + +;;;; Converting to and from external representations + +(defvar *precision* 2 + "Default precision.") + +(defmacro with-precision (prec &body body) + "Evalute BODY with *precision* bound to PREC." + (let ((precision (gensym))) + `(let ((,precision ,prec)) + (assert (integerp ,precision) + (,precision) + "Precision must be an integer, not ~S" ,precision) + (let ((*precision* (10^ ,precision))) + (declare (special *precision*)) + ,@body)))) + +(defun decimal-from-float (float + &optional (precision *precision*) + (rounding-method #'round-half-up)) + "Convert FLOAT to an exact value with precision PRECISION using + ROUNDING-METHOD to do any neccessary rounding." + (funcall rounding-method float precision)) + +(defun float-from-decimal (decimal) + "Convert the exact decimal value DECIMAL to a (not neccassily + equal) floating point value." + (float decimal)) + +;;;; Rounding functions + +(defun round-down (number &optional (precision *precision*)) + "Round towards 0." + (if (minusp number) + (round-ceiling number precision) + (round-floor number precision))) + +(defun round-half-up (number &optional (precision *precision*)) + "Round towards the nearest value allowed with the current +precision. If the current value is exactly halfway between two logal +values round away from 0." + (multiple-value-bind (value discarded) + (floor (* number precision)) + (if (<= 1/2 discarded) + (/ (1+ value) precision) + (/ value precision)))) + +(defun round-half-even (number &optional (precision *precision*)) + "Round towards the nearest value allowed with the current +precision. If the current value is exactly halfway between two legal +values round towards the nearest even value." + (multiple-value-bind (value discarded) + (floor (* number precision)) + (cond + ((< discarded 1/2) ;; down + (/ value precision)) + ((= discarded 1/2) ;; goto even + (if (evenp value) + (/ value precision) + (/ (1+ value) precision))) + (t ;; (>= discarded 1/2) + (/ (1+ value) precision))))) + +(defun round-ceiling (number &optional (precision *precision*)) + "Round towards positive infintity" + (/ (ceiling (* number precision)) precision)) + +(defun round-floor (number &optional (precision *precision*)) + "Round towards negative infinity." + (/ (floor (* number precision)) precision)) + +(defun round-half-down (number &optional (precision *precision*)) + "Round towards the nearest legal value. If the current value is +exactly half way between two legal values round towards 0." + (multiple-value-bind (value discarded) + (floor number) + (if (< 1/2 discarded) + (/ (1+ value) precision) + (/ value precision)))) + +(defun round-up (number &optional (precision *precision*)) + "Round away from 0." + (if (minusp number) + (round-floor number precision) + (round-ceiling number precision))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/defclass-struct.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/defclass-struct.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,100 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Defining classes with DEFSTRUCT's syntax + +(defmacro defclass-struct (name-and-options supers &rest slots) + "DEFCLASS with a DEFSTRUCT api. + +NAME-AND-OPTIONS: + + name-symbol | + ( name-symbol [ (:conc-name conc-name ) ] + [ (:predicate predicate-name ) ] + class-option* ) + +SUPERS - a list of super classes passed directly to DEFCLASS. + +SLOTS - a list of slot forms: + + name | + ( name [ init-arg ] [ slot-options* ] )" + (generate-defclass (first (ensure-list name-and-options)) + (cdr (ensure-list name-and-options)) + supers slots)) + +(defun generate-defclass (class-name options supers slots) + (let ((conc-name nil) + (predicate nil) + (predicate-forms nil) + (class-options '())) + (loop + for (option-name . args) in options + do (case option-name + (:conc-name + (when conc-name + (error "Can't specify the :CONC-NAME argument more than once.")) + (setf conc-name (first args))) + (:predicate + (when predicate + (error "Can't specify the :PREDICATE argument more than once.")) + (setf predicate (if (eql t (first args)) + (intern (strcat class-name :-p) *package*) + (first args)))) + (t + (push (cons option-name args) class-options)))) + (setf slots + (mapcar + (lambda (slot-spec) + (destructuring-bind (name + &optional initform + &rest options) + (ensure-list slot-spec) + `(,name + :initform ,initform + ,@(when conc-name + `(:accessor ,(intern (strcat conc-name name) + (symbol-package conc-name)))) + :initarg ,(intern (symbol-name name) :keyword) + ,@options))) + slots) + predicate-forms + (if predicate + (with-unique-names (obj) + `((defmethod ,predicate ((,obj ,class-name)) t) + (defmethod ,predicate ((,obj t)) nil))) + nil)) + `(prog1 + (defclass ,class-name ,supers ,slots ,@(nreverse class-options)) + ,@predicate-forms))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/flow-control.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/flow-control.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,235 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Various flow control operators + +;;;; ** Anaphoric conditionals + +(defmacro if-bind (var test &body then/else) + "Anaphoric IF control structure. + +VAR (a symbol) will be bound to the primary value of TEST. If +TEST returns a true value then THEN will be executed, otherwise +ELSE will be executed." + (assert (first then/else) + (then/else) + "IF-BIND missing THEN clause.") + (destructuring-bind (then &optional else) + then/else + `(let ((,var ,test)) + (if ,var ,then ,else)))) + +(defmacro aif (test then &optional else) + "Just like IF-BIND but the var is always IT." + `(if-bind it ,test ,then ,else)) + +(defmacro when-bind (var test &body body) + "Just like when except VAR will be bound to the + result of TEST in BODY." + `(if-bind ,var ,test (progn ,@body))) + +(defmacro awhen (test &body body) + "Just like when expect the symbol IT will be + bound to the result of TEST in BODY." + `(when-bind it ,test ,@body)) + +(defmacro cond-bind (var &body clauses) + "Just like COND but VAR will be bound to the result of the + condition in the clause when executing the body of the clause." + (if clauses + (destructuring-bind ((test &rest body) &rest others) + clauses + `(if-bind ,var ,test + (progn ,@(if body body (list var))) + (cond-bind ,var ,@others))) + nil)) + +(defmacro acond (&rest clauses) + "Just like cond-bind except the var is automatically IT." + `(cond-bind it ,@clauses)) + +(defmacro aand (&rest forms) + `(and-bind it ,@forms)) + +(defmacro and-bind (var &rest forms) + (cond + ((cdr forms) + `(when-bind ,var ,(first forms) + (and-bind ,var ,@(cdr forms)))) + (forms (first forms)) + (t 't))) + +;;;; ** Multiple value anaphoric conditionals + +(defmacro if2-bind (var test &body then/else) + "Anaphoric IF control structure for multiple values. + +VAR (a symbol) will be bound to the primary value of TEST. If +TEST's second value is true then THEN will be executed, otherwise +ELSE will be executed." + (assert (first then/else) + (then/else) + "IF-BIND missing THEN clause.") + (destructuring-bind (then &optional else) + then/else + (with-unique-names (bool) + `(multiple-value-bind (,var ,bool) ,test + (if ,bool ,then ,else))))) + +(defmacro aif2 (test then &optional else) + "Just like IF-BIND but the var is always IT. + +Very useful with functions like GETHASH." + `(if2-bind it ,test ,then ,else)) + +;;;; ** Looping + +(defmacro while (test &body body) + "Repeat BODY while TEST is true. + +You may exit the loop with (RETURN-FROM WHILE)." + `(block while + (loop + (if ,test + (progn ,@body) + (return-from while))))) + +(defmacro awhile (test &body body) + "Just like WHILE, but the result of TEST is bound to IT. + +You may exit the loop with (RETURN-FROM AWHILE)." + `(block awhile + (loop + (aif ,test + (progn ,@body) + (return-from awhile))))) + +(defmacro until (test &body body) + "Repeat BODY until TEST is false. + +You may exit the loop with (RETURN-FROM UNTIL)." + `(block until + (loop + (if (not ,test) + (progn ,@body) + (return-from until))))) + +;;;; ** Whichever + +(defmacro whichever (&rest possibilities) + "Evaluates one (and only one) of its args, which one is chosen at random" + `(ecase (random ,(length possibilities)) + ,@(loop for poss in possibilities + for x from 0 + collect (list x poss)))) + +;;;; ** XOR - The missing conditional + +(defmacro xor (&rest datums) + "Evaluates the args one at a time. If more than one arg returns true + evaluation stops and NIL is returned. If exactly one arg returns + true that value is returned." + (let ((state (gensym "XOR-state-")) + (block-name (gensym "XOR-block-")) + (arg-temp (gensym "XOR-arg-temp-"))) + `(let ((,state nil) + (,arg-temp nil)) + (block ,block-name + ,@(loop + for arg in datums + collect `(setf ,arg-temp ,arg) + collect `(if ,arg-temp + ;; arg is T, this can change the state + (if ,state + ;; a second T value, return NIL + (return-from ,block-name nil) + ;; a first T, swap the state + (setf ,state ,arg-temp)))) + (return-from ,block-name ,state))))) + +;;;; ** Switch + +(defmacro switch ((obj &key (test #'eql)) &body clauses) + "Evaluate the first clause whose car satisfies (funcall test + car obj)." + ;; NB: There is no need to do the find-if and the remove here, we + ;; can just as well do them with in the expansion + (let ((default-clause (find-if (lambda (c) (eq t (car c))) clauses))) + (when default-clause + (setf clauses (remove default-clause clauses :test #'equalp))) + (let ((obj-sym (gensym)) + (test-sym (gensym))) + `(let ((,obj-sym ,obj) + (,test-sym ,test)) + (cond + ,@(mapcar (lambda (clause) + (let ((keys (ensure-list (car clause))) + (form (cdr clause))) + `((or ,@(mapcar (lambda (key) + `(funcall ,test-sym ',key ,obj-sym)) + keys)) + ,@form))) + clauses) + ,@(when default-clause + `((t ,@(cdr default-clause))))))))) + +(defmacro eswitch ((obj &key (test #'eql)) &body body) + "Like switch but signals an error if no clause succeeds." + (rebinding (obj test) + `(switch (,obj :test ,test) + ,@body + (t + (error "Unmatched SWITCH. Testing against ~S with ~S." + ,obj ,test))))) + +(defmacro cswitch ((obj &key (test #'eql)) &body body) + "Like SWITCH but signals a continuable error if no clause + matches." + (rebinding (obj test) + `(switch (,obj :test ,test) + ,@body + (t + (cerror "Unmatched SWITCH. Testing against ~S with ~S." + ,obj ,test))))) + +;;;; ** Eliminating Nesting + +(defmacro with* (&body body) + (cond + ((cddr body) + (append (first body) `((with* ,@(cdr body))))) + ((cdr body) + `(,@(first body) ,(second body))) + (body (first body)) + (t nil))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/hash.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/hash.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,105 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Convience functions for working with hash tables. + +(defun build-hash-table (hash-spec inital-contents) + "Create a hash table containing ``INITAL-CONTENTS``." + (let ((ht (apply #'make-hash-table hash-spec))) + (dolist* ((key value) inital-contents) + (setf (gethash key ht) value)) + ht)) + +(defmacro deflookup-table + (name &key (var (make-lookup-name name "*" name "*")) + (reader (make-lookup-name name "GET-" name)) + (writer (make-lookup-name name "GET-" name)) + (rem-er (make-lookup-name name "REM-" name)) + (at-redefinition :warn) + (documentation + (format nil "Global var for the ~S lookup table" name)) + (test 'eql) + (initial-contents nil)) + "Creates a hash table and the associated accessors." + ;; if they explicitly pass in NIL we make the name a gensym + (unless var + (setf var (gensym (strcat "var for " name " lookup table ")))) + (unless reader + (setf reader (gensym (strcat "reader for " name " lookup table ")))) + (unless writer + (setf writer (gensym (strcat "writer for " name " lookup table ")))) + (assert (symbolp name) (name) + "The name of the lookup table must be a symbol.") + (assert (symbolp var) (var) + "The name of the underlying var must be a symbol.") + (assert (symbolp reader) (reader) + "The name of the reader for a lookup table must be a symbol.") + (assert (symbolp writer) (writer) + "The name of the writer for a lookup table must be a symbol.") + `(progn + (defvar ,var + (build-hash-table '(:test ,test) ,initial-contents) + ,documentation) + (defun ,reader (key &optional default) + (gethash key ,var default)) + (defun (setf ,writer) (value key) + ,(when at-redefinition + `(when (gethash key ,var) + ,(case at-redefinition + (:warn `(warn "Redefining ~A in deflookup-table named ~S" + (let ((*package* (find-package "KEYWORD"))) + (format nil "~S" key)) + ',name)) + (t at-redefinition)))) + (setf (gethash key ,var) value)) + (defun ,rem-er (key) + (remhash key ,var)) + (list ',name ',var ',reader '(setf ,writer) ',rem-er))) + +(defun make-lookup-name (name &rest parts) + (funcall #'intern-concat parts (symbol-package name))) + +(defun hash-to-alist (hash-table) + (loop for k being the hash-keys of hash-table + collect (cons k (gethash k hash-table)))) + +(defun hash-table-keys (hash-table) + (loop + for k being the hash-keys of hash-table + collect k)) + +(defun hash-table-values (hash-table) + (loop + for v being the hash-values of hash-table + collect v)) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/http.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/http.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,255 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * HTTP/HTML utilities + +;;;; ** URIs/URLs +;;;; http://www.faqs.org/rfcs/rfc2396.html + +(eval-always + (defvar *uri-escaping-ok-table* (make-array 256 + :element-type 'boolean + :initial-element nil)) + (loop + ;; The list of characters which don't need to be escaped when writing URIs. + ;; This list is inherently a heuristic, because different uri components may have + ;; different escaping needs, but it should work fine for http. + for ok-char across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789.,/" do + (setf (aref *uri-escaping-ok-table* (char-code ok-char)) t)) + (setf *uri-escaping-ok-table* (coerce *uri-escaping-ok-table* '(simple-array boolean (256))))) + +(defun escape-as-uri (string) + "Escapes all non alphanumeric characters in STRING following + the URI convention. Returns a fresh string." + (with-output-to-string (escaped) + (write-as-uri string escaped))) + +(defun write-as-uri (string stream) + (declare (type vector string) + (type stream stream) + (optimize (speed 3) (debug 0))) + (loop + for char-code :of-type (unsigned-byte 8) :across (the (vector (unsigned-byte 8)) + (string-to-octets string :utf-8)) do + (if (aref (the (simple-array boolean (256)) (load-time-value *uri-escaping-ok-table* t)) char-code) + (write-char (code-char char-code) stream) + (format stream "%~2,'0X" char-code)))) + +(define-condition uri-parse-error (error) + ((what :initarg :what :reader uri-parse-error.what))) + +(define-condition expected-digit-uri-parse-error (uri-parse-error) ()) + +(defun continue-as-is (c) + (declare (ignore c)) + (awhen (find-restart 'continue-as-is) + (invoke-restart it))) + +(defun try-other-encoding (c encoding) + (declare (ignore c)) + (awhen (find-restart 'try-other-encoding) + (invoke-restart it encoding))) + +(defun unescape-as-uri-non-strict (string) + (handler-bind ((uri-parse-error #'continue-as-is) + (serious-condition #'(lambda (c) + (try-other-encoding c :iso-8859-1)) )) + (%unescape-as-uri string))) + +(defun %unescape-as-uri (input) + "URI unescape based on http://www.ietf.org/rfc/rfc2396.txt" + (declare (type string input) + (optimize (speed 3) (debug 0))) + (let ((input-length (length input))) + (when (zerop input-length) + (return-from %unescape-as-uri "")) + (let* ((input-index 0) + (output (make-array input-length :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0))) + (declare (type fixnum input-length input-index)) + (labels ((read-next-char (must-exists-p) + (when (>= input-index input-length) + (if must-exists-p + (error 'uri-parse-error :what input) + (return-from %unescape-as-uri + (restart-case + (octets-to-string output :utf-8) + (try-other-encoding (encoding) + :report "Try converting uri using other encoding" + (octets-to-string output encoding)))))) + (prog1 (aref input input-index) + (incf input-index))) + (write-next-byte (byte) + (vector-push-extend byte output) + (values)) + (char-to-int (char) + (let ((result (digit-char-p char 16))) + (unless result + (error 'expected-digit-uri-parse-error :what char)) + result)) + (parse () + (let ((next-char (read-next-char nil))) + (case next-char + (#\% (char%)) + (#\+ (char+)) + (t (write-next-byte (char-code next-char)))) + (parse))) + (char% () + (let ((restart-input-index input-index)) + (restart-case + (write-next-byte (+ (ash (char-to-int (read-next-char t)) 4) + (char-to-int (read-next-char t)))) + (continue-as-is () + :report "Continue reading uri without attempting to convert the escaped-code to a char." + (setf input-index restart-input-index) + (write-next-byte #.(char-code #\%))))) + (values)) + (char+ () + (write-next-byte #.(char-code #\Space)))) + (parse))))) + +(declaim (inline unescape-as-uri)) +(defun unescape-as-uri (string) + (%unescape-as-uri string)) + +(declaim (inline nunescape-as-uri)) +(defun nunescape-as-uri (string) + (%unescape-as-uri string)) + + + +;;;; ** HTML + +;;;; This so blatently wrong its not even funny, and while this is +;;;; exactly what I need I would do well to start using a "real" html +;;;; escaping library (there are a couple to choose from). + +(defun make-html-entities () + (let ((ht (make-hash-table :test 'equalp))) + (flet ((add-mapping (char escaped) + (setf (gethash char ht) escaped + (gethash escaped ht) char))) + (add-mapping #\< "<") + (add-mapping #\> ">") + (add-mapping #\& "&") + (add-mapping #\" """) + (add-mapping #\space " ") + (add-mapping "a`" "à") + (add-mapping "a'" "á") + (add-mapping "e`" "è") + (add-mapping "e'" "é") + (add-mapping "i'" "ì") + (add-mapping "i`" "í") + (add-mapping "o`" "ò") + (add-mapping "o'" "ó") + (add-mapping "u`" "ù") + (add-mapping "u'" "ú")) + ht)) + +(defparameter *html-entites* (make-html-entities)) + +(defun html-entity->char (entity &optional (default #\?)) + (let ((res (gethash entity *html-entites*))) + (if res + (if (stringp res) + (char res 0) + res) + default))) + +(defun write-as-html (string &key (stream t) (escape-whitespace nil)) + (loop + for char across string + do (cond + ((char= char #\Space) + (if escape-whitespace + (princ " " stream) + (write-char char stream))) + ((gethash char *html-entites*) + (princ (gethash char *html-entites*) stream)) + (t (write-char char stream))))) + +(defun escape-as-html (string &key (escape-whitespace nil)) + (with-output-to-string (escaped) + (write-as-html string + :stream escaped + :escape-whitespace escape-whitespace))) + +(define-condition html-escape-error (error) + ((what :accessor html-escape-error.what :initarg :what))) + +(define-condition unterminated-html-entity (html-escape-error) + ()) + +(define-condition unknown-html-entity (html-escape-error) + ()) + +(define-condition unknown-char-escape (warning) + ((what :accessor html-escape-error.what :initarg :what))) + +(defun unescape-as-html (string) + (with-output-to-string (unescaped) + (loop + for offset upfrom 0 below (length string) + for char = (aref string offset) + if (char= #\& char) + do (progn + (aif (position #\; string :start offset) + (let ((escape-tag (subseq string offset (1+ it)))) + (aif (gethash escape-tag *html-entites*) + (progn + (princ it unescaped) + (incf offset (1- (length escape-tag)))) + (if (char= #\# (aref escape-tag 1)) + ;; special code, ignore + (restart-case + (warn 'unknown-char-escape :what escape-tag) + (continue-delete () + :report "Continue processing, delete this char." + (incf offset (1- (length escape-tag))))) + (restart-case + (error 'unknown-html-entity :what escape-tag) + (continue-as-is () + :report "Continue processing, leaving the string as is." + (write-char #\& unescaped)) + (continue-delete () + :report "Continue processing, delete this entity." + (incf offset (1- (length escape-tag)))))))) + (restart-case + (error 'unterminated-html-entity + :what (subseq string offset + (min (+ offset 20) + (length string)))) + (continue-as-is () + :report "Continue processing, leave the string as is." + (write-char #\& unescaped))))) + else do (write-char char unescaped)))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/io.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/io.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,156 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Utilites for file system I/O + +(defmacro with-input-from-file ((stream-name file-name &rest args &key + (direction nil direction-provided-p) + external-format + &allow-other-keys) + &body body) + "Evaluate BODY with STREAM-NAME bound to an + input-stream from file FILE-NAME. ARGS is passed + directly to open." + (declare (ignore direction)) + (when direction-provided-p + (error "Can't specifiy :DIRECTION in WITH-INPUT-FILE.")) + (remf-keywords args :external-format) + `(with-open-file (,stream-name ,file-name :direction :input + ,@(when external-format + `(:external-format + ,(if (keywordp external-format) + `(encoding-keyword-to-native ,external-format) + external-format))) + ,@args) + ,@body)) + +(defmacro with-output-to-file ((stream-name file-name &rest args &key + (direction nil direction-provided-p) + external-format + &allow-other-keys) + &body body) + "Evaluate BODY with STREAM-NAME to an output stream + on the file named FILE-NAME. ARGS is sent as is to + the call te open." + (declare (ignore direction)) + (when direction-provided-p + (error "Can't specifiy :DIRECTION in WITH-OUTPUT-FILE.")) + (remf-keywords args :external-format) + `(with-open-file (,stream-name ,file-name :direction :output + ,@(when external-format + `(:external-format + ,(if (keywordp external-format) + `(encoding-keyword-to-native ,external-format) + external-format))) + ,@args) + ,@body)) + +(defun read-string-from-file (pathname &key (buffer-size 4096) + (element-type 'character) + (external-format :us-ascii)) + "Return the contents of PATHNAME as a fresh string. + +The file specified by PATHNAME will be read one ELEMENT-TYPE +element at a time, the EXTERNAL-FORMAT and ELEMENT-TYPEs must be +compatible. + +The EXTERNAL-FORMAT parameter will be passed to +ENCODING-KEYWORD-TO-NATIVE, see ENCODING-KEYWORD-TO-NATIVE to +possible values." + (with-input-from-file + (file-stream pathname :external-format (encoding-keyword-to-native external-format)) + (with-output-to-string (datum) + (let ((buffer (make-array buffer-size :element-type element-type))) + (loop for bytes-read = (read-sequence buffer file-stream) + do (write-sequence buffer datum :start 0 :end bytes-read) + while (= bytes-read buffer-size)))))) + +(defun write-string-to-file (string pathname &key (if-exists :error) + (if-does-not-exist :error) + (external-format :us-ascii)) + "Write STRING to PATHNAME. + +The EXTERNAL-FORMAT parameter will be passed to +ENCODING-KEYWORD-TO-NATIVE, see ENCODING-KEYWORD-TO-NATIVE to +possible values." + (with-output-to-file (file-stream pathname :if-exists if-exists + :if-does-not-exist if-does-not-exist + :external-format (encoding-keyword-to-native external-format)) + (write-sequence string file-stream))) + +(defun copy-file (from to &key (if-to-exists :supersede) + (element-type '(unsigned-byte 8))) + (with* + (with-input-from-file (input from :element-type element-type)) + (with-output-to-file (output to :element-type element-type + :if-exists if-to-exists)) + (progn + (copy-stream input output)))) + +(defun copy-stream (input output &optional (element-type (stream-element-type input))) + "Reads data from FROM and writes it to TO. Both FROM and TO + must be streams, they will be passed to + read-sequence/write-sequence and must have compatable + element-types." + (loop + with buffer-size = 4096 + with buffer = (make-array buffer-size :element-type element-type) + for bytes-read = (read-sequence buffer input) + while (= bytes-read buffer-size) + do (write-sequence buffer output) + finally (write-sequence buffer output :end bytes-read))) + +(defmacro defprint-object ((self class-name &key (identity t) (type t) with-package + (muffle-errors t)) + &body body) + "Define a print-object method using print-unreadable-object. + An example: + (defprint-object (self parenscript-dispatcher) + (when (cachep self) + (princ \"cached\") + (princ \" \")) + (princ (parenscript-file self)))" + (with-unique-names (stream) + `(defmethod print-object ((,self ,class-name) ,stream) + (print-unreadable-object (,self ,stream :type ,type :identity ,identity) + (let ((*standard-output* ,stream)) + (block printing + (,@(if muffle-errors + `(handler-bind ((error (lambda (error) + (declare (ignore error)) + (write-string "<<error printing object>>") + (return-from printing))))) + `(progn)) + (let (,@(when with-package `((*package* ,(find-package with-package))))) + ,@body)))))))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/lambda-list.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/lambda-list.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,92 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Lambda-lists + +(defun extract-argument-names (lambda-list &key allow-specializers) + "Returns a list of symbols representing the names of the + variables bound by the lambda list LAMBDA-LIST." + (mapcan (lambda (argument) + (let1 vars '() + (dolist (slot-name '(name supplied-p-parameter)) + (awhen (and (slot-exists-p argument slot-name) + (slot-boundp argument slot-name) + (slot-value argument slot-name)) + (push it vars))) + (nreverse vars))) + (walk-lambda-list lambda-list nil '() :allow-specializers allow-specializers))) + +(defun convert-to-generic-lambda-list (defmethod-lambda-list) + (loop + with generic-lambda-list = '() + for arg in (walk-lambda-list defmethod-lambda-list + nil nil + :allow-specializers t) + do (etypecase arg + ((or required-function-argument-form + specialized-function-argument-form) + (push (name arg) generic-lambda-list)) + (keyword-function-argument-form + (pushnew '&key generic-lambda-list) + (if (keyword-name arg) + (push (list (list (keyword-name arg) + (name arg))) + generic-lambda-list) + (push (list (name arg)) generic-lambda-list))) + (rest-function-argument-form + (push '&rest generic-lambda-list) + (push (name arg) generic-lambda-list)) + (optional-function-argument-form + (pushnew '&optional generic-lambda-list) + (push (name arg) generic-lambda-list)) + (allow-other-keys-function-argument-form + (unless (member '&key generic-lambda-list) + (push '&key generic-lambda-list)) + (push '&allow-other-keys generic-lambda-list))) + finally (return (nreverse generic-lambda-list)))) + +(defun clean-argument-list (lambda-list) + (loop + for head on lambda-list + for argument = (car head) + if (member argument '(&optional &key &rest &allow-other-keys)) + return (append cleaned head) + else + collect (if (listp argument) + (first argument) + argument) + into cleaned + finally (return cleaned))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; Copyright (c) 2006, Hoan Ton-That +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, Hoan Ton-That, nor +;; BESE, nor the names of its contributors may be used to endorse +;; or promote products derived from this software without specific +;; prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/lambda.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/lambda.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,120 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Higher order functions + +(defun compose (f1 &rest functions) + "Returns a function which applies the arguments in order. + + (funcall (compose #'list #'+) 1 2 3) ==> (6)" + (case (length functions) + (0 f1) + (1 (lambda (&rest args) + (funcall f1 (apply (car functions) args)))) + (2 (lambda (&rest args) + (funcall f1 + (funcall (first functions) + (apply (second functions) args))))) + (3 (lambda (&rest args) + (funcall f1 + (funcall (first functions) + (funcall (second functions) + (apply (third functions) args)))))) + (t + (let ((funcs (nreverse (cons f1 functions)))) + (lambda (&rest args) + (loop + for f in funcs + for r = (multiple-value-list (apply f args)) + then (multiple-value-list (apply f r)) + finally (return (values-list r)))))))) + +(defun conjoin (&rest predicates) + (case (length predicates) + (0 (constantly t)) + (1 (car predicates)) + (2 (lambda (&rest args) + (and (apply (first predicates) args) + (apply (second predicates) args)))) + (3 (lambda (&rest args) + (and (apply (first predicates) args) + (apply (second predicates) args) + (apply (third predicates) args)))) + (t + (lambda (&rest args) + (loop + for p in predicates + for val = (apply p args) + while val + finally (return val)))))) + +(defun curry (function &rest initial-args) + "Returns a function which will call FUNCTION passing it + INITIAL-ARGS and then any other args. + + (funcall (curry #'list 1) 2) ==> (list 1 2)" + (lambda (&rest args) + (apply function (append initial-args args)))) + +(defun rcurry (function &rest initial-args) + "Returns a function which will call FUNCTION passing it the + passed args and then INITIAL-ARGS. + + (funcall (rcurry #'list 1) 2) ==> (list 2 1)" + (lambda (&rest args) + (apply function (append args initial-args)))) + +(defun noop (&rest args) + "Do nothing." + (declare (ignore args)) + (values)) + +(defmacro lambda-rec (name args &body body) + "Just like lambda except BODY can make recursive calls to the + lambda by calling the function NAME." + `(lambda ,args + (labels ((,name ,args ,@body)) + (,name ,@args)))) + +;;;; ** Just for fun + +(defun y (lambda) + (funcall (lambda (f) + (funcall (lambda (g) + (funcall g g)) + (lambda (x) + (funcall f + (lambda () + (funcall x x)))))) + lambda)) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/lexenv.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/lexenv.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,588 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Portable lexical environment access + +(defgeneric environment-p (environment) + (:documentation "Returns T if ENVIRONMENT is a lexical + environment object (something suitable for passing to + macroexpand-1 or similar)")) + +(defgeneric lexical-variables (environment) + (:documentation "Return the names of all the local variables + in ENVIRONMENT. Does not return neither symbol-macrolets nor + ignared variables.")) + +(defgeneric lexical-functions (environment) + (:documentation "Returns the names of all the local functions + in ENVIRONMENT. Names may be symbols of lists of the form (setf + name).")) + +(defgeneric lexical-macros (environment) + (:documentation "Returns the lexical macro definitions in + ENVIRONMENT. The return value is a list of elements of form + (SYMBOL . MACRO-FUNCTION. MACRO-FUNCTION can be called like + functions returned by macro-function.")) + +(defgeneric lexical-symbol-macros (environment) + (:documentation "Returns the lexical symbol macro definitions + in ENVIRONMENT. The return value is a list of elements of form + (SYMBOL . EXPANSION).")) + +(defmethod lexical-variables ((environment t)) + '()) + +(defmethod lexical-functions ((environment t)) + '()) + +(defmethod lexical-macros ((environment t)) + '()) + +(defmethod lexical-symbol-macros ((environment t)) + '()) + +;;;; ** OpenMCL + +#+openmcl +(defmethod environment-p ((e ccl::lexical-environment)) + t) + +#+openmcl +(defmethod lexical-variables ((environment ccl::lexical-environment)) + (loop + for env = environment + then (ccl::lexenv.parent-env env) + while (and env + (not (ccl::istruct-typep env 'ccl::definition-environment))) + for vars = (ccl::lexenv.variables env) + when (listp vars) + ;; we now weed out all symbol-macros and ignored variables + append (remove-if (lambda (var-name) + (let ((decs (assoc var-name (ccl::lexenv.vdecls env)))) + (and decs + (eql 'cl:ignore (second decs)) + (eql 'cl:t (cddr decs))))) + (mapcar (lambda (var) + ;; ccl::var-name is a macro, se we can't do #'ccl::var-name directly + (ccl::var-name var)) + (remove-if (lambda (var-spec) + (and (ccl::var-ea var-spec) + (consp (ccl::var-ea var-spec)) + (eql :symbol-macro (car (ccl::var-ea var-spec))))) + vars))))) + +#+openmcl +(defmethod lexical-functions ((environment ccl::lexical-environment)) + (loop + for env = environment + then (ccl::lexenv.parent-env env) + while (and env + (not (ccl::istruct-typep env 'ccl::definition-environment))) + for funs = (ccl::lexenv.functions env) + when (listp funs) + ;; we now weed out all symbol-macros and ignored variables + append (mapcar (lambda (func-spec) + ;; convert the function name to a "real" function name + (let ((name (first func-spec))) + (if (eql (symbol-package (first func-spec)) + (find-package :SETF)) + (list 'cl:setf (read-from-string (symbol-name name))) + name))) + (remove-if (lambda (func-spec) + ;; weed out all the macrolets + (eql 'ccl::macro (second func-spec))) + funs)))) + +;;;; ** SBCL + +#+sbcl +(defmethod environment-p ((environment sb-kernel:lexenv)) + t) + +#+sbcl +(defmethod lexical-variables ((environment sb-kernel:lexenv)) + (loop + for var-spec in (sb-c::lexenv-vars environment) + when (and (atom (cdr var-spec)) + (not (and (typep (cdr var-spec) 'sb-c::lambda-var) + (sb-c::lambda-var-ignorep (cdr var-spec))))) + collect (car var-spec))) + +#+sbcl +(defmethod lexical-functions ((environment sb-kernel:lexenv)) + (loop + for fun-spec in (sb-c::lexenv-funs environment) + when (not (consp (cdr fun-spec))) + collect (car fun-spec))) + +#+sbcl +(defmethod lexical-macros ((environment sb-kernel:lexenv)) + (loop + for mac-spec in (sb-c::lexenv-funs environment) + when (and (consp (cdr mac-spec)) + (eq 'sb-sys::macro (cadr mac-spec))) + collect (cons (car mac-spec) (cddr mac-spec)))) + +#+sbcl +(defmethod lexical-symbol-macros ((environment sb-kernel:lexenv)) + (loop + for mac-spec in (sb-c::lexenv-vars environment) + when (and (consp (cdr mac-spec)) + (eq 'sb-sys::macro (cadr mac-spec))) + collect (cons (car mac-spec) (cddr mac-spec)))) + +;;;; ** CMUCL + +#+cmu +(defmethod environment-p ((environment c::lexenv)) + t) + +#+cmu +(defmethod lexical-variables ((environment c::lexenv)) + (loop + for var-spec in (c::lexenv-variables environment) + ;; variable refs are (NAME . LAMBDA-VAR), we want to void + ;; symbol-macrolets which are (NAME SYSTEM:MACRO . EXPANSION) + when (and (atom (cdr var-spec)) + ;; don't return ignored vars + (not (eq (type-of (cdr var-spec)) 'c::global-var)) + (not (c::lambda-var-ignorep (cdr var-spec)))) + collect (car var-spec))) + +#+cmu +(defmethod lexical-functions ((environment c::lexenv)) + (loop + for func-spec in (c::lexenv-functions environment) + ;; flet and labels function look like ((FLET ACTUAL-NAME) . STUFF) + if (and (consp (first func-spec)) + (member (car (first func-spec)) '(flet labels))) + collect (second (first func-spec)) + ;; macrolets look like (NAME SYSTEM:MACRO . STUFF) + else if (and (consp (cdr func-spec)) + (eql 'system:macro (second func-spec))) + ;; except that we don't return macros for now + do (progn) + ;; handle the case (NAME . #<C::FUNCTIONAL>) + else if (typep (cdr func-spec) 'C::FUNCTIONAL) + collect (car func-spec) + ;; if we get here we're confused :( + else + do (error "Sorry, don't know how to handle the lexcial function spec ~S." + func-spec))) + +#+cmu +(defmethod lexical-macros ((environment c::lexenv)) + (loop + for mac-spec in (c::lexenv-functions environment) + when (and (consp (cdr mac-spec)) + (eq 'system::macro (cadr mac-spec))) + collect (cons (car mac-spec) (cddr mac-spec)))) + +#+cmu +(defmethod lexical-symbol-macros ((environment c::lexenv)) + (loop + for mac-spec in (c::lexenv-variables environment) + when (and (consp (cdr mac-spec)) + (eq 'system::macro (cadr mac-spec))) + collect (cons (car mac-spec) (cddr mac-spec)))) + +;;;; ** CLISP + +#+clisp +(defmethod environment-p ((environment vector)) + (= 2 (length environment))) + +#+clisp +(defun walk-vector-tree (function vector-tree) + (labels ((%walk (vector-tree) + (loop + for index upfrom 0 by 2 + for tree-top = (aref vector-tree index) + if (null tree-top) + do (return-from %walk nil) + else if (vectorp tree-top) + do (return-from %walk + (%walk tree-top)) + else + do (funcall function + (aref vector-tree index) + (aref vector-tree (1+ index)))))) + (%walk vector-tree))) + +#+clisp +(defmethod lexical-variables ((environment vector)) + (let ((vars '())) + (when (aref environment 0) + (walk-vector-tree (lambda (var-name var-spec) + (unless (system::symbol-macro-p var-spec) + (push var-name vars))) + (aref environment 0))) + vars)) + +#+clisp +(defmethod lexical-functions ((environment vector)) + (let ((vars '())) + (when (aref environment 1) + (walk-vector-tree (lambda (func-name func-spec) + (push func-name vars)) + (aref environment 1))) + vars)) + +#+clisp +(defmethod lexical-macros ((environment vector)) + (let ((macros '())) + (when (aref environment 1) + (walk-vector-tree + (lambda (macro-name macro-spec) + (if (system::macrop macro-spec) + (push (cons macro-name + (macro-function macro-name environment)) + macros))) + (aref environment 1))) + macros)) + +#+clisp +(defmethod lexical-symbol-macros ((environment vector)) + (let (symbol-macros '()) + (when (aref environment 0) + (walk-vector-tree + (lambda (macro-name macro-spec) + (if (system::symbol-macro-p macro-spec) + (push (cons macro-name + (macroexpand-1 macro-name environment)) + symbol-macros))) + (aref environment 0))) + symbol-macros)) + +;;;; ** LispWorks + +#+(and lispworks macosx) +(defmethod environment-p ((environment system::augmented-environment)) + t) + +#+(and lispworks macosx) +(defmethod lexical-variables ((environment system::augmented-environment)) + (mapcar (lambda (venv) + (slot-value venv 'compiler::name)) + (remove-if (lambda (venv) + ;; regular variables, the ones we're interested + ;; in, appear to have a NIL in this slot. + (slot-value venv 'compiler::kind)) + (slot-value environment 'compiler::venv)))) + +#+(and lispworks macosx) +(defmethod lexical-functions ((environment system::augmented-environment)) + (mapcar #'car + (remove-if (lambda (fenv) + ;; remove all the macros + (eql 'compiler::macro (slot-value (cdr fenv) 'compiler::function-or-macro))) + (slot-value environment 'compiler::fenv)))) + +#+(and lispworks macosx) +(defmethod environment-p ((environment compiler::environment)) + t) + +#+(and lispworks macosx) +(defmethod lexical-variables ((environment compiler::environment)) + (mapcar (lambda (venv) + (slot-value venv 'compiler::name)) + (remove-if (lambda (venv) + ;; regular variables, the ones we're interested + ;; in, appear to have a NIL in this slot. + (slot-value venv 'compiler::kind)) + (slot-value environment 'compiler::venv)))) + +#+(and lispworks macosx) +(defmethod lexical-functions ((environment compiler::environment)) + (mapcar #'car + (remove-if (lambda (fenv) + ;; remove all the macros + (macro-function (car fenv) environment)) + (slot-value environment 'compiler::fenv)))) + +#+(and lispworks (or win32 linux)) +(defmethod environment-p ((environment lexical::environment)) + t) + +#+(and lispworks (or win32 linux)) +(defun lexical-runtime-p (value) + (and (symbolp value) + (eq (symbol-package value) nil))) + +#+(and lispworks (or win32 linux)) +(defmethod lexical-variables ((environment lexical::environment)) + (loop for candidate in (slot-value environment 'lexical::variables) + if (lexical-runtime-p (cdr candidate)) + collect (car candidate))) + +#+(and lispworks (or win32 linux)) +(defmethod lexical-functions ((environment lexical::environment)) + (loop for candidate in (slot-value environment 'lexical::functions) + if (lexical-runtime-p (cdr candidate)) + collect (car candidate))) + + +#+(and lispworks (or win32 linux)) +(defmethod lexical-symbol-macros ((environment lexical::environment)) + (loop for candidate in (slot-value environment 'lexical::variables) + unless (lexical-runtime-p (cdr candidate)) + collect candidate)) + +#+(and lispworks (or win32 linux)) +(defmethod lexical-macros ((environment lexical::environment)) + (loop for candidate in (slot-value environment 'lexical::functions) + unless (lexical-runtime-p (cdr candidate)) + collect candidate)) + +;;;; ** Allegro + +#+(and allegro (version>= 7 0)) +(defmethod environment-p ((env sys::augmentable-environment)) t) + +#+(and allegro (version>= 7 0)) +(defmethod lexical-variables ((env sys::augmentable-environment)) + (let (fns) + (system::map-over-environment-variables + (lambda (symbol type rest) + (declare (ignore rest)) + (when (and (eq type :lexical) + (sys:variable-information symbol env)) + (push symbol fns))) + env) + fns)) + +#+(and allegro (version>= 7 0)) +(defmethod lexical-functions ((env sys::augmentable-environment)) + (let (fns) + (system::map-over-environment-functions + (lambda (name type rest) + (when (and (eq type :function) + (sys:function-information name env)) + (push name fns))) + env) + fns)) + +#+(and allegro (version>= 7 0)) +(defmethod lexical-macros ((env sys::augmentable-environment)) + (let (fns) + (system::map-over-environment-functions + (lambda (name type rest) + (when (eq type :macro) + (push (cons name (car rest)) fns))) + env) + fns)) + +#+(and allegro (version>= 7 0)) +(defmethod lexical-symbol-macros ((env sys::augmentable-environment)) + (let (fns) + (system::map-over-environment-variables + (lambda (symbol type rest) + (when (eq type :symbol-macro) + (push (cons symbol (car rest)) fns))) + env) + fns)) + + +;; These functions are a half-assed implementation of section 8.5 in CLtL2 +;; (environment manipulation) +;; I really don't feel like implementing THAT interface for every supported +;; Lisp. + +(defgeneric augment-with-variable (env var)) + +(defgeneric augment-with-function (env fun)) + +(defgeneric augment-with-macro (env mac def)) + +(defgeneric augment-with-symbol-macro (env symmac def)) + +(defmethod augment-with-variable ((env t) var) + (declare (ignore var)) + env) + +(defmethod augment-with-function ((env t) fun) + (declare (ignore fun)) + env) + +(defmethod augment-with-macro ((env t) mac def) + (declare (ignore mac def)) + env) + +(defmethod augment-with-symbol-macro ((env t) symmac def) + (declare (ignore symmac def)) + env) + +#+sbcl +(defmethod augment-with-variable ((env sb-kernel:lexenv) var) + (sb-c::make-lexenv :default env :vars (list (cons var t)))) + +#+sbcl +(defmethod augment-with-function ((env sb-kernel:lexenv) fun) + (sb-c::make-lexenv :default env :funs (list (cons fun t)))) + +#+sbcl +(defmethod augment-with-macro ((env sb-kernel:lexenv) mac def) + (sb-c::make-lexenv :default env :funs (list (list* mac 'sb-sys::macro def)))) + +#+sbcl +(defmethod augment-with-symbol-macro ((env sb-kernel:lexenv) symmac def) + (sb-c::make-lexenv :default env :vars (list (list* symmac 'sb-sys::macro def)))) + +#+cmu +(defmethod augment-with-variable ((env c::lexenv) var) + (c::make-lexenv :default env + :variables (list (cons var (c::make-lambda-var :name var))))) + +#+cmu +(defmethod augment-with-function ((env c::lexenv) fun) + (c::make-lexenv :default env + :functions (list (cons fun (lambda () 42))))) + +#+cmu +(defmethod augment-with-macro ((env c::lexenv) mac def) + (c::make-lexenv :default env + :functions (list (list* mac 'system::macro def)))) + +#+cmu +(defmethod augment-with-symbol-macro ((env c::lexenv) symmac def) + (c::make-lexenv :default env + :variables (list (list* symmac 'system::macro def)))) + + +#+clisp +(defun augment-with-var-and-fun (env &key var fun) + (let* ((old-vars (aref env 0)) + (old-funs (aref env 1)) + (new-vars (if (eq var nil) + (make-array '(1) :initial-contents (list old-vars)) + (make-array '(3) :initial-contents (list (car var) (cdr var) old-vars)))) + (new-funs (if (eq fun nil) + (make-array '(1) :initial-contents (list old-funs)) + (make-array '(3) :initial-contents (list (car fun) (cdr fun) old-funs))))) + (make-array '(2) :initial-contents (list new-vars new-funs)))) + +;; I don't know whether t is an acceptable value to store here, +;; but CLISP does not complain. +#+clisp +(defmethod augment-with-variable ((env vector) var) + (augment-with-var-and-fun env :var (cons var t))) + +#+clisp +(defmethod augment-with-function ((env vector) fun) + (augment-with-var-and-fun env :fun (cons fun t))) + +#+clisp +(defmethod augment-with-macro ((env vector) mac def) + (augment-with-var-and-fun env :fun (cons mac (system::make-macro def)))) + +#+clisp +(defmethod augment-with-symbol-macro ((env vector) symmac def) + (augment-with-var-and-fun env :var + (cons symmac + (system::make-symbol-macro def)))) + + +#+(and lispworks (or win32 linux)) +(defmethod augment-with-variable ((env lexical::environment) var) + (harlequin-common-lisp:augment-environment + env :variable (list var))) + +#+(and lispworks (or win32 linux)) +(defmethod augment-with-function ((env lexical::environment) fun) + (harlequin-common-lisp:augment-environment + env :function (list fun))) + +#+(and lispworks (or win32 linux)) +(defmethod augment-with-macro ((env lexical::environment) mac def) + (harlequin-common-lisp:augment-environment + env :macro (list (list mac def)))) + +#+(and lispworks (or win32 linux)) +(defmethod augment-with-symbol-macro ((env lexical::environment) symmac def) + (harlequin-common-lisp:augment-environment + env :symbol-macro (list (list symmac def)))) + +#+(and allegro (version>= 7 0)) +(defmethod augment-with-variable ((env sys::augmentable-environment) var) + (system:augment-environment env :variable (list var))) + +#+(and allegro (version>= 7 0)) +(defmethod augment-with-function ((env sys::augmentable-environment) fun) + (system:augment-environment env :function (list fun))) + +#+(and allegro (version>= 7 0)) +(defmethod augment-with-macro ((env sys::augmentable-environment) mac def) + (system:augment-environment env :macro (list (list mac def)))) + +#+(and allegro (version>= 7 0)) +(defmethod augment-with-symbol-macro ((env sys::augmentable-environment) symmac def) + (system:augment-environment env :symbol-macro (list (list symmac def)))) + + +(defun macroexpand-all (form &optional env) + (unwalk-form (walk-form form nil (make-walk-env env)))) + +;; Sort of parse-macro from CLtL2. + +(defun parse-macro-definition (name lambda-list body env) + (declare (ignore name)) + (let* ((environment-var nil) + (lambda-list-without-environment + (loop + for prev = nil then i + for i in lambda-list + if (not (or (eq '&environment i) (eq '&environment prev))) + collect i + if (eq '&environment prev) + do (if (eq environment-var nil) + (setq environment-var i) + (error "Multiple &ENVIRONMENT clauses in macro lambda list: ~S" lambda-list)))) + (handler-env (if (eq environment-var nil) (gensym "ENV-") environment-var)) + whole-list lambda-list-without-whole) + (if (eq '&whole (car lambda-list-without-environment)) + (setq whole-list (list '&whole (second lambda-list-without-environment)) + lambda-list-without-whole (cddr lambda-list-without-environment)) + (setq whole-list '() + lambda-list-without-whole lambda-list-without-environment)) + (eval + (with-unique-names (handler-args form-name) + `(lambda (,handler-args ,handler-env) + ,@(if (eq environment-var nil) + `((declare (ignore ,handler-env))) + nil) + (destructuring-bind (,@whole-list ,form-name ,@lambda-list-without-whole) + ,handler-args + (declare (ignore ,form-name)) + ,@(mapcar (lambda (form) (macroexpand-all form env)) body))))))) + + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/lisp1.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/lisp1.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,255 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Entry point + +(defgeneric lisp1 (form) + (:documentation "Translate FORM from Lisp-1 to Lisp-2. + +Define methods on this generic function with DEFLISP1-WALKER.")) + +(defmethod lisp1 (form) + "If FORM isn't a FORM object, we'll convert it to one, apply +the transformation and convert it back." + (unwalk-form (lisp1 (walk-form form)))) + +(defmacro with-lisp1 (form) + "Execute FORM as if it were run in a Lisp-1." + (lisp1 form)) + +(defmacro deflisp1-walker (class (&rest slots) &body body) + "Define a Lisp-1 to Lisp-2 walker. + +It takes the class of a CL form object, and its slots as +arguments. It also captures the variable FORM for convenience." + `(defmethod lisp1 ((form ,class)) + (with-slots ,slots form + ,@body))) + +;;;; * Special Variables + +(defvar *bound-vars* nil + "When walking code, this variable contains a list of +variables (represented by symbols) which have been bound in +the variable namespace. + +In essence these variables do not have to be sharp-quoted.") + +(defvar *bound-funs* nil + "When walking code, this variable contains a list of +variables (represented by symbols) which have been bound in +the function namespace. + +In essence these variables must be sharp-quoted.") + +(defmacro with-bound-vars (vars &body body) + "Execute BODY with VARS added to the variable namespace and +VARS removed from the function namespace. + +This should only be used when code-walking." + `(let ((*bound-vars* (append *bound-vars* ,vars)) + (*bound-funs* (set-difference *bound-funs* ,vars))) + ,@body)) + +(defmacro with-bound-funs (funs &body body) + "Execute BODY with FUNS added to the function namespace and +FUNS removed from the variable namespace. + +This should only be used when code-walking." + `(let ((*bound-funs* (append *bound-funs* ,funs)) + (*bound-vars* (set-difference *bound-vars* ,funs))) + ,@body)) + +;;;; * Definers + +(defmacro defun1 (name (&rest args) &body body) + "Define a function with BODY written in Lisp-1 style. + +This is just like DEFUN." + (with-bound-vars (extract-argument-names args :allow-specializers nil) + `(defun ,name ,args + ,(lisp1 `(block ,name ,@body))))) + +(defmacro defmethod1 (name (&rest args) &body body) + "Define a method with BODY written in Lisp-1 style. + +This is just like DEFMETHOD." + (with-bound-vars (extract-argument-names args :allow-specializers t) + `(defmethod ,name ,args + ,(lisp1 `(block ,name ,@body))))) + +;;;; * Utils + +(defun lisp1s (forms) + "Convert a list of forms to Lisp-1 style." + (mapcar #'lisp1 forms)) + +(defun lisp1b (binds) + "Convert an alist of (VAR . FORM) to Lisp-1 style." + (mapcar (lambda (bind) + (cons (car bind) + (lisp1 (cdr bind)))) + binds)) + +;;;; * Walkers + +(deflisp1-walker form () + ;; By default all forms will stay the same. + form) + +(deflisp1-walker if-form (consequent then else) + ;; Transform the test and branches recursively. + (new 'if-form + :consequent (lisp1 consequent) + :then (lisp1 then) + :else (lisp1 else))) + +(deflisp1-walker lambda-function-form (arguments body) + ;; For any function-form (ie lambda), we just transform the body. + ;; We also must add the parameters to the variable namespace, and + ;; remove the parameters from the function namespace. + (with-bound-vars (mapcar #'name arguments) + (new 'lambda-function-form + :arguments arguments + :body (lisp1s body)))) + +(deflisp1-walker variable-reference (name) + ;; If a free variable is bound in the toplevel, *and* not bound by + ;; an enclosing lambda, then we'll return that function. Also, if + ;; the variable has been bound by an enclosing function binding form + ;; then we'll return that function. We take advantage of the fact + ;; that the `name' slot is shared. + (if (or (and (fboundp name) (not (member name *bound-vars*))) + (member name *bound-funs*)) + (change-class form 'free-function-object-form) + form)) + +(deflisp1-walker application-form (operator arguments) + ;; We transform all applications so they use explicit funcall. We + ;; also must take into account ((a b) c ...) which must also + ;; transform the operator accordingly. + (new 'free-application-form + :operator 'funcall + :arguments (cons (if (not (typep operator 'form)) + (lisp1 (walk-form operator)) + (lisp1 operator)) + (lisp1s arguments)))) + +(deflisp1-walker function-binding-form (binds body) + ;; Add all the bindings to the function namespace to be sharp + ;; quoted. + (with-bound-funs (mapcar #'car binds) + (new (class-name-of form) + :binds (lisp1b binds) + :body (lisp1s body)))) + +(deflisp1-walker variable-binding-form (binds body) + ;; Add all the bindings to the variable namespace so they aren't + ;; sharp-quoted. + (with-bound-vars (mapcar #'car binds) + (new (class-name-of form) + :binds (lisp1b binds) + :body (lisp1s body)))) + +;; Walking all the other Common Lisp forms is rather straight-forward. + +(deflisp1-walker setq-form (var value) + (new 'setq-form + :var var + :value (lisp1 value))) + +(deflisp1-walker progn-form (body) + (new 'progn-form + :body (lisp1s body))) + +(deflisp1-walker progv-form (vars-form values-form) + (new 'progv-form + :vars-form vars-form + :values-form (lisp1s values-form))) + +(deflisp1-walker block-form (name body) + (new 'block-form + :name name + :body (lisp1s body))) + +(deflisp1-walker return-from-form (target-block result) + (new 'return-from-form + :target-block target-block + :result (lisp1 result))) + +(deflisp1-walker catch-form (tag body) + (new 'catch-form + :tag tag + :body (lisp1s body))) + +(deflisp1-walker throw-form (tag value) + (new 'throw-form + :tag tag + :value (lisp1 value))) + +(deflisp1-walker eval-when-form (body eval-when-times) + (new 'eval-when-form + :eval-when-times eval-when-times + :body (lisp1s body))) + +(deflisp1-walker multiple-value-call-form (func arguments) + (new 'multiple-value-call-form + :func (lisp1 func) + :arguments (lisp1s arguments))) + +(deflisp1-walker multiple-value-prog1-form (first-form other-forms) + (new 'multiple-value-prog1-form + :first-form (lisp1 first-form) + :other-forms (lisp1s other-forms))) + +(deflisp1-walker symbol-macrolet-form (binds body) + (new 'symbol-macrolet-form + :binds (lisp1b binds) + :body (lisp1s body))) + +(deflisp1-walker tagbody-form (body) + (new 'tagbody-form + :body (lisp1s body))) + +(deflisp1-walker the-form (type-form value) + (new 'the-form + :type-form type-form + :value (lisp1 value))) + +(deflisp1-walker unwind-protect-form (protected-form cleanup-form) + (new 'unwind-protect-form + :protected-form (lisp1 protected-form) + :cleanup-form (lisp1s cleanup-form))) + +;;;; http://groups.google.com/group/comp.lang.lisp/browse_thread/thread/82994055… + +;; Copyright (c) 2006, Hoan Ton-That +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Hoan Ton-That, nor the names of the +;; contributors may be used to endorse or promote products derived +;; from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/list.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/list.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,223 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Working with lists + +(defmacro dolist* ((iterator list &optional return-value) &body body) + "Like DOLIST but destructuring-binds the elements of LIST. + +If ITERATOR is a symbol then dolist* is just like dolist EXCEPT +that it creates a fresh binding." + (if (listp iterator) + (let ((i (gensym "DOLIST*-I-"))) + `(dolist (,i ,list ,return-value) + (destructuring-bind ,iterator ,i + ,@body))) + `(dolist (,iterator ,list ,return-value) + (let ((,iterator ,iterator)) + ,@body)))) + +(defun ensure-list (thing) + "Returns THING as a list. + +If THING is already a list (as per listp) it is returned, +otherwise a one element list containing THING is returned." + (if (listp thing) + thing + (list thing))) + +(defun ensure-cons (thing) + (if (consp thing) + thing + (cons thing nil))) + +(defun partition (list &rest lambdas) + "Split LIST into sub lists according to LAMBDAS. + +Each element of LIST will be passed to each element of LAMBDAS, +the first function in LAMBDAS which returns T will cause that +element to be collected into the corresponding list. + +Examples: + + (partition '(1 2 3) #'oddp #'evenp) => ((1 3) (2)) + + (partition '(1 2 3) #'oddp t) => ((1 3) (1 2 3)) + + (partition '(1 2 3) #'oddp #'stringp) => ((1 3) nil)" + (let ((collectors (mapcar (lambda (predicate) + (cons (case predicate + ((t :otherwise) + (constantly t)) + ((nil) + (constantly nil)) + (t predicate)) + (make-collector))) + lambdas))) + (dolist (item list) + (dolist* ((test-func . collector-func) collectors) + (when (funcall test-func item) + (funcall collector-func item)))) + (mapcar #'funcall (mapcar #'cdr collectors)))) + +(defun partitionx (list &rest lambdas) + (let ((collectors (mapcar (lambda (l) + (cons (if (and (symbolp l) + (member l (list :otherwise t) + :test #'string=)) + (constantly t) + l) + (make-collector))) + lambdas))) + (dolist (item list) + (block item + (dolist* ((test-func . collector-func) collectors) + (when (funcall test-func item) + (funcall collector-func item) + (return-from item))))) + (mapcar #'funcall (mapcar #'cdr collectors)))) + +(defmacro dotree ((name tree &optional ret-val) &body body) + "Evaluate BODY with NAME bound to every element in TREE. Return RET-VAL." + (with-unique-names (traverser list list-element) + `(progn + (labels ((,traverser (,list) + (dolist (,list-element ,list) + (if (consp ,list-element) + (,traverser ,list-element) + (let ((,name ,list-element)) + ,@body))))) + (,traverser ,tree) + ,ret-val)))) + +(define-modify-macro push* (&rest items) + (lambda (list &rest items) + (dolist (i items) + (setf list (cons i list))) + list) + "Pushes every element of ITEMS onto LIST. Equivalent to calling PUSH + with each element of ITEMS.") + +(defun proper-list-p (object) + "Tests whether OBJECT is properlist. + +A proper list is a non circular cons chain whose last cdr is eq +to NIL." + (or + (null object) + (and (consp object) + ;; check if the last cdr of object is null. deal with + ;; circular lists. + (loop + for turtoise = object then (cdr turtoise) + for hare = (cdr object) then (cddr hare) + ;; we need to agressivly check hare's cdr so that the call to + ;; cddr doesn't signal an error + when (eq turtoise hare) return nil + when (null turtoise) return t + when (null hare) return t + when (not (consp hare)) return nil + when (null (cdr hare)) return t + when (not (consp (cdr hare))) return nil + when (null (cddr hare)) return t + when (not (consp (cddr hare))) return nil)))) + +;;;; ** Simple list matching based on code from Paul Graham's On Lisp. + +(defmacro acond2 (&rest clauses) + (if (null clauses) + nil + (with-unique-names (val foundp) + (destructuring-bind ((test &rest progn) &rest others) + clauses + `(multiple-value-bind (,val ,foundp) + ,test + (if (or ,val ,foundp) + (let ((it ,val)) + (declare (ignorable it)) + ,@progn) + (acond2 ,@others))))))) + +(defun varsymp (x) + (and (symbolp x) (eq (aref (symbol-name x) 0) #\?))) + +(defun binding (x binds) + (labels ((recbind (x binds) + (aif (assoc x binds) + (or (recbind (cdr it) binds) + it)))) + (let ((b (recbind x binds))) + (values (cdr b) b)))) + +(defun list-match (x y &optional binds) + (acond2 + ((or (eql x y) (eql x '_) (eql y '_)) + (values binds t)) + ((binding x binds) (list-match it y binds)) + ((binding y binds) (list-match x it binds)) + ((varsymp x) (values (cons (cons x y) binds) t)) + ((varsymp y) (values (cons (cons y x) binds) t)) + ((and (consp x) (consp y) (list-match (car x) (car y) binds)) + (list-match (cdr x) (cdr y) it)) + (t (values nil nil)))) + +(defun vars (match-spec) + (let ((vars nil)) + (labels ((find-vars (spec) + (cond + ((null spec) nil) + ((varsymp spec) (push spec vars)) + ((consp spec) + (find-vars (car spec)) + (find-vars (cdr spec)))))) + (find-vars match-spec)) + (delete-duplicates vars))) + +(defmacro list-match-case (target &body clauses) + (if clauses + (destructuring-bind ((test &rest progn) &rest others) + clauses + (with-unique-names (tgt binds success) + `(let ((,tgt ,target)) + (multiple-value-bind (,binds ,success) + (list-match ,tgt ',test) + (declare (ignorable ,binds)) + (if ,success + (let ,(mapcar (lambda (var) + `(,var (cdr (assoc ',var ,binds)))) + (vars test)) + (declare (ignorable ,@(vars test))) + ,@progn) + (list-match-case ,tgt ,@others)))))) + nil)) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/log.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/log.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,512 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * A Trivial logging facility + +;;;; A logger is a way to have the system generate a text message and +;;;; have that messaged saved somewhere for future review. Logging can +;;;; be used as a debugging mechanism or for just reporting on the +;;;; status of a system. + +;;;; Logs are sent to a particular log category, each log category +;;;; sends the messages it receives to its handlers. A handler's job +;;;; is to take a message and write it somewhere. Log categories are +;;;; organized in a hierarchy and messages sent to a log category will +;;;; also be sent to that category's ancestors. + +;;;; Each log category has a log level which is used to determine +;;;; whether are particular message should be processed or +;;;; not. Categories inherit their log level from their ancestors. If a +;;;; category has multiple fathers its log level is the min of the +;;;; levels of its fathers. + +;;;; ** Log Levels + +(eval-always + (defconstant +dribble+ 0) + (defconstant +debug+ 1) + (defconstant +info+ 2) + (defconstant +warn+ 3) + (defconstant +error+ 4) + (defconstant +fatal+ 5) + + (defparameter *log-level-names* (coerce '(+dribble+ +debug+ +info+ +warn+ +error+ +fatal+) + 'simple-vector)) + (deflookup-table logger)) + +(defun log-level-name-of (level) + (when (not (<= 0 level #.(1- (length *log-level-names*)))) + (error "~S is an invalid log level" level)) + (aref *log-level-names* level)) + +;;;; ** Log Categories + +(defclass log-category () + ((ancestors :initform '() :accessor ancestors :initarg :ancestors + :documentation "The log categories this category inherits from.") + (children :initform '() :accessor children :initarg :children + :documentation "The log categories which inherit from this category.") + (appenders :initform '() :accessor appenders :initarg :appenders + :documentation "A list of appender objects this category sholud send messages to.") + (level :initform nil :initarg :level :accessor level + :type (or null integer) + :documentation "This category's log level.") + (compile-time-level + :initform +dribble+ :initarg :compile-time-level :accessor compile-time-level + :type integer + :documentation "This category's compile time log level. Any log expression below this level will macro-expand to NIL.") + (name :initarg :name :accessor name))) + +(defmethod make-load-form ((self log-category) &optional env) + (declare (ignore env)) + `(let ((result (get-logger ',(name self)))) + (assert result) + result)) + +(defmethod print-object ((category log-category) stream) + (print-unreadable-object (category stream :type t :identity t) + (if (slot-boundp category 'name) + (format stream "~S" (name category)) + (format stream "#<NO NAME>")))) + +(defmethod shared-initialize :after ((l log-category) slot-names + &key ancestors &allow-other-keys) + (declare (ignore slot-names)) + (dolist (anc ancestors) + (pushnew l (children anc) :test (lambda (a b) + (eql (name a) (name b)))))) + +(defun log-level-setter-inspector-action-for (prompt current-level setter) + (lambda () + (with-simple-restart + (abort "Abort setting log level") + (let ((value-string (swank::eval-in-emacs + `(condition-case c + (let ((arnesi-log-levels '(,@(mapcar #'string-downcase (coerce *log-level-names* 'list))))) + (slime-read-object ,prompt :history (cons 'arnesi-log-levels ,(1+ current-level)) + :initial-value ,(string-downcase (log-level-name-of current-level)))) + (quit nil))))) + (when (and value-string + (not (string= value-string ""))) + (funcall setter (eval (let ((*package* #.(find-package :arnesi))) + (read-from-string value-string))))))))) + +(defmethod swank:inspect-for-emacs ((category log-category)) + (let ((class (class-of category))) + (values "A log-category." + `("Class: " (:value ,class) (:newline) + "Runtime level: " (:value ,(log.level category) + ,(string (log-level-name-of (log.level category)))) + " " + (:action "[set level]" ,(log-level-setter-inspector-action-for + "Set runtime log level to (evaluated): " + (log.level category) + (lambda (value) + (setf (log.level category) value)))) + (:newline) + "Compile-time level: " (:value ,(log.compile-time-level category) + ,(string (log-level-name-of (log.compile-time-level category)))) + " " + (:action "[set level]" ,(log-level-setter-inspector-action-for + "Set compile-time log level to (evaluated): " + (log.compile-time-level category) + (lambda (value) + (setf (log.compile-time-level category) value)))) + (:newline) + ,@(swank::all-slots-for-inspector category))))) + +;;; Runtime levels +(defmethod enabled-p ((cat log-category) level) + (>= level (log.level cat))) + +(defmethod log.level ((cat log-category)) + (or (level cat) + (if (ancestors cat) + (loop for ancestor in (ancestors cat) + minimize (log.level ancestor)) + (error "Can't determine level for ~S" cat)))) + +(defmethod log.level ((cat-name symbol)) + (log.level (get-logger cat-name))) + +(defmethod (setf log.level) (new-level (cat log-category) + &optional (recursive t)) + "Change the log level of CAT to NEW-LEVEL. If RECUSIVE is T the + setting is also applied to the sub categories of CAT." + (setf (slot-value cat 'level) new-level) + (when recursive + (dolist (child (children cat)) + (setf (log.level child) new-level))) + new-level) + +(defmethod (setf log.level) (new-level (cat-name symbol) &optional (recursive t)) + (setf (log.level (get-logger cat-name) recursive) new-level)) + +(defmethod (setf log.level) (new-level (cat-name null) &optional (recursive t)) + (declare (ignore new-level cat-name recursive)) + (error "NIL does not specify a category.")) + +;;; Compile time levels +(defmethod compile-time-enabled-p ((cat log-category) level) + (>= level (log.compile-time-level cat))) + +(defmethod log.compile-time-level ((cat log-category)) + (or (compile-time-level cat) + (if (ancestors cat) + (loop for ancestor in (ancestors cat) + minimize (log.compile-time-level ancestor)) + (error "Can't determine compile time level for ~S" cat)))) + +(defmethod log.compile-time-level ((cat-name symbol)) + (log.compile-time-level (get-logger cat-name))) + +(defmethod (setf log.compile-time-level) (new-level (cat log-category) + &optional (recursive t)) + "Change the compile time log level of CAT to NEW-LEVEL. If RECUSIVE is T the + setting is also applied to the sub categories of CAT." + (setf (slot-value cat 'compile-time-level) new-level) + (when recursive + (dolist (child (children cat)) + (setf (log.compile-time-level child) new-level))) + new-level) + +(defmethod (setf log.compile-time-level) (new-level (cat-name symbol) &optional (recursive t)) + (setf (log.compile-time-level (get-logger cat-name) recursive) new-level)) + +(defmethod (setf log.compile-time-level) (new-level (cat-name null) &optional (recursive t)) + (declare (ignore new-level cat-name recursive)) + (error "NIL does not specify a category.")) + +(defmacro with-logger-level (logger-name new-level &body body) + "Set the level of the listed logger(s) to NEW-LEVEL and restore the original value in an unwind-protect." + (cond ((consp logger-name) + `(with-logger-level ,(pop logger-name) ,new-level + ,(if logger-name + `(with-logger-level ,logger-name ,new-level + ,@body) + `(progn + ,@body)))) + ((symbolp logger-name) + (with-unique-names (logger old-level) + `(let* ((,logger (get-logger ',logger-name)) + (,old-level (level ,logger))) + (setf (level ,logger) ,new-level) + (unwind-protect + (progn ,@body) + (setf (level ,logger) ,old-level))))) + (t (error "Don't know how to interpret ~S as a logger name" logger-name)))) + +;;;; ** Handling Messages + +(defmacro with-logging-io (&body body) + `(let ((*print-right-margin* most-positive-fixnum) + (*print-readably* nil) + (*print-length* 64) + (*package* #+ecl (find-package "COMMON-LISP") + #-ecl #.(find-package "COMMON-LISP"))) + ,@body)) + +(defgeneric handle (category message level) + (:documentation "Message is either a string or a list. When it's a list and the first element is a string then it's processed as args to cl:format.")) + +(defmethod handle :around ((cat log-category) message level) + ;; turn off line wrapping for the entire time while inside the loggers + (with-logging-io + (call-next-method))) + +(defmethod handle ((cat log-category) message level) + (if (appenders cat) + ;; if we have any appenders send them the message + (dolist (appender (appenders cat)) + (append-message cat appender message level)) + ;; send the message to our ancestors + (dolist (ancestor (ancestors cat)) + (handle ancestor message level)))) + +(defgeneric append-message (category log-appender message level) + (:method :around (category log-appender message level) + ;; what else should we do? + (ignore-errors + (call-next-method)))) + +;;;; *** Stream log appender + +(defclass appender () + ((verbosity :initform 2 :initarg :verbosity :accessor verbosity-of))) + +(defclass stream-log-appender (appender) + ((stream :initarg :stream :accessor log-stream)) + (:documentation "Human readable to the console logger.")) + +(defmethod make-instance ((class (eql (find-class 'stream-log-appender))) + &rest initargs) + (declare (ignore initargs)) + (error "STREAM-LOG-APPENDER is an abstract class. You must use either brief-stream-log-appender or verbose-stream-log-appender objects.")) + +(defmethod append-message :around (category (appender stream-log-appender) (message cons) level) + (append-message category appender (apply #'format nil message) level)) + +(defclass brief-stream-log-appender (stream-log-appender) + ((last-message-year :initform 0) + (last-message-month :initform 0) + (last-message-day :initform 0)) + (:documentation "A subclass of stream-log-appender with minimal + 'overhead' text in log messages. This amounts to: not printing + the package names of log categories and log levels and a more + compact printing of the current time.")) + +(defclass verbose-stream-log-appender (stream-log-appender) + () + (:documentation "A subclass of stream-log-appender which + attempts to be as precise as possible, category names and log + level names are printed with a package prefix and the time is + printed in long format.")) + +(defmethod append-message :around ((category log-category) (s stream-log-appender) + message level) + (restart-case + (call-next-method) + (use-*debug-io* () + :report "Use the current value of *debug-io*" + (setf (log-stream s) *debug-io*) + (append-message category s message level)) + (use-*standard-output* () + :report "Use the current value of *standard-output*" + (setf (log-stream s) *standard-output*) + (append-message category s message level)) + (silence-logger () + :report "Ignore all future messages to this logger." + (setf (log-stream s) (make-broadcast-stream))))) + +(eval-always + (defparameter *max-category-name-length* 12)) + +(defmethod append-message ((category log-category) (s brief-stream-log-appender) + message level) + (multiple-value-bind (second minute hour day month year) + (decode-universal-time (get-universal-time)) + (declare (ignore second)) + (with-slots (last-message-year last-message-month last-message-day) + s + (unless (and (= year last-message-year) + (= month last-message-month) + (= day last-message-day)) + (format (log-stream s) "--TIME MARK ~4,'0D-~2,'0D-~2,'0D--~%" + year month day) + (setf last-message-year year + last-message-month month + last-message-day day))) + (let* ((category-name (symbol-name (name category))) + (level-name (symbol-name level)) + (category-length (length category-name))) + (format (log-stream s) + #.(strcat "~2,'0D:~2,'0D ~" + *max-category-name-length* + "@A ~7A ") + hour minute + (subseq category-name + (max 0 (- category-length + *max-category-name-length*)) + category-length) + (subseq level-name 1 (1- (length level-name))))) + (format (log-stream s) "~A~%" message))) + +(defmethod append-message ((category log-category) (s verbose-stream-log-appender) + message level) + (multiple-value-bind (second minute hour date month year) + (decode-universal-time (get-universal-time)) + (format (log-stream s) + "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D.~2,'0D ~S/~S: " + year month date hour minute second + (name category) level) + (format (log-stream s) "~A~%" message))) + +(defun make-stream-log-appender (&rest args &key (stream *debug-io*) (verbosity 2) &allow-other-keys) + (remf-keywords args :stream :verbosity) + (apply #'make-instance (case verbosity + ((0 1) 'brief-stream-log-appender) + (t 'verbose-stream-log-appender)) + :stream stream + :verbosity verbosity + args)) + +(defclass slime-repl-log-appender (appender) + () + (:documentation "Logs to the slime repl when there's a valid swank::*emacs-connection* bound. Arguments are presented ready for inspection. + +You may want to add this to your init.el to speed up cursor movement in the repl buffer with many presentations: + +\(add-hook 'slime-repl-mode-hook + (lambda () + (setf parse-sexp-lookup-properties nil))) +")) + +(defun swank::present-in-emacs (value-or-values &key (separated-by " ")) + "Present VALUE in the Emacs repl buffer of the current thread." + (unless (consp value-or-values) + (setf value-or-values (list value-or-values))) + (flet ((present (value) + (if (stringp value) + (swank::send-to-emacs `(:write-string ,value)) + (let ((id (swank::save-presented-object value))) + (swank::send-to-emacs `(:write-string ,(prin1-to-string value) ,id)))))) + (map nil (let ((first-time-p t)) + (lambda (value) + (when (and (not first-time-p) + separated-by) + (present separated-by)) + (present value) + (setf first-time-p nil))) + value-or-values)) + (values)) + +(defmethod append-message ((category log-category) (appender slime-repl-log-appender) + message level) + (when (swank::default-connection) + (swank::with-connection ((swank::default-connection)) + (multiple-value-bind (second minute hour day month year) + (decode-universal-time (get-universal-time)) + (declare (ignore second day month year)) + (swank::present-in-emacs (format nil + "~2,'0D:~2,'0D ~A/~A: " + hour minute + (symbol-name (name category)) + (symbol-name level)))) + (if (consp message) + (let ((format-control (when (stringp (first message)) + (first message))) + (args (if (stringp (first message)) + (rest message) + message))) + (when format-control + (setf message (apply #'format nil format-control args))) + (swank::present-in-emacs message) + (awhen (and format-control + (> (verbosity-of appender) 1) + (remove-if (lambda (el) + (or (stringp el) + (null el))) + args)) + (swank::present-in-emacs " (") + (swank::present-in-emacs it) + (swank::present-in-emacs ")"))) + (swank::present-in-emacs message)) + (swank::present-in-emacs #.(string #\Newline))))) + +(defun arnesi-logger-inspector-lookup-hook (form) + (when (symbolp form) + (if-bind logger (get-logger form) + (values logger t) + (when-bind logger-name (get form 'logger) + (when-bind logger (get-logger logger-name) + (values logger t)))))) + +(awhen (find-symbol (symbol-name '#:*inspector-dwim-lookup-hooks*) :swank) + (pushnew 'arnesi-logger-inspector-lookup-hook (symbol-value it))) + +(defun make-slime-repl-log-appender (&rest args &key (verbosity 2)) + (remf-keywords args :verbosity) + (apply #'make-instance 'slime-repl-log-appender :verbosity verbosity args)) + +(defclass file-log-appender (stream-log-appender) + ((log-file :initarg :log-file :accessor log-file + :documentation "Name of the file to write log messages to.")) + (:documentation "Logs to a file. the output of the file logger + is not meant to be read directly by a human.")) + +(defmethod append-message ((category log-category) (appender file-log-appender) + message level) + (with-output-to-file (log-file (log-file appender) + :if-exists :append + :if-does-not-exist :create) + (format log-file "(~S ~D ~S ~S)~%" level (get-universal-time) (name category) message))) + +(defun make-file-log-appender (file-name) + (make-instance 'file-log-appender :log-file file-name)) + +;;;; ** Creating Loggers + +(defmacro deflogger (name ancestors &key compile-time-level level appender appenders documentation) + (declare (ignore documentation) + (type symbol name)) + (unless (eq (symbol-package name) *package*) + (warn "When defining a logger named ~A the home package of the symbol is not *package* (not (eq ~A ~A)) " + (let ((*package* (find-package "KEYWORD"))) + (format nil "~S" name)) + (symbol-package name) *package*)) + (when appender + (setf appenders (append appenders (list appender)))) + (let ((ancestors (mapcar (lambda (ancestor-name) + `(or (get-logger ',ancestor-name) + (error "Attempt to define a sub logger of the undefined logger ~S." + ',ancestor-name))) + ancestors))) + (flet ((make-log-helper (suffix level) + (let ((logger-macro-name (intern (strcat name "." suffix)))) + `(progn + (setf (get ',logger-macro-name 'logger) ',name) + (defmacro ,logger-macro-name (message-control &rest message-args) + ;; first check at compile time + (if (compile-time-enabled-p (get-logger ',name) ,level) + ;; then check at runtime + `(progn + (when (enabled-p (load-time-value (get-logger ',',name)) ,',level) + ,(if message-args + `(handle (load-time-value (get-logger ',',name)) (list ,message-control ,@message-args) + ',',level) + `(handle (load-time-value (get-logger ',',name)) ,message-control ',',level))) + (values)) + (values))))))) + `(progn + (eval-when (:load-toplevel :execute) + (setf (get-logger ',name) (make-instance 'log-category + :name ',name + ,@(cond (level + `(:level ,level)) + ((not ancestors) + `(:level +debug+)) + (t '())) + ,@(when compile-time-level + `(:compile-time-level ,compile-time-level)) + :appenders (remove nil (list ,@appenders)) + :ancestors (list ,@ancestors)))) + ,(make-log-helper '#:dribble '+dribble+) + ,(make-log-helper '#:debug '+debug+) + ,(make-log-helper '#:info '+info+) + ,(make-log-helper '#:warn '+warn+) + ,(make-log-helper '#:error '+error+) + ,(make-log-helper '#:fatal '+fatal+) + (values))))) + + + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/matcher.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/matcher.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,341 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * A fare-like matchingfacility + +;;;; The code is written in CPS style, it's hard to understand at +;;;; first but once you "get it" it's actually quite simple. Basically +;;;; the idea is that at every point during a match one of two things +;;;; can happen, the match can succeed or it can fail. What we do is +;;;; we pass every match two functions (closures usually), one which +;;;; specifies what to if it succeeds and one which specifies what to +;;;; do if it fails. These two closures can refer to the original +;;;; match parameter and hence we can easily "backtrack" if we +;;;; fail. Another important aspect is that we explicitly pass the +;;;; target against which to match, if we didn't do this it would be +;;;; impossible to really backtrack. + +;;;; ** The matching and compiling environment + +(deflookup-table match-handler + :documentation "Table mapping symbol names to the matching function") + +(defstruct (match-state (:conc-name ||)) + target + bindings + matched) + +(defun copy-state (orig-state + &key (target nil target-supp) + (bindings nil bindings-supp) + (matched nil matched-supp)) + "Make a copy ORIG-STATE." + (make-match-state :target (if target-supp + target + (target orig-state)) + :bindings (if bindings-supp + bindings + (bindings orig-state)) + :matched (if matched-supp + matched + (matched orig-state)))) + +(defmacro def-matcher (name args &body body) + `(progn (setf (get-match-handler ',name) + (lambda ,args ,@body)) + ',name)) + +(defmacro def-matcher-macro (name args &body body) + `(progn (setf (get-match-handler ',name) + (lambda ,args + (%make-matcher (progn ,@body)))) + ',name)) + +;;;; ** Matching + +(defun make-matcher (spec) + "Create a matcher function from SPEC." + (let ((%bind-vars% '())) + (declare (special %bind-vars%)) + (values (%make-matcher spec) + %bind-vars%))) + +(defun %make-matcher (spec) + ;; NIL means many different things, deal with it explicitly + (if (eql nil spec) + (%make-matcher `(:eql ,spec)) + (if (listp spec) + (aif (get-match-handler (car spec)) + (apply it (cdr spec)) + (error "Don't know how to handle ~S" spec)) + (aif (get-match-handler spec) + ;; we allow :x as a an abbreviation for (:x) + (funcall it) + (if (and (symbolp spec) + (not (keywordp spec))) + (%make-matcher `(:bind :anything ,spec)) + (if (constantp spec) + (%make-matcher `(:eql ,spec)) + (error "Don't know how to deal with ~S" spec))))))) + +(defun match (matcher target) + "Attempt to match MATCHER against TARGET. MATCHER can be either a +function or a list." + (if (functionp matcher) + (funcall matcher + (make-match-state :target target + :bindings '() + :matched nil) + (lambda (s k q) + (declare (ignore k q)) + (return-from match (values t + (matched s) + (bindings s)))) + (lambda (s k q) + (declare (ignore s k q)) + (return-from match (values nil nil nil)))) + (match (make-matcher matcher) target))) + +(defmacro match-case (form &rest clauses) + "NB: the clauses wil be compiled at macro expansion time." + (when clauses + (destructuring-bind ((spec &rest body) &rest other-clauses) clauses + (with-unique-names (form-sym matched-p dummy bindings) + (multiple-value-bind (matcher-func vars) + (make-matcher spec) + (declare (ignore matcher-func)) + `(let ((,form-sym ,form)) + (multiple-value-bind (,matched-p ,dummy ,bindings) + (match (make-matcher ',spec) ,form-sym) + (declare (ignore ,dummy) (ignorable ,bindings)) + (if ,matched-p + (let ,vars + ,@(mapcar (lambda (var-name) + `(setf ,var-name (cdr (assoc ',var-name ,bindings)))) + vars) + ,@body) + (match-case ,form-sym ,@other-clauses))))))))) + +;;;; ** Matching forms + +(def-matcher :bind (spec var) + "The :bind matcher attempts to match MATCHER and bind whatever + MATCHER consumnd to VAR. group is equivalent to SPEC except the value + of matched when spec has matched will be bound to var." + (declare (special %bind-vars%)) + (push var %bind-vars%) + (let ((spec-matcher (%make-matcher spec))) + (lambda (s k q) + (funcall spec-matcher s + (lambda (s. k. q.) + (declare (ignore k.)) + ;; SPEC succeded, bind var + (funcall k (copy-state s. :bindings (cons (cons var (matched s.)) (bindings s.))) + k q.)) + q)))) + +(def-matcher :ref (var &key (test #'eql)) + (lambda (s k q) + (if (and (assoc var (bindings s)) + (funcall test (target s) (cdr (assoc var (bindings s))))) + (funcall k (copy-state s :matched (target s)) + k q) + (funcall q s k q)))) + +(def-matcher :alternation (a-spec b-spec) + (let ((a (%make-matcher a-spec)) + (b (%make-matcher b-spec))) + (lambda (s k q) + ;; first try A + (funcall a s k + ;; a failed, try B + (lambda (s. k. q.) + (declare (ignore s. k. q.)) + (funcall b s k q)))))) + +(def-matcher-macro :alt (&rest possibilities) + (case (length possibilities) + (0 `(:fail)) + (1 (car possibilities)) + (t `(:alternation ,(car possibilities) (:alt ,@(cdr possibilities)))))) + +(def-matcher :fail () + (lambda (s k q) + (funcall q s k q))) + +(def-matcher :not (match) + (let ((m (%make-matcher match))) + (lambda (s k q) + (funcall m s q k)))) + +(def-matcher :anything () + (lambda (s k q) + (funcall k (copy-state s :matched (target s)) + k q))) + +;;;; ** Matching within a sequence + +(defun next-target () + (declare (special *next-target*)) + (funcall *next-target*)) + +(defun make-greedy-star (m) + (lambda (s k q) + (if (funcall m (target s)) + (funcall (make-greedy-star m) (copy-state s + :matched (target s) + :target (next-target)) + k (lambda (s. k. q.) + (declare (ignore k. s.)) + (funcall k s k q.))) + (funcall q s k q)))) + +(def-matcher :greedy-star (match) + (make-greedy-star (%make-matcher match))) + +;;;; ** The actual matching operators + +;;;; All of the above allow us to build matchers but non of them +;;;; actually match anything. + +(def-matcher :test (predicate) + "Matches if the current matches satisfies PREDICATE." + (lambda (s k q) + (if (funcall predicate (target s)) + (funcall k (copy-state s :matched (target s)) + k q) + (funcall q s k q)))) + +(def-matcher-macro :test-not (predicate) + `(:not (:test ,predicate))) + +(def-matcher-macro :satisfies-p (predicate) + `(:test ,(lambda (target) (funcall predicate target)))) + +(def-matcher-macro :eq (object) + `(:test ,(lambda (target) (eq object target)))) + +(def-matcher-macro :eql (object) + `(:test ,(lambda (target) (eql object target)))) + +(def-matcher-macro cl:quote (constant) + `(:eql ,constant)) + +(def-matcher-macro :equal (object) + `(:test ,(lambda (target) (equal object target)))) + +(def-matcher-macro :equalp (object) + `(:test ,(lambda (target) (equalp object target)))) + +(def-matcher :cons (car-spec cdr-spec) + (let ((car (%make-matcher car-spec)) + (cdr (%make-matcher cdr-spec))) + (lambda (s k q) + (if (consp (target s)) + (funcall car (copy-state s :target (car (target s))) + (lambda (s. k. q.) + (declare (ignore k.)) + ;; car matched, try cdr + (funcall cdr (copy-state s. :target (cdr (target s))) + (lambda (s.. k.. q..) + (declare (ignore k.. q..)) + ;; cdr matched, ok, we've matched! + (funcall k (copy-state s.. :matched (target s)) + k q)) + q.)) + q) + (funcall q s k q))))) + +(def-matcher-macro :list (&rest items) + `(:list* ,@items nil)) + +(def-matcher-macro :list* (&rest items) + (case (length items) + (1 (car items)) + (2 `(:cons ,(first items) ,(second items))) + (t + `(:cons ,(first items) (:list* ,@(cdr items)))))) + +(def-matcher :property (key value-spec) + (let ((value (%make-matcher value-spec))) + (lambda (s k q) + (if (listp (target s)) + (aif (getf (target s) key) + (funcall value (copy-state s :target it) + (lambda (s. k. q.) + (declare (ignore k. q.)) + (funcall k (copy-state s. :matched (target s)) + k q)) + q) + (funcall q s k q)) + (funcall q s k q))))) + +(def-matcher :accessor (type accessor value-spec) + (let ((value (%make-matcher value-spec))) + (lambda (s k q) + (if (typep (target s) type) + (funcall value (copy-state s :target (funcall accessor (target s))) + (lambda (s. k. q.) + (declare (ignore k. q.)) + (funcall k (copy-state s. :matched (target s)) + k q)) + q) + (funcall q s k q))))) + +(def-matcher :and (a-spec b-spec) + (let ((a (%make-matcher a-spec)) + (b (%make-matcher b-spec))) + (lambda (s k q) + (funcall a s + (lambda (s. k. q.) + (declare (ignore k. q.)) + (funcall b (copy-state s. :target (target s)) + k q)) + q)))) + +(def-matcher-macro :plist (&rest items) + (case (length items) + (1 (error ":PLIST has been given an odd num of args.")) + (2 `(:PROPERTY ,(first items) ,(second items))) + (t + `(:AND (:PROPERTY ,(first items) ,(second items)) + (:PLIST ,@(nthcdr 2 items)))))) + +(def-matcher-macro :accessors (type &rest accs-vals) + (case (length accs-vals) + (1 (error ":ACCESSORS has been given an odd num of args.")) + (2 `(:ACCESSOR ,type ,(first accs-vals) ,(second accs-vals))) + (t + `(:AND (:ACCESSOR ,type ,(first accs-vals) ,(second accs-vals)) + (:ACCESSORS ,type ,@(nthcdr 2 accs-vals)))))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/mop.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/mop.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,126 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Messing with the MOP + +;;;; The code pre-dates Pascal Costanza's closer-mop package. If +;;;; you're looking for a compatability layer you should probably look +;;;; there instead. + +(defmacro with-class-slots ((object class-name &key except) &body body) + "Execute BODY as if in a with-slots form containig _all_ the + slots of (find-clas CLASS-NAME). This macro, which is something + of an ugly hack, inspects the class named by CLASS-NAME at + macro expansion time. Should the class CLASS-NAME change form + containing WITH-CLASS-SLOTS must be recompiled. Should the + class CLASS-NAME not be available at macro expansion time + WITH-CLASS-SLOTS will fail." + (declare (ignore object class-name except body)) + (error "Not yet implemented.")) + +;;;; ** wrapping-standard method combination + +(define-method-combination wrapping-standard + (&key (around-order :most-specific-first) + (before-order :most-specific-first) + (primary-order :most-specific-first) + (after-order :most-specific-last) + (wrapping-order :most-specific-last) + (wrap-around-order :most-specific-last)) + ((wrap-around (:wrap-around)) + (around (:around)) + (before (:before)) + (wrapping (:wrapping)) + (primary () :required t) + (after (:after))) + "Same semantics as standard method combination but allows +\"wrapping\" methods. Ordering of methods: + + (wrap-around + (around + (before) + (wrapping + (primary)) + (after))) + +:warp-around, :around, :wrapping and :primary methods call the +next least/most specific method via call-next-method (as in +standard method combination). + +The various WHATEVER-order keyword arguments set the order in +which the methods are called and be set to either +:most-specific-last or :most-specific-first." + (labels ((effective-order (methods order) + (ecase order + (:most-specific-first methods) + (:most-specific-last (reverse methods)))) + (call-methods (methods) + (mapcar (lambda (meth) `(call-method ,meth)) + methods))) + (let* (;; reorder the methods based on the -order arguments + (wrap-around (effective-order wrap-around wrap-around-order)) + (around (effective-order around around-order)) + (wrapping (effective-order wrapping wrapping-order)) + (before (effective-order before before-order)) + (primary (effective-order primary primary-order)) + (after (effective-order after after-order)) + ;; inital value of the effective call is a call its primary + ;; method(s) + (form (case (length primary) + (1 `(call-method ,(first primary))) + (t `(call-method ,(first primary) ,(rest primary)))))) + (when wrapping + ;; wrap form in call to the wrapping methods + (setf form `(call-method ,(first wrapping) + (,@(rest wrapping) (make-method ,form))))) + (when before + ;; wrap FORM in calls to its before methods + (setf form `(progn + ,@(call-methods before) + ,form))) + (when after + ;; wrap FORM in calls to its after methods + (setf form `(multiple-value-prog1 + ,form + ,@(call-methods after)))) + (when around + ;; wrap FORM in calls to its around methods + (setf form `(call-method ,(first around) + (,@(rest around) + (make-method ,form))))) + (when wrap-around + (setf form `(call-method ,(first wrap-around) + (,@(rest wrap-around) + (make-method ,form))))) + form))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/mopp.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/mopp.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,340 @@ +;; -*- lisp -*- + +;;;; * A MOP compatibility protocol + +(defpackage :it.bese.arnesi.mopp + (:nicknames :mopp) + (:documentation "A MOP compatabilitly layer. + +This package wraps the various similar but slightly different MOP +APIs. All the MOP symbols are exported (even those which are +normally exported from the common-lisp package) though not all +maybe be properly defined on all lisps. + +The name of the library in an acronym for \"the Meta Object +Protocol Package\". + +This package is nominally part of the arnesi utility library but +has been written so that this single file can be included in +other applications without requiring the rest of the arnesi +library. + +Implementation Notes: + +1) The mopp package also exports the function + SLOT-DEFINITION-DOCUMENTATION which while not strictly part of + the MOP specification really should be and is implementened on + most systems. + +2) On Lispworks (tested only lightly) the MOPP package + implementes an eql-specializer class and defines a version of + method-specializers built upon clos:method-specializers which + returns them.") + (:use) + (:export + ;; classes + #:standard-object + #:funcallable-standard-object + #:metaobject + #:generic-function + #:standard-generic-function + #:method + #:standard-method + #:standard-accessor-method + #:standard-reader-method + #:standard-writer-method + #:method-combination + #:slot-definition + #:direct-slot-definition + #:effective-slot-definition + #:standard-slot-definition + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:specializer + #:eql-specializer + #:class + #:built-in-class + #:forward-referenced-class + #:standard-class + #:funcallable-standard-class + ;; Taken from the MOP dictionary + #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:add-method + #:allocate-instance + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-name + #:class-precedence-list + #:class-prototype + #:class-slots + #:compute-applicable-methods + #: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-using-class + #:ensure-generic-function + #: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-instance + #:make-method-lambda + #:map-dependents + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-specializers + #:method-qualifiers + #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:remove-method + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition-allocation + #:slot-definition-documentation + #: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)) + +(defpackage :it.bese.arnesi.mopp%internals + (:use :common-lisp)) + +(in-package :it.bese.arnesi.mopp%internals) + +(defgeneric provide-mopp-symbol (symbol implementation) + (:documentation "Provide the implementation of the MOP symbol SYMBOL. + +SYMBOL - One of the external symbols of the package it.bese.arnesi.mopp + +IMPLEMENTATION - A keyword indetifying the implementation, one +of: :OPENMCL, :SBCL, :CMU, :LISPWORKS, :ALLEGRO. + +Do \"something\" such that the external symbol SYMBOL in the mopp +package provides the sematics for the like named symbol in the +MOP. Methods defined on this generic function are free to +destructivly modify SYMBOL (and the mopp package) as long as when +the method terminates there is a symbol with the same name as +SYMBOL exported form the package mopp. + +Methods must return a true value if they have successfully +provided SYMBOL and nil otherwise.")) + +(defun import-to-mopp (symbol) + (let ((sym (find-symbol (string symbol) :it.bese.arnesi.mopp))) + (when sym + (unexport sym :it.bese.arnesi.mopp) + (unintern sym :it.bese.arnesi.mopp))) + (import symbol :it.bese.arnesi.mopp) + (export symbol :it.bese.arnesi.mopp) + t) + +;;;; OpenMCL + +(defmethod provide-mopp-symbol ((symbol symbol) + (implementation (eql :openmcl))) + "Provide MOP symbols for OpenMCL. + +All of OpenMCL's MOP is defined in the CCL package." + (when (find-symbol (string symbol) :ccl) + (import-to-mopp (find-symbol (string symbol) :ccl)))) + +;;;; SBCL + +(defmethod provide-mopp-symbol ((symbol symbol) + (implementation (eql :sbcl))) + (when (find-symbol (string symbol) :sb-mop) + (import-to-mopp (find-symbol (string symbol) :sb-mop)))) + +(defmethod provide-mopp-symbol ((symbol (eql 'mopp:slot-definition-documentation)) + (implementation (eql :sbcl))) + "Provide SLOT-DEFINITION-DOCUMENTATION for SBCL. + +On SBCL SLOT-DEFINITION-DOCUMENTATION is just a call to +sb-pcl:documentation." + t) + +#+sbcl +(defun mopp:slot-definition-documentation (slot) + (sb-pcl::documentation slot t)) + +;;;; CMUCL + +(defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :cmu))) + (when (find-symbol (string symbol) :pcl) + (import-to-mopp (find-symbol (string symbol) :pcl)))) + +(defmethod provide-mopp-symbol ((symbol (eql 'mopp:slot-definition-documentation)) + (implementation (eql :cmu))) + "Provide SLOT-DEFINITION-DOCUMENTATION on CMUCL. + +Like SBCL SLOT-DEFINITION-DOCUMENTATION on CMUCL is just a call +to documentation." + t) + +#+cmu +(defun mopp:slot-definition-documentation (slot) + (documentation slot t)) + +;;;; Lispworks + +(defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :lispworks))) + (when (find-symbol (string symbol) :clos) + (import-to-mopp (find-symbol (string symbol) :clos)))) + +(defmethod provide-mopp-symbol ((symbol (eql 'mopp:eql-specializer)) + (implementation (eql :lispworks))) + t) + +(defmethod provide-mopp-symbol ((symbol (eql 'mopp:eql-specializer-object)) + (implementation (eql :lispworks))) + t) + +(defmethod provide-mopp-symbol ((symbol (eql 'mopp:method-specializers)) + (implementation (eql :lispworks))) + "We can not simply export CLOS:METHOD-SPECIALIZERS as we have +to insert mopp:eql-specializers" + t) + +#+lispworks +(defclass mopp:eql-specializer () + ((object :accessor mopp::eql-specializer-object :initarg :object)) + (:documentation "Wrapper class representing eql-specializers. + +Lispworks does not implement an eql-specializer class but simply +returns lists form method-specializers, this class (along with a +wrapper for clos:method-specializers) hide this detail.")) + +#+lispworks +(defun mopp:method-specializers (method) + "More MOP-y implementation of clos:method-specializers. + +For every returned value of clos:method-specializers of the +form `(eql ,OBJECT) this function returns a mopp:eql-specializer +object wrapping OBJECT." + (mapcar (lambda (spec) + (typecase spec + (cons (make-instance 'mopp:eql-specializer :object (second spec))) + (t spec))) + (clos:method-specializers method))) + +;;;; CLISP + +(defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :clisp))) + (when (find-symbol (string symbol) :clos) + (import-to-mopp (find-symbol (string symbol) :clos)))) + +;;;; ALLEGRO + +(defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :allegro))) + (when (find-symbol (string symbol) :mop) + (import-to-mopp (find-symbol (string symbol) :mop)))) + +(defmethod provide-mopp-symbol ((symbol (eql 'mopp:slot-definition-documentation)) + (implementation (eql :allegro))) + t) + +#+allegro +(defun mopp:slot-definition-documentation (slot) + (documentation slot t)) + +;;;; ** Building the MOPP package + +;;;; we can't just do a do-external-symbols since we mess with the +;;;; package and that would put us in implementation dependent +;;;; territory, so we first build up a list of all the external symbols +;;;; in mopp and then work on that list. + +#+(or + openmcl + sbcl + cmu + lispworks + clisp + allegro) +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew 'mopp::have-mop *features*)) + +#+mopp::have-mop +(let ((external-symbols '())) + (do-external-symbols (sym (find-package :it.bese.arnesi.mopp)) + (push sym external-symbols)) + (dolist (sym external-symbols) + (unless (provide-mopp-symbol sym #+openmcl :openmcl + #+sbcl :sbcl + #+cmu :cmu + #+lispworks :lispworks + #+clisp :clisp + #+allegro :allegro) + (warn "Unimplemented MOP symbol: ~S" sym)))) + +#-mopp::have-mop +(warn "No MOPP implementation available for this lisp implementation.") + +;; Copyright (C) 2004-2006 Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/numbers.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/numbers.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,152 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Messing with numbers + +(defun parse-ieee-double (u64) + "Given an IEEE 64 bit double representeted as an integer (ie a + sequence of 64 bytes), return the coressponding double value" + (* (expt -1 (ldb (byte 1 63) u64)) + (expt 2 (- (ldb (byte 11 52) u64) 1023)) + (1+ (float (loop for i from 51 downto 0 + for n = 2 then (* 2 n) + for frac = (* (/ n) (ldb (byte 1 i) u64)) + sum frac))))) + +(defun radix-values (radix) + (assert (<= 2 radix 35) + (radix) + "RADIX must be between 2 and 35 (inclusive), not ~D." radix) + (make-array radix + :displaced-to "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" + :displaced-index-offset 0 + :element-type + #+lispworks 'base-char + #-lispworks 'character)) + +(defun parse-float (float-string + &key (start 0) (end nil) (radix 10) + (junk-allowed t) + (type 'single-float) + (decimal-character #\.)) + (let ((radix-array (radix-values radix)) + (integer-part 0) + (mantissa 0) + (mantissa-size 1) + (sign 1)) + (with-input-from-string (float-stream (string-upcase (string-trim '(#\Space #\Tab) float-string)) :start start :end end) + (labels ((peek () (peek-char nil float-stream nil nil nil)) + (next () (read-char float-stream nil nil nil)) + (sign () ;; reads the (optional) sign of the number + (cond + ((char= (peek) #\+) (next) (setf sign 1)) + ((char= (peek) #\-) (next) (setf sign -1))) + (integer-part)) + (integer-part () + (cond + ((position (peek) radix-array) + ;; the next char is a valid char + (setf integer-part (+ (* integer-part radix) + (position (next) radix-array))) + ;; again + (return-from integer-part (integer-part))) + ((null (peek)) + ;; end of string + (done)) + ((char= decimal-character (peek)) + ;; the decimal seperator + (next) + (return-from integer-part (mantissa))) + ;; junk + (junk-allowed (done)) + (t (bad-string)))) + (mantissa () + (cond + ((position (peek) radix-array) + (setf mantissa (+ (* mantissa radix) + (position (next) radix-array)) + mantissa-size (* mantissa-size radix)) + (return-from mantissa + (mantissa))) + ((or (null (peek)) junk-allowed) + ;; end of string + (done)) + (t (bad-string)))) + (bad-string () + (error "Unable to parse ~S." float-string)) + (done () + (return-from parse-float + (coerce (* sign (+ integer-part (/ mantissa mantissa-size))) type)))) + (sign))))) + +(define-modify-macro mulf (B) + * + "SETF NUM to the result of (* NUM B).") + +(define-modify-macro divf (B) + / + "SETF NUM to the result of (/ NUM B).") + +(define-modify-macro minf (other) + (lambda (current other) + (if (< other current) + other + current)) + "Sets the place to new-value if new-value is #'< the current value") + +(define-modify-macro maxf (other) + (lambda (current other) + (if (> other current) + other + current)) + "Sets the place to new-value if new-value is #'> the current value") + +(defun map-range (lambda min max &optional (step 1)) + (loop for i from min upto max by step + collect (funcall lambda i))) + +(defmacro do-range ((index &optional min max step return-value) + &body body) + (assert (or min max) + (min max) + "Must specify at least MIN or MAX") + `(loop + for ,index ,@(when min `(from ,min)) + ,@(when max `(upto ,max)) + ,@(when step `(by ,step)) + do (progn ,@body) + finally (return ,return-value))) + +(defun 10^ (x) + (expt 10 x)) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/one-liners.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/one-liners.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,228 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Miscalaneous stuff + +(defun intern-concat (string-designators &optional (package *package*)) + (intern (with-output-to-string (symbol-name) + (dolist (designator string-designators) + (write-string (etypecase designator + (symbol (symbol-name designator)) + (string designator)) + symbol-name))) + package)) + +(defmacro with-unique-names ((&rest bindings) &body body) + "Evaluate BODY with BINDINGS bound to fresh unique symbols. + +Syntax: WITH-UNIQUE-NAMES ( [ var | (var x) ]* ) declaration* form* + +Executes a series of forms with each VAR bound to a fresh, +uninterned symbol. The uninterned symbol is as if returned by a call +to GENSYM with the string denoted by X - or, if X is not supplied, the +string denoted by VAR - as argument. + +The variable bindings created are lexical unless special declarations +are specified. The scopes of the name bindings and declarations do not +include the Xs. + +The forms are evaluated in order, and the values of all but the last +are discarded \(that is, the body is an implicit PROGN)." + ;; reference implementation posted to comp.lang.lisp as + ;; <cy3bshuf30f.fsf(a)ljosa.com> by Vebjorn Ljosa - see also + ;; <http://www.cliki.net/Common%20Lisp%20Utilities> + `(let ,(mapcar (lambda (binding) + (check-type binding (or cons symbol)) + (destructuring-bind (var &optional (prefix (symbol-name var))) + (if (consp binding) binding (list binding)) + (check-type var symbol) + `(,var (gensym ,(concatenate 'string prefix "-"))))) + bindings) + ,@body)) + +(defmacro rebinding (bindings &body body) + "Bind each var in BINDINGS to a gensym, bind the gensym to +var's value via a let, return BODY's value wrapped in this let. + +Evaluates a series of forms in the lexical environment that is +formed by adding the binding of each VAR to a fresh, uninterned +symbol, and the binding of that fresh, uninterned symbol to VAR's +original value, i.e., its value in the current lexical +environment. + +The uninterned symbol is created as if by a call to GENSYM with the +string denoted by PREFIX - or, if PREFIX is not supplied, the string +denoted by VAR - as argument. + +The forms are evaluated in order, and the values of all but the last +are discarded \(that is, the body is an implicit PROGN)." + ;; reference implementation posted to comp.lang.lisp as + ;; <cy3wv0fya0p.fsf(a)ljosa.com> by Vebjorn Ljosa - see also + ;; <http://www.cliki.net/Common%20Lisp%20Utilities> + (loop for binding in bindings + for var = (car (if (consp binding) binding (list binding))) + for name = (gensym) + collect `(,name ,var) into renames + collect ``(,,var ,,name) into temps + finally (return `(let* ,renames + (with-unique-names ,bindings + `(let (,,@temps) + ,,@body)))))) + +(defmacro rebind (bindings &body body) + `(let ,(loop + for symbol-name in bindings + collect (list symbol-name symbol-name)) + ,@body)) + +(defmacro with-accessors* (accessor-names object &body body) + "Just like WITH-ACCESSORS, but if the slot-entry is a symbol + assume the variable and accessor name are the same." + `(with-accessors ,(mapcar (lambda (name) + (if (consp name) + name + `(,name ,name))) + accessor-names) + ,object + ,@body)) + +(defmacro define-constant (name value doc-string &optional export-p) + "DEFCONSTANT with extra EXPORT-P argument." + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,(when export-p + `(export ',name ,(package-name (symbol-package name)))) + (defconstant ,name ,value ,doc-string))) + + +(defun register (environment type name datum &rest other-datum) + (cons (if other-datum + (list* type name datum other-datum) + (list* type name datum)) + environment)) + +(defmacro extend (environment type name datum &rest other-datum) + `(setf ,environment (register ,environment ,type ,name ,datum ,@other-datum))) + +(defun lookup (environment type name &key (error-p nil) (default-value nil)) + (loop + for (.type .name . data) in environment + when (and (eql .type type) (eql .name name)) + return (values data t) + finally + (if error-p + (error "Sorry, No value for ~S of type ~S in environment ~S found." + name type environment) + (values default-value nil)))) + +(defun (setf lookup) (value environment type name &key (error-p nil)) + (loop + for env-piece in environment + when (and (eql (first env-piece) type) + (eql (second env-piece) name)) + do (setf (cddr env-piece) value) and + return value + finally + (when error-p + (error "Sorry, No value for ~S of type ~S in environment ~S found." + name type environment)))) + +(defun remove-keywords (plist &rest keywords) + "Creates a copy of PLIST without the listed KEYWORDS." + (declare (optimize (speed 3))) + (loop for cell = plist :then (cddr cell) + for el = (car cell) + while cell + unless (member el keywords :test #'eq) + collect el + and collect (cadr cell) + and do (assert (cdr cell) () "Not a proper plist"))) + +(define-modify-macro remf-keywords (&rest keywords) remove-keywords + "Creates a copy of PLIST without the properties identified by KEYWORDS.") + +(defmacro eval-always (&body body) + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@body)) + +(defmacro defalias (function redefinition) + `(eval-always + (progn + (setf (fdefinition ',redefinition) (function ,function)) + ',redefinition))) + +(defmacro defvaralias (variable redefinition) + `(eval-always + (defvar ,redefinition ,variable))) + +(defmacro defmacalias (macro redefinition) + #-allegro + (with-unique-names (args) + `(eval-always + (defmacro ,redefinition (&rest ,args) + `(,',macro ,@,args)))) + #+allegro ;; with-unique-names is undefined in allegro, why? This is a quick fix. + (let ((args (gensym))) + `(eval-always + (defmacro ,redefinition (&rest ,args) + `(,',macro ,@,args))))) + + +(defmacalias lambda fun) + +(defalias make-instance new) + +(defun append1 (list x) + (append list (list x))) + +(defun last1 (l) + (car (last l))) + +(defun flatten1 (l) + (reduce #'append l)) + +(defun singlep (list) + (and (consp list) (not (cdr list)))) + +(defun class-name-of (obj) + (class-name (class-of obj))) + +(defun circularize (&rest items) + (let ((items (copy-list items))) + (nconc items items))) + +(defmacro let1 (var val &body body) + `(let ((,var ,val)) + ,@body)) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; Copyright (c) 2006, Hoan Ton-That +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, Hoan Ton-That, nor +;; BESE, nor the names of its contributors may be used to endorse +;; or promote products derived from this software without specific +;; prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/packages.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/packages.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,496 @@ +;; -*- lisp -*- + +(in-package :common-lisp-user) + +;;;; * Introduction + +;;;; It is a collection of lots of small bits and pieces which have +;;;; proven themselves usefull in various applications. They are all +;;;; tested, some even have a test suite and a few are even +;;;; documentated. + +(defpackage :it.bese.arnesi + (:documentation "The arnesi utility suite.") + (:nicknames :arnesi) + (:use :common-lisp) + (:export + + #:clean-op + #:collect-timing + + #:make-reducer + #:make-pusher + #:make-collector + #:with-reducer + #:with-collector + #:with-collectors + + #:form + #:walk-form + #:make-walk-env + #:*walk-handlers* + #:*warn-undefined* + #:undefined-reference + #:undefined-variable-reference + #:undefined-function-reference + #:return-from-unknown-block + #:defwalker-handler + #:implicit-progn-mixin + #:implicit-progn-with-declare-mixin + #:binding-form-mixin + #:declaration-form + #:constant-form + #:variable-reference + #:local-variable-reference + #:local-lexical-variable-reference + #:free-variable-reference + #:application-form + #:local-application-form + #:lexical-application-form + #:free-application-form + #:lambda-application-form + #:function-form + #:lambda-function-form + #:function-object-form + #:local-function-object-form + #:free-function-object-form + #:lexical-function-object-form + #:function-argument-form + #:required-function-argument-form + #:specialized-function-argument-form + #:optional-function-argument-form + #:keyword-function-argument-form + #:allow-other-keys-function-argument-form + #:rest-function-argument-form + #:block-form + #:return-from-form + #:catch-form + #:throw-form + #:eval-when-form + #:if-form + #:function-binding-form + #:flet-form + #:labels-form + #:variable-binding-form + #:let-form + #:let*-form + #:locally-form + #:macrolet-form + #:multiple-value-call-form + #:multiple-value-prog1-form + #:progn-form + #:progv-form + #:setq-form + #:symbol-macrolet-form + #:tagbody-form + #:go-tag-form + #:go-form + #:the-form + #:unwind-protect-form + #:extract-argument-names + #:walk-lambda-list + #:walk-implict-progn + #:arguments + #:binds + #:body + #:cleanup-form + #:code + #:consequent + #:declares + #:default-value +;; #:else ; iterate + #:enclosing-tagbody + #:eval-when-times + #:first-form + #:func + #:keyword-name + #:name + #:operator + #:optimize-spec + #:other-forms + #:parent + #:protected-form + #:read-only-p + #:result + #:source +;; #:specializer ; closer-mop + #:supplied-p-parameter + #:tag + #:target-block + #:target-progn + #:then + #:type-form + #:value + #:values-form + #:var + #:vars-form + + #:defunwalker-handler + #:unwalk-form + #:unwalk-forms + #:unwalk-lambda-list + + #:to-cps + #:with-call/cc + #:kall + #:call/cc + #:let/cc + #:*call/cc-returns* + #:invalid-return-from + #:unreachable-code + #:defun/cc + #:defgeneric/cc + #:defmethod/cc + #:fmakun-cc + #:*debug-evaluate/cc* + #:*trace-cc* + + #:ppm + #:ppm1 + #:apropos-list* + #:apropos* + + #:with-input-from-file + #:with-output-to-file + #:read-string-from-file + #:write-string-to-file + #:copy-file + #:copy-stream + #:string-to-octets + #:octets-to-string + #:encoding-keyword-to-native + #:defprint-object + + #:if-bind + #:aif + #:when-bind + #:awhen + #:cond-bind + #:acond + #:aand + #:and-bind + #:if2-bind + #:aif2 +;; #:while ; iterate + #:awhile +;; #:until ; iterate + #:it + #:whichever + #:xor + #:switch + #:eswitch + #:cswitch + + #:build-hash-table + #:deflookup-table + #:hash-to-alist + #:hash-table-keys + #:hash-table-values + + #:write-as-uri + #:escape-as-uri + #:unescape-as-uri + #:nunescape-as-uri + #:unescape-as-uri-non-strict + #:uri-parse-error + #:expected-digit-uri-parse-error + #:continue-as-is + + #:write-as-html + #:escape-as-html + #:unescape-as-html + #:html-entity->char + + #:compose + #:conjoin + #:curry + #:rcurry + #:noop + #:y + #:lambda-rec + + #:dolist* + #:dotree + #:ensure-list + #:ensure-cons + #:partition + #:partitionx + #:proper-list-p + #:push* + + #:get-logger + #:log-category + #:stream-log-appender + #:brief-stream-log-appender + #:verbose-stream-log-appender + #:make-stream-log-appender + #:make-slime-repl-log-appender + #:file-log-appender + #:make-file-log-appender + #:deflogger + #:with-logger-level + #:log.level + #:log.compile-time-level + #:+dribble+ + #:+debug+ + #:+info+ + #:+warn+ + #:+error+ + #:+fatal+ + #:handle + #:append-message + #:ancestors + #:appenders + #:children + + #:with-unique-names + #:rebinding + #:rebind + #:define-constant + #:remove-keywords + #:remf-keywords + + #:make-matcher + #:match + #:match-case + #:list-match-case + + #:parse-ieee-double + #:parse-float + #:mulf + #:divf + #:minf + #:maxf + #:map-range + #:do-range + #:10^ + + #:tail + #:but-tail + #:head + #:but-head + #:starts-with + #:ends-with + #:read-sequence* + #:deletef + #:copy-array + #:make-displaced-array + + #:+lower-case-ascii-alphabet+ + #:+upper-case-ascii-alphabet+ + #:+ascii-alphabet+ + #:+alphanumeric-ascii-alphabet+ + #:+base64-alphabet+ + #:random-string + #:strcat + #:strcat* + #:princ-csv + #:parse-csv-string + #:join-strings + #:fold-strings + #:~% + #:~T + #:+CR-LF+ + #:~D + #:~A + #:~S + #:~W + + #:def-special-environment + + #:intern-concat + + #:vector-push-extend* + #:string-from-array + + #:queue + #:enqueue + #:dequeue + #:peek-queue + #:queue-empty-p + #:queue-count + #:random-queue-element + #:queue->list + #:lru-queue + + ;; decimal arith + #:*precision* + #:with-precision + #:decimal-from-float + #:float-from-decimal + #:round-down + #:round-half-up + #:round-half-even + #:round-ceiling + #:round-floor + #:round-half-down + #:round-up + + #:enable-sharp-l-syntax + #:enable-bracket-syntax + #:enable-pf-syntax + #:with-sharp-l-syntax + #:with-package + + #:defclass-struct + + #:with* + + #:quit + + #:wrapping-standard + + #:levenshtein-distance + + #:getenv + + + #:lisp1 + #:with-lisp1 + #:defun1 + #:defmethod1 + + #:_ + + #:eval-always + #:defalias + #:defvaralias + #:defmacalias + #:fun + #:set + #:new + #:append1 + #:last1 + #:singlep + #:class-name-of + #:circularize + #:let1 + + ;; Obsolete stuff for backward compatibility. To be removed eventually. + #:enable-sharp-l + #:enable-bracket-reader + #:enable-pf-reader + )) + +;;;; * Colophon + +;;;; This documentation was produced by qbook. + +;;;; arnesi, and the associated documentation, is written by Edward +;;;; Marco Baringer <mb(a)bese.it>. + +;;;; ** COPYRIGHT + +;;;; Copyright (c) 2002-2006, Edward Marco Baringer +;;;; Copyright (c) 2006 Luca Capello http://luca.pca.it <luca(a)pca.it> +;;;; All rights reserved. + +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions are +;;;; met: + +;;;; - Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. + +;;;; - Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. + +;;;; - Neither the name of Edward Marco Baringer, Luca Capello, nor +;;;; BESE, nor the names of its contributors may be used to endorse +;;;; or promote products derived from this software without specific +;;;; prior written permission. + +;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;;;@include "accumulation.lisp" + +;;;;@include "asdf.lisp" + +;;;;@include "compat.lisp" + +;;;; / @include "cps.lisp" + +;;;;@include "csv.lisp" + +;;;;@include "debug.lisp" + +;;;;@include "decimal-arithmetic.lisp" + +;;;;@include "defclass-struct.lisp" + +;;;;@include "flow-control.lisp" + +;;;;@include "hash.lisp" + +;;;;@include "http.lisp" + +;;;;@include "io.lisp" + +;;;;@include "lambda.lisp" + +;;;;@include "list.lisp" + +;;;;@include "log.lisp" + +;;;;@include "matcher.lisp" + +;;;;@include "mop.lisp" + +;;;;@include "mopp.lisp" + +;;;;@include "numbers.lisp" + +;;;;@include "one-liners.lisp" + +;;;;@include "sequence.lisp" + +;;;;@include "sharpl-reader.lisp" + +;;;;@include "specials.lisp" + +;;;;@include "string.lisp" + +;;;;@include "walk.lisp" + +;;;;@include "vector.lisp" + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/pf-reader.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/pf-reader.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,74 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * A partial application syntax + +;;;; Reader +(defmacro enable-pf-syntax (&optional (open-character #\[) (close-character #\])) + "Enable bracket reader for the rest of the file (being loaded or compiled). +Be careful when using in different situations, because it modifies *readtable*." + ;; The standard sais that *readtable* is restored after loading/compiling a file, + ;; so we make a copy and alter that. The effect is that it will be enabled + ;; for the rest of the file being processed. + `(eval-when (:compile-toplevel :execute) + (setf *readtable* (copy-readtable *readtable*)) + (%enable-pf-reader ,open-character ,close-character))) + +(defun %enable-pf-reader (&optional (open-character #\[) (close-character #\])) + (set-macro-character open-character #'|[-reader| t *readtable*) + (set-syntax-from-char close-character #\) *readtable*)) + +(defun enable-pf-reader () + "TODO Obsolete, to be removed. Use the enable-pf-syntax macro." + ;; (warn "Use the enable-pf-syntax macro instead of enable-pf-reader") + (%enable-pf-reader)) + +(defun |[-reader| (stream char) + (declare (ignore char)) + (destructuring-bind (fname &rest args) + (read-delimited-list #\] stream t) + (let* ((rest (gensym "REST")) + (count (count '_ args)) + (end (if (zerop count) rest `(nthcdr ,count ,rest))) + (args (reduce (lambda (x y) + (cons (if (eq x '_) + `(nth ,(decf count) ,rest) + x) + y)) + args + :from-end t + :initial-value '()))) + `(lambda (&rest ,rest) (apply #',fname ,@args ,end))))) + +;;;; http://groups.google.com/group/comp.lang.lisp/browse_thread/thread/1a86740d… + +;; Copyright (c) 2006, Hoan Ton-That +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Hoan Ton-That, nor the names of the +;; contributors may be used to endorse or promote products derived +;; from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/posixenv.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/posixenv.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,50 @@ +;;; -*- lisp -*- + + +(in-package :it.bese.arnesi) + +;;;; * POSIX environment functions + +(defun getenv (var) + #+allegro (sys:getenv var) + #+clisp (ext:getenv var) + #+cmu + (cdr (assoc var ext:*environment-list* :test #'string=)) + #+lispworks (lw:environment-variable var) + #+openmcl (ccl::getenv var) + #+sbcl (sb-ext:posix-getenv var) + + #-(or allegro clisp cmu lispworks openmcl openmcl sbcl) + (error "Could not define `getenv'.")) + + +;; Copyright (c) 2006 Luca Capello http://luca.pca.it <luca(a)pca.it> +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Luca Capello, Edward Marco Baringer, nor +;; BESE, nor the names of its contributors may be used to endorse +;; or promote products derived from this software without specific +;; prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/queue.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/queue.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,164 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Queues (FIFO) + +;;;; The class QUEUE represents a simple, circular buffer based, FIFO +;;;; implementation. The two core operations are enqueue and dequeue, +;;;; the utility method queue-count is also provided. + +(defclass queue () + ((head-index :accessor head-index) + (tail-index :accessor tail-index) + (buffer :accessor buffer))) + +(defmethod initialize-instance :after + ((queue queue) + &key + (size 20) + (element-type t) + &allow-other-keys) + (assert (< 1 size) + (size) + "Initial size of a queue must be greater than 1.") + (setf (head-index queue) 0 + (tail-index queue) 0 + (buffer queue) (make-array (1+ size) :element-type element-type))) + +(defmethod enqueue ((queue queue) value) + (when (queue-full-p queue) + (grow-queue queue)) + (setf (aref (buffer queue) (head-index queue)) value) + (move-head queue) + queue) + +(defmethod dequeue ((queue queue) &optional (default-value nil)) + (if (queue-empty-p queue) + default-value + (prog1 + (aref (buffer queue) (tail-index queue)) + (move-tail queue)))) + +(defmethod peek-queue ((queue queue)) + (aref (buffer queue) (tail-index queue))) + +(defmethod queue-empty-p ((queue queue)) + (= (head-index queue) (tail-index queue))) + +(defmethod queue-full-p ((queue queue)) + (= (mod (tail-index queue) (length (buffer queue))) + (mod (1+ (head-index queue)) (length (buffer queue))))) + +(defmethod queue-count ((queue queue)) + (let ((head-index (head-index queue)) + (tail-index (tail-index queue))) + (cond + ((= head-index tail-index) + 0) + ((< tail-index head-index) + (- head-index tail-index)) + ((> tail-index head-index) + (- (+ (length (buffer queue)) head-index) + tail-index))))) + +(defmethod random-queue-element ((queue queue)) + (let ((tail-index (tail-index queue)) + (buffer (buffer queue)) + (count (queue-count queue))) + (when (zerop count) + (error "Queue ~A is empty" queue)) + (aref buffer (mod (+ tail-index (random count)) + (length buffer))))) + +(defmethod call-for-all-elements-with-index ((queue queue) callback) + "Calls CALLBACK passing it each element in QUEUE. The elements +will be called in the same order thah DEQUEUE would return them." + (flet ((callback (index) + (funcall callback (aref (buffer queue) index) index))) + (if (< (head-index queue) (tail-index queue)) + ;; growing from the bottom. conceptualy the new elements need + ;; to go between tail and head. it's simpler to just move them + ;; all + (progn + (loop + for index upfrom (tail-index queue) below (length (buffer queue)) + do (callback index)) + (loop + for index upfrom 0 below (head-index queue) + do (callback index))) + ;; growing from the top + (loop + for index from (tail-index queue) below (head-index queue) + do (callback index))))) + +(defmacro do-all-elements ((element queue &optional index) &body body) + (if index + `(call-for-all-elements-with-index ,queue + (lambda (,element ,index) + ,@body)) + (let ((index (gensym "do-all-elements-index-"))) + `(call-for-all-elements-with-index ,queue + (lambda (,element ,index) + (declare (ignore ,index)) + ,@body))))) + +(defmethod grow-queue ((queue queue)) + (let ((new-buffer (make-array (* (length (buffer queue)) 2) + :element-type (array-element-type (buffer queue))))) + (let ((index 0)) + (do-all-elements (element queue) + (setf (aref new-buffer index) element) + (incf index)) + (setf (head-index queue) index + (tail-index queue) 0 + (buffer queue) new-buffer)) + queue)) + +(defmacro incf-mod (place divisor) + `(setf ,place (mod (1+ ,place) ,divisor))) + +(defmethod move-tail ((queue queue)) + (incf-mod (tail-index queue) (length (buffer queue)))) + +(defmethod move-head ((queue queue)) + (incf-mod (head-index queue) (length (buffer queue)))) + +(defmethod print-object ((queue queue) stream) + (print-unreadable-object (queue stream :type t :identity t) + (format stream "~D" (queue-count queue)))) + +(defmethod queue->list ((queue queue)) + (let ((res nil)) + (do-all-elements (element queue) + (push element res)) + (nreverse res))) + +;;;; ** LRU Queue + +(defclass lru-queue (queue) + () + (:documentation "A queue which never grows. When an element is + enqueued and the buffer is full we simply drop the last + element.")) + +(defmethod enqueue ((queue lru-queue) value) + (when (queue-full-p queue) + (dequeue queue)) + (call-next-method queue value)) + +(defmethod enqueue-or-move-to-front ((queue lru-queue) element &key (test #'eql) (key #'identity)) + "Enqueues ELEMENT, if ELEMENT is already in the queue it is + moved to the head. + +NB: this method needs a better name." + (do-all-elements (e queue index) + (when (funcall test element (funcall key e)) + ;; found the element + (rotatef (aref (buffer queue) index) + (aref (buffer queue) (1- (if (zerop (head-index queue)) + (length (buffer queue)) + (head-index queue))))) + (return-from enqueue-or-move-to-front queue))) + ;; if we get here the element wasn't found + (enqueue queue element)) Added: branches/trunk-reorg/thirdparty/arnesi/src/sequence.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/sequence.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,221 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Manipulating sequences + +(defun tail (seq &optional (how-many 1)) + "Returns the last HOW-MANY elements of the sequence SEQ. HOW-MANY is + greater than (length SEQ) then all of SEQ is returned." + (let ((seq-length (length seq))) + (cond + ((<= 0 how-many seq-length) + (subseq seq (- seq-length how-many))) + ((< seq-length how-many) + (copy-seq seq)) + (t ; (< how-many 0) + (head seq (- how-many)))))) + +(defun but-tail (seq &optional (how-many 1)) + "Returns SEQ with the last HOW-MANY elements removed." + (let ((seq-length (length seq))) + (cond + ((<= 0 how-many seq-length) + (subseq seq 0 (- seq-length how-many))) + ((< seq-length how-many) + (copy-seq seq)) + (t + (but-head seq (- how-many)))))) + +(defun head (seq &optional (how-many 1)) + "Returns the first HOW-MANY elements of SEQ." + (let ((seq-length (length seq))) + (cond + ((<= 0 how-many seq-length) + (subseq seq 0 how-many)) + ((< seq-length how-many) + (copy-seq seq)) + (t + (tail seq (- how-many)))))) + +(defun but-head (seq &optional (how-many 1)) + "Returns SEQ with the first HOW-MANY elements removed." + (let ((seq-length (length seq))) + (cond ((<= 0 how-many (length seq)) + (subseq seq how-many)) + ((< seq-length how-many) + (copy-seq seq)) + (t + (but-tail seq (- how-many)))))) + +(defun starts-with (sequence prefix &key (test #'eql) (return-suffix nil)) + "Test whether the first elements of SEQUENCE are the same (as + per TEST) as the elements of PREFIX. + +If RETURN-SUFFIX is T the functions returns, as a second value, a +displaced array pointing to the sequence after PREFIX." + (let ((length1 (length sequence)) + (length2 (length prefix))) + (when (< length1 length2) + (return-from starts-with (values nil nil))) + (dotimes (index length2) + (when (not (funcall test (elt sequence index) (elt prefix index))) + (return-from starts-with (values nil nil)))) + ;; if we get here then we match + (values t + (if return-suffix + (make-array (- (length sequence) (length prefix)) + :element-type (array-element-type sequence) + :displaced-to sequence + :displaced-index-offset (length prefix) + :adjustable nil) + nil)))) + +(defun ends-with (seq1 seq2 &key (test #'eql)) + "Test whether SEQ1 ends with SEQ2. In other words: return true if + the last (length seq2) elements of seq1 are equal to seq2." + (let ((length1 (length seq1)) + (length2 (length seq2))) + (when (< length1 length2) + ;; if seq1 is shorter than seq2 than seq1 can't end with seq2. + (return-from ends-with nil)) + (loop + for seq1-index from (- length1 length2) below length1 + for seq2-index from 0 below length2 + when (not (funcall test (elt seq1 seq1-index) (elt seq2 seq2-index))) + do (return-from ends-with nil) + finally (return t)))) + +(defun read-sequence* (sequence stream &key (start 0) end) + "Like READ-SEQUENCE except the sequence is returned as well. + +The second value returned is READ-SEQUENCE's primary value, the +primary value returned by READ-SEQUENCE* is the medified +sequence." + (let ((pos (read-sequence sequence stream :start start :end end))) + (values sequence pos))) + +(defmacro deletef + (item sequence &rest delete-args + &environment e) + "Delete ITEM from SEQUENCE, using cl:delete, and update SEQUENCE. + +DELETE-ARGS are passed directly to cl:delete." + (multiple-value-bind (vars vals store-vars writer-form reader-form) + (get-setf-expansion sequence e) + `(let* (,@(mapcar #'list vars vals) + (,(car store-vars) ,reader-form)) + (setq ,(car store-vars) (delete ,item ,(car store-vars) + ,@delete-args)) + ,writer-form))) + + +(defun copy-array (array) + "Returns a fresh copy of ARRAY. The returned array will have + the same dimensions and element-type, will not be displaced and + will have the same fill-pointer as ARRAY. + +See http://thread.gmane.org/gmane.lisp.allegro/13 for the +original implementation and discussion." + (let ((dims (array-dimensions array)) + (fill-pointer (and (array-has-fill-pointer-p array) + (fill-pointer array)))) + (adjust-array + (make-array dims :displaced-to array) + dims + :fill-pointer fill-pointer))) + +(defun make-displaced-array (array &optional (start 0) (end (length array))) + (make-array (- end start) + :element-type (array-element-type array) + :displaced-to array + :displaced-index-offset start)) + +;;;; ** Levenshtein Distance + +;;;; 1) Set n to be the length of s. Set m to be the length of t. If n +;;;; = 0, return m and exit. If m = 0, return n and exit. Construct +;;;; a matrix containing 0..m rows and 0..n columns. + +;;;; 2) Initialize the first row to 0..n. Initialize the first column +;;;; to 0..m. + +;;;; 3) Examine each character of s (i from 1 to n). + +;;;; 4) Examine each character of t (j from 1 to m). + +;;;; 5) If s[i] equals t[j], the cost is 0. If s[i] doesn't equal +;;;; t[j], the cost is 1. + +;;;; 6) Set cell d[i,j] of the matrix equal to the minimum of: a. The +;;;; cell immediately above plus 1: d[i-1,j] + 1. b. The cell +;;;; immediately to the left plus 1: d[i,j-1] + 1. c. The cell +;;;; diagonally above and to the left plus the cost: d[i-1,j-1] + +;;;; cost. + +;;;; 7) After the iteration steps (3, 4, 5, 6) are complete, the +;;;; distance is found in cell d[n,m]. + +(defun levenshtein-distance (source target &key (test #'eql)) + (block nil + (let ((source-length (length source)) + (target-length (length target))) + (when (zerop source-length) + (return target-length)) + (when (zerop target-length) + (return source-length)) + (let ((buffer (make-array (1+ target-length)))) + (dotimes (i (1+ target-length)) + (setf (aref buffer i) i)) + ;; we make a slight modification to the alogrithm described + ;; above. we don't create the entire array, just enough to + ;; keep the info we need, which is an array of size + ;; target-length + the "above" value and the "over". (this is + ;; similar to the optimizaiont for determining lcs). + (loop + for i from 1 upto source-length + do (setf (aref buffer 0) i) + do (loop + with above-value = i + with over-value = (1- i) + for j from 1 upto target-length + for cost = (if (funcall test (elt source (1- i)) + (elt target (1- j))) + 0 1) + do (let ((over-value* (aref buffer j))) + (setf (aref buffer j) (min (1+ above-value) + (1+ (aref buffer j)) + (+ cost over-value)) + above-value (aref buffer j) + over-value over-value*)))) + (return (aref buffer target-length)))))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/sharpl-reader.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/sharpl-reader.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,173 @@ +;; -*- lisp -*- + +(in-package :arnesi) + +;;;; * A reader macro for simple lambdas + +;;;; Often we have to create small (in the sense of textually short) +;;;; lambdas. This read macro, bound to #L by default, allows us to +;;;; eliminate the 'boilerplate' LAMBDA and concentrate on the body of +;;;; the lambda. + +(defmacro sharpl-expander (package body min-args &environment env) + (let* ((form body) + (lambda-args (loop + for i upfrom 1 upto (max (or min-args 0) + (highest-bang-var form env)) + collect (make-sharpl-arg package i)))) + `(lambda ,lambda-args + , (when lambda-args + `(declare (ignorable ,@lambda-args))) + ,form))) + +(defun sharpL-reader (stream subchar min-args) + "Reader macro for simple lambdas. + +This read macro reads exactly one form and serves to eliminate +the 'boiler' plate text from such lambdas and write only the body +of the lambda itself. If the form contains any references to +variables named !1, !2, !3, !n etc. these are bound to the Nth +parameter of the lambda. + +Examples: + +#L(foo) ==> (lambda () (foo)). + +#L(foo !1) ==> (lambda (!1) (foo !1)) + +#L(foo (bar !2) !1) ==> (lambda (!1 !2) (foo (bar !2) !1)) + +All arguments are declared ignorable. So if there is a reference +to an argument !X but not !(x-1) we still take X arguments, but x +- 1 is ignored. Examples: + +#L(foo !2) ==> (lambda (!1 !2) (declare (ignore !1)) (foo !2)) + +We can specify exactly how many arguments to take by using the +read macro's prefix parameter. NB: this is only neccessary if the +lambda needs to accept N arguments but only uses N - 1. Example: + +#2L(foo !1) ==> (lambda (!1 !2) (declare (ignore !2)) (foo !1)) + +When #l forms are nested, !X variables are bound to the innermost +form. Example: + +#l#l(+ !1 !2) + +returns a function that takes no arguments and returns a function +that adds its two arguments." + (declare (ignore subchar)) + (let ((body (read stream t nil t))) + `(sharpl-expander ,*package* ,body ,min-args))) + +(defun with-sharp-l-syntax () + "To be used with the curly reader from arnesi: {with-sharp-l-syntax #L(typep !1 'foo)}" + (lambda (handler) + (%enable-sharp-l-reader) + `(progn ,@(funcall handler)))) + +(defmacro enable-sharp-l-syntax () + ;; The standard sais that *readtable* is restored after loading/compiling a file, + ;; so we make a copy and alter that. The effect is that it will be enabled + ;; for the rest of the file being processed. + `(eval-when (:compile-toplevel :execute) + (setf *readtable* (copy-readtable *readtable*)) + (%enable-sharp-l-reader))) + +(defun %enable-sharp-l-reader () + "Bind SHARPL-READER to the macro character #L. + +This function overrides (and forgets) and previous value of #L." + (set-dispatch-macro-character #\# #\L 'sharpL-reader)) + +(defun enable-sharp-l () + "TODO: Obsolete, to be removed. Use the enable-sharp-l-syntax macro." + ;; (warn "Use the enable-sharp-l-syntax macro instead of enable-sharp-l") + (%enable-sharp-l-reader)) + +(defun find-var-references (input-form) + (typecase input-form + (cons + (append (find-var-references (car input-form)) + (find-var-references (cdr input-form)))) + + (free-variable-reference (list (slot-value input-form 'name))) + (local-lexical-variable-reference (list (slot-value input-form 'name))) + + (form + (loop for slot-name in (mapcar #'mopp:slot-definition-name + (mopp::class-slots (class-of input-form))) + if (not (member slot-name '(parent target-progn enclosing-tagbody target-block))) + append (find-var-references (slot-value input-form slot-name)))) + + (t nil))) + +(defun highest-bang-var (form env) + (let ((*warn-undefined* nil)) + (or + (loop for var in (find-var-references (walk-form form nil (make-walk-env env))) + if (bang-var-p var) + maximize (bang-var-p var)) + 0))) + +(defun bang-var-p (form) + (and (char= #\! (aref (symbol-name form) 0)) + (parse-integer (subseq (symbol-name form) 1) :junk-allowed t))) + +(defun make-sharpl-arg (package number) + (intern (format nil "!~D" number) package)) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;; This code was heavily inspired by iterate, which has the following +;; copyright: + +;; ITERATE, An Iteration Macro +;; +;; Copyright 1989 by Jonathan Amsterdam +;; Adapted to ANSI Common Lisp in 2003 by Andreas Fuchs +;; +;; Permission to use, copy, modify, and distribute this software and its +;; documentation for any purpose and without fee is hereby granted, +;; provided that this copyright and permission notice appear in all +;; copies and supporting documentation, and that the name of M.I.T. not +;; be used in advertising or publicity pertaining to distribution of the +;; software without specific, written prior permission. M.I.T. makes no +;; representations about the suitability of this software for any +;; purpose. It is provided "as is" without express or implied warranty. + +;; M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +;; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +;; M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +;; ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +;; WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +;; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +;; SOFTWARE. Added: branches/trunk-reorg/thirdparty/arnesi/src/specials.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/specials.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,81 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * def-special-environment + +(defun check-required (name vars required) + (dolist (var required) + (assert (member var vars) + (var) + "Unrecognized symbol ~S in ~S." var name))) + +(defmacro def-special-environment (name (&key accessor binder binder*) + &rest vars) + "Define two macros for dealing with groups or related special variables. + +ACCESSOR is defined as a macro: (defmacro ACCESSOR (VARS &rest +BODY)). Each element of VARS will be bound to the +current (dynamic) value of the special variable. + +BINDER is defined as a macro for introducing (and binding new) +special variables. It is basically a readable LET form with the +prorpe declarations appended to the body. The first argument to +BINDER must be a form suitable as the first argument to LET. + +ACCESSOR defaults to a new symbol in the same package as NAME +which is the concatenation of \"WITH-\" NAME. BINDER is built as +\"BIND-\" and BINDER* is BINDER \"*\"." + (unless accessor + (setf accessor (intern-concat (list '#:with- name) (symbol-package name)))) + (unless binder + (setf binder (intern-concat (list '#:bind- name) (symbol-package name)))) + (unless binder* + (setf binder* (intern-concat (list binder '#:*) (symbol-package binder)))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (flet () + (defmacro ,binder (requested-vars &body body) + (check-required ',name ',vars (mapcar #'car requested-vars)) + `(let ,requested-vars + (declare (special ,@(mapcar #'car requested-vars))) + ,@body)) + (defmacro ,binder* (requested-vars &body body) + (check-required ',name ',vars (mapcar #'car requested-vars)) + `(let* ,requested-vars + (declare (special ,@(mapcar #'car requested-vars))) + ,@body)) + (defmacro ,accessor (requested-vars &body body) + (check-required ',name ',vars requested-vars) + `(locally (declare (special ,@requested-vars)) + ,@body)) + ',name))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/string.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/string.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,297 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Manipulating strings + +(defvar +lower-case-ascii-alphabet+ + "abcdefghijklmnopqrstuvwxyz" + "All the lower case letters in 7 bit ASCII.") +(defvar +upper-case-ascii-alphabet+ + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "All the upper case letters in 7 bit ASCII.") +(defvar +ascii-alphabet+ + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + "All letters in 7 bit ASCII.") +(defvar +alphanumeric-ascii-alphabet+ + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" + "All the letters and numbers in 7 bit ASCII.") +(defvar +base64-alphabet+ + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" + "All the characters allowed in base64 encoding.") + +(defun random-string (&optional (length 32) (alphabet +ascii-alphabet+)) + "Returns a random alphabetic string. + +The returned string will contain LENGTH characters chosen from +the vector ALPHABET. +" + (loop with id = (make-string length) + with alphabet-length = (length alphabet) + for i below length + do (setf (cl:aref id i) + (cl:aref alphabet (random alphabet-length))) + finally (return id))) + +(declaim (inline strcat)) +(defun strcat (&rest items) + "Returns a fresh string consisting of ITEMS concat'd together." + (declare (optimize speed)) + (strcat* items)) + +(defun strcat* (string-designators) + "Concatenate all the strings in STRING-DESIGNATORS." + (let ((*print-pretty* nil) + (*print-circle* nil)) + (with-output-to-string (stream) + (dotree (str string-designators) + (when str + (princ str stream)))))) + +;;; A "faster" version for string concatenating. +;;; Could use just (apply #'concatenate 'string list), but that's quite slow +(defun join-strings (list) + (let* ((length (reduce #'+ list :key #'length)) + (result (make-string length))) + (loop + for string in list + for start = 0 then end + for end = (+ start (length string)) + while string + do (replace result string :start1 start :end1 end) + finally (return result)))) + +(defun fold-strings (list) + (declare (optimize (speed 3) (safety 0) (debug 0))) + (let ((strings '()) + (result '())) + (dolist (object list) + (typecase object + (string (push object strings)) + (t (when strings + (push (join-strings (nreverse strings)) result) + (setf strings '())) + (push object result)))) + (when strings + (push (join-strings (nreverse strings)) result)) + (nreverse result))) + +(defvar ~% + (format nil "~%") + "A string containing a single newline") +(defvar ~T + (string #\Tab) + "A string containing a single tab character.") +(defvar +CR-LF+ + (make-array 2 :element-type 'character + :initial-contents (list (code-char #x0D) + (code-char #x0A))) + "A string containing the two characters CR and LF.") + +(defun ~D (number &optional stream &key mincol pad-char) + (format stream "~v,vD" mincol pad-char number)) + +(defun ~A (object &optional stream) + (format stream "~A" object)) + +(defun ~S (object &optional stream) + (format stream "~S" object)) + +(defun ~W (object &optional stream) + (format stream "~W" object)) + +;;;; ** Converting strings to/from foreign encodings + +;;;; *** CLISP + +#+(and clisp unicode) +(progn + (defun %encoding-keyword-to-native (encoding) + (ext:make-encoding + :charset (case encoding + (:utf-8 charset:utf-8) + (:utf-16 charset:utf-16) + (:us-ascii charset:ascii) + (t (multiple-value-bind (symbol status) + (find-symbol (string encoding) (find-package :charset)) + (if (eq status :external) + (symbol-value symbol) + ;; otherwise, if SYSTEM::*HTTP-ENCODING* + ;; is available, then use it + #+#.(cl:if (cl:and (cl:find-package "SYSTEM") + (cl:find-symbol "*HTTP-ENCODING*" + (cl:find-package "SYSTEM"))) + '(and) '(or)) + SYSTEM::*HTTP-ENCODING* + ;; otherwise, use EXT:*MISC-ENCODING* + #+#.(cl:if (cl:and (cl:find-package "SYSTEM") + (cl:find-symbol "*HTTP-ENCODING*" + (cl:find-package "SYSTEM"))) + '(or) '(and)) + EXT:*MISC-ENCODING*)))) + ;; These native encodings will be used for the HTTP protocol, + ;; therefore we set the line-terminator to MS-DOS. + ;; Of course, it would be better if this was explicitely requested... + :line-terminator :dos + :input-error-action #\uFFFD + :output-error-action #+debug :error #-debug :ignore)) + (defun %string-to-octets (string encoding) + (ext:convert-string-to-bytes string (encoding-keyword-to-native encoding))) + (defun %octets-to-string (octets encoding) + (ext:convert-string-from-bytes octets (encoding-keyword-to-native encoding)))) + +;;;; *** SBCL + +#+(and sbcl sb-unicode) +(progn + (defun %encoding-keyword-to-native (encoding) + (case encoding + (:utf-8 :utf8) + (:utf-16 :utf16) + (:us-ascii :us-ascii) + (t encoding))) + (defun %string-to-octets (string encoding) + (sb-ext:string-to-octets string :external-format (encoding-keyword-to-native encoding))) + (defun %octets-to-string (octets encoding) + (sb-ext:octets-to-string octets :external-format (encoding-keyword-to-native encoding)))) + +;;;; *** Allegro + +#+allegro +(progn + (defun %encoding-keyword-to-native (encoding) + (case encoding + (:utf-8 :utf8) + (:iso-8859-1 :iso8859-1) + (:utf-16 :unicode) + (:us-ascii :ascii) + (t encoding))) + + (defun %string-to-octets (string encoding) + (excl:string-to-octets string :external-format (encoding-keyword-to-native encoding) :null-terminate nil)) + + (defun %octets-to-string (octets encoding) + (multiple-value-bind (displaced-array index) (array-displacement octets) + (if displaced-array + (excl:octets-to-string displaced-array :start index :end (+ index (length octets)) :external-format (encoding-keyword-to-native encoding)) + (excl:octets-to-string octets :external-format (encoding-keyword-to-native encoding)))))) + + +;;;; *** LispWorks + +;; TODO this is partial. someone with a lispworks at hand should finish it. +;; see this as an example: +;; (defun encode-lisp-string (string) +;; (translate-string-via-fli string :utf-8 :latin-1)) +;; +;; (defun decode-external-string (string) +;; (translate-string-via-fli string :latin-1 :utf-8)) +;; +;; ;; Note that a :utf-8 encoding of a null in a latin-1 string is +;; ;; also null, and vice versa. So don't have to worry about +;; ;; null-termination or length. (If we were translating to/from +;; ;; :unicode, this would become an issue.) +;; +;; (defun translate-string-via-fli (string from to) +;; (fli:with-foreign-string (ptr elements bytes :external-format from) +;; string +;; (declare (ignore elements bytes)) +;; (fli:convert-from-foreign-string ptr :external-format to))) + +#+lispworks +(progn + (defun %encoding-keyword-to-native (encoding) + (case encoding + (:utf-8 :utf-8) + (:iso-8859-1 :latin-1) + (:utf-16 :unicode) + (:us-ascii :us-ascii) + (t encoding))) + + (defun %string-to-octets (string encoding) + (declare (ignore encoding)) + ;; TODO + (map-into (make-array (length string) :element-type 'unsigned-byte) + #'char-code string)) + + (defun %octets-to-string (octets encoding) + (declare (ignore encoding)) + ;; TODO + (map-into (make-array (length octets) :element-type 'character) + #'code-char octets))) + + +;;;; *** Default Implementation + +#-(or (and sbcl sb-unicode) (and clisp unicode) allegro lispworks) +(progn + (defun %encoding-keyword-to-native (encoding) + encoding) + + (defun %string-to-octets (string encoding) + (declare (ignore encoding)) + (map-into (make-array (length string) :element-type 'unsigned-byte) + #'char-code string)) + + (defun %octets-to-string (octets encoding) + (declare (ignore encoding)) + (map-into (make-array (length octets) :element-type 'character) + #'code-char octets))) + +(declaim (inline string-to-octets %string-to-octets)) +(defun string-to-octets (string encoding) + "Convert STRING, a list string, a vector of bytes according to ENCODING. + +ENCODING is a keyword representing the desired character +encoding. We gurantee that :UTF-8, :UTF-16 and :ISO-8859-1 will +work as expected. Any other values are simply passed to the +underlying lisp's function and the results are implementation +dependant. + +On CLISP we intern the ENCODING symbol in the CHARSET package and +pass that. On SBCL we simply pass the keyword." + (%string-to-octets string encoding)) + +(declaim (inline octets-to-string %octets-to-string)) +(defun octets-to-string (octets encoding) + (%octets-to-string octets encoding)) + +(declaim (inline encoding-keyword-to-native)) +(defun encoding-keyword-to-native (encoding) + "Convert ENCODING, a keyword, to an object the native list +accepts as an encoding. + +ENCODING can be: :UTF-8, :UTF-16, or :US-ASCII and specify the +corresponding encodings. Any other keyword is passed, as is, to +the underlying lisp." + (%encoding-keyword-to-native encoding)) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/time.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/time.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,185 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * Programmatic interface to CL:TIME + +(defclass timing-info () + ((real-time :accessor real-time :initarg :real-time + :initform :not-available + :documentation "Real time (also known as wall time) + consumed. Expressed in milliseconds.") + (user-time :accessor user-time :initarg :user-time + :initform :not-available + :documentation "User time. Expressed in milliseconds.") + (system-time :accessor system-time :initarg :system-time + :initform :not-available + :documentation "System time. Expressed in milliseconds.") + (gc-time :accessor gc-time :initarg :gc-time + :initform :not-available + :documentation "GC time. Expressed in milliseconds.") + (page-faults :accessor page-faults :initarg :page-faults + :initform :not-available + :documentation "Number of page faults.") + (bytes-consed :accessor bytes-consed :initarg :bytes-consed + :initform :not-available + :documentation "Number of bytes allocated.")) + (:documentation "Specificer for collect-timing info. + +Every slot is either a number (with the exact meanining depending +on the slot) or the keyword :not-available in the case the lisp +doesn't provide this information.")) + +(defun pprint-milliseconds (milliseconds &optional stream) + (cond + ((< milliseconds 1000) + (format stream "~D ms" milliseconds)) + ((= milliseconds 1000) + (format stream "1.00 second")) + ((< milliseconds (* 60 1000)) + (format stream "~,2F seconds" (/ milliseconds 1000))) + ((= milliseconds (* 60 1000)) + (format stream "1.00 minute")) + (t + (format stream "~,2F minutes" (/ milliseconds (* 60 1000)))))) + +(defun pprint-bytes (num-bytes &optional stream) + "Writes NUM-BYTES to stream, rounds num-bytes and appends a +suffix depending on the size of num-bytes." + (cond + ((< num-bytes (expt 2 10)) + (format stream "~D B" num-bytes)) + ((< num-bytes (expt 2 20)) + (format stream "~,2F KiB" (/ num-bytes (expt 2 10)))) + ((< num-bytes (expt 2 30)) + (format stream "~,2F MiB" (/ num-bytes (expt 2 20)))) + ((< num-bytes (expt 2 40)) + (format stream "~,2F GiB" (/ num-bytes (expt 2 30)))) + (t + (format stream "~,2F TiB" (/ num-bytes (expt 2 40)))))) + +(defmethod print-object ((info timing-info) stream) + (print-unreadable-object (info stream :type t :identity t) + (format stream "~A/~A" + (pprint-milliseconds (real-time info)) + (pprint-bytes (bytes-consed info))))) + +(defun collect-timing (lambda) + "Executes LAMBDA and returns a timing-info object specifying + how long execution took and how much memory was used. + +NB: Not all implementations provide all information. See the +various %collect-timing definitions for details." + (%collect-timing lambda)) + +#+sbcl +(defun %collect-timing (fun) + (declare (type function fun)) + "Implementation of collect-timing for SBCL. + +This code is a cut 'n paste from sbcl/src/code/time.lisp. It uses +internal functions, all bets off." + (let (old-run-utime + new-run-utime + old-run-stime + new-run-stime + old-real-time + new-real-time + old-page-faults + new-page-faults + real-time-overhead + run-utime-overhead + run-stime-overhead + page-faults-overhead + old-bytes-consed + new-bytes-consed + cons-overhead) + ;; Calculate the overhead... + (multiple-value-setq + (old-run-utime old-run-stime old-page-faults old-bytes-consed) + (sb-impl::time-get-sys-info)) + ;; Do it a second time to make sure everything is faulted in. + (multiple-value-setq + (old-run-utime old-run-stime old-page-faults old-bytes-consed) + (sb-impl::time-get-sys-info)) + (multiple-value-setq + (new-run-utime new-run-stime new-page-faults new-bytes-consed) + (sb-impl::time-get-sys-info)) + (setq run-utime-overhead (- new-run-utime old-run-utime)) + (setq run-stime-overhead (- new-run-stime old-run-stime)) + (setq page-faults-overhead (- new-page-faults old-page-faults)) + (setq old-real-time (get-internal-real-time)) + (setq old-real-time (get-internal-real-time)) + (setq new-real-time (get-internal-real-time)) + (setq real-time-overhead (- new-real-time old-real-time)) + (setq cons-overhead (- new-bytes-consed old-bytes-consed)) + ;; Now get the initial times. + (multiple-value-setq + (old-run-utime old-run-stime old-page-faults old-bytes-consed) + (sb-impl::time-get-sys-info)) + (setq old-real-time (get-internal-real-time)) + (let ((start-gc-run-time sb-impl::*gc-run-time*)) + (progn + ;; Execute the form and return its values. + (funcall fun) + (multiple-value-setq + (new-run-utime new-run-stime new-page-faults new-bytes-consed) + (sb-impl::time-get-sys-info)) + (setq new-real-time (- (get-internal-real-time) real-time-overhead)) + (let ((gc-run-time (max (- sb-impl::*gc-run-time* start-gc-run-time) 0))) + (make-instance 'timing-info + :real-time (max (- new-real-time old-real-time) 0.0) + :user-time (max (/ (- new-run-utime old-run-utime) 1000.0) 0.0) + :system-time (max (/ (- new-run-stime old-run-stime) 1000.0) 0.0) + :gc-time (float gc-run-time) + :page-faults (max (- new-page-faults old-page-faults) 0) + :bytes-consed (max (- new-bytes-consed old-bytes-consed) 0))))))) + +#+openmcl +(defun %collect-timing (lambda) + "Implementation of collect-timing for OpenMCL. + +We only report the MAJOR-PAGE-FAULTS, the number of +MINOR-PAGE-FAULTS is ignored." + (let ((ccl:*report-time-function* #'list)) + (destructuring-bind (&key elapsed-time user-time system-time + gc-time bytes-allocated major-page-faults + &allow-other-keys) + (time (funcall lambda)) + (make-instance 'timing-info + :real-time elapsed-time + :user-time user-time + :system-time system-time + :gc-time gc-time + :bytes-consed bytes-allocated + :page-faults major-page-faults)))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/unwalk.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/unwalk.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,311 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * A Code UnWalker + +;;; ** Public Entry Point + +(defgeneric unwalk-form (form) + (:documentation "Unwalk FORM and return a list representation.")) + +(defmacro defunwalker-handler (class (&rest slots) &body body) + (with-unique-names (form) + `(progn + (defmethod unwalk-form ((,form ,class)) + (with-slots ,slots ,form + ,@body)) + ',class))) + +(declaim (inline unwalk-forms)) +(defun unwalk-forms (forms) + (mapcar #'unwalk-form forms)) + +;;;; Atoms + +(defunwalker-handler constant-form (value) + (typecase value + (symbol `(quote ,value)) + (cons `(quote ,value)) + (t value))) + +(defunwalker-handler variable-reference (name) + name) + +;;;; Function Application + +(defunwalker-handler application-form (operator arguments) + (cons operator (unwalk-forms arguments))) + +(defunwalker-handler lambda-application-form (operator arguments) + ;; The cadr is for getting rid of (function ...) which we can't have + ;; at the beginning of a form. + (cons (cadr (unwalk-form operator)) (unwalk-forms arguments))) + +;;;; Functions + +(defunwalker-handler lambda-function-form (arguments body declares) + `(function + (lambda ,(unwalk-lambda-list arguments) + ,@(unwalk-declarations declares) + ,@(unwalk-forms body)))) + +(defunwalker-handler function-object-form (name) + `(function ,name)) + +;;;; Arguments + +(defun unwalk-lambda-list (arguments) + (let (optional-p rest-p keyword-p) + (mapcan #'(lambda (form) + (append + (typecase form + (optional-function-argument-form + (unless optional-p (setq optional-p t) '(&optional))) + (rest-function-argument-form + (unless rest-p (setq rest-p t) '(&rest))) + (keyword-function-argument-form + (unless keyword-p (setq keyword-p t) '(&key)))) + (list (unwalk-form form)))) + arguments))) + +(defunwalker-handler required-function-argument-form (name) + name) + +(defunwalker-handler specialized-function-argument-form (name specializer) + (if (eq specializer t) + name + `(,name ,specializer))) + +(defunwalker-handler optional-function-argument-form (name default-value supplied-p-parameter) + (let ((default-value (unwalk-form default-value))) + (cond ((and name default-value supplied-p-parameter) + `(,name ,default-value ,supplied-p-parameter)) + ((and name default-value) + `(,name ,default-value)) + (name name) + (t (error "Invalid optional argument"))))) + +(defunwalker-handler keyword-function-argument-form (keyword-name name default-value supplied-p-parameter) + (let ((default-value (unwalk-form default-value))) + (cond ((and keyword-name name default-value supplied-p-parameter) + `((,keyword-name ,name) ,default-value ,supplied-p-parameter)) + ((and name default-value supplied-p-parameter) + `(,name ,default-value ,supplied-p-parameter)) + ((and name default-value) + `(,name ,default-value)) + (name name) + (t (error "Invalid keyword argument"))))) + +(defunwalker-handler allow-other-keys-function-argument-form () + '&allow-other-keys) + +(defunwalker-handler rest-function-argument-form (name) + name) + +;;;; Declarations + +(defun unwalk-declarations (decls) + ;; Return a list so declarations can be easily spliced. + (if (null decls) + nil + (list `(declare ,@(unwalk-forms decls))))) + +(defunwalker-handler optimize-declaration-form (optimize-spec) + `(optimize ,optimize-spec)) + +(defunwalker-handler dynamic-extent-declaration-form (name) + `(dynamic-extent ,name)) + +(defunwalker-handler variable-ignorable-declaration-form (name) + `(ignorable ,name)) + +(defunwalker-handler function-ignorable-declaration-form (name) + `(ignorable (function ,name))) + +(defunwalker-handler special-declaration-form (name) + `(special ,name)) + +(defunwalker-handler type-declaration-form (type-form name) + `(type ,type-form ,name)) + +(defunwalker-handler ftype-declaration-form (type-form name) + `(ftype ,type-form ,name)) + +(defunwalker-handler notinline-declaration-form (name) + `(notinline ,name)) + +;;;; BLOCK/RETURN-FROM + +(defunwalker-handler block-form (name body) + `(block ,name ,@(unwalk-forms body))) + +(defunwalker-handler return-from-form (target-block result) + `(return-from ,(name target-block) ,(unwalk-form result))) + +;;;; CATCH/THROW + +(defunwalker-handler catch-form (tag body) + `(catch ,(unwalk-form tag) ,@(unwalk-forms body))) + +(defunwalker-handler throw-form (tag value) + `(throw ,(unwalk-form tag) ,(unwalk-form value))) + +;;;; EVAL-WHEN + +(defunwalker-handler eval-when-form (body eval-when-times) + `(eval-when ,eval-when-times + ,@(unwalk-forms body))) + +;;;; IF + +(defunwalker-handler if-form (consequent then else) + `(if ,(unwalk-form consequent) ,(unwalk-form then) ,(unwalk-form else))) + +;;;; FLET/LABELS + +;; The cdadr is here to remove (function (lambda ...)) of the function +;; bindings. + +(defunwalker-handler flet-form (binds body declares) + (flet ((unwalk-flet (binds) + (mapcar #'(lambda (bind) + (cons (car bind) + (cdadr (unwalk-form (cdr bind))))) + binds))) + `(flet ,(unwalk-flet binds) + ,@(unwalk-declarations declares) + ,@(unwalk-forms body)))) + +(defunwalker-handler labels-form (binds body declares) + (flet ((unwalk-labels (binds) + (mapcar #'(lambda (bind) + (cons (car bind) + (cdadr (unwalk-form (cdr bind))))) + binds))) + `(labels ,(unwalk-labels binds) + ,@(unwalk-declarations declares) + ,@(unwalk-forms body)))) + +;;;; LET/LET* + +(defunwalker-handler let-form (binds body declares) + (flet ((unwalk-let (binds) + (mapcar #'(lambda (bind) + (list (car bind) (unwalk-form (cdr bind)))) + binds))) + `(let ,(unwalk-let binds) + ,@(unwalk-declarations declares) + ,@(unwalk-forms body)))) + +(defunwalker-handler let*-form (binds body declares) + (flet ((unwalk-let* (binds) + (mapcar #'(lambda (bind) + (list (car bind) (unwalk-form (cdr bind)))) + binds))) + `(let* ,(unwalk-let* binds) + ,@(unwalk-declarations declares) + ,@(unwalk-forms body)))) + +;;;; LOAD-TIME-VALUE + +(defunwalker-handler load-time-value-form (value read-only-p) + `(load-time-value ,(unwalk-form value) ,read-only-p)) + +;;;; LOCALLY + +(defunwalker-handler locally-form (body declares) + `(locally ,@(unwalk-declarations declares) + ,@(unwalk-forms body))) + +;;;; MACROLET + +(defunwalker-handler macrolet-form (body binds declares) + ;; We ignore the binds, because the expansion has already taken + ;; place at walk-time. + (declare (ignore binds)) + `(locally ,@(unwalk-declarations declares) ,@(unwalk-forms body))) + +;;;; MULTIPLE-VALUE-CALL + +(defunwalker-handler multiple-value-call-form (func arguments) + `(multiple-value-call ,(unwalk-form func) ,@(unwalk-forms arguments))) + +;;;; MULTIPLE-VALUE-PROG1 + +(defunwalker-handler multiple-value-prog1-form (first-form other-forms) + `(multiple-value-prog1 ,(unwalk-form first-form) ,@(unwalk-forms other-forms))) + +;;;; PROGN + +(defunwalker-handler progn-form (body) + `(progn ,@(unwalk-forms body))) + +;;;; PROGV + +(defunwalker-handler progv-form (body vars-form values-form) + `(progv ,(unwalk-form vars-form) ,(unwalk-form values-form) ,@(unwalk-forms body))) + +;;;; SETQ + +(defunwalker-handler setq-form (var value) + `(setq ,var ,(unwalk-form value))) + +;;;; SYMBOL-MACROLET + +(defunwalker-handler symbol-macrolet-form (body binds declares) + ;; We ignore the binds, because the expansion has already taken + ;; place at walk-time. + (declare (ignore binds)) + `(locally ,@(unwalk-declarations declares) ,@(unwalk-forms body))) + +;;;; TAGBODY/GO + +(defunwalker-handler tagbody-form (body) + `(tagbody ,@(unwalk-forms body))) + +(defunwalker-handler go-tag-form (name) + name) + +(defunwalker-handler go-form (name) + `(go ,name)) + +;;;; THE + +(defunwalker-handler the-form (type-form value) + `(the ,type-form ,(unwalk-form value))) + +;;;; UNWIND-PROTECT + +(defunwalker-handler unwind-protect-form (protected-form cleanup-form) + `(unwind-protect ,(unwalk-form protected-form) ,@(unwalk-forms cleanup-form))) + +;; Copyright (c) 2006, Hoan Ton-That +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Hoan Ton-That, nor the names of the +;; contributors may be used to endorse or promote products derived +;; from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/vector.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/vector.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,78 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * vector/array utilities + +(defun vector-push-extend* (vector &rest items) + (let ((element-type (array-element-type vector))) + (dolist (item items) + (cond + ((typep item element-type) ;; item can be put directly into the + (vector-push-extend item vector)) + ((typep item `(vector ,element-type)) ;; item should be a vector + (loop + for i across item + do (vector-push-extend i vector))) + (t + (error "Bad type for item ~S." item)))) + vector)) + +(defun string-from-array (array &key (start 0) (end (1- (length array)))) + "Assuming ARRAY is an array of ASCII chars encoded as bytes return +the corresponding string. Respect the C convention of null terminating +strings. START and END specify the zero indexed offsets of a sub range +of ARRAY." + ;; This is almost always the case + (assert (<= 0 start (1- (length array))) + (start) + "START must be a valid offset of ARRAY.") + (assert (<= 0 end (1- (length array))) + (end) + "END must be a valid offset of ARRAY.") + (assert (<= start end) + (start end) + "START must be less than or equal to END.") + (assert (every (lambda (element) (<= 0 element 255)) array) + (array) + "Some element of ~S was not > 0 and < 255" array) + (let* ((working-array (make-array (1+ (- end start)) + :element-type (array-element-type array) + :displaced-to array + :displaced-index-offset start)) + (length (if-bind pos (position 0 working-array) + pos + (length working-array)))) + (map-into (make-array length :element-type 'character) + #'code-char + working-array))) + +;; Copyright (c) 2002-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/src/walk.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/walk.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,1002 @@ +;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +;;;; * A Code Walker + +;;;; ** Public Entry Point + +(defvar *warn-undefined* nil + "When non-NIL any references to undefined functions or + variables will signal a warning.") + +(defun walk-form (form &optional (parent nil) (env (make-walk-env))) + "Walk FORM and return a FORM object." + (funcall (find-walker-handler form) form parent env)) + +(defun make-walk-env (&optional lexical-env) + (let ((walk-env '())) + (when lexical-env + (dolist (var (lexical-variables lexical-env)) + (extend walk-env :lexical-let var t)) + (dolist (fun (lexical-functions lexical-env)) + (extend walk-env :lexical-flet fun t)) + (dolist (mac (lexical-macros lexical-env)) + (extend walk-env :macrolet (car mac) (cdr mac))) + (dolist (symmac (lexical-symbol-macros lexical-env)) + (extend walk-env :symbol-macrolet (car symmac) (cdr symmac)))) + (cons walk-env lexical-env))) + +(defun register-walk-env (env type name datum &rest other-datum) + (let ((walk-env (register (car env) type name datum)) + (lexenv (case type + (:let (augment-with-variable (cdr env) name)) + (:macrolet (augment-with-macro (cdr env) name datum)) + (:flet (augment-with-function (cdr env) name)) + (:symbol-macrolet (augment-with-symbol-macro (cdr env) name datum)) + ;;TODO: :declare + (t (cdr env))))) + (cons walk-env lexenv))) + +(defmacro extend-walk-env (env type name datum &rest other-datum) + `(setf ,env (register-walk-env ,env ,type ,name ,datum ,@other-datum))) + +(defun lookup-walk-env (env type name &key (error-p nil) (default-value nil)) + (lookup (car env) type name :error-p error-p :default-value default-value)) + +;;;; This takes a Common Lisp form and transforms it into a tree of +;;;; FORM objects. + +(defvar *walker-handlers* (make-hash-table :test 'eq)) + +(define-condition undefined-reference (warning) + ((enclosing-code :accessor enclosing-code :initform nil) + (name :accessor name :initarg :name))) + +(define-condition undefined-variable-reference (undefined-reference) + () + (:report + (lambda (c s) + (if (enclosing-code c) + (format s "Reference to unknown variable ~S in ~S." (name c) (enclosing-code c)) + (format s "Reference to unknown variable ~S." (name c)))))) + +(define-condition undefined-function-reference (undefined-reference) + () + (:report + (lambda (c s) + (if (enclosing-code c) + (format s "Reference to unknown function ~S in ~S." (name c) (enclosing-code c)) + (format s "Reference to unknown function ~S." (name c)))))) + +(defvar +atom-marker+ '+atom-marker+) + +(defun find-walker-handler (form) + "Simple function which tells us what handler should deal + with FORM. Signals an error if we don't have a handler for + FORM." + (if (atom form) + (gethash '+atom-marker+ *walker-handlers*) + (aif (gethash (car form) *walker-handlers*) + it + (case (car form) + ((block declare flet function go if labels let let* + macrolet progn quote return-from setq symbol-macrolet + tagbody unwind-protect catch multiple-value-call + multiple-value-prog1 throw load-time-value the + eval-when locally progv) + (error "Sorry, No walker for the special operater ~S defined." (car form))) + (t (gethash 'application *walker-handlers*)))))) + +(defmacro defwalker-handler (name (form parent lexical-env) + &body body) + `(progn + (setf (gethash ',name *walker-handlers*) + (lambda (,form ,parent ,lexical-env) + (declare (ignorable ,parent ,lexical-env)) + ,@body)) + ',name)) + +(defclass form () + ((parent :accessor parent :initarg :parent) + (source :accessor source :initarg :source))) + +(defmethod make-load-form ((object form) &optional env) + (make-load-form-saving-slots object + :slot-names (mapcar #'mopp:slot-definition-name + (mopp:class-slots (class-of object))) + :environment env)) + +(defmethod print-object ((form form) stream) + (print-unreadable-object (form stream :type t :identity t) + (when (slot-boundp form 'source) + (let ((*print-readably* nil) + (*print-level* 0) + (*print-length* 4)) + (format stream "~S" (source form)))))) + +(defmacro with-form-object ((variable type &rest initargs) + &body body) + `(let ((,variable (make-instance ',type ,@initargs))) + ,@body + ,variable)) + +(defclass implicit-progn-mixin () + ((body :accessor body :initarg :body))) + +(defclass implicit-progn-with-declare-mixin (implicit-progn-mixin) + ((declares :accessor declares :initarg :declares))) + +(defclass binding-form-mixin () + ((binds :accessor binds :initarg :binds))) + +(defmacro multiple-value-setf (places form) + (loop + for place in places + for name = (gensym) + collect name into bindings + if (eql 'nil place) + collect `(declare (ignore ,name)) into ignores + else + collect `(setf ,place ,name) into body + finally (return + `(multiple-value-bind ,bindings ,form + ,@ignores + ,@body)))) + +(defun split-body (body env &key parent (docstring t) (declare t)) + (let ((documentation nil) + (newdecls nil) + (decls nil)) + (flet ((done () + (return-from split-body (values body env documentation (nreverse decls))))) + (loop + for form = (car body) + while body + do (typecase form + (cons (if (and declare (eql 'cl:declare (first form))) + ;; declare form + (let ((declarations (rest form))) + (dolist* (dec declarations) + (multiple-value-setf (env newdecls) (parse-declaration dec env parent)) + (setf decls (append newdecls decls)))) + ;; source code, all done + (done))) + (string (if docstring + (if documentation + ;; already found the docstring, this is source + (done) + (if (cdr body) + ;; found the doc string + (setf documentation form) + ;; this looks like a doc string, but + ;; it's the only form in body, so + ;; it's actually code. + (done))) + ;; no docstring allowed, this is source + (done))) + (t ;; more code, all done + (done))) + do (pop body) + finally (done))))) + +(defclass declaration-form (form) + ()) + +(defclass optimize-declaration-form (declaration-form) + ((optimize-spec :accessor optimize-spec :initarg :optimize-spec))) + +(defclass variable-declaration-form (declaration-form) + ((name :accessor name :initarg :name))) + +(defclass function-declaration-form (declaration-form) + ((name :accessor name :initarg :name))) + +(defclass dynamic-extent-declaration-form (variable-declaration-form) + ()) + +(defclass ignorable-declaration-form-mixin (declaration-form) + ()) + +(defclass variable-ignorable-declaration-form (variable-declaration-form ignorable-declaration-form-mixin) + ()) + +(defclass function-ignorable-declaration-form (function-declaration-form ignorable-declaration-form-mixin) + ()) + +(defclass special-declaration-form (variable-declaration-form) + ()) + +(defclass type-declaration-form (variable-declaration-form) + ((type-form :accessor type-form :initarg :type-form))) + +(defclass ftype-declaration-form (function-declaration-form) + ((type-form :accessor type-form :initarg :type-form))) + +(defclass notinline-declaration-form (function-declaration-form) + ()) + +(defun parse-declaration (declaration environment parent) + (let ((declares nil)) + (flet ((funname (form) + (if (and (consp form) (eql (car form) 'function)) + (cadr form) + nil))) + (macrolet ((mkdecl (varname formclass &rest rest) + `(make-instance ,formclass :parent parent :source (list type ,varname) ,@rest)) + (extend-env ((var list) newdeclare &rest datum) + `(dolist (,var ,list) + (when ,newdeclare (push ,newdeclare declares)) + (extend-walk-env environment :declare ,@datum)))) + (destructuring-bind (type &rest arguments) + declaration + (case type + (dynamic-extent + (extend-env (var arguments) + (mkdecl var 'dynamic-extent-declaration-form :name var) + var `(dynamic-extent))) + (ftype + (extend-env (function-name (cdr arguments)) + (make-instance 'ftype-declaration-form + :parent parent + :source `(ftype ,(first arguments) function-name) + :name function-name + :type-form (first arguments)) + function-name `(ftype ,(first arguments)))) + ((ignore ignorable) + (extend-env (var arguments) + (aif (funname var) + (mkdecl var 'function-ignorable-declaration-form :name it) + (mkdecl var 'variable-ignorable-declaration-form :name var)) + var `(ignorable))) + (inline + (extend-env (function arguments) + (mkdecl function 'function-ignorable-declaration-form :name function) + function `(ignorable))) + (notinline + (extend-env (function arguments) + (mkdecl function 'notinline-declaration-form :name function) + function `(notinline))) + (optimize + (extend-env (optimize-spec arguments) + (mkdecl optimize-spec 'optimize-declaration-form :optimize-spec optimize-spec) + 'optimize optimize-spec)) + (special + (extend-env (var arguments) + (mkdecl var 'special-declaration-form :name var) + var `(special))) + (type + (extend-env (var (rest arguments)) + (make-instance 'type-declaration-form + :parent parent + :source `(type ,(first arguments) ,var) + :name var + :type-form (first arguments)) + var `(type ,(first arguments)))) + (t + (extend-env (var arguments) + (make-instance 'type-declaration-form + :parent parent + :source `(,type ,var) + :name var + :type-form type) + var `(type ,type))))))) + (when (null declares) + (setq declares (list (make-instance 'declaration-form :parent parent :source declaration)))) + (values environment declares))) + +(defun walk-implict-progn (parent forms env &key docstring declare) + (handler-bind ((undefined-reference (lambda (condition) + (unless (enclosing-code condition) + (setf (enclosing-code condition) `(progn ,@forms)))))) + (multiple-value-bind (body env docstring declarations) + (split-body forms env :parent parent :docstring docstring :declare declare) + (values (mapcar (lambda (form) + (walk-form form parent env)) + body) + docstring + declarations)))) + +;;;; Atoms + +(defclass constant-form (form) + ((value :accessor value :initarg :value))) + +(defclass variable-reference (form) + ((name :accessor name :initarg :name))) + +(defmethod print-object ((v variable-reference) stream) + (print-unreadable-object (v stream :type t :identity t) + (format stream "~S" (name v)))) + +(defclass local-variable-reference (variable-reference) + ()) + +(defclass local-lexical-variable-reference (local-variable-reference) + () + (:documentation "A reference to a local variable defined in the + lexical environment outside of the form passed to walk-form.")) + +(defclass free-variable-reference (variable-reference) + ()) + +(defwalker-handler +atom-marker+ (form parent env) + (declare (special *macroexpand*)) + (cond + ((not (or (symbolp form) (consp form))) + (make-instance 'constant-form :value form + :parent parent :source form)) + ((lookup-walk-env env :let form) + (make-instance 'local-variable-reference :name form + :parent parent :source form)) + ((lookup-walk-env env :lexical-let form) + (make-instance 'local-lexical-variable-reference :name form + :parent parent :source form)) + ((lookup-walk-env env :symbol-macrolet form) + (walk-form (lookup-walk-env env :symbol-macrolet form) parent env)) + ((nth-value 1 (macroexpand-1 form)) + ;; a globaly defined symbol-macro + (walk-form (macroexpand-1 form) parent env)) + (t + (when (and *warn-undefined* + (not (boundp form))) + (warn 'undefined-variable-reference :name form)) + (make-instance 'free-variable-reference :name form + :parent parent :source form)))) + +;;;; Function Applictation + +(defclass application-form (form) + ((operator :accessor operator :initarg :operator) + (arguments :accessor arguments :initarg :arguments))) + +(defclass local-application-form (application-form) + ((code :accessor code :initarg :code))) + +(defclass lexical-application-form (application-form) + ()) + +(defclass free-application-form (application-form) + ()) + +(defclass lambda-application-form (application-form) + ()) + +(defwalker-handler application (form parent env) + (block nil + (destructuring-bind (op &rest args) + form + (when (and (consp op) + (eq 'cl:lambda (car op))) + (return + (with-form-object (application lambda-application-form :parent parent :source form) + (setf (operator application) (walk-form op application env) + (arguments application) (mapcar (lambda (form) + (walk-form form application env)) + args))))) + (when (lookup-walk-env env :macrolet op) + (return (walk-form (funcall (lookup-walk-env env :macrolet op) form (cdr env)) parent env))) + (when (and (symbolp op) (macro-function op)) + (multiple-value-bind (expansion expanded) + (macroexpand-1 form (cdr env)) + (when expanded + (return (walk-form expansion parent env))))) + (let ((app (if (lookup-walk-env env :flet op) + (make-instance 'local-application-form :code (lookup-walk-env env :flet op)) + (if (lookup-walk-env env :lexical-flet op) + (make-instance 'lexical-application-form) + (progn + (when (and *warn-undefined* + (symbolp op) + (not (fboundp op))) + (warn 'undefined-function-reference :name op)) + (make-instance 'free-application-form)))))) + (setf (operator app) op + (parent app) parent + (source app) form + (arguments app) (mapcar (lambda (form) + (walk-form form app env)) + args)) + app)))) + +;;;; Functions + +(defclass function-form (form) + ()) + +(defclass lambda-function-form (function-form implicit-progn-with-declare-mixin) + ((arguments :accessor arguments :initarg :arguments))) + +(defclass function-object-form (form) + ((name :accessor name :initarg :name))) + +(defclass local-function-object-form (function-object-form) + ()) + +(defclass free-function-object-form (function-object-form) + ()) + +(defclass lexical-function-object-form (function-object-form) + ()) + +(defwalker-handler function (form parent env) + (if (and (listp (second form)) + (eql 'cl:lambda (first (second form)))) + ;; (function (lambda ...)) + (walk-lambda (second form) parent env) + ;; (function foo) + (make-instance (if (lookup-walk-env env :flet (second form)) + 'local-function-object-form + (if (lookup-walk-env env :lexical-flet (second form)) + 'lexical-function-object-form + 'free-function-object-form)) + :name (second form) + :parent parent :source form))) + +(defun walk-lambda (form parent env) + (with-form-object (func lambda-function-form + :parent parent + :source form) + ;; 1) parse the argument list creating a list of FUNCTION-ARGUMENT-FORM objects + (multiple-value-setf ((arguments func) env) + (walk-lambda-list (second form) func env)) + ;; 2) parse the body + (multiple-value-setf ((body func) nil (declares func)) + (walk-implict-progn func (cddr form) env :declare t)) + ;; all done + func)) + +(defun walk-lambda-list (lambda-list parent env &key allow-specializers macro-p) + (flet ((extend-env (argument) + (unless (typep argument 'allow-other-keys-function-argument-form) + (extend-walk-env env :let (name argument) argument)))) + (let ((state :required) + (arguments '())) + (dolist (argument lambda-list) + (if (member argument '(&optional &key &rest)) + (setf state argument) + (progn + (push (case state + (:required + (if allow-specializers + (walk-specialized-argument-form argument parent env) + (walk-required-argument argument parent env))) + (&optional (walk-optional-argument argument parent env)) + (&key + (if (eql '&allow-other-keys argument) + (make-instance 'allow-other-keys-function-argument-form + :parent parent :source argument) + (walk-keyword-argument argument parent env))) + (&rest (walk-rest-argument argument parent env))) + arguments) + (extend-env (car arguments))))) + (values (nreverse arguments) env)))) + +(defclass function-argument-form (form) + ((name :accessor name :initarg :name))) + +(defmethod print-object ((argument function-argument-form) stream) + (print-unreadable-object (argument stream :type t :identity t) + (if (slot-boundp argument 'name) + (format stream "~S" (name argument)) + (write-string "#<unbound name>" stream)))) + +(defclass required-function-argument-form (function-argument-form) + ()) + +(defgeneric required-function-argument-form-p (object) + (:method ((object t)) nil) + (:method ((object required-function-argument-form)) t)) + +(defun walk-required-argument (form parent env) + (declare (ignore env)) + (make-instance 'required-function-argument-form + :name form + :parent parent :source form)) + +(defclass specialized-function-argument-form (required-function-argument-form) + ((specializer :accessor specializer :initarg :specializer))) + +(defun walk-specialized-argument-form (form parent env) + (declare (ignore env)) + (make-instance 'specialized-function-argument-form + :name (if (listp form) + (first form) + form) + :specializer (if (listp form) + (second form) + 'T) + :parent parent + :source form)) + +(defclass optional-function-argument-form (function-argument-form) + ((default-value :accessor default-value :initarg :default-value) + (supplied-p-parameter :accessor supplied-p-parameter :initarg :supplied-p-parameter))) + +(defun walk-optional-argument (form parent env) + (destructuring-bind (name &optional default-value supplied-p-parameter) + (ensure-list form) + (with-form-object (arg optional-function-argument-form + :parent parent + :source form + :name name + :supplied-p-parameter supplied-p-parameter) + (setf (default-value arg) (walk-form default-value arg env))))) + +(defclass keyword-function-argument-form (function-argument-form) + ((keyword-name :accessor keyword-name :initarg :keyword-name) + (default-value :accessor default-value :initarg :default-value) + (supplied-p-parameter :accessor supplied-p-parameter :initarg :supplied-p-parameter))) + +(defmethod effective-keyword-name ((k keyword-function-argument-form)) + (or (keyword-name k) + (intern (symbol-name (name k)) :keyword))) + +(defun walk-keyword-argument (form parent env) + (destructuring-bind (name &optional default-value supplied-p-parameter) + (ensure-list form) + (let ((name (if (consp name) + (second name) + name)) + (keyword (if (consp name) + (first name) + nil))) + (with-form-object (arg keyword-function-argument-form + :parent parent + :source form + :name name + :keyword-name keyword + :supplied-p-parameter supplied-p-parameter) + (setf (default-value arg) (walk-form default-value arg env)))))) + +(defclass allow-other-keys-function-argument-form (function-argument-form) + ()) + +(defclass rest-function-argument-form (function-argument-form) + ()) + +(defun walk-rest-argument (form parent env) + (declare (ignore env)) + (make-instance 'rest-function-argument-form :name form + :parent parent :source form)) + +;;;; BLOCK/RETURN-FROM + +(defclass block-form (form implicit-progn-mixin) + ((name :accessor name :initarg :name))) + +(defclass return-from-form (form) + ((target-block :accessor target-block :initarg :target-block) + (result :accessor result :initarg :result))) + +(defwalker-handler block (form parent env) + (destructuring-bind (block-name &rest body) + (cdr form) + (with-form-object (block block-form + :parent parent :source form + :name block-name) + (setf (body block) (walk-implict-progn block + body + (register-walk-env env :block block-name block)))))) + +(define-condition return-from-unknown-block (error) + ((block-name :accessor block-name :initarg :block-name)) + (:report (lambda (condition stream) + (format stream "Unable to return from block named ~S." (block-name condition))))) + +(defwalker-handler return-from (form parent env) + (destructuring-bind (block-name &optional (value '(values))) + (cdr form) + (if (lookup-walk-env env :block block-name) + (with-form-object (return-from return-from-form :parent parent :source form + :target-block (lookup-walk-env env :block block-name)) + (setf (result return-from) (walk-form value return-from env))) + (restart-case + (error 'return-from-unknown-block :block-name block-name) + (add-block () + :report "Add this block and continue." + (walk-form form parent (register-walk-env env :block block-name :unknown-block))))))) + +;;;; CATCH/THROW + +(defclass catch-form (form implicit-progn-mixin) + ((tag :accessor tag :initarg :tag))) + +(defclass throw-form (form) + ((tag :accessor tag :initarg :tag) + (value :accessor value :initarg :value))) + +(defwalker-handler catch (form parent env) + (destructuring-bind (tag &body body) + (cdr form) + (with-form-object (catch catch-form :parent parent :source form) + (setf (tag catch) (walk-form tag catch env) + (body catch) (walk-implict-progn catch body env))))) + +(defwalker-handler throw (form parent env) + (destructuring-bind (tag &optional (result '(values))) + (cdr form) + (with-form-object (throw throw-form :parent parent :source form) + (setf (tag throw) (walk-form tag throw env) + (value throw) (walk-form result throw env))))) + +;;;; EVAL-WHEN + +(defclass eval-when-form (form implicit-progn-mixin) + ((eval-when-times :accessor eval-when-times :initarg :eval-when-times))) + +(defwalker-handler eval-when (form parent env) + (destructuring-bind (times &body body) + (cdr form) + (with-form-object (eval-when eval-when-form :parent parent :source form) + (setf (eval-when-times eval-when) times + (body eval-when) (walk-implict-progn eval-when body env))))) + +;;;; IF + +(defclass if-form (form) + ((consequent :accessor consequent :initarg :consequent) + (then :accessor then :initarg :then) + (else :accessor else :initarg :else))) + +(defwalker-handler if (form parent env) + (with-form-object (if if-form :parent parent :source form) + (setf (consequent if) (walk-form (second form) if env) + (then if) (walk-form (third form) if env) + (else if) (walk-form (fourth form) if env)))) + +;;;; FLET/LABELS + +(defclass function-binding-form (form binding-form-mixin implicit-progn-with-declare-mixin) + ()) + +(defclass flet-form (function-binding-form) + ()) + +(defclass labels-form (function-binding-form) + ()) + +(defwalker-handler flet (form parent env) + (destructuring-bind (binds &body body) + (cdr form) + (with-form-object (flet flet-form :parent parent :source form) + ;;;; build up the objects for the bindings in the original env + (loop + for (name args . body) in binds + collect (cons name (walk-form `(lambda ,args ,@body) flet env)) into bindings + finally (setf (binds flet) bindings)) + ;;;; walk the body in the new env + (multiple-value-setf ((body flet) nil (declares flet)) + (walk-implict-progn flet + body + (loop + with env = env + for (name . lambda) in (binds flet) + do (extend-walk-env env :flet name lambda) + finally (return env)) + :declare t))))) + +(defwalker-handler labels (form parent env) + (destructuring-bind (binds &body body) + (cdr form) + (with-form-object (labels labels-form :parent parent :source form :binds '()) + ;; we need to walk over the bindings twice. the first pass + ;; creates some 'empty' lambda objects in the environment so + ;; that local-application-form and local-function-object-form + ;; have something to point to. the second pass then walks the + ;; actual bodies of the form filling in the previously created + ;; objects. + (loop + for (name arguments . body) in binds + for lambda = (make-instance 'lambda-function-form + :parent labels + :source (list* name arguments body)) + do (push (cons name lambda) (binds labels)) + do (extend-walk-env env :flet name lambda)) + (setf (binds labels) (nreverse (binds labels))) + (loop + for form in binds + for (arguments . body) = (cdr form) + for binding in (binds labels) + for lambda = (cdr binding) + for tmp-lambda = (walk-lambda `(lambda ,arguments ,@body) labels env) + do (setf (body lambda) (body tmp-lambda) + (arguments lambda) (arguments tmp-lambda) + (declares lambda) (declares tmp-lambda))) + (multiple-value-setf ((body labels) nil (declares labels)) (walk-implict-progn labels body env :declare t))))) + +;;;; LET/LET* + +(defclass variable-binding-form (form binding-form-mixin implicit-progn-with-declare-mixin) + ()) + +(defclass let-form (variable-binding-form) + ()) + +(defwalker-handler let (form parent env) + (with-form-object (let let-form :parent parent :source form) + (setf (binds let) (mapcar (lambda (binding) + (destructuring-bind (var &optional initial-value) + (ensure-list binding) + (cons var (walk-form initial-value let env)))) + (second form))) + (multiple-value-bind (b e d declarations) + (split-body (cddr form) env :parent let :declare t) + (declare (ignore b e d)) + (dolist* ((var . value) (binds let)) + (declare (ignore value)) + (if (not (find-if (lambda (declaration) + (and (typep declaration 'special-declaration-form) + (eq var (name declaration)))) declarations)) + (extend-walk-env env :let var :dummy))) + (multiple-value-setf ((body let) nil (declares let)) + (walk-implict-progn let (cddr form) env :declare t))))) + +(defclass let*-form (variable-binding-form) + ()) + +(defwalker-handler let* (form parent env) + (with-form-object (let* let*-form :parent parent :source form :binds '()) + (dolist* ((var &optional initial-value) (mapcar #'ensure-list (second form))) + (push (cons var (walk-form initial-value let* env)) (binds let*)) + (extend-walk-env env :let var :dummy)) + (setf (binds let*) (nreverse (binds let*))) + (multiple-value-setf ((body let*) nil (declares let*)) (walk-implict-progn let* (cddr form) env :declare t)))) + +;;;; LOAD-TIME-VALUE + +(defclass load-time-value-form (form) + ((value :accessor value) + (read-only-p :accessor read-only-p))) + +(defwalker-handler load-time-value (form parent env) + (with-form-object (load-time-value load-time-value-form + :parent parent :source form) + (setf (value load-time-value) (walk-form (second form) load-time-value env) + (read-only-p load-time-value) (third form)))) + +;;;; LOCALLY + +(defclass locally-form (form implicit-progn-with-declare-mixin) + ()) + +(defwalker-handler locally (form parent env) + (with-form-object (locally locally-form :parent parent :source form) + (multiple-value-setf ((body locally) nil (declares locally)) (walk-implict-progn locally (cdr form) env :declare t)))) + +;;;; MACROLET + +(defclass macrolet-form (form binding-form-mixin implicit-progn-with-declare-mixin) + ()) + +(defwalker-handler macrolet (form parent env) + (with-form-object (macrolet macrolet-form :parent parent :source form + :binds '()) + (dolist* ((name args &body body) (second form)) + (let ((handler (parse-macro-definition name args body (cdr env)))) + (extend-walk-env env :macrolet name handler) + (push (cons name handler) (binds macrolet)))) + (setf (binds macrolet) (nreverse (binds macrolet))) + (multiple-value-setf ((body macrolet) nil (declares macrolet)) + (walk-implict-progn macrolet (cddr form) env :declare t)))) + +;;;; MULTIPLE-VALUE-CALL + +(defclass multiple-value-call-form (form) + ((func :accessor func :initarg :func) + (arguments :accessor arguments :initarg :arguments))) + +(defwalker-handler multiple-value-call (form parent env) + (with-form-object (m-v-c multiple-value-call-form :parent parent :source form) + (setf (func m-v-c) (walk-form (second form) m-v-c env) + (arguments m-v-c) (mapcar (lambda (f) (walk-form f m-v-c env)) + (cddr form))))) + +;;;; MULTIPLE-VALUE-PROG1 + +(defclass multiple-value-prog1-form (form) + ((first-form :accessor first-form :initarg :first-form) + (other-forms :accessor other-forms :initarg :other-forms))) + +(defwalker-handler multiple-value-prog1 (form parent env) + (with-form-object (m-v-p1 multiple-value-prog1-form :parent parent :source form) + (setf (first-form m-v-p1) (walk-form (second form) m-v-p1 env) + (other-forms m-v-p1) (mapcar (lambda (f) (walk-form f m-v-p1 env)) + (cddr form))))) + +;;;; PROGN + +(defclass progn-form (form implicit-progn-mixin) + ()) + +(defwalker-handler progn (form parent env) + (with-form-object (progn progn-form :parent parent :source form) + (setf (body progn) (walk-implict-progn progn (cdr form) env)))) + +;;;; PROGV + +(defclass progv-form (form implicit-progn-mixin) + ((vars-form :accessor vars-form :initarg :vars-form) + (values-form :accessor values-form :initarg :values-form))) + +(defwalker-handler progv (form parent env) + (with-form-object (progv progv-form :parent parent :source form) + (setf (vars-form progv) (walk-form (cadr form) progv env)) + (setf (values-form progv) (walk-form (caddr form) progv env)) + (setf (body progv) (walk-implict-progn progv (cdddr form) env)) + progv)) + +;;;; QUOTE + +(defwalker-handler quote (form parent env) + (make-instance 'constant-form :parent parent :source form :value (second form))) + +;;;; SETQ + +(defclass setq-form (form) + ((var :accessor var :initarg :var) + (value :accessor value :initarg :value))) + +(defwalker-handler setq (form parent env) + ;; the SETQ handler needs to be able to deal with symbol-macrolets + ;; which haven't yet been expanded and may expand into something + ;; requiring setf and not setq. + (let ((effective-code '())) + (loop + for (name value) on (cdr form) by #'cddr + if (lookup-walk-env env :symbol-macrolet name) + do (push `(setf ,(lookup-walk-env env :symbol-macrolet name) ,value) effective-code) + else + do (push `(setq ,name ,value) effective-code)) + (if (= 1 (length effective-code)) + ;; only one form, the "simple case" + (destructuring-bind (type var value) + (first effective-code) + (ecase type + (setq (with-form-object (setq setq-form :parent parent :source form + :var var) + (setf (value setq) (walk-form value setq env)))) + (setf (walk-form (first effective-code) parent env)))) + ;; multiple forms + (with-form-object (progn progn-form :parent parent :source form) + (setf (body progn) (walk-implict-progn progn effective-code env)))))) + +;;;; SYMBOL-MACROLET + +(defclass symbol-macrolet-form (form binding-form-mixin implicit-progn-with-declare-mixin) + ()) + +(defwalker-handler symbol-macrolet (form parent env) + (with-form-object (symbol-macrolet symbol-macrolet-form :parent parent :source form + :binds '()) + (dolist* ((symbol expansion) (second form)) + (extend-walk-env env :symbol-macrolet symbol expansion) + (push (cons symbol expansion) (binds symbol-macrolet))) + (setf (binds symbol-macrolet) (nreverse (binds symbol-macrolet))) + (multiple-value-setf ((body symbol-macrolet) nil (declares symbol-macrolet)) + (walk-implict-progn symbol-macrolet (cddr form) env :declare t)))) + +;;;; TAGBODY/GO + +(defclass tagbody-form (form implicit-progn-mixin) + ()) + +(defclass go-tag-form (form) + ((name :accessor name :initarg :name))) + +(defgeneric go-tag-form-p (object) + (:method ((object go-tag-form)) t) + (:method ((object t)) nil)) + +(defwalker-handler tagbody (form parent env) + (with-form-object (tagbody tagbody-form :parent parent :source form :body (cdr form)) + (extend-walk-env env :tagbody 'enclosing-tagbody tagbody) + (flet ((go-tag-p (form) + (or (symbolp form) (integerp form)))) + ;; the loop below destructuivly modifies the body of tagbody, + ;; since it's the same object as the source we need to copy it. + (setf (body tagbody) (copy-list (body tagbody))) + (loop + for part on (body tagbody) + if (go-tag-p (car part)) + do (extend-walk-env env :tag (car part) (cdr part))) + (loop + for part on (body tagbody) + if (go-tag-p (car part)) + do (setf (car part) (make-instance 'go-tag-form :parent tagbody + :source (car part) + :name (car part))) + else + do (setf (car part) (walk-form (car part) tagbody env)))))) + +(defclass go-form (form) + ((target-progn :accessor target-progn :initarg :target-progn) + (name :accessor name :initarg :name) + (enclosing-tagbody :accessor enclosing-tagbody :initarg :enclosing-tagbody))) + +(defwalker-handler go (form parent env) + (make-instance 'go-form + :parent parent + :source form + :name (second form) + :target-progn (lookup-walk-env env :tag (second form)) + :enclosing-tagbody (lookup-walk-env env :tagbody 'enclosing-tagbody))) + +;;;; THE + +(defclass the-form (form) + ((type-form :accessor type-form :initarg :type-form) + (value :accessor value :initarg :value))) + +(defwalker-handler the (form parent env) + (with-form-object (the the-form :parent parent :source form + :type-form (second form)) + (setf (value the) (walk-form (third form) the env)))) + +;;;; UNWIND-PROTECT + +(defclass unwind-protect-form (form) + ((protected-form :accessor protected-form :initarg :protected-form) + (cleanup-form :accessor cleanup-form :initarg :cleanup-form))) + +(defwalker-handler unwind-protect (form parent env) + (with-form-object (unwind-protect unwind-protect-form :parent parent + :source form) + (setf (protected-form unwind-protect) (walk-form (second form) unwind-protect env) + (cleanup-form unwind-protect) (walk-implict-progn unwind-protect (cddr form) env)))) + +;;;; LOAD-TIME-VALUE + +(defclass load-time-value-form (form) + ((body :accessor body :initarg :body) + (read-only :initform nil :accessor read-only-p :initarg :read-only) + (value :accessor value))) + +(defmethod initialize-instance :after ((self load-time-value-form) &key) + (setf (value self) (eval (body self)))) + +(defwalker-handler load-time-value (form parent env) + (assert (<= (length form) 3)) + (with-form-object (load-time-value load-time-value-form :parent parent + :body form + :read-only (third form)) + (setf (body load-time-value) (second form)))) + +;;;; ** Implementation specific walkers + +;;;; These are for forms which certain compilers treat specially but +;;;; aren't macros or special-operators. + +#+lispworks +(defwalker-handler compiler::internal-the (form parent env) + (walk-form (third form) parent env)) + +;; Copyright (c) 2005-2006, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/arnesi/t/accumulation.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/t/accumulation.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,17 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi.test) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-suite :it.bese.arnesi.accumulation :in :it.bese.arnesi)) + +(in-suite :it.bese.arnesi.accumulation) + +(test make-reducer + + (let ((r (make-reducer #'+ 0))) + (funcall r 0) + (funcall r 1 2) + (funcall r 1 2 3) + (is (= 9 (funcall r))))) + Added: branches/trunk-reorg/thirdparty/arnesi/t/call-cc.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/t/call-cc.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,530 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi.test) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-suite :it.bese.arnesi.call/cc :in :it.bese.arnesi)) + +(in-suite :it.bese.arnesi.call/cc) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *call/cc-returns* nil)) + +(test call/cc-constant + (is (= 4 (with-call/cc 4))) + (is (eql :a (with-call/cc :a))) + (is (eql 'a (with-call/cc 'a))) + (is (eql #'+ (with-call/cc #'+)))) + +(test call/cc-progn + (is (null (with-call/cc))) + (is (= 1 (with-call/cc 1))) + (is (= 2 (with-call/cc 1 2))) + (is (= 3 (with-call/cc 1 2 3))) + (is (= 4 (with-call/cc 1 2 3 4)))) + +(test call/cc-progn/cc + (is (= 1 (kall (with-call/cc (let/cc k k) 1)))) + (is (= 1 (kall (with-call/cc (let/cc k k) 0 1))))) + +(test call/cc-let + (is (= 1 (with-call/cc + (let () 1)))) + (is (= 1 (with-call/cc + (let ((a 1)) a)))) + (is (= 1 (with-call/cc + (let ((a 1)) + (let ((a nil) + (b a)) + (declare (ignore a)) + b))))) + (with-call/cc + (let ((a 1)) + (let ((a 2)) + (is (= 2 a))) + (is (= 1 a)))) + + (let ((cont nil)) + (setf cont + (with-call/cc + (let ((a (let/cc k k))) + (+ a 4)))) + (is (= 9 (kall cont 5))) + (is (= 12 (kall cont 8))))) + +(test call/cc-let/cc + (let ((k (with-call/cc + (let ((a (arnesi::retk))) + (+ a 1))))) + (is (= 1 (arnesi::kall k 0))) + (is (= 2 (arnesi::kall k 1))))) + +(test call/cc-setq + (is (= 1 (with-call/cc + (let ((a nil)) (setq a 1))))) + (is (= 2 (with-call/cc + (let ((a 1)) (setq a (1+ a))))))) + +(test call/cc-let* + (with-call/cc + (let* ((a 1) + (b a)) + (is (= 1 a)) + (is (= 1 b)))) + (with-call/cc + (let ((a 0) + (b 1)) + (declare (ignore a)) + (let* ((a b) + (b a)) + (is (= a 1)) + (is (= b 1)) + (setq a 47) + (is (= a 47)))))) + +(test call/cc-apply + (is (= 0 (with-call/cc (+)))) + (is (= 1 (with-call/cc (+ 1)))) + (is (= 2 (with-call/cc (+ 1 1)))) + (is (= 3 (with-call/cc (+ 1 (+ 1 (+ 1 (+)))))))) + +(test call/cc-if + (is (= 1 (with-call/cc (if t 1)))) + (is (= 1 (with-call/cc (if nil 0 1)))) + (is (null (with-call/cc (if nil 1))))) + +(test call/cc-block/return-from + (is (= 1 + (with-call/cc + (block foo + nil + (return-from foo 1) + nil)))) + (is (eql t + (with-call/cc + (block foo + (return-from foo t) + nil))))) + +(defun reached-unreachable-code () + (fail "Somehow we reached unreachable code in a tagbody.")) + +(test call/cc-tagbody + (with-call/cc + (tagbody + (go a) + (reached-unreachable-code) + a + (pass))) + (with-call/cc + (tagbody + (go a) (reached-unreachable-code) + b + (pass) + (go c) (reached-unreachable-code) + a + (pass) + (go b) (reached-unreachable-code) + c + (pass))) + (with-call/cc + (let ((counter 0)) + (dotimes (i 5) + (incf counter)) + (is (= 5 counter)))) + (with-call/cc + (let ((i 0)) + (tagbody + a (incf i) (is (= 1 i)) + b (incf i) (is (= 2 i)) + c (is (= 2 i)))))) + +(test call/cc-flet + (with-call/cc + (flet ((foo () 'x)) + (is (eql 'x (foo)))) + (is (= 4 (funcall (let ((a 4)) + (flet ((foo () a)) + #'foo))))) + (flet ((foo () + 'outer-foo)) + (flet ((foo () + 'inner-foo) + (bar () + (foo))) + (is (eql 'outer-foo (bar))))))) + +(test call/cc-labels + (with-call/cc + (labels ((foo () 'x)) + (is (eql 'x (foo)))) + (labels ((foo () 'outer-foo)) + (labels ((bar () (foo)) + (foo () 'inner-foo)) + (is (eql 'inner-foo (bar)))))) + (finishes + (with-call/cc + (labels ((rec (x) x)) + #'rec + (is (= 1 (funcall #'rec 1))) + (is (= 1 (apply #'rec (list 1))))) + (flet ((f () 1)) + (is (= 1 (f))) + (is (= 1 (funcall #'f))) + (is (= 1 (apply #'f '())))))) + (let ((cont (with-call/cc + (labels ((rec (n) + (if (zerop n) + 0 + (+ (rec (1- n)) + (let/cc k k))))) + (rec 2))))) + (is (= 5 (kall (kall cont 2) 3))))) + +(let ((value 0)) + (defun test-funcall.0 () + value) + (defun (setf test-funcall.0) (new-value) + (setf value new-value))) + +(test call/cc-setf-funcall + (setf (test-funcall.0) 0) + (is (= 0 (with-call/cc (test-funcall.0)))) + (is (= 1 (with-call/cc (setf (test-funcall.0) 1)))) + (is (= 2 (with-call/cc (funcall #'(setf test-funcall.0) 2))))) + +(test call/cc-lambda-requried-arguments + (with-call/cc + (is (eql t (funcall (lambda () t)))) + (is (eql t (funcall (lambda (x) x) t)))) + (signals error + (with-call/cc + (funcall (lambda (x) x))))) + +(test call/cc-lambda-optional-arguments + (with-call/cc + (is (eql t (funcall (lambda (&optional a) a) t))) + (is (eql t (funcall (lambda (&optional (a t)) a))))) + + (let ((cont (with-call/cc + (funcall (lambda (&optional (a (let/cc k k))) + (+ a 1)))))) + (is (= 1 (kall cont 0))))) + +(test call/cc-lambda-keyword-arguments + (with-call/cc + (is (eql 'a (funcall (lambda (&key a) a) :a 'a))) + (is (eql 'b (funcall (lambda (&key (a 'b)) a)))) + (is (eql t (funcall (lambda (&optional a &key (b (not a))) b)))) + (is (eql nil (funcall (lambda (&optional a &key (b (not a))) + b) + t))) + (is (eql 42 (funcall (lambda (&optional a &key (b (not a))) + b) + t :b 42))))) + +(defun/cc test-defun/cc1 () + (let/cc k k)) + +(defun/cc test-defun/cc2 (arg1) + (let/cc k k) + arg1) + +(defun/cc test-defun/cc3 (a &key (b 1)) + (+ a b)) + +(test call/cc-defun/cc + (let ((cont nil)) + (setf cont (with-call/cc (test-defun/cc1))) + (is (eql nil (kall cont nil))) + + (setf cont (with-call/cc (test-defun/cc2 'foo))) + (is (eql 'foo (kall cont))) + (is (eql 'foo (kall cont nil))) + + (with-call/cc + (is (= 1 (test-defun/cc3 0))) + (is (= 2 (test-defun/cc3 1)))))) + +(defgeneric/cc test-generic/cc (a &key v)) + +(defmethod/cc test-generic/cc ((a symbol) &key (v 3)) + v) + +(defmethod/cc test-generic/cc ((a string) &key (v 5)) + v) + +(test call/cc-defgeneric/cc + (with-call/cc + (is (= 3 (test-generic/cc 'a))) + (is (= 0 (test-generic/cc 'a :v 0))) + (is (= 5 (test-generic/cc "a"))) + (is (= 0 (test-generic/cc "a" :v 0))))) + +(defmethod/cc test-generic/cc2 :before (a) + (let/cc k 'before)) + +(defmethod/cc test-generic/cc2 (a) + 'primary) + +(test test-generic/cc2 + (with-call/cc + (is (eql 'before (test-generic/cc2 t))))) + +(defmethod/cc test-generic/cc3 :before (a) + (let/cc k (cons 'before k))) + +(defmethod/cc test-generic/cc3 :around (a) + (let/cc k (cons 'around k)) + (call-next-method a)) + +(defmethod/cc test-generic/cc3 (a) + (let/cc k (cons 'primary k)) + a) + +(defmethod/cc test-generic/cc3 :after (a) + (let/cc k (cons 'after k))) + +(test call/cc-defgeneric/cc3 + (destructuring-bind (value . cont) + (with-call/cc (test-generic/cc3 32)) + (is (eql 'around value)) + (destructuring-bind (value . cont) + (with-call/cc (kall cont)) + (is (eql 'before value)) + (destructuring-bind (value . cont) + (with-call/cc (kall cont)) + (is (eql 'primary value)) + (destructuring-bind (value . cont) + (with-call/cc (kall cont)) + (is (eql 'after value)) + (is (eql 32 (kall cont)))))))) + +(test call/cc-loop + (let ((cont (with-call/cc + (loop + repeat 2 + sum (let/cc k k) into total + finally (return (values total total)))))) + (multiple-value-bind (a b) + (kall (kall cont 1) 2) + (is (= 3 a)) + (is (= 3 b)))) + + (let ((cont (with-call/cc + (block done + (loop + for how-many = (let/cc k k) + do (loop + repeat how-many + sum (let/cc k k) into total + finally (return-from done total))))))) + (is (= 26 (kall (kall (kall cont 2) 13) 13))))) + +(test common-lisp/cc + (let (cont value) + (setf cont (with-call/cc (mapcar (lambda (x) + (+ x (let/cc k k))) + (list 1 2 3)))) + (setf cont (with-call/cc (kall cont -1)) + cont (with-call/cc (kall cont -2)) + value (with-call/cc (kall cont -3))) + (is (equal (list 0 0 0) value)))) + +(defun/cc throw-something (something) + (throw 'done something)) + +(test catch/cc + (with-call/cc + (is (eql t + (catch 'whatever + (throw 'whatever t) + (throw 'whatever nil) + 'something-else))) + (is (eql t + (catch 'whatever + t))) + (is (eql t + (flet ((throw-it (it) + (throw 'done it))) + (catch 'done + (throw-it t) + (throw 'done 'bad-bad-bad))))) + (is (eql t + (catch 'done + (throw-something t) + nil))))) + +(test multiple-value-call + (with-call/cc + (is (= 1 (multiple-value-call + #'identity + (values 1))))) + (with-call/cc + (is (= 3 (length (multiple-value-call + #'list + (values 1) + (values 1) + (values 1)))))) + + (with-call/cc + (is (= 3 (multiple-value-call + (lambda (a b) + (+ a b)) + (values 1 2))))) + + (with-call/cc + (is (= 3 (multiple-value-call + (lambda (&rest numbers) + (reduce #'+ numbers)) + (values -1 1) + (values 1) + (values -1) + (values 1 2)))))) + +;;; speical variable handling +(defun/cc lookup-special-in-defun/cc (stop) + (declare (special var)) + (when stop (let/cc k k)) + var) + +(defun/cc lookup-special-in-let/cc (stop) + (let ((normal 0)) + (declare (special var)) + (when stop (let/cc k k)) + var)) + +(defun/cc lookup-special-in-let*/cc (stop) + (let* ((normal 0)) + (declare (special var)) + (when stop (let/cc k k)) + var)) + +(defun lookup-special-in-lisp () + (declare (special var)) + var) + +(defun/cc define-and-lookup-special-in-defun/cc (stop) + (let ((var 1)) + (declare (special var)) + (when stop (let/cc k k)) + var)) + +(defun/cc export-special-from-let/cc-and-lookup-in-defun/cc (stop) + (let ((var 1)) + (declare (special var)) + (lookup-special-in-defun/cc stop))) + +(defun/cc export-special-from-let/cc-and-lookup-in-let/cc (stop) + (let ((var 1)) + (declare (special var)) + (lookup-special-in-let/cc stop))) + +(defun/cc export-special-from-let/cc-and-lookup-in-let*/cc (stop) + (let ((var 1)) + (declare (special var)) + (lookup-special-in-let*/cc stop))) + +(defun/cc export-special-from-let/cc-and-lookup-in-lisp (stop) + (let ((var 1)) + (declare (special var)) + (when stop (let/cc k k)) + (lookup-special-in-lisp))) + +(defun/cc export-special-from-let*/cc-and-lookup-in-defun/cc (stop) + (let* ((var 1)) + (declare (special var)) + (lookup-special-in-defun/cc stop))) + +(defun/cc export-special-from-let*/cc-and-lookup-in-let/cc (stop) + (let* ((var 1)) + (declare (special var)) + (lookup-special-in-let/cc stop))) + +(defun/cc export-special-from-let*/cc-and-lookup-in-let*/cc (stop) + (let* ((var 1)) + (declare (special var)) + (lookup-special-in-let*/cc stop))) + +(defun/cc export-special-from-let*/cc-and-lookup-in-lisp (stop) + (let* ((var 1)) + (declare (special var)) + (when stop (let/cc k k)) + (lookup-special-in-lisp))) + +(defun export-special-from-lisp-and-lookup-in-defun/cc (stop) + (let ((var 1)) + (declare (special var)) + (with-call/cc + (lookup-special-in-defun/cc stop)))) + +(defun export-special-from-lisp-and-lookup-in-let/cc (stop) + (let ((var 1)) + (declare (special var)) + (with-call/cc + (lookup-special-in-let/cc stop)))) + +(defun export-special-from-lisp-and-lookup-in-let*/cc (stop) + (let ((var 1)) + (declare (special var)) + (with-call/cc + (lookup-special-in-let*/cc stop)))) + +(defmacro test-special (name) + (let ((body-without-stop `(,name nil)) + (body-with-stop `(,name t))) + `(test ,name + (is (= 1 (with-call/cc ,body-without-stop))) + (signals unbound-variable + (with-call/cc ,body-without-stop (lookup-special-in-lisp))) + (signals unbound-variable + (with-call/cc ,body-without-stop (lookup-special-in-defun/cc nil))) + ;; now stop once + (is (= 1 (kall (with-call/cc ,body-with-stop)))) + (signals unbound-variable + (kall (with-call/cc ,body-with-stop (lookup-special-in-lisp)))) + (signals unbound-variable + (kall (with-call/cc ,body-with-stop (lookup-special-in-defun/cc nil))))))) + +;; export and lookup in the same lexical environment +(test-special define-and-lookup-special-in-defun/cc) + +;; export and lookup in cc code +(test-special export-special-from-let/cc-and-lookup-in-defun/cc) +(test-special export-special-from-let/cc-and-lookup-in-let/cc) +(test-special export-special-from-let/cc-and-lookup-in-let*/cc) +(test-special export-special-from-let*/cc-and-lookup-in-defun/cc) +(test-special export-special-from-let*/cc-and-lookup-in-let/cc) +(test-special export-special-from-let*/cc-and-lookup-in-let*/cc) + +;; export from cc code and lookup in lisp code +(test-special export-special-from-let/cc-and-lookup-in-lisp) +(test-special export-special-from-let*/cc-and-lookup-in-lisp) + +;; export from lisp code and lookup in cc code +(test-special export-special-from-lisp-and-lookup-in-defun/cc) +(test-special export-special-from-lisp-and-lookup-in-let/cc) +(test-special export-special-from-lisp-and-lookup-in-let*/cc) + +;; export in lisp code let it go through some cc code and lookup in lisp code after continuing +(test export-special-from-lisp-and-lookup-in-lisp + (is (= 1 + (kall (let ((var 1)) + (declare (special var)) + (with-call/cc + (let () ;; TODO: shouldn't we allow declares within with-call/cc? + (declare (special var)) + (let/cc k k) + (lookup-special-in-lisp)))))))) + +(defvar *special-variable-in-lisp* 42) + +(test special-lisp-var-rebound-in/cc + (is (= 42 + (with-call/cc + *special-variable-in-lisp*))) + (is (= 43 + (with-call/cc + (let ((*special-variable-in-lisp* 43)) + ;;(declare (special *special-variable-in-lisp*)) ; TODO shouldn't be needed + *special-variable-in-lisp*))))) Added: branches/trunk-reorg/thirdparty/arnesi/t/csv.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/t/csv.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,24 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi.test) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-suite :it.bese.arnesi.csv :in :it.bese.arnesi)) + +(in-suite :it.bese.arnesi.csv) + +(test csv.1 + (is (equal '("1" "2" "3") + (arnesi:parse-csv-string "1,2,3"))) + (is (equal '("1" "2" "3") + (arnesi:parse-csv-string "1;2;3" :separator #\;))) + (is (equal '("1" "2;" "3") + (arnesi:parse-csv-string "1;'2;';3" :separator #\; :quote #\')))) + +(test csv.2 + ;; this corresponds to the quoting used in princ-csv + (is (equal '("1" "2'" "3") + (arnesi:parse-csv-string "1;'2''';3" :separator #\; :quote #\'))) + (is (equal '("1" "2'" "3") + (arnesi:parse-csv-string "1;'2''';'3'" :separator #\; :quote #\')))) + Added: branches/trunk-reorg/thirdparty/arnesi/t/flow-control.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/t/flow-control.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,89 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi.test) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-suite :it.bese.arnesi.flow-control :in :it.bese.arnesi)) + +(in-suite :it.bese.arnesi.flow-control) + +(test flow-control + (let ((ht (make-hash-table))) + (setf (gethash 'a ht) 1) + (setf (gethash 'b ht) 'a) + + ;; if-bind and aif + (is (= 3 (if-bind var (gethash 'z ht) (1+ var) 3))) + (is (= 2 (if-bind var (gethash 'a ht) (1+ var) 3))) + (is (= 3 (aif (gethash 'z ht) (1+ it) 3))) + (is (= 2 (aif (gethash 'a ht) (1+ it) 3))) + ;; when-bind and awhen + (let ((result nil)) + (when-bind var (gethash 'z ht) + (setf result (1+ var))) + (is (null result)) + (when-bind var (gethash 'a ht) + (setf result (1+ var))) + (is (= 2 result)) + (setf result nil) + (awhen (gethash 'z ht) + (setf result (1+ it))) + (is (null result)) + (awhen (gethash 'a ht) + (setf result (1+ it))) + (is (= 2 result))) + ;; cond-bind and acond + (is (= 99 (cond-bind var + ((gethash 'z ht) (1+ var)) + ((gethash 'y ht) (1+ var)) + (t 99)))) + (is (= 2 (cond-bind var + ((gethash 'z ht) (1+ var)) + ((gethash 'a ht) (1+ var)) + (t 99)))) + (is (= 1 (cond-bind var + ((gethash 'z ht)) + ((gethash 'y ht)) + ((gethash 'a ht)) + (t 99)))) + (is (= 99 (acond + ((gethash 'z ht) (1+ it)) + ((gethash 'y ht) (1+ it)) + (t 99)))) + (is (= 2 (acond + ((gethash 'z ht) (1+ it)) + ((gethash 'a ht) (1+ it)) + (t 99)))) + (is (= 2 (acond + ((gethash 'z ht)) + ((gethash 'a ht) (1+ it)) + (t 99)))) + ;; and-bind and aand + (is-false (and-bind var (gethash 'z ht) (gethash var ht) (1+ var))) + (is (= 2 (and-bind var (gethash 'b ht) (gethash var ht) (1+ var)))) + (is-false (aand (gethash 'z ht) (gethash it ht) (1+ it))) + (is (= 2 (aand (gethash 'b ht) (gethash it ht) (1+ it)))) + ;; whichever + (let ((result 0)) + (is (member (whichever (progn (incf result) 'a) + (progn (incf result) 'b) + (progn (incf result) 'c)) + '(a b c))) + (is (= 1 result))) + ;; xor + (let ((result 0)) + (is (eq 'a (xor (progn (incf result) 'a) + (progn (incf result) nil) + (progn (incf result) nil)))) + (is (= 3 result)) + (setf result 0) + (is (eq 'a (xor (progn (incf result) nil) + (progn (incf result) 'a) + (progn (incf result) nil)))) + (is (= 3 result)) + (setf result 0) + (is-false (xor (progn (incf result) 'a) + (progn (incf result) 'b) + (progn (incf result) 'c))) + (is (= 2 result))))) + Added: branches/trunk-reorg/thirdparty/arnesi/t/http.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/t/http.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,38 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi.test) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-suite :it.bese.arnesi.http :in :it.bese.arnesi)) + +(in-suite :it.bese.arnesi.http) + +(test escape-uri + (for-all ((uri (gen-string :elements (gen-character :code-limit #16rffff)))) + (is (string= uri (unescape-as-uri (escape-as-uri uri))))) + + (is (string= (unescape-as-uri "a+b+c") + "a b c"))) + +(defmacro help-test-bad-uri (uri expected-error) + `(progn + (signals ,expected-error + (unescape-as-uri ,uri)) + (finishes + (unescape-as-uri-non-strict ,uri)) + (let ((returned (unescape-as-uri-non-strict ,uri))) + (is (> (length returned) (* 0.5 (length ,uri)))) ; a big chunk should be returned + (is (string= (subseq returned 0 8) ; that is looking like a proper url + (subseq ,uri 0 8)))))) + +(test unescape-uri/iso8859-1-instead-of-utf8 + (help-test-bad-uri "http://router.advertising.se/?&CHANNEL_ID=1&SITE_KEY=Webbhotell%20f%F6r%20a…" + error)) + +(test unescape-uri/wrong-percentage-quoting + (help-test-bad-uri "http://ad.doubleclick.net/adi/N763.business_week_online/B1803870.12;sz=468x…" + expected-digit-uri-parse-error)) + +(test unescape-uri/percentage-at-end + (help-test-bad-uri "http://groups.google.com/groups/adfetch?adid=zMKqMREAAAAwVvp0Nmmxmm2KqccSr5…" + uri-parse-error)) Added: branches/trunk-reorg/thirdparty/arnesi/t/list.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/t/list.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,34 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi.test) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-suite :it.bese.arnesi.list :in :it.bese.arnesi)) + +(in-suite :it.bese.arnesi.list) + +(test proper-list-p + (is-true (proper-list-p '())) + (is-true (proper-list-p '(nil))) + (is-true (proper-list-p '(nil nil))) + (is-true (proper-list-p '(nil nil nil))) + (is-true (proper-list-p '(nil . nil))) + (is-true (proper-list-p '(nil nil . nil))) + (is-true (proper-list-p '(nil nil nil . nil))) + (is-false (proper-list-p 1)) + (is-false (proper-list-p '(a . b))) + (let ((a (cons nil nil))) + (setf (cdr a) a) + (is-false (proper-list-p a))) + (let ((a (list nil nil))) + (setf (cdr (last a)) a) + (is-false (proper-list-p a))) + (let ((a (list nil nil nil nil nil))) + (setf (cdr (last a)) a) + (is-false (proper-list-p a))) + (let ((a (list nil nil nil nil nil))) + (setf (first a) a + (car (last a)) a + (cdr (last a)) a) + (is-false (proper-list-p a)))) + Added: branches/trunk-reorg/thirdparty/arnesi/t/log.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/t/log.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,39 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi.test) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-suite :it.bese.arnesi.log :in :it.bese.arnesi)) + +(in-suite :it.bese.arnesi.log) + +#| +(defparameter a-handler (make-instance 'collecting-log-handler)) + +(deflogger log-a () + :appender a-handler + :level +dribble+) + +(deflogger log-b (log-a)) + +(deflogger log-c (log-a)) + +(deflogger log-d (log-c)) + +(test log1 + (log-a.dribble "FOO") + (is (string= "FOO" (car (slot-value (car (appenders (get-logger 'log-a))) 'messages)))) + + (setf (log.level (get-logger 'log-a)) +warn+) + (is (= +warn+ (log.level (get-logger 'log-d)))) + + (setf (log.level (get-logger 'log-d)) +dribble+) + (is (= +dribble+ (log.level (get-logger 'log-d)))) + (is (= +warn+ (log.level (get-logger 'log-b)))) + (is (= +warn+ (log.level (get-logger 'log-c)))) + + (is (enabled-p (get-logger 'log-d) +warn+)) + (is (enabled-p (get-logger 'log-a) +warn+)) + (is (not (enabled-p (get-logger 'log-a) +dribble+)))) + +|# \ No newline at end of file Added: branches/trunk-reorg/thirdparty/arnesi/t/matcher.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/t/matcher.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,99 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi.test) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-suite :it.bese.arnesi.matcher :in :it.bese.arnesi)) + +(in-suite :it.bese.arnesi.matcher) + +(test eql + (is-true (match '(:EQL 1) 1)) + (is-false (match `(:EQL ,(gensym)) (gensym))) + (let ((sym (gensym))) + (is-true (match `(:EQL ,sym) sym)))) + +(test cons + (is-true (match '(:CONS (:EQL NIL) (:EQL NIL)) (cons nil nil))) + (is-true (match '(:CONS 'a 'b) (cons 'a'b)))) + +(test list + (is-true (match '(:LIST 'A) '(a))) + (is-true (match '(:LIST 'A NIL) '(a nil))) + (is-true (match '(:LIST 'A 'B) '(a b))) + (is-true (match '(:LIST 'A 'B :ANYTHING) '(a b c))) + (is-true (match '(:LIST* 'A 'B :ANYTHING) '(a b))) + (is-true (match '(:LIST* 'A 'B :ANYTHING) '(a b . 444))) + (is-true (match '(:LIST* 'A 'B :ANYTHING) '(a b 444 555 666)))) + +(test alt + (is-true (match `(:ALTERNATION (:EQL a) (:EQL b)) 'a)) + (is-true (match `(:ALTERNATION (:EQL a) (:EQL b)) 'b)) + (is-false (match `(:ALTERNATION (:EQL a) (:EQL b)) 'c)) + (is-true (match `(:ALT (:EQL a) (:EQL b) (:EQL c)) 'a)) + (is-true (match `(:ALT (:EQL a) (:EQL b) (:EQL c)) 'b)) + (is-true (match `(:ALT (:EQL a) (:EQL b) (:EQL c)) 'c)) + (is-false (match `(:ALT (:EQL a) (:EQL b) (:EQL c)) 'd))) + +(test bind/ref + (is-true (match `(:CONS (:BIND :ANYTHING $1) (:REF $1)) (cons 1 1))) + (is-false (match `(:CONS (:BIND :ANYTHING $1) (:REF $1)) (cons 1 2))) + (is-true (match `(:CONS (:BIND (:ALT (:EQL a) (:EQL b)) $1) (:REF $1)) (cons 'a 'a))) + (is-true (match `(:CONS (:BIND (:ALT (:EQL a) (:EQL b)) $1) (:REF $1)) (cons 'b 'b))) + (is-false (match `(:CONS (:BIND (:ALT (:EQL a) (:EQL b)) $1) (:REF $1)) (cons 'b 'a))) + (is-false (match `(:CONS (:BIND (:ALT (:EQL a) (:EQL b)) $1) (:REF $1)) (cons 'a 'b))) + (is-false (match `(:CONS (:BIND (:ALT (:EQL a) (:EQL b)) $1) (:REF $1)) (cons 1 1))) + (is-true (match `(:CONS (:BIND (:EQUALP "AAA") aaa) (:REF aaa :test equalp)) (cons "AAA" "aaa")))) + +(test sym-group + (is-true (match `(:CONS a (:REF a)) (cons 1 1))) + (is-false (match `(:CONS a (:NOT (:REF a))) (cons 1 1))) + (is-true (match `(:CONS a (:NOT (:REF a))) (cons 1 2)))) + +(test match-case + (match-case '(1 . 1) + ((:CONS (:BIND (:EQL 1) a) (:REF a)) (is (= 1 a))) + (:ANYTHING (fail))) + (match-case '(1 . 2) + ((:CONS a b) (is (= 1 a)) (is (= 2 b))) + (:ANYTHING (fail "For some odd reason we didn't match"))) + (match-case '(1 . 2) + ((:LIST* (:BIND :ANYTHING a) (:BIND :ANYTHING b)) (is (= 1 a)) (is (= 2 b))))) + +(test and + (match-case 3 + ((:AND (:TEST numberp) (:TEST oddp)) + (pass)) + (:ANYTHING (fail))) + (match-case 2 + ((:AND (:TEST numberp) (:TEST oddp)) + (fail)) + (:ANYTHING (pass)))) + +(defclass foo () + ((x :initarg :x :accessor x) + (z :initarg :z :accessor z))) + +(test accessors + (match-case (make-instance 'foo :x 1 :z 2) + ((:ACCESSORS foo x x z z) + (is (= 1 x)) + (is (= 2 z))) + (:ANYTHING (fail))) + (match-case (make-instance 'foo :x 1 :z 2) + ((:ACCESSORS standard-object x a z b) + (is (= 1 a)) + (is (= 2 b))) + (:ANYTHING (fail))) + (match-case (make-instance 'foo :x 1 :z 2) + ((:ACCESSORS cons x a z b) + a b ; we won't need them... + (fail)) + (:ANYTHING (pass)))) + +(test plist + (match-case '(:b 2 :a 1) + ((:PLIST :a a :b b) + (is (= 1 a)) + (is (= 2 b))) + (:ANYTHING (fail)))) Added: branches/trunk-reorg/thirdparty/arnesi/t/numbers.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/t/numbers.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,43 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi.test) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-suite :it.bese.arnesi.numbers :in :it.bese.arnesi)) + +(in-suite :it.bese.arnesi.numbers) + +(test mulf + (let ((a 0)) + (is (= 0 (mulf a 10))) + (is (= 0 a))) + (for-all ((a (gen-integer)) + (b (gen-integer))) + (let ((orig-a a)) + (mulf a b) + (is (= a (* orig-a b))))) + + (let ((a 1)) + (is (= 4 (mulf a 4))) + (is (= 1 (mulf a (/ 4)))) + (is (= 1 a)))) + +(test minf + (let ((a 10)) + (is (= 5 (minf a 5))) + (is (= 5 a))) + + (let ((a 0)) + (is (= 0 (minf a 10))) + (is (= 0 a)))) + +(test parse-float + (is (= 0 (parse-float "0"))) + (is (= -1 (parse-float "-1"))) + (is (= 1 (parse-float "1"))) + + (dolist (type '(short-float single-float double-float long-float)) + (for-all ((float (gen-float :type type :bound 1000))) + (let* ((*print-base* 10) + (*print-radix* nil)) + (is (= float (parse-float (princ-to-string float) :type type))))))) Added: branches/trunk-reorg/thirdparty/arnesi/t/queue.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/t/queue.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,80 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi.test) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-suite :it.bese.arnesi.queue :in :it.bese.arnesi)) + +(in-suite :it.bese.arnesi.queue) + +(test make-queue + (is (queue-empty-p (make-instance 'queue))) + (is (eql 'empty (dequeue (make-instance 'queue) 'empty)))) + +(test queue-not-full-no-wrapping + (let ((q (make-instance 'queue))) + (enqueue q 1) + (is (= 1 (dequeue q))) + (enqueue q 1) + (enqueue q 2) + (is (= 1 (dequeue q))) + (is (= 2 (dequeue q))))) + +(test queue-full-not-wrapping + (let ((q (make-instance 'queue :size 2))) + (enqueue q 1) + (enqueue q 2) ;; this causes the size to grow to 2 + (enqueue q 3) ;; this causes the size to grow to 4 + (enqueue q 4) ;; this doesn't affect the size + (enqueue q 5) ;; this couses the size to grow to 8 + (is (= 1 (dequeue q))) + (is (= 2 (dequeue q))) + (is (= 3 (dequeue q))) + (is (= 4 (dequeue q))) + (is (= 5 (dequeue q))))) + +(test queue-not-full-wrapping + (let ((q (make-instance 'queue :size 2))) + (enqueue q 1) + (is (= 1 (queue-count q))) + (is (= 1 (dequeue q))) + (enqueue q 1) + (is (= 1 (queue-count q))) + (is (= 1 (dequeue q))))) + +(test queue-full-wrapping + (let ((q (make-instance 'queue :size 2))) + (setf (arnesi::head-index q) 2 + (arnesi::tail-index q) 1 + (arnesi::buffer q) #(0 1)) + q + (enqueue q 2) + (is (= 1 (dequeue q))) + (is (= 2 (dequeue q))))) + +(test queue + (for-all ((item (gen-integer :min -10 :max 10))) + (let ((q (make-instance 'queue))) + (enqueue q item) + (is (= item (dequeue q))) + (is (= 0 (queue-count q))))) + (for-all ((one (gen-list :length (gen-integer :min 2 :max 3) + :elements (gen-integer :min -10 :max 10))) + (two (gen-list :length (gen-integer :min 2 :max 3) + :elements (gen-integer :min -10 :max 10))) + (three (gen-list :length (gen-integer :min 2 :max 3) + :elements (gen-integer :min -10 :max 10)))) + (let ((q (make-instance 'queue :size (1- (+ (length one) + (length two) + (length three)))))) + (flet ((enqueue-all (list) + (loop for e in list do (enqueue q e))) + (dequeue-all (list) + (loop for e in list do (is (= e (dequeue q)))))) + (enqueue-all one) + (enqueue-all two) + (dequeue-all one) + (enqueue-all three) + (dequeue-all two) + (dequeue-all three)) + (is (queue-empty-p q))))) Added: branches/trunk-reorg/thirdparty/arnesi/t/read-macros.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/t/read-macros.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,18 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi.test) + +(in-suite :it.bese.arnesi) + +(test bracket-reader + (enable-bracket-syntax) + (is (= 7 (read-from-string "{(constantly 7)}"))) + (destructuring-bind (progn a b c) + (let ((*package* (find-package :common-lisp-user))) + (read-from-string "{(arnesi::with-package :arnesi) a b c}")) + (is (eql 'cl:progn progn)) + (is (eql 'arnesi::a a)) + (is (eql 'arnesi::b b)) + (is (eql 'arnesi::c c)))) + + Added: branches/trunk-reorg/thirdparty/arnesi/t/sequence.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/t/sequence.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,20 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi.test) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-suite :it.bese.arnesi.sequence :in :it.bese.arnesi)) + +(in-suite :it.bese.arnesi.sequence) + +(test levenshtein-distance + (is (= 4 (levenshtein-distance "aaaa" ""))) + (is (= 4 (levenshtein-distance "" "aaaa"))) + (is (= 0 (levenshtein-distance "" ""))) + (is (= 0 (levenshtein-distance "a" "a"))) + (is (= 2 (levenshtein-distance "aa" "cc"))) + (is (= 1 (levenshtein-distance "a" "aa"))) + (is (= 1 (levenshtein-distance "ab" "aa"))) + (is (= 1 (levenshtein-distance "test" "tent")))) + + Added: branches/trunk-reorg/thirdparty/arnesi/t/sharpl.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/t/sharpl.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,93 @@ +(in-package :it.bese.arnesi.test) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-suite :it.bese.arnesi.sharpl :in :it.bese.arnesi)) + +(in-suite :it.bese.arnesi.sharpl) + +(enable-sharp-l-syntax) + +(test sharpl-simple + (is (eql 42 (funcall #L42)))) + +(test sharpl-mb-example + (is (eql 6 (funcall #L(block !2 (return-from !2 !1)) 6)))) + +(test sharpl-finds-variables + (is (eql 111 (funcall #L(+ !1 !2) 42 69)))) + +(test sharpl-no-variable-in-quote + (is (eq (funcall #L'!1) '!1))) + +(test sharpl-not-captures-outer-bang + (let ((!1 42)) + (declare (ignore !1)) + (is (eql 69 (funcall #L!1 69))))) + +(test sharpl-nested-simple + (is (eql 1 (funcall (funcall #L#L1))))) + +(test sharpl-nested-arg + (is (eql 42 (funcall (funcall #L#L!1) 42)))) + +(test sharpl-nested-complex + (is (eql 3 (funcall + (funcall #L(let ((a !1)) + #L(+ !1 a)) + 1) + 2)))) + +(test sharpl-symbol-macrolet-1 + (is (eql 3 (symbol-macrolet ((sym !1)) (funcall #Lsym 3))))) + +(test sharpl-symbol-macrolet-2 + (is (eql 3 (funcall (symbol-macrolet ((sym !1)) + #Lsym) + 3)))) + +(test sharpl-macrolet-1 + (is (eql 15 (macrolet ((mac (arg) `(+ !1 ,arg))) + (funcall #L(mac 10) 5))))) + +(test sharpl-macrolet-2 + (is (eql 15 (funcall (macrolet ((mac (arg) `(+ !1 ,arg))) + #L(mac 10)) + 5)))) + +(test sharpl-inner-macrolet + (is (eql 15 (funcall + #L(macrolet ((!2 () '!1)) (!2)) + 15)))) + +(test sharpl-inner-symbol-macrolet + (is (eql 15 (funcall + #L(symbol-macrolet ((!2 !1)) (+ !2 10)) + 5)))) + +(test sharpl-bang-binds-to-innermost + (is (eql 10 (funcall + (funcall #L(let ((a !1)) + #L(+ a !1)) + 6) + 4)))) + +(test sharpl-interposed-macrolet + (is (eql 6 (funcall + (funcall #L(macrolet ((mac () '!1)) + #L(mac))) + 6)))) + +(test sharpl-nested-macrolet + (is (eql 21 (funcall + (funcall + #L(macrolet ((return-bang () ''!1)) + (macrolet ((multiply-first-bang (arg) `(* ,arg ,(return-bang)))) + #L(+ (multiply-first-bang 2) 1)))) + 10)))) + +(test sharpl-interposed-symbol-macrolet + (is (eql 'result (funcall + (funcall #L(symbol-macrolet ((mac !1)) + #Lmac)) + 'result)))) + Added: branches/trunk-reorg/thirdparty/arnesi/t/string.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/t/string.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,9 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi.test) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-suite :it.bese.arnesi.string :in :it.bese.arnesi)) + +(in-suite :it.bese.arnesi.string) + Added: branches/trunk-reorg/thirdparty/arnesi/t/suite.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/t/suite.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,13 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi) + +(defpackage :it.bese.arnesi.test + (:use :common-lisp + :it.bese.arnesi + :it.bese.FiveAM)) + +(unless (5am:get-test :it.bese) + (5am:def-suite :it.bese)) + +(5am:def-suite :it.bese.arnesi :in :it.bese) Added: branches/trunk-reorg/thirdparty/arnesi/t/walk.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/t/walk.lisp Mon Feb 11 08:38:43 2008 @@ -0,0 +1,195 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.arnesi.test) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-suite :it.bese.arnesi.walk :in :it.bese.arnesi)) + +(in-suite :it.bese.arnesi.walk) + +(defun test-walk (form) + (values (equal (unwalk-form (walk-form form)) form) + (unwalk-form (walk-form form)) + form)) + +(test walk-constant + (is (test-walk 1)) + (is (test-walk ''a)) + (is (test-walk "a")) + (is (test-walk '(1 2 3))) + (is (test-walk '#(1 2 3)))) + +(test walk-variable + (is (test-walk 'var))) + +(test walk-application + (is (test-walk '(* 2 3))) + (is (test-walk '(+ (* 3 3) (* 4 4))))) + +(test walk-lambda-application + (is (test-walk '((lambda (x) (x x)) #'(lambda (x) (x x))))) + (is (test-walk '((lambda (x k) (k x)) (if p x y) id)))) + +(test walk-lambda-function + (is (test-walk '#'(lambda (x y) (y x)))) + (is (test-walk '#'(lambda (x &key y z) (z (y x))))) + (is (test-walk '#'(lambda (&optional port) (close port)))) + (is (test-walk '#'(lambda (x &rest args) (apply x args)))) + (is (test-walk '#'(lambda (object &key a &allow-other-keys) (values)))) + ;; Unwalking argument lists is lax. + (is (test-walk '#'(lambda (&rest args &key a b &optional x &allow-other-keys) 2)))) + +(test walk-block + (is (test-walk '(block label (get-up) (eat-food) (go-to-sleep)))) + (is (test-walk '(block label ((lambda (f x) (f (f x))) #'car)))) + (is (test-walk '(block label (reachable) (return-from label 'done) (unreachable))))) + +(test walk-catch + (is (test-walk '(catch 'done (with-call/cc* (* 2 3))))) + (is (test-walk '(catch 'scheduler + (tagbody start + (funcall thunk) + (if (done-p) (throw 'scheduler 'done) (go start)))))) + (is (test-walk '(catch 'c + (flet ((c1 () (throw 'c 1))) + (catch 'c (c1) (print 'unreachable)) + 2))))) + +(test walk-if + (is (test-walk '(if p x y))) + (is (test-walk '(if (pred x) (f x) (f-tail y #(1 2 3)))))) + +(test walk-flet + (is (test-walk '(flet ((sq (x) + (* x x))) + (+ (sq 3) (sq 4))))) + (is (test-walk '(flet ((prline (s) + (princ s) + (terpri))) + (prline "hello") + (prline "world"))))) + +(test walk-labels + (is (test-walk '(labels ((fac-acc (n acc) + (if (zerop n) + (land acc) + (bounce + (fac-acc (1- n) (* n acc)))))) + (fac-acc (fac-acc 10 1) 1)))) + (is (test-walk '(labels ((evenp (n) + (if (zerop n) t (oddp (1- n)))) + (oddp (n) + (if (zerop n) nil (evenp (1- n))))) + (oddp 666))))) + +(test walk-let + (is (test-walk '(let ((a 2) (b 3) (c 4)) + (+ (- a b) (- b c) (- c a))))) + (is (test-walk '(let ((a b) (b a)) (format t "side-effect~%") (f a b))))) + +(test walk-let* + (is (test-walk '(let* ((a (random 100)) (b (* a a))) (- b a)))) + (is (test-walk '(let* ((a b) (b a)) (equal a b))))) + +(test walk-load-time-value + (is (test-walk '(load-time-value *load-pathname* nil)))) + +(test walk-locally + (is (test-walk '(locally (setq *global* (whoops)))))) + +(test walk-macrolet + (is (unwalk-form + (walk-form + '(macrolet ((+ (&body body) + (reverse body))) + (+ 1 2 3 -)))) + '(locally (- 3 2 1))) + (is (unwalk-form + (walk-form + '(macrolet ()))) + '(locally ())) + (is (unwalk-form + (walk-form + '(macrolet ((+ (&body body) + (reverse body))) + (princ "1111") + (+ 1 2 3 -)))) + '(locally + (princ "1111") + (- 3 2 1)))) + +(test walk-multiple-value-call + (is (test-walk '(multiple-value-call #'list 1 '/ (values 2 3) '/ (values) '/ (floor 2.5)))) + (is (test-walk '(multiple-value-call #'+ (floor 5 3) (floor 19 4))))) + +(test walk-multiple-value-prog1 + (is (test-walk '(multiple-value-prog1 + (values-list temp) + (setq temp nil) + (values-list temp))))) + +(test walk-progn + (is (test-walk '(progn (f a) (f-tail b) c))) + (is (test-walk '(progn #'(lambda (x) (x x)) 2 'a)))) + +(test walk-progv + (is (test-walk '(progv '(*x*) '(2) *x*)))) + +(test walk-setq + (is (test-walk '(setq x '(2 #(3 5 7) 11 "13" '17)))) + (is (test-walk '(setq *global* 'symbol)))) + +(test walk-symbol-macrolet + (is (unwalk-form + (walk-form + '(symbol-macrolet ((a (slot-value obj 'a)) + (b (slot-value obj 'b))) + (+ a b)))) + '(locally + (+ (slot-value obj 'a) (slot-value obj 'b)))) + (is (unwalk-form + (walk-form + '(symbol-macrolet ()))) + '(locally)) + (is (unwalk-form + (walk-form + '(symbol-macrolet ((a (slot-value obj 'a))) + (double! a) + (/ a 2)))) + '(locally + (double! (slot-value obj 'a)) + (/ (slot-value obj 'a) 2)))) + +(test walk-tagbody + (is (test-walk '(tagbody + (setq val 1) + (go point-a) + (setq val (+ val 16)) + point-c + (setq val (+ val 4)) + (go point-b) + (setq val (+ val 32)) + point-a + (setq val (+ val 2)) + (go point-c) + (setq val (+ val 64)) + point-b + (setq val (+ val 8))))) + (is (test-walk '(tagbody + (setq n (f2 flag #'(lambda () (go out)))) + out + (prin1 n))))) + +(test walk-the + (is (test-walk '(the number (reverse "naoh")))) + (is (test-walk '(the string 1)))) + +(test walk-unwind-protect + (is (test-walk '(unwind-protect + (progn (setq count (+ count 1)) + (perform-access)) + (setq count (- count 1))))) + (is (test-walk '(unwind-protect + (progn (with-call/cc* (walk-the-plank)) + (pushed-off-the-plank)) + (save-life)))))

1 0

[bknr-cvs] r2468 - branches/trunk-reorg/thirdparty/cl-pdf
by ksprotte＠common-lisp.net 11 Feb '08

11 Feb '08

Author: ksprotte Date: Mon Feb 11 08:21:38 2008 New Revision: 2468 Removed: branches/trunk-reorg/thirdparty/cl-pdf/ Log: rm cl-pdf from thirdparty

1 0

[bknr-cvs] r2467 - branches/trunk-reorg/thirdparty/usocket-0.3.5/test
by ksprotte＠common-lisp.net 11 Feb '08

11 Feb '08

Author: ksprotte Date: Mon Feb 11 08:20:23 2008 New Revision: 2467 Removed: branches/trunk-reorg/thirdparty/usocket-0.3.5/test/usocket.asd Log: removed duplicate usocket.asd in usocket-0.3.5/test/

1 0

[bknr-cvs] r2466 - branches/trunk-reorg/thirdparty/cffi-070901/uffi-compat
by hhubner＠common-lisp.net 11 Feb '08

11 Feb '08

Author: hhubner Date: Mon Feb 11 08:13:30 2008 New Revision: 2466 Modified: branches/trunk-reorg/thirdparty/cffi-070901/uffi-compat/uffi-compat.lisp Log: remove :uffi package alias (not a good idea) Modified: branches/trunk-reorg/thirdparty/cffi-070901/uffi-compat/uffi-compat.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/cffi-070901/uffi-compat/uffi-compat.lisp (original) +++ branches/trunk-reorg/thirdparty/cffi-070901/uffi-compat/uffi-compat.lisp Mon Feb 11 08:13:30 2008 @@ -29,7 +29,6 @@ ;;; Code borrowed from UFFI is Copyright (c) Kevin M. Rosenberg. (defpackage #:cffi-uffi-compat - (:nicknames #:uffi) ;; is this a good idea? (:use #:cl) (:export

1 0

[bknr-cvs] r2465 - in branches/bos/projects/bos: payment-website/templates/da payment-website/templates/de payment-website/templates/en web
by ksprotte＠common-lisp.net 11 Feb '08

11 Feb '08

Author: ksprotte Date: Mon Feb 11 07:39:01 2008 New Revision: 2465 Modified: branches/bos/projects/bos/payment-website/templates/da/profil.xml branches/bos/projects/bos/payment-website/templates/de/profil.xml branches/bos/projects/bos/payment-website/templates/en/profil.xml branches/bos/projects/bos/web/tags.lisp Log: fix for #16 Koordinaten in Laenge und Breite - Einbau eines Links auf die Profilseite Modified: branches/bos/projects/bos/payment-website/templates/da/profil.xml ============================================================================== --- branches/bos/projects/bos/payment-website/templates/da/profil.xml (original) +++ branches/bos/projects/bos/payment-website/templates/da/profil.xml Mon Feb 11 07:39:01 2008 @@ -55,7 +55,7 @@ </tr> <tr> <td class="Label">kvardratmeter</td> - <td class="Input">til værdi af $(numsqm) m² er blevet opkøbt<br></br>UTM-kordinater: N$(sqm-x) E$(sqm-y) + <td class="Input">til værdi af $(numsqm) m² er blevet opkøbt<br></br>kordinater: $(geo-coord) <br /><a href="/contract-kml/$(contract-id)">Your square metres in Google Earth</a></td> <td class="Info"></td> </tr> Modified: branches/bos/projects/bos/payment-website/templates/de/profil.xml ============================================================================== --- branches/bos/projects/bos/payment-website/templates/de/profil.xml (original) +++ branches/bos/projects/bos/payment-website/templates/de/profil.xml Mon Feb 11 07:39:01 2008 @@ -60,7 +60,7 @@ </tr> <tr> <td class="Label">Quadratmeter</td> - <td class="Input">Insgesamt $(numsqm) Quadratmeter gekauft<br />UTM-Koordinate: N$(sqm-x) E$(sqm-y) + <td class="Input">Insgesamt $(numsqm) Quadratmeter gekauft<br />Koordinate: $(geo-coord) <br /><a href="/contract-kml/$(contract-id)">Ihre Quadratmeter in Google Earth</a></td> <td class="Info"></td> </tr> Modified: branches/bos/projects/bos/payment-website/templates/en/profil.xml ============================================================================== --- branches/bos/projects/bos/payment-website/templates/en/profil.xml (original) +++ branches/bos/projects/bos/payment-website/templates/en/profil.xml Mon Feb 11 07:39:01 2008 @@ -60,7 +60,7 @@ </tr> <tr> <td class="Label">square metres</td> - <td class="Input">a total of $(numsqm) m² has been bought<br />UTM-coordinate: N$(sqm-x) E$(sqm-y) + <td class="Input">a total of $(numsqm) m² has been bought<br />coordinate: $(geo-coord) <br /><a href="/contract-kml/$(contract-id)">Your square metres in Google Earth</a></td> <td class="Info"></td> </tr> Modified: branches/bos/projects/bos/web/tags.lisp ============================================================================== --- branches/bos/projects/bos/web/tags.lisp (original) +++ branches/bos/projects/bos/web/tags.lisp Mon Feb 11 07:39:01 2008 @@ -170,8 +170,9 @@ (setf (get-template-var :name) (user-full-name sponsor)) (setf (get-template-var :sqm-x) (format nil "~,3f" (m2-utm-x (first (contract-m2s contract))))) (setf (get-template-var :sqm-y) (format nil "~,3f" (m2-utm-y (first (contract-m2s contract))))) - (setf (get-template-var :geo-coord) (multiple-value-bind (left top) + (setf (get-template-var :geo-coord) (destructuring-bind (left top . ignore) (contract-bounding-box contract) + (declare (ignore ignore)) (apply #'geometry:format-lon-lat nil (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ left) (- +nw-utm-y+ top) +utm-zone+ t))))

1 0

[bknr-cvs] r2464 - trunk/projects/lisp-ecoop/website/templates
by dverna＠common-lisp.net 11 Feb '08

11 Feb '08

Author: dverna Date: Mon Feb 11 07:35:17 2008 New Revision: 2464 Modified: trunk/projects/lisp-ecoop/website/templates/home.xml trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl trunk/projects/lisp-ecoop/website/templates/toplevel.xml Log: Fixed workshop location spelling Modified: trunk/projects/lisp-ecoop/website/templates/home.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/home.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/home.xml Mon Feb 11 07:35:17 2008 @@ -5,7 +5,7 @@ <h1>5th European Lisp Workshop</h1> -<p>July 07 - Paphos-Cyprus - co-located with ECOOP 2008</p> +<p>July 07 - Paphos, Cyprus - co-located with ECOOP 2008</p> <p> <!-- Supported by <a href="http://clozure.com/" target="_new">Clozure Modified: trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl (original) +++ trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl Mon Feb 11 07:35:17 2008 @@ -21,7 +21,8 @@ <body> <div id="banner"> <div id="title">5th European Lisp Workshop</div> - <div id="subtitle">Co-located with <a href="http://2008.ecoop.org/" target="_new">ECOOP 2008</a><br />July 07 - Paphos-Cyprus</div> + <div id="subtitle">Co-located with <a href="http://2008.ecoop.org/" + target="_new">ECOOP 2008</a><br />July 07 - Paphos, Cyprus</div> <div id="logo"> <a href="http://bknr.net/" target="_new"> <img width="57" height="20" alt="BKNR Logo" src="/static/bknr-logo.png" border="0" /> Modified: trunk/projects/lisp-ecoop/website/templates/toplevel.xml ============================================================================== --- trunk/projects/lisp-ecoop/website/templates/toplevel.xml (original) +++ trunk/projects/lisp-ecoop/website/templates/toplevel.xml Mon Feb 11 07:35:17 2008 @@ -16,7 +16,8 @@ <body> <div id="banner"> <div id="title">5th European Lisp Workshop</div> - <div id="subtitle">Co-located with <a href="http://2008.ecoop.org/" target="_new">ECOOP 2008</a><br />July 07 - Paphos-Cyprus</div> + <div id="subtitle">Co-located with <a href="http://2008.ecoop.org/" +target="_new">ECOOP 2008</a><br />July 07 - Paphos, Cyprus</div> <div id="logo"> <a href="http://bknr.net/" target="_new"> <img width="57" height="20" alt="BKNR Logo" src="$(base)image/bknr-logo/thumbnail,,57,20" border="0" />

1 0

[bknr-cvs] r2463 - branches/bos/projects/bos/web
by ksprotte＠common-lisp.net 11 Feb '08

11 Feb '08

Author: ksprotte Date: Mon Feb 11 07:30:08 2008 New Revision: 2463 Modified: branches/bos/projects/bos/web/tags.lisp Log: added again template-vars :sqm-x, :sqm-y. Also reindent/untabify Modified: branches/bos/projects/bos/web/tags.lisp ============================================================================== --- branches/bos/projects/bos/web/tags.lisp (original) +++ branches/bos/projects/bos/web/tags.lisp Mon Feb 11 07:30:08 2008 @@ -10,13 +10,13 @@ (defun language-options-1 (current-language) (loop for (language-symbol language-name) in (website-languages) - do (if (equal language-symbol current-language) - (html ((:option :value (format nil "/~a/index" language-symbol) :selected "selected") " " (:princ language-name) " ")) - (html ((:option :value (format nil "/~a/index" language-symbol)) " " (:princ language-name) " "))))) + do (if (equal language-symbol current-language) + (html ((:option :value (format nil "/~a/index" language-symbol) :selected "selected") " " (:princ language-name) " ")) + (html ((:option :value (format nil "/~a/index" language-symbol)) " " (:princ language-name) " "))))) (define-bknr-tag language-chooser (name) (html ((:select :name name) - (language-options-1 (current-website-language))))) + (language-options-1 (current-website-language))))) (define-bknr-tag language-options () (language-options-1 (current-website-language))) @@ -27,7 +27,7 @@ (define-bknr-tag process-payment (&key children) (with-template-vars (cartId transId email country) (let* ((contract (get-contract (parse-integer cartId))) - (sponsor (contract-sponsor contract))) + (sponsor (contract-sponsor contract))) (change-slot-values sponsor 'bknr.web::email email) (change-slot-values contract 'bos.m2::worldpay-trans-id transId) (sponsor-set-country sponsor country) @@ -40,13 +40,13 @@ (with-template-vars (gift email name address want-print) (let ((contract (find-store-object (parse-integer (get-template-var :contract-id))))) (when (equal want-print "no") - (contract-set-download-only-p contract t)) + (contract-set-download-only-p contract t)) (contract-issue-cert contract name :address address :language (session-variable :language)) (mail-worldpay-sponsor-data (get-template-var :request)) (bknr.web::redirect-request :target (if gift "index" - (format nil "profil_setup?name=~A&email=~A&sponsor-id=~A" - (uriencode-string name) (uriencode-string email) - (store-object-id (contract-sponsor contract)))))))) + (format nil "profil_setup?name=~A&email=~A&sponsor-id=~A" + (uriencode-string name) (uriencode-string email) + (store-object-id (contract-sponsor contract)))))))) (define-bknr-tag urkunde-per-post (&key contract-id min-amount message) (let ((contract (get-contract (parse-integer contract-id)))) @@ -60,81 +60,81 @@ (define-bknr-tag maybe-base (&key href) (when (and href - (not (equal "" href))) + (not (equal "" href))) (html ((:base "href" href))))) (define-bknr-tag buy-sqm (&key children) (handler-case (with-template-vars (numsqm numsqm1 action gift donationcert-yearly download-only) - (let* ((numsqm (parse-integer (or numsqm numsqm1))) - ;; Wer ueber dieses Formular bestellt, ist ein neuer - ;; Sponsor, also ein neues Sponsorenobjekt anlegen. Eine - ;; Profil-ID wird automatisch zugewiesen, sonstige Daten - ;; haben wir zu diesem Zeitpunkt noch nicht. - ;; Überweisung wird nur für die deutsche und dänische - ;; Website angeboten, was passenderweise durch die folgende - ;; Überprüfung auch sicher gestellt wurde. Sollte man aber - ;; eventuell noch mal prüfen und sicher stellen. - (manual-transfer (or (scan #?r"rweisen" action) - (scan #?r"rweisung" action) - (scan #?r"verf" action))) - (language (session-variable :language)) - (sponsor (make-sponsor :language language)) - (contract (make-contract sponsor numsqm - :download-only download-only - :expires (+ (if manual-transfer - bos.m2::*manual-contract-expiry-time* - bos.m2::*online-contract-expiry-time*) - (get-universal-time))))) - (destructuring-bind (price currency) - (case (make-keyword-from-string language) - (:da (list (* numsqm 24) "DKK")) - (t (list (* numsqm 3) "EUR"))) - (setf (get-template-var :worldpay-url) - (if manual-transfer - (format nil "ueberweisung?contract-id=~A&amount=~A&numsqm=~A~@[&donationcert-yearly=1~]" - (store-object-id contract) - price - numsqm - donationcert-yearly) - (format nil "https://select.worldpay.com/wcc/purchase?instId=~A&cartId=~A&amount=~A&curr…" - *worldpay-installation-id* - (store-object-id contract) - price - currency - language - (encode-urlencoded (format nil "~A ~A Samboja Lestari" - numsqm - (case (make-keyword-from-string language) - (:de "qm Regenwald in") - (:da "m2 Regnskov i") - (t "sqm rain forest in")))) - (store-object-id sponsor) - (sponsor-master-code sponsor) - (if donationcert-yearly "1" "0") - (if gift "1" "0") - (when *worldpay-test-mode* "&testMode=100")))))) - (mapc #'emit-template-node children)) + (let* ((numsqm (parse-integer (or numsqm numsqm1))) + ;; Wer ueber dieses Formular bestellt, ist ein neuer + ;; Sponsor, also ein neues Sponsorenobjekt anlegen. Eine + ;; Profil-ID wird automatisch zugewiesen, sonstige Daten + ;; haben wir zu diesem Zeitpunkt noch nicht. + ;; Überweisung wird nur für die deutsche und dänische + ;; Website angeboten, was passenderweise durch die folgende + ;; Überprüfung auch sicher gestellt wurde. Sollte man aber + ;; eventuell noch mal prüfen und sicher stellen. + (manual-transfer (or (scan #?r"rweisen" action) + (scan #?r"rweisung" action) + (scan #?r"verf" action))) + (language (session-variable :language)) + (sponsor (make-sponsor :language language)) + (contract (make-contract sponsor numsqm + :download-only download-only + :expires (+ (if manual-transfer + bos.m2::*manual-contract-expiry-time* + bos.m2::*online-contract-expiry-time*) + (get-universal-time))))) + (destructuring-bind (price currency) + (case (make-keyword-from-string language) + (:da (list (* numsqm 24) "DKK")) + (t (list (* numsqm 3) "EUR"))) + (setf (get-template-var :worldpay-url) + (if manual-transfer + (format nil "ueberweisung?contract-id=~A&amount=~A&numsqm=~A~@[&donationcert-yearly=1~]" + (store-object-id contract) + price + numsqm + donationcert-yearly) + (format nil "https://select.worldpay.com/wcc/purchase?instId=~A&cartId=~A&amount=~A&curr…" + *worldpay-installation-id* + (store-object-id contract) + price + currency + language + (encode-urlencoded (format nil "~A ~A Samboja Lestari" + numsqm + (case (make-keyword-from-string language) + (:de "qm Regenwald in") + (:da "m2 Regnskov i") + (t "sqm rain forest in")))) + (store-object-id sponsor) + (sponsor-master-code sponsor) + (if donationcert-yearly "1" "0") + (if gift "1" "0") + (when *worldpay-test-mode* "&testMode=100")))))) + (mapc #'emit-template-node children)) (bos.m2::allocation-areas-exhausted (e) (declare (ignore e)) (bknr.web::redirect-request :target "allocation-areas-exhausted")))) (define-bknr-tag mail-transfer () (with-query-params ((get-template-var :request) - country - contract-id - name vorname strasse plz ort) + country + contract-id + name vorname strasse plz ort) (let* ((contract (store-object-with-id (parse-integer contract-id))) - (download-only (< (contract-price contract) *mail-certificate-threshold*))) + (download-only (< (contract-price contract) *mail-certificate-threshold*))) (with-transaction (:prepare-before-mail) - (setf (contract-download-only contract) download-only) - (setf (sponsor-country (contract-sponsor contract)) country)) + (setf (contract-download-only contract) download-only) + (setf (sponsor-country (contract-sponsor contract)) country)) (contract-issue-cert contract (format nil "~A ~A" vorname name) - :address (format nil "~A ~A~%~A~%~A ~A" - vorname name - strasse - plz ort) - :language (session-variable :language)) + :address (format nil "~A ~A~%~A~%~A ~A" + vorname name + strasse + plz ort) + :language (session-variable :language)) (mail-manual-sponsor-data (get-template-var :request))))) (define-bknr-tag when-certificate (&key children) @@ -148,34 +148,36 @@ (define-bknr-tag save-profile (&key children) (let* ((sponsor (bknr-request-user (get-template-var :request))) - (contract (first (sponsor-contracts sponsor)))) + (contract (first (sponsor-contracts sponsor)))) (with-template-vars (email name password infotext anonymize) (when anonymize - (change-slot-values sponsor - 'full-name nil - 'info-text nil - 'email nil)) + (change-slot-values sponsor + 'full-name nil + 'info-text nil + 'email nil)) (when name - (change-slot-values sponsor 'full-name name)) + (change-slot-values sponsor 'full-name name)) (when email - (change-slot-values sponsor 'bknr.web::email email)) + (change-slot-values sponsor 'bknr.web::email email)) (when password - (set-user-password sponsor password)) + (set-user-password sponsor password)) (when infotext - (change-slot-values sponsor 'info-text infotext))) + (change-slot-values sponsor 'info-text infotext))) (setf (get-template-var :sponsor-id) (format nil "~D" (store-object-id sponsor))) (setf (get-template-var :contract-id) (format nil "~D" (store-object-id contract))) (setf (get-template-var :country) (sponsor-country sponsor)) (setf (get-template-var :infotext) (sponsor-info-text sponsor)) (setf (get-template-var :name) (user-full-name sponsor)) + (setf (get-template-var :sqm-x) (format nil "~,3f" (m2-utm-x (first (contract-m2s contract))))) + (setf (get-template-var :sqm-y) (format nil "~,3f" (m2-utm-y (first (contract-m2s contract))))) (setf (get-template-var :geo-coord) (multiple-value-bind (left top) - (contract-bounding-box contract) - (apply #'geometry:format-lon-lat nil - (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ left) - (- +nw-utm-y+ top) +utm-zone+ t)))) + (contract-bounding-box contract) + (apply #'geometry:format-lon-lat nil + (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ left) + (- +nw-utm-y+ top) +utm-zone+ t)))) (setf (get-template-var :numsqm) - (format nil "~D" - (apply #'+ (mapcar #'(lambda (contract) (length (contract-m2s contract))) (sponsor-contracts sponsor)))))) + (format nil "~D" + (apply #'+ (mapcar #'(lambda (contract) (length (contract-m2s contract))) (sponsor-contracts sponsor)))))) (mapc #'emit-template-node children)) (define-bknr-tag admin-login-page (&key children) @@ -185,7 +187,7 @@ (define-bknr-tag google-analytics-track () (html ((:script :type "text/javascript") - "var gaJsHost = (('https:' == document.location.protocol) ? 'https://ssl.' : 'http://www.'); + "var gaJsHost = (('https:' == document.location.protocol) ? 'https://ssl.' : 'http://www.'); document.write(unescape('%3Cscript src=%22' + gaJsHost + 'google-analytics.com/ga.js%22 type=%22text/javascript%22%3E%3C/script%3E'));") - ((:script :type "text/javascript") - (:princ #?"if (_gat) { var pageTracker = _gat._getTracker('$(*google-analytics-account*)'); pageTracker._initData(); pageTracker._trackPageview(); }")))) + ((:script :type "text/javascript") + (:princ #?"if (_gat) { var pageTracker = _gat._getTracker('$(*google-analytics-account*)'); pageTracker._initData(); pageTracker._trackPageview(); }"))))

1 0