From 39f12d4ea042b7ec74e440daf6165e62641a3d9f Mon Sep 17 00:00:00 2001 From: AJ Rossini Date: Sun, 9 Mar 2008 10:34:18 +0100 Subject: [PATCH] adding CFFI just in case. Need to make into a submodule at somepoint. --- external/cffi.darcs/COPYRIGHT | 21 + external/cffi.darcs/HEADER | 28 + external/cffi.darcs/Makefile | 68 + external/cffi.darcs/README | 17 + external/cffi.darcs/TODO | 108 + external/cffi.darcs/cffi-examples.asd | 37 + external/cffi.darcs/cffi-tests.asd | 85 + external/cffi.darcs/cffi-uffi-compat.asd | 41 + external/cffi.darcs/cffi.asd | 68 + external/cffi.darcs/doc/Makefile | 44 + external/cffi.darcs/doc/allegro-internals.txt | 132 + external/cffi.darcs/doc/cffi-manual.texinfo | 5951 ++++++++++++++++++++ external/cffi.darcs/doc/cffi-sys-spec.texinfo | 309 + .../cffi.darcs/doc/colorize-lisp-examples.lisp | 1051 ++++ external/cffi.darcs/doc/gendocs.sh | 310 + external/cffi.darcs/doc/gendocs_template | 259 + external/cffi.darcs/doc/mem-vector.txt | 75 + external/cffi.darcs/doc/shareable-vectors.txt | 44 + external/cffi.darcs/doc/style.css | 48 + external/cffi.darcs/examples/examples.lisp | 78 + external/cffi.darcs/examples/gethostname.lisp | 51 + external/cffi.darcs/examples/gettimeofday.lisp | 93 + external/cffi.darcs/examples/mapping.lisp | 76 + external/cffi.darcs/examples/run-examples.lisp | 38 + external/cffi.darcs/examples/translator-test.lisp | 88 + external/cffi.darcs/scripts/release.sh | 45 + external/cffi.darcs/src/cffi-allegro.lisp | 459 ++ external/cffi.darcs/src/cffi-clisp.lisp | 402 ++ external/cffi.darcs/src/cffi-cmucl.lisp | 389 ++ external/cffi.darcs/src/cffi-corman.lisp | 337 ++ external/cffi.darcs/src/cffi-ecl.lisp | 306 + external/cffi.darcs/src/cffi-gcl.lisp | 313 + external/cffi.darcs/src/cffi-lispworks.lisp | 406 ++ external/cffi.darcs/src/cffi-openmcl.lisp | 315 ++ external/cffi.darcs/src/cffi-sbcl.lisp | 354 ++ external/cffi.darcs/src/cffi-scl.lisp | 333 ++ external/cffi.darcs/src/early-types.lisp | 519 ++ external/cffi.darcs/src/enum.lisp | 216 + external/cffi.darcs/src/features.lisp | 89 + external/cffi.darcs/src/foreign-vars.lisp | 88 + external/cffi.darcs/src/functions.lisp | 307 + external/cffi.darcs/src/libraries.lisp | 280 + external/cffi.darcs/src/package.lisp | 123 + external/cffi.darcs/src/strings.lisp | 138 + external/cffi.darcs/src/types.lisp | 772 +++ external/cffi.darcs/src/utils.lisp | 200 + external/cffi.darcs/tests/Makefile | 85 + external/cffi.darcs/tests/bindings.lisp | 96 + external/cffi.darcs/tests/callbacks.lisp | 511 ++ external/cffi.darcs/tests/compile.bat | 9 + external/cffi.darcs/tests/defcfun.lisp | 401 ++ external/cffi.darcs/tests/enum.lisp | 115 + external/cffi.darcs/tests/foreign-globals.lisp | 284 + external/cffi.darcs/tests/funcall.lisp | 193 + external/cffi.darcs/tests/libtest.c | 864 +++ external/cffi.darcs/tests/libtest2.c | 50 + external/cffi.darcs/tests/memory.lisp | 565 ++ external/cffi.darcs/tests/misc-types.lisp | 235 + external/cffi.darcs/tests/misc.lisp | 151 + external/cffi.darcs/tests/package.lisp | 32 + external/cffi.darcs/tests/random-tester.lisp | 246 + external/cffi.darcs/tests/run-tests.lisp | 45 + external/cffi.darcs/tests/struct.lisp | 324 ++ external/cffi.darcs/tests/union.lisp | 50 + external/cffi.darcs/uffi-compat/uffi-compat.lisp | 622 ++ external/cffi.darcs/uffi-compat/uffi.asd | 3 + 66 files changed, 20392 insertions(+) create mode 100644 external/cffi.darcs/COPYRIGHT create mode 100644 external/cffi.darcs/HEADER create mode 100644 external/cffi.darcs/Makefile create mode 100644 external/cffi.darcs/README create mode 100644 external/cffi.darcs/TODO create mode 100644 external/cffi.darcs/cffi-examples.asd create mode 100644 external/cffi.darcs/cffi-tests.asd create mode 100644 external/cffi.darcs/cffi-uffi-compat.asd create mode 100644 external/cffi.darcs/cffi.asd create mode 100644 external/cffi.darcs/doc/Makefile create mode 100644 external/cffi.darcs/doc/allegro-internals.txt create mode 100644 external/cffi.darcs/doc/cffi-manual.texinfo create mode 100644 external/cffi.darcs/doc/cffi-sys-spec.texinfo create mode 100644 external/cffi.darcs/doc/colorize-lisp-examples.lisp create mode 100644 external/cffi.darcs/doc/gendocs.sh create mode 100644 external/cffi.darcs/doc/gendocs_template create mode 100644 external/cffi.darcs/doc/mem-vector.txt create mode 100644 external/cffi.darcs/doc/shareable-vectors.txt create mode 100644 external/cffi.darcs/doc/style.css create mode 100644 external/cffi.darcs/examples/examples.lisp create mode 100644 external/cffi.darcs/examples/gethostname.lisp create mode 100644 external/cffi.darcs/examples/gettimeofday.lisp create mode 100644 external/cffi.darcs/examples/mapping.lisp create mode 100644 external/cffi.darcs/examples/run-examples.lisp create mode 100644 external/cffi.darcs/examples/translator-test.lisp create mode 100644 external/cffi.darcs/scripts/release.sh create mode 100644 external/cffi.darcs/src/cffi-allegro.lisp create mode 100644 external/cffi.darcs/src/cffi-clisp.lisp create mode 100644 external/cffi.darcs/src/cffi-cmucl.lisp create mode 100644 external/cffi.darcs/src/cffi-corman.lisp create mode 100644 external/cffi.darcs/src/cffi-ecl.lisp create mode 100644 external/cffi.darcs/src/cffi-gcl.lisp create mode 100644 external/cffi.darcs/src/cffi-lispworks.lisp create mode 100644 external/cffi.darcs/src/cffi-openmcl.lisp create mode 100644 external/cffi.darcs/src/cffi-sbcl.lisp create mode 100644 external/cffi.darcs/src/cffi-scl.lisp create mode 100644 external/cffi.darcs/src/early-types.lisp create mode 100644 external/cffi.darcs/src/enum.lisp create mode 100644 external/cffi.darcs/src/features.lisp create mode 100644 external/cffi.darcs/src/foreign-vars.lisp create mode 100644 external/cffi.darcs/src/functions.lisp create mode 100644 external/cffi.darcs/src/libraries.lisp create mode 100644 external/cffi.darcs/src/package.lisp create mode 100644 external/cffi.darcs/src/strings.lisp create mode 100644 external/cffi.darcs/src/types.lisp create mode 100644 external/cffi.darcs/src/utils.lisp create mode 100644 external/cffi.darcs/tests/Makefile create mode 100644 external/cffi.darcs/tests/bindings.lisp create mode 100644 external/cffi.darcs/tests/callbacks.lisp create mode 100644 external/cffi.darcs/tests/compile.bat create mode 100644 external/cffi.darcs/tests/defcfun.lisp create mode 100644 external/cffi.darcs/tests/enum.lisp create mode 100644 external/cffi.darcs/tests/foreign-globals.lisp create mode 100644 external/cffi.darcs/tests/funcall.lisp create mode 100644 external/cffi.darcs/tests/libtest.c create mode 100644 external/cffi.darcs/tests/libtest2.c create mode 100644 external/cffi.darcs/tests/memory.lisp create mode 100644 external/cffi.darcs/tests/misc-types.lisp create mode 100644 external/cffi.darcs/tests/misc.lisp create mode 100644 external/cffi.darcs/tests/package.lisp create mode 100644 external/cffi.darcs/tests/random-tester.lisp create mode 100644 external/cffi.darcs/tests/run-tests.lisp create mode 100644 external/cffi.darcs/tests/struct.lisp create mode 100644 external/cffi.darcs/tests/union.lisp create mode 100644 external/cffi.darcs/uffi-compat/uffi-compat.lisp create mode 100644 external/cffi.darcs/uffi-compat/uffi.asd diff --git a/external/cffi.darcs/COPYRIGHT b/external/cffi.darcs/COPYRIGHT new file mode 100644 index 0000000..67a5f68 --- /dev/null +++ b/external/cffi.darcs/COPYRIGHT @@ -0,0 +1,21 @@ +Copyright (C) 2005-2007, James Bielman + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, copy, +modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. diff --git a/external/cffi.darcs/HEADER b/external/cffi.darcs/HEADER new file mode 100644 index 0000000..7181d31 --- /dev/null +++ b/external/cffi.darcs/HEADER @@ -0,0 +1,28 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; filename --- description +;;; +;;; Copyright (C) 2007, James Bielman +;;; +;;; Permission is hereby granted, free of charge, to any person +;;; obtaining a copy of this software and associated documentation +;;; files (the "Software"), to deal in the Software without +;;; restriction, including without limitation the rights to use, copy, +;;; modify, merge, publish, distribute, sublicense, and/or sell copies +;;; of the Software, and to permit persons to whom the Software is +;;; furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. +;;; + + diff --git a/external/cffi.darcs/Makefile b/external/cffi.darcs/Makefile new file mode 100644 index 0000000..feac36f --- /dev/null +++ b/external/cffi.darcs/Makefile @@ -0,0 +1,68 @@ +# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*- +# +# Makefile --- Make targets for various tasks. +# +# Copyright (C) 2005-2006, James Bielman +# +# Permission is hereby granted, free of charge, to any person +# obtaining a copy of this software and associated documentation +# files (the "Software"), to deal in the Software without +# restriction, including without limitation the rights to use, copy, +# modify, merge, publish, distribute, sublicense, and/or sell copies +# of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be +# included in all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +# DEALINGS IN THE SOFTWARE. +# + +# This way you can easily run the tests for different versions +# of each lisp with, e.g. ALLEGRO=/path/to/some/lisp make test-allegro +CMUCL ?= lisp +OPENMCL ?= openmcl +SBCL ?= sbcl +CLISP ?= clisp +ALLEGRO ?= acl +SCL ?= scl + +shlibs: + @$(MAKE) -wC tests shlibs + +clean: + @$(MAKE) -wC tests clean + find . -name ".fasls" | xargs rm -rf + find . \( -name "*.dfsl" -o -name "*.fasl" -o -name "*.fas" -o -name "*.lib" -o -name "*.x86f" -o -name "*.amd64f" -o -name "*.sparcf" -o -name "*.sparc64f" -o -name "*.hpf" -o -name "*.hp64f" -o -name "*.ppcf" -o -name "*.nfasl" -o -name "*.ufsl" -o -name "*.fsl" -o -name "*.lx64fsl" \) -exec rm {} \; + +test-openmcl: + @-$(OPENMCL) --load tests/run-tests.lisp + +test-sbcl: + @-$(SBCL) --noinform --load tests/run-tests.lisp + +test-cmucl: + @-$(CMUCL) -load tests/run-tests.lisp + +test-scl: + @-$(SCL) -load tests/run-tests.lisp + +test-clisp: + @-$(CLISP) -q -x '(load "tests/run-tests.lisp")' + +test-clisp-modern: + @-$(CLISP) -modern -q -x '(load "tests/run-tests.lisp")' + +test-allegro: + @-$(ALLEGRO) -L tests/run-tests.lisp + +test: test-openmcl test-sbcl test-cmucl test-clisp + +# vim: ft=make ts=3 noet diff --git a/external/cffi.darcs/README b/external/cffi.darcs/README new file mode 100644 index 0000000..13b1069 --- /dev/null +++ b/external/cffi.darcs/README @@ -0,0 +1,17 @@ + +CFFI, the Common Foreign Function Interface, purports to be a portable +foreign function interface, similar in spirit to UFFI. + +Unlike UFFI, CFFI requires only a small set of low-level functionality +from the Lisp implementation, such as calling a foreign function by +name, allocating foreign memory, and dereferencing pointers. + +More complex tasks like accessing foreign structures can be done in +portable "user space" code, making use of the low-level memory access +operations defined by the implementation-specific bits. + +CFFI also aims to be more efficient than UFFI when possible. In +particular, UFFI's use of aliens in CMUCL and SBCL can be tricky to +get right. CFFI avoids this by using system area pointers directly +instead of alien objects. All foreign function definitions and uses +should compile without alien-value compiler notes in CMUCL/SBCL. diff --git a/external/cffi.darcs/TODO b/external/cffi.darcs/TODO new file mode 100644 index 0000000..0ad65c2 --- /dev/null +++ b/external/cffi.darcs/TODO @@ -0,0 +1,108 @@ +-*- Text -*- + +This is a collection of TODO items and ideas in no particular order. + +### Testing + +-> Test uffi-compat with more UFFI libraries. +-> Write more FOREIGN-GLOBALS.SET.* tests. +-> Finish tests/random-tester.lisp +-> Write benchmarks comparing CFFI vs. native FFIs and also demonstrating + performance of each platform. +-> Write more STRUCT.ALIGNMENT.* tests (namely involving the :LONG-LONG + and :UNSIGNED-LONG-LONG types) and test them in more ABIs. +-> Run tests with the different kinds of shared libraries available on + MacOS X. + +### Ports + +-> Finish GCL port, port to MCL. +-> Update Corman port. [2007-02-22 LO] + +### Features + +-> Implement a declarative interface for FOREIGN-FUNCALL-PTR, similar to + DEFCUN/FOREIGN-FUNCALL. +-> Figure out how to portably define types like: time_t, size_t, wchar_t, + etc... Likely to involve something like SB-GROVEL and possibly avoiding + this step on known platforms? +-> Implement the proposed interfaces (see doc/). +-> Implement CFFI-SYS:ERRNO-VALUE (name?). +-> Extend FOREIGN-SLOT-VALUE and make it accept multiple "indices" for + directly accessing structs inside structs, arrays inside structs, etc... +-> Implement EXPLAIN-FOREIGN-SLOT-VALUE. +-> Implement :in/:out/:in-out for DEFCFUN (and FOREIGN-FUNCALL?). +-> Add support for multiple memory allocation schemes (like CLISP), namely + support for allocating with malloc() (so that it can be freed on the C + side)> +-> Extend DEFCVAR's symbol macro in order to handle memory (de)allocation + automatically (see CLISP). +-> Implement byte swapping routines (see /usr/include/linux/byteorder) +-> [Lost Idea] Implement UB8-REF? +-> [Lost Idea] Something about MEM-READ-C-STRING returning multiple value? +-> Implement an array type? Useful when we're working with ranks >= 2? +-> External encodings for the :STRING type. See: + +-> Define a lisp type for pointers in the backends. Eg: for clisp: + (deftype pointer-type (or ffi:foreign-address null)) + Useful for type declarations. +-> Warn about :void in places where it doesn't make sense. + +### Underspecified Semantics + +-> (setf (mem-ref ptr offset) ) +-> Review the interface for coherence across Lisps with regard to + behaviour in "exceptional" situations. Eg: threads, dumping cores, + accessing foreign symbols that don't exist, etc... +-> On Lispworks a Lisp float is a double and therefore won't necessarily + fit in a C float. Figure out a way to handle this. +-> Allegro: callbacks' return values. +-> Lack of uniformity with regard to pointers. Allegro: 0 -> NULL. + CLISP/Lispworks: NIL -> NULL. +-> Some lisps will accept a lisp float being passed to :double + and a lisp double to :float. We should either coerce on lisps that + don't accept this or check-type on lisps that do. Probably the former + is better since on lispworks/x86 double == float. +-> What happens when the same library is loaded twice. + +### Possible Optimizations + +-> More compiler macros on some of the CFFI-SYS implementations. +-> Optimize UFFI-COMPAT when the vector stuff is implemented. +-> Being able to declare that some C int will always fit in a Lisp + fixnum. Allegro has a :fixnum ftype and CMUCL/SBCL can use + (unsigned-byte 29) others could perhaps behave like :int? +-> An option for defcfun to expand into a compiler macro which would + allow the macroexpansion-time translators to look at the forms + passed to the functions. + +### Known Issues + +-> CLISP FASL portability is broken. Fix this by placing LOAD-TIME-VALUE + forms in the right places and moving other calculations to load-time. + (eg: calculating struct size/alignment.) Ideally we'd only move them + to load-time when we actually care about fasl portability. + (defmacro maybe-load-time-value (form) + (if + `(load-time-value ,form) + form)) +-> cffi-tests.asd's :c-test-lib component is causing the whole testsuite + to be recompiled everytime. Figure that out. +-> The (if (constantp foo) (do-something-with (eval foo)) ...) pattern + used in many places throughout the code is apparently not 100% safe. +-> On ECL platforms without DFFI we need to build a non-linked version + of libtest. +-> LOAD-FOREIGN-LIBRARY should give better errors. On ECL with DFFI + it should show the error that %LOAD-FOREIGN-LIBRARY is signalling. +-> foreign-enum-keyword/value should have their own error condition? + [2007-02-22 LO] + +### Documentation + +-> Fill the missing sections in the CFFI User Manual. +-> Update the CFFI-SYS Specification. +-> have two versions of the manual on the website + +### Other + +-> Type-checking pointer interface. diff --git a/external/cffi.darcs/cffi-examples.asd b/external/cffi.darcs/cffi-examples.asd new file mode 100644 index 0000000..4208923 --- /dev/null +++ b/external/cffi.darcs/cffi-examples.asd @@ -0,0 +1,37 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; cffi-examples.asd --- ASDF system definition for CFFI examples. +;;; +;;; Copyright (C) 2005-2006, James Bielman +;;; +;;; Permission is hereby granted, free of charge, to any person +;;; obtaining a copy of this software and associated documentation +;;; files (the "Software"), to deal in the Software without +;;; restriction, including without limitation the rights to use, copy, +;;; modify, merge, publish, distribute, sublicense, and/or sell copies +;;; of the Software, and to permit persons to whom the Software is +;;; furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. +;;; + +(defsystem cffi-examples + :description "CFFI Examples" + :author "James Bielman " + :components + ((:module examples + :components + ((:file "examples") + (:file "gethostname") + (:file "gettimeofday")))) + :depends-on (cffi)) diff --git a/external/cffi.darcs/cffi-tests.asd b/external/cffi.darcs/cffi-tests.asd new file mode 100644 index 0000000..be0d0d9 --- /dev/null +++ b/external/cffi.darcs/cffi-tests.asd @@ -0,0 +1,85 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; cffi-tests.asd --- ASDF system definition for CFFI unit tests. +;;; +;;; Copyright (C) 2005-2006, James Bielman +;;; +;;; Permission is hereby granted, free of charge, to any person +;;; obtaining a copy of this software and associated documentation +;;; files (the "Software"), to deal in the Software without +;;; restriction, including without limitation the rights to use, copy, +;;; modify, merge, publish, distribute, sublicense, and/or sell copies +;;; of the Software, and to permit persons to whom the Software is +;;; furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. +;;; + +(defpackage #:cffi-tests-system + (:use #:cl #:asdf)) +(in-package #:cffi-tests-system) + +(defvar *tests-dir* (append (pathname-directory *load-truename*) '("tests"))) + +(defclass c-test-lib (c-source-file) + ()) + +(defmethod perform ((o load-op) (c c-test-lib)) + nil) + +(defmethod perform ((o load-source-op) (c c-test-lib)) + nil) + +(defmethod perform ((o compile-op) (c c-test-lib)) + #-(or win32 mswindows) + (unless (zerop (run-shell-command + #-(or freebsd solaris) "cd ~A; make" + #+(or freebsd solaris) "cd ~A; gmake" + (namestring (make-pathname :name nil :type nil + :directory *tests-dir*)))) + (error 'operation-error :component c :operation o))) + +;; For the convenience of ECL users. +#+ecl (require 'rt) + +(defsystem cffi-tests + :description "Unit tests for CFFI." + :depends-on (cffi #-ecl rt) + :components + ((:module "tests" + :serial t + :components + ((:c-test-lib "libtest") + (:file "package") + (:file "bindings") + (:file "funcall") + (:file "defcfun") + (:file "callbacks") + (:file "foreign-globals") + (:file "memory") + (:file "struct") + (:file "union") + (:file "enum") + (:file "misc-types") + (:file "misc"))))) + +(defun run-cffi-tests (&key (compiled nil)) + (funcall (intern (symbol-name '#:run-cffi-tests) '#:cffi-tests) + :compiled compiled)) + +(defmethod perform ((o test-op) (c (eql (find-system :cffi-tests)))) + (unless (and (run-cffi-tests :compiled nil) + (run-cffi-tests :compiled t)) + (error "test-op failed."))) + +;;; vim: ft=lisp et diff --git a/external/cffi.darcs/cffi-uffi-compat.asd b/external/cffi.darcs/cffi-uffi-compat.asd new file mode 100644 index 0000000..3ea9b77 --- /dev/null +++ b/external/cffi.darcs/cffi-uffi-compat.asd @@ -0,0 +1,41 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; cffi-uffi-compat.asd --- ASDF system definition for CFFI-UFFI-COMPAT. +;;; +;;; Copyright (C) 2005-2006, James Bielman +;;; +;;; Permission is hereby granted, free of charge, to any person +;;; obtaining a copy of this software and associated documentation +;;; files (the "Software"), to deal in the Software without +;;; restriction, including without limitation the rights to use, copy, +;;; modify, merge, publish, distribute, sublicense, and/or sell copies +;;; of the Software, and to permit persons to whom the Software is +;;; furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. +;;; + +(defpackage #:cffi-uffi-compat-system + (:use #:cl #:asdf)) +(in-package #:cffi-uffi-compat-system) + +(defsystem cffi-uffi-compat + :description "UFFI Compatibility Layer for CFFI" + :author "James Bielman " + :components + ((:module uffi-compat + :components + ((:file "uffi-compat")))) + :depends-on (cffi)) + +;; vim: ft=lisp et diff --git a/external/cffi.darcs/cffi.asd b/external/cffi.darcs/cffi.asd new file mode 100644 index 0000000..280bd0e --- /dev/null +++ b/external/cffi.darcs/cffi.asd @@ -0,0 +1,68 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; cffi.asd --- ASDF system definition for CFFI. +;;; +;;; Copyright (C) 2005-2006, James Bielman +;;; +;;; Permission is hereby granted, free of charge, to any person +;;; obtaining a copy of this software and associated documentation +;;; files (the "Software"), to deal in the Software without +;;; restriction, including without limitation the rights to use, copy, +;;; modify, merge, publish, distribute, sublicense, and/or sell copies +;;; of the Software, and to permit persons to whom the Software is +;;; furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. +;;; + +#-(or openmcl sbcl cmu scl clisp lispworks ecl allegro cormanlisp) +(error "Sorry, this Lisp is not yet supported. Patches welcome!") + +(defpackage #:cffi-system + (:use #:cl #:asdf)) +(in-package #:cffi-system) + +(defsystem cffi + :description "The Common Foreign Function Interface" + :author "James Bielman " + :version "0.9.2" + :licence "MIT" + :components + ((:module src + :serial t + :components + ((:file "utils") + (:file "features") + #+openmcl (:file "cffi-openmcl") + #+sbcl (:file "cffi-sbcl") + #+cmu (:file "cffi-cmucl") + #+scl (:file "cffi-scl") + #+clisp (:file "cffi-clisp") + #+lispworks (:file "cffi-lispworks") + #+ecl (:file "cffi-ecl") + #+allegro (:file "cffi-allegro") + #+cormanlisp (:file "cffi-corman") + (:file "package") + (:file "libraries") + (:file "early-types") + (:file "types") + (:file "enum") + (:file "strings") + (:file "functions") + (:file "foreign-vars"))))) + +(defmethod perform ((o test-op) (c (eql (find-system :cffi)))) + (operate 'asdf:load-op :cffi-tests) + (operate 'asdf:test-op :cffi-tests)) + +;; vim: ft=lisp et diff --git a/external/cffi.darcs/doc/Makefile b/external/cffi.darcs/doc/Makefile new file mode 100644 index 0000000..ba154f1 --- /dev/null +++ b/external/cffi.darcs/doc/Makefile @@ -0,0 +1,44 @@ +# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*- +# +# Makefile --- Make targets for generating the documentation. +# +# Copyright (C) 2005-2007, Luis Oliveira +# +# Permission is hereby granted, free of charge, to any person +# obtaining a copy of this software and associated documentation +# files (the "Software"), to deal in the Software without +# restriction, including without limitation the rights to use, copy, +# modify, merge, publish, distribute, sublicense, and/or sell copies +# of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be +# included in all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +# DEALINGS IN THE SOFTWARE. +# + +all: manual spec + +manual: cffi-manual.texinfo style.css + sh gendocs.sh -o manual --html "--css-include=style.css" cffi-manual "CFFI User Manual" + +spec: cffi-sys-spec.texinfo style.css + sh gendocs.sh -o spec --html "--css-include=style.css" cffi-sys-spec "CFFI-SYS Interface Specification" + +clean: + find . \( -name "*.info" -o -name "*.aux" -o -name "*.cp" -o -name "*.fn" -o -name "*.fns" -o -name "*.ky" -o -name "*.log" -o -name "*.pg" -o -name "*.toc" -o -name "*.tp" -o -name "*.vr" -o -name "*.dvi" -o -name "*.cps" -o -name "*.vrs" \) -exec rm {} \; + rm -rf manual spec + +upload-docs: + rsync -av --delete -e ssh manual spec common-lisp.net:/project/cffi/public_html/ +# scp -r manual spec common-lisp.net:/project/cffi/public_html/ + +# vim: ft=make ts=3 noet diff --git a/external/cffi.darcs/doc/allegro-internals.txt b/external/cffi.darcs/doc/allegro-internals.txt new file mode 100644 index 0000000..64c0d7e --- /dev/null +++ b/external/cffi.darcs/doc/allegro-internals.txt @@ -0,0 +1,132 @@ +July 2005 +These details were kindly provided by Duane Rettig of Franz. + +Regarding the following snippet of the macro expansion of +FF:DEF-FOREIGN-CALL: + + (SYSTEM::FF-FUNCALL + (LOAD-TIME-VALUE (EXCL::DETERMINE-FOREIGN-ADDRESS + '("foo" :LANGUAGE :C) 2 NIL)) + '(:INT (INTEGER * *)) ARG1 + '(:DOUBLE (DOUBLE-FLOAT * *)) ARG2 + '(:INT (INTEGER * *))) + +" +... in Allegro CL, if you define a foreign call FOO with C entry point +"foo" and with :call-direct t in the arguments, and if other things are +satisfied, then if a lisp function BAR is compiled which has a call to +FOO, that call will not go through ff-funcall (and thus a large amount +of argument manipulation and processing) but will instead set up its +arguments directly on the stack, and will then perform the "call" more +or less directly, through the "entry vec" (a small structure which +keeps track of a foreign entry's address and status)." + +This is the code that generates what the compiler expects to see: + +(setq call-direct-form + (if* call-direct + then `(setf (get ',lispname 'sys::direct-ff-call) + (list ',external-name + ,callback + ,convention + ',returning + ',arg-types + ,arg-checking + ,entry-vec-flags)) + else `(remprop ',lispname 'sys::direct-ff-call))) + +Thus generating something like: + + (EVAL-WHEN (COMPILE LOAD EVAL) + (SETF (GET 'FOO 'SYSTEM::DIRECT-FF-CALL) + (LIST '("foo" :LANGUAGE :C) T :C + '(:INT (INTEGER * *)) + '((:INT (INTEGER * *)) + (:FLOAT (SINGLE-FLOAT * *))) + T + 2 ; this magic value is explained later + ))) + +" +(defun determine-foreign-address (name &optional (flags 0) method-index) + ;; return an entry-vec struct suitable for the foreign-call of name. + ;; + ;; name is either a string, which is taken without conversion, or + ;; a list consisting of a string to convert or a conversion function + ;; call. + ;; flags is an integer representing the flags to place into the entry-vec. + ;; method-index, if non-nil, is a word-index into a vtbl (virtual table). + ;; If method-index is true, then the name must be a string uniquely + ;; represented by the index and by the flags field. + +Note that not all architectures implement the :method-index argument +to def-foreign-call, but your interface likely won't support it +anyway, so just leave it nil. As for the flags, they are constants +stored into the entry-vec returned by d-f-a and are given here: + +(defconstant ep-flag-call-semidirect 1) ; Real address stored in alt-address slot +(defconstant ep-flag-never-release 2) ; Never release the heap +(defconstant ep-flag-always-release 4) ; Always release the heap +(defconstant ep-flag-release-when-ok 8) ; Release the heap unless without-interrupts + +(defconstant ep-flag-tramp-calls #x70) ; Make calls through special trampolines +(defconstant ep-flag-tramp-shift 4) + +(defconstant ep-flag-variable-address #x100) ; Entry-point contains address of C var +(defconstant ep-flag-strings-convert #x200) ; Convert strings automatically + +(defconstant ep-flag-get-errno #x1000) ;; [rfe5060]: Get errno value after call +(defconstant ep-flag-get-last-error #x2000) ;; [rfe5060]: call GetLastError after call +;; Leave #x4000 and #x8000 open for expansion + +Mostly, you'll give the value 2 (never release the heap), but if you +give 4 or 8, then d-f-a will automatically set the 1 bit as well, +which takes the call through a heap-release/reacquire process. + +Some docs for entry-vec are: + +;; -- entry vec -- +;; An entry-vec is an entry-point descriptor, usually a pointer into +;; a shared-library. It is represented as a 5-element struct of type +;; foreign-vector. The reason for this represntation is +;; that it allows the entry point to be stored in a table, called +;; the .saved-entry-points. table, and to be used by a foreign +;; function. When the location of the foreign function to which the entry +;; point refers changes, it is simply a matter of changing the value in entry +;; point vector and the foreign call code sees it immediately. There is +;; even an address that can be put in the entry point vector that denotes +;; a missing foreign function, thus lookup can happen dynamically. + +(defstruct (entry-vec + (:type (vector excl::foreign (*))) + (:constructor make-entry-vec-boa ())) + name ; entry point name + (address 0) ; jump address for foreign code + (handle 0) ; shared-lib handle + (flags 0) ; ep-* flags + (alt-address 0) ; sometimes holds the real func addr + ) + +[...] +" + +Regarding the arguments to SYSTEM::FF-FUNCALL: + '(:int (integer * *)) argN + +"The type-spec is as it is given in the def-foreign-call +syntax, with a C type optionally followed by a lisp type, +followed optionally by a user-conversion function name[...]" + + +Getting the alignment: + +CL-USER(2): (ff:get-foreign-type :int) +#S(FOREIGN-FUNCTIONS::IFOREIGN-TYPE + :ATTRIBUTES NIL + :SFTYPE + #S(FOREIGN-FUNCTIONS::SIZED-FTYPE-PRIM + :KIND :INT + :WIDTH 4 + :OFFSET 0 + :ALIGN 4) + ...) diff --git a/external/cffi.darcs/doc/cffi-manual.texinfo b/external/cffi.darcs/doc/cffi-manual.texinfo new file mode 100644 index 0000000..9a02d0e --- /dev/null +++ b/external/cffi.darcs/doc/cffi-manual.texinfo @@ -0,0 +1,5951 @@ +\input texinfo @c -*- Mode: Texinfo; Mode: auto-fill -*- +@c %**start of header +@setfilename cffi.info +@settitle CFFI User Manual +@exampleindent 2 + +@c @documentencoding utf-8 + +@ignore +Style notes: + +* The reference section names and "See Also" list are roman, not + @code. This is to follow the format of CLHS. + +* How it looks in HTML is the priority. +@end ignore + +@c ============================= Macros ============================= +@c The following macros are used throughout this manual. + +@macro Function {args} +@defun \args\ +@end defun +@end macro + +@macro Macro {args} +@defmac \args\ +@end defmac +@end macro + +@macro Accessor {args} +@deffn {Accessor} \args\ +@end deffn +@end macro + +@macro GenericFunction {args} +@deffn {Generic Function} \args\ +@end deffn +@end macro + +@macro ForeignType {args} +@deftp {Foreign Type} \args\ +@end deftp +@end macro + +@macro Variable {args} +@defvr {Special Variable} \args\ +@end defvr +@end macro + +@macro Condition {args} +@deftp {Condition Type} \args\ +@end deftp +@end macro + +@macro cffi +@acronym{CFFI} +@end macro + +@macro impnote {text} +@quotation +@strong{Implementor's note:} @emph{\text\} +@end quotation +@end macro + +@c Info "requires" that x-refs end in a period or comma, or ) in the +@c case of @pxref. So the following implements that requirement for +@c the "See also" subheadings that permeate this manual, but only in +@c Info mode. +@ifinfo +@macro seealso {name} +@ref{\name\}. +@end macro +@end ifinfo + +@ifnotinfo +@alias seealso = ref +@end ifnotinfo + +@c Set ROMANCOMMENTS to get comments in roman font. +@ifset ROMANCOMMENTS +@alias lispcmt = r +@end ifset +@ifclear ROMANCOMMENTS +@alias lispcmt = asis +@end ifclear + + +@c ============================= Macros ============================= + + +@c Show types, functions, and concepts in the same index. +@syncodeindex tp cp +@syncodeindex fn cp + +@copying +Copyright @copyright{} 2005 James Bielman @* +Copyright @copyright{} 2005-2007 Lu@'{@dotless{i}}s Oliveira + @* +Copyright @copyright{} 2006 Stephen Compall + +@quotation +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +``Software''), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +@sc{The software is provided ``as is'', without warranty of any kind, +express or implied, including but not limited to the warranties of +merchantability, fitness for a particular purpose and noninfringement. +In no event shall the authors or copyright holders be liable for any +claim, damages or other liability, whether in an action of contract, +tort or otherwise, arising from, out of or in connection with the +software or the use or other dealings in the software.} +@end quotation +@end copying +@c %**end of header + +@titlepage +@title CFFI User Manual +@c @subtitle Version X.X +@c @author James Bielman + +@page +@vskip 0pt plus 1filll +@insertcopying +@end titlepage + +@contents + +@ifnottex +@node Top +@top cffi +@insertcopying +@end ifnottex + +@menu +* Introduction:: What is CFFI? +* Implementation Support:: +* Tutorial:: Interactive intro to using CFFI. +* Wrapper generators:: CFFI forms from munging C source code. +* Foreign Types:: +* Pointers:: +* Strings:: +* Variables:: +* Functions:: +* Libraries:: +* Callbacks:: +* Limitations:: +* Platform-specific features:: Details about the underlying system. +* Glossary:: List of CFFI-specific terms and meanings. +* Comprehensive Index:: + +@detailmenu + --- Dictionary --- + +Foreign Types + +* convert-from-foreign:: Outside interface to backward type translator. +* convert-to-foreign:: Outside interface to forward type translator. +* defbitfield:: Defines a bitfield. +* defcstruct:: Defines a C structure type. +* defcunion:: Defines a C union type. +* defctype:: Defines a foreign typedef. +* defcenum:: Defines a C enumeration. +* define-foreign-type:: Defines a foreign type specifier. +* define-parse-method:: Specifies how a type should be parsed. +@c * explain-foreign-slot-value:: +* foreign-bitfield-symbols:: Returns a list of symbols for a bitfield type. +* foreign-bitfield-value:: Calculates a value for a bitfield type. +* foreign-enum-keyword:: Finds a keyword in an enum type. +* foreign-enum-value:: Finds a value in an enum type. +* foreign-slot-names:: Returns a list of slot names in a foreign struct. +* foreign-slot-offset:: Returns the offset of a slot in a foreign struct. +* foreign-slot-pointer:: Returns a pointer to a slot in a foreign struct. +* foreign-slot-value:: Returns the value of a slot in a foreign struct. +* foreign-type-alignment:: Returns the alignment of a foreign type. +* foreign-type-size:: Returns the size of a foreign type. +* free-converted-object:: Outside interface to typed object deallocators. +* free-translated-object:: Free a type translated foreign object. +* translate-from-foreign:: Translate a foreign object to a Lisp object. +* translate-to-foreign:: Translate a Lisp object to a foreign object. +* with-foreign-object:: Allocates a foreign object with dynamic extent. +* with-foreign-slots:: Access the slots of a foreign structure. + +Pointers + +* foreign-free:: Deallocates memory. +* foreign-alloc:: Allocates memory. +* foreign-symbol-pointer:: Returns a pointer to a foreign symbol. +* inc-pointer:: Increments the address held by a pointer. +* incf-pointer:: Increments the pointer address in a place. +* make-pointer:: Returns a pointer to a given address. +* mem-aref:: Accesses the value of an index in an array. +* mem-ref:: Dereferences a pointer. +* null-pointer:: Returns a NULL pointer. +* null-pointer-p:: Tests a pointer for NULL value. +* pointerp:: Tests whether an object is a pointer or not. +* pointer-address:: Returns the address pointed to by a pointer. +* pointer-eq:: Tests if two pointers point to the same address. +* with-foreign-pointer:: Allocates memory with dynamic extent. + +Strings + +* foreign-string-alloc:: Converts a Lisp string to a foreign string. +* foreign-string-free:: Deallocates memory used by a foreign string. +* foreign-string-to-lisp:: Converts a foreign string to a Lisp string. +* lisp-string-to-foreign:: Copies a Lisp string into a foreign string. +* with-foreign-string:: Allocates a foreign string with dynamic extent. +* with-foreign-pointer-as-string:: Similar to CL's with-output-to-string. + +Variables + +* defcvar:: Defines a C global variable. +* get-var-pointer:: Returns a pointer to a defined global variable. + +Functions + +* defcfun:: Defines a foreign function. +* foreign-funcall:: Performs a call to a foreign function. +* foreign-funcall-pointer:: Performs a call through a foreign pointer. + +Libraries + +* close-foreign-library:: Closes a foreign library. +* *darwin-framework-directories*:: Search path for Darwin frameworks. +* define-foreign-library:: Explain how to load a foreign library. +* *foreign-library-directories*:: Search path for shared libraries. +* load-foreign-library:: Load a foreign library. +* load-foreign-library-error:: Signalled on failure of its namesake. +* use-foreign-library:: Load a foreign library when needed. + +Callbacks + +* callback:: Returns a pointer to a defined callback. +* defcallback:: Defines a Lisp callback. +* get-callback:: Returns a pointer to a defined callback. + +@end detailmenu +@end menu + + + + +@c =================================================================== +@c CHAPTER: Introduction + +@node Introduction +@chapter Introduction + +@cffi{} is the Common Foreign Function Interface for @acronym{ANSI} +Common Lisp systems. By @dfn{foreign function} we mean a function +written in another programming language and having different data and +calling conventions than Common Lisp, namely, C. @cffi{} allows you +to call foreign functions and access foreign variables, all without +leaving the Lisp image. + +We consider this manual ever a work in progress. If you have +difficulty with anything @cffi{}-specific presented in the manual, +please contact @email{cffi-devel@@common-lisp.net,the developers} with +details. + + +@heading Motivation + +@xref{Tutorial-Comparison,, What makes Lisp different}, for +an argument in favor of @acronym{FFI} in general. + +@cffi{}'s primary role in any image is to mediate between Lisp +developers and the widely varying @acronym{FFI}s present in the +various Lisp implementations it supports. With @cffi{}, you can +define foreign function interfaces while still maintaining portability +between implementations. It is not the first Common Lisp package with +this objective; however, it is meant to be a more malleable framework +than similar packages. + + +@heading Design Philosophy + +@itemize +@item +Pointers do not carry around type information. Instead, type +information is supplied when pointers are dereferenced. + +@item +A type safe pointer interface can be developed on top of an +untyped one. It is difficult to do the opposite. + +@item +Functions are better than macros. When a macro could be used +for performance, use a compiler-macro instead. +@end itemize + + +@c =================================================================== +@c CHAPTER: Implementation Support + +@node Implementation Support +@chapter Implementation Support + +@cffi{} supports various free and commercial Lisp implementations: +Allegro CL, Corman CL, @sc{clisp}, @acronym{CMUCL}, @acronym{ECL}, +LispWorks, Open@acronym{MCL}, @acronym{SBCL} and the Scieneer CL. + +There are also plans to support Digitool @acronym{MCL}, and @acronym{GCL}. + + +@section Allegro CL + +@strong{Tested platforms:} linux/x86, linux/ppc, win32/x86, darwin/ppc. + +Version 7.0 is supported. The 8.0 beta is also known to work. Earlier +versions are untested and unsupported but patches to support them +are welcome. + +@subheading Limitations + +@itemize +@item +Does not support the @code{:long-long} type. +@end itemize + +@section Corman CL + +@strong{Tested platforms:} win32/x86. + +Versions prior to 2.51 are untested and unsupported. Also, you will +need to avoid Corman's buggy @code{COMPILE-FILE} and fasl +loader. Please follow @uref{http://www.weitz.de/corman-asdf/, these +instructions} by Edi Weitz to setup ASDF for Corman CL in a way that +works around these issues. + +@subheading Limitations + +@itemize +@item +Does not support @code{foreign-funcall}. +@end itemize + + +@section @sc{clisp} + +@strong{Tested platforms:} linux/x86, linux/ppc, win32/x86, darwin/ppc. + +Version is 2.34 or newer is required on win32/x86. For other platforms +version 2.35 or newer is required. + + +@section @acronym{CMUCL} + +@strong{Tested platforms:} linux/x86, darwin/ppc. + +Versions prior to 19B are untested. For darwin/ppc, the 2006-02 (19C) +snapshot or later is recommended. + + +@section @acronym{ECL} + +@strong{Tested platforms:} @emph{needs testing...} + +As of November 2005, the CVS version of ECL is required. It is +reported to pass all tests. + +@subheading Limitations +@itemize +@item +Does not support the @code{:long-long} type. + +@item +On platforms where ECL's dynamic FFI is not supported (ie. when +@code{:dffi} is not present in @code{*features*}), +@code{cffi:load-foreign-library} does not work and you must use ECL's +own @code{ffi:load-foreign-library} with a constant string argument. +@end itemize + + +@section Lispworks + +@strong{Tested platforms:} linux/x86, win32/x86, darwin/ppc. + +Versions prior to 4.4 are untested. + +@subheading Limitations +@itemize +@item +Does not support the @code{:long-long} type. +@end itemize + + +@section Open@acronym{MCL} + +@strong{Tested platforms:} darwin/ppc, linux/ppc. + +Open@acronym{MCL} 1.0 or newer is recommended. + + +@section @acronym{SBCL} + +@strong{Tested platforms:} linux/x86, linux/ppc, darwin/ppc. + +Version 0.9.6 or newer is recommended. + +@subheading Limitations + +@itemize +@item +Not all platforms support callbacks. +@end itemize + + +@section Scieneer CL + +@strong{Tested platforms:} linux/x86, linux/amd64. + +Version 1.2.10 or newer is recommended. Passes all tests. +The x86 and AMD64 ports feature long-double support. + + +@c =================================================================== +@c CHAPTER: An Introduction to Foreign Interfaces and CFFI + +@c This macro is merely a marker that I don't think I'll use after +@c all. +@macro tutorialsource {text} +@c \text\ +@end macro + +@c because I don't want to type this over and over +@macro clikicffi +http://www.cliki.net/CFFI +@end macro +@c TeX puts spurious newlines in when you use the above macro +@c in @examples &c. So it is expanded below in some places. + + +@node Tutorial +@chapter An Introduction to Foreign Interfaces and @acronym{CFFI} + +@c Above, I don't use the cffi macro because it breaks TeX. + +@cindex tutorial, @cffi{} +Users of many popular languages bearing semantic similarity to Lisp, +such as Perl and Python, are accustomed to having access to popular C +libraries, such as @acronym{GTK}, by way of ``bindings''. In Lisp, we +do something similar, but take a fundamentally different approach. +This tutorial first explains this difference, then explains how you +can use @cffi{}, a powerful system for calling out to C and C++ and +access C data from many Common Lisp implementations. + +@cindex foreign functions and data +The concept can be generalized to other languages; at the time of +writing, only @cffi{}'s C support is fairly complete, but C++ +support is being worked on. Therefore, we will interchangeably refer +to @dfn{foreign functions} and @dfn{foreign data}, and ``C functions'' +and ``C data''. At no time will the word ``foreign'' carry its usual, +non-programming meaning. + +This tutorial expects you to have a working understanding of both +Common Lisp and C, including the Common Lisp macro system. + +@menu +* Tutorial-Comparison:: Why FFI? +* Tutorial-Getting a URL:: An FFI use case. +* Tutorial-Loading:: Load libcurl.so. +* Tutorial-Initializing:: Call a function in libcurl.so. +* Tutorial-easy_setopt:: An advanced libcurl function. +* Tutorial-Abstraction:: Why breaking it is necessary. +* Tutorial-Lisp easy_setopt:: Semi-Lispy option interface. +* Tutorial-Memory:: In C, you collect the garbage. +* Tutorial-Callbacks:: Make useful C function pointers. +* Tutorial-Completion:: Minimal get-url functionality. +* Tutorial-Types:: Defining new foreign types. +* Tutorial-Conclusion:: What's next? +@end menu + + +@node Tutorial-Comparison +@section What makes Lisp different + +The following sums up how bindings to foreign libraries are usually +implemented in other languages, then in Common Lisp: + +@table @asis +@item Perl, Python, Java, other one-implementation languages +@cindex @acronym{SWIG} +@cindex Perl +@cindex Python +Bindings are implemented as shared objects written in C. In some +cases, the C code is generated by a tool, such as @acronym{SWIG}, but +the result is the same: a new C library that manually translates +between the language implementation's objects, such as @code{PyObject} +in Python, and whatever C object is called for, often using C +functions provided by the implementation. It also translates between +the calling conventions of the language and C. + +@item Common Lisp +@cindex @acronym{SLIME} +Bindings are written in Lisp. They can be created at-will by Lisp +programs. Lisp programmers can write new bindings and add them to the +image, using a listener such as @acronym{SLIME}, as easily as with +regular Lisp definitions. The only foreign library to load is the one +being wrapped---the one with the pure C interface; no C or other +non-Lisp compilation is required. +@end table + +@cindex advantages of @acronym{FFI} +@cindex benefits of @acronym{FFI} +We believe the advantages of the Common Lisp approach far outweigh any +disadvantages. Incremental development with a listener can be as +productive for C binding development as it is with other Lisp +development. Keeping it ``in the [Lisp] family'', as it were, makes +it much easier for you and other Lisp programmers to load and use the +bindings. Common Lisp implementations such as @acronym{CMUCL}, freed +from having to provide a C interface to their own objects, are thus +freed to be implemented in another language (as @acronym{CMUCL} is) +while still allowing programmers to call foreign functions. + +@cindex minimal bindings +Perhaps the greatest advantage is that using an @acronym{FFI} doesn't +obligate you to become a professional binding developer. Writers of +bindings for other languages usually end up maintaining or failing to +maintain complete bindings to the foreign library. Using an +@acronym{FFI}, however, means if you only need one or two functions, +you can write bindings for only those functions, and be assured that +you can just as easily add to the bindings if need be. + +@cindex C abstractions +@cindex abstractions in C +The removal of the C compiler, or C interpretation of any kind, +creates the main disadvantage: some of C's ``abstractions'' are not +available, violating information encapsulation. For example, +@code{struct}s that must be passed on the stack, or used as return +values, without corresponding functional abstractions to create and +manage the @code{struct}s, must be declared explicitly in Lisp. This +is fine for structs whose contents are ``public'', but is not so +pleasant when a struct is supposed to be ``opaque'' by convention, +even though it is not so defined.@footnote{Admittedly, this is an +advanced issue, and we encourage you to leave this text until you are +more familiar with how @cffi{} works.} + +Without an abstraction to create the struct, Lisp needs to be able to +lay out the struct in memory, so must know its internal details. + +@cindex workaround for C +In these cases, you can create a minimal C library to provide the +missing abstractions, without destroying all the advantages of the +Common Lisp approach discussed above. In the case of @code{struct}s, +you can write simple, pure C functions that tell you how many bytes a +struct requires or allocate new structs, read and write fields of the +struct, or whatever operations are supposed to be +public.@footnote{This does not apply to structs whose contents are +intended to be part of the public library interface. In those cases, +a pure Lisp struct definition is always preferred. In fact, many +prefer to stay in Lisp and break the encapsulation anyway, placing the +burden of correct library interface definition on the library.} + +@impnote{cffi-grovel, a project not yet part of @cffi{}, automates +this and other processes.} + +Another disadvantage appears when you would rather use the foreign +language than Lisp. However, someone who prefers C to Lisp is not a +likely candidate for developing a Lisp interface to a C library. + + +@node Tutorial-Getting a URL +@section Getting a @acronym{URL} + +@cindex c@acronym{URL} +The widely available @code{libcurl} is a library for downloading files +over protocols like @acronym{HTTP}. We will use @code{libcurl} with +@cffi{} to download a web page. + +Please note that there are many other ways to download files from the +web, not least the @sc{cl-curl} project to provide bindings to +@code{libcurl} via a similar @acronym{FFI}.@footnote{Specifically, +@acronym{UFFI}, an older @acronym{FFI} that takes a somewhat different +approach compared to @cffi{}. I believe that these days (December +2005) @cffi{} is more portable and actively developed, though not as +mature yet. Consensus in the free @sc{unix} Common Lisp community +seems to be that @cffi{} is preferred for new development, though +@acronym{UFFI} will likely go on for quite some time as many projects +already use it. @cffi{} includes the @code{UFFI-COMPAT} package for +complete compatibility with @acronym{UFFI}.} + +@uref{http://curl.haxx.se/libcurl/c/libcurl-tutorial.html,,libcurl-tutorial(3)} +is a tutorial for @code{libcurl} programming in C. We will follow +that to develop a binding to download a file. We will also use +@file{curl.h}, @file{easy.h}, and the @command{man} pages for the +@code{libcurl} function, all available in the @samp{curl-dev} package +or equivalent for your system, or in the c@acronym{URL} source code +package. If you have the development package, the headers should be +installed in @file{/usr/include/curl/}, and the @command{man} pages +may be accessed through your favorite @command{man} facility. + + +@node Tutorial-Loading +@section Loading foreign libraries + +@cindex loading @cffi{} +@cindex requiring @cffi{} +First of all, we will create a package to work in. You can save these +forms in a file, or just send them to the listener as they are. If +creating bindings for an @acronym{ASDF} package of yours, you will +want to add @code{:cffi} to the @code{:depends-on} list in your +@file{.asd} file. Otherwise, just use the @code{asdf:oos} function to +load @cffi{}. + +@tutorialsource{Initialization} +@lisp +(asdf:oos 'asdf:load-op :cffi) + +;;; @lispcmt{Nothing special about the "CFFI-USER" package. We're just} +;;; @lispcmt{using it as a substitute for your own CL package.} +(defpackage :cffi-user + (:use :common-lisp :cffi)) + +(in-package :cffi-user) + +(define-foreign-library libcurl + (:unix (:or "libcurl.so.3" "libcurl.so")) + (t (:default "libcurl"))) + +(use-foreign-library libcurl) +@end lisp + +@cindex foreign library load +@cindex library, foreign +Using @code{define-foreign-library} and @code{use-foreign-library}, we +have loaded @code{libcurl} into Lisp, much as the linker does when you +start a C program, or @code{common-lisp:load} does with a Lisp source +file or @acronym{FASL} file. We special-cased for @sc{unix} machines +to always load a particular version, the one this tutorial was tested +with; for those who don't care, the @code{define-foreign-library} +clause @code{(t (:default "libcurl"))} should be satisfactory, and +will adapt to various operating systems. + + +@node Tutorial-Initializing +@section Initializing @code{libcurl} + +@cindex function definition +After the introductory matter, the tutorial goes on to present the +first function you should use. + +@example +CURLcode curl_global_init(long flags); +@end example + +@noindent +Let's pick this apart into appropriate Lisp code: + +@tutorialsource{First CURLcode} +@lisp +;;; @lispcmt{A CURLcode is the universal error code. curl/curl.h says} +;;; @lispcmt{no return code will ever be removed, and new ones will be} +;;; @lispcmt{added to the end.} +(defctype curl-code :int) + +;;; @lispcmt{Initialize libcurl with FLAGS.} +(defcfun "curl_global_init" curl-code + (flags :long)) +@end lisp + +@impnote{CFFI currently assumes the UNIX viewpoint that there is one C +symbol namespace, containing all symbols in all loaded objects. This +is not so on Windows and Darwin. The interface may be changed to deal +with this.} + +Note the parallels with the original C declaration. We've defined +@code{curl-code} as a wrapping type for @code{:int}; right now, it +only marks it as special, but later we will do something more +interesting with it. The point is that we don't have to do it yet. + +@cindex calling foreign functions +Looking at @file{curl.h}, @code{CURL_GLOBAL_NOTHING}, a possible value +for @code{flags} above, is defined as @samp{0}. So we can now call +the function: + +@example +@sc{cffi-user>} (curl-global-init 0) +@result{} 0 +@end example + +@cindex looks like it worked +Looking at @file{curl.h} again, @code{0} means @code{CURLE_OK}, so it +looks like the call succeeded. Note that @cffi{} converted the +function name to a Lisp-friendly name. You can specify your own name +if you want; use @code{("curl_global_init" @var{your-name-here})} as +the @var{name} argument to @code{defcfun}. + +The tutorial goes on to have us allocate a handle. For good measure, +we should also include the deallocator. Let's look at these +functions: + +@example +CURL *curl_easy_init( ); +void curl_easy_cleanup(CURL *handle); +@end example + +Advanced users may want to define special pointer types; we will +explore this possibility later. For now, just treat every pointer as +the same: + +@tutorialsource{curl_easy handles} +@lisp +(defcfun "curl_easy_init" :pointer) + +(defcfun "curl_easy_cleanup" :void + (easy-handle :pointer)) +@end lisp + +Now we can continue with the tutorial: + +@example +@sc{cffi-user>} (defparameter *easy-handle* (curl-easy-init)) +@result{} *EASY-HANDLE* +@sc{cffi-user>} *easy-handle* +@result{} # +@end example + +@cindex pointers in Lisp +Note the print representation of a pointer. It changes depending on +what Lisp you are using, but that doesn't make any difference to +@cffi{}. + + +@node Tutorial-easy_setopt +@section Setting download options + +The @code{libcurl} tutorial says we'll want to set many options before +performing any download actions. This is done through +@code{curl_easy_setopt}: + +@c That is literally ..., not an ellipsis. +@example +CURLcode curl_easy_setopt(CURL *curl, CURLoption option, ...); +@end example + +@cindex varargs +@cindex foreign arguments +We've introduced a new twist: variable arguments. There is no obvious +translation to the @code{defcfun} form, particularly as there are four +possible argument types. Because of the way C works, we could define +four wrappers around @code{curl_easy_setopt}, one for each type; in +this case, however, we'll use the general-purpose macro +@code{foreign-funcall} to call this function. + +@cindex enumeration, C +To make things easier on ourselves, we'll create an enumeration of the +kinds of options we want to set. The @code{enum CURLoption} isn't the +most straightforward, but reading the @code{CINIT} C macro definition +should be enlightening. + +@tutorialsource{CURLoption enumeration} +@lisp +(defmacro define-curl-options (name type-offsets &rest enum-args) + "As with CFFI:DEFCENUM, except each of ENUM-ARGS is as follows: + + (NAME TYPE NUMBER) + +Where the arguments are as they are with the CINIT macro defined +in curl.h, except NAME is a keyword. + +TYPE-OFFSETS is a plist of TYPEs to their integer offsets, as +defined by the CURLOPTTYPE_LONG et al constants in curl.h." + (flet ((enumerated-value (type offset) + (+ (getf type-offsets type) offset))) + `(progn + (defcenum ,name + ,@@(loop for (name type number) in enum-args + collect (list name (enumerated-value type number)))) + ',name))) ;@lispcmt{for REPL users' sanity} + +(define-curl-options curl-option + (long 0 objectpoint 10000 functionpoint 20000 off-t 30000) + (:noprogress long 43) + (:nosignal long 99) + (:errorbuffer objectpoint 10) + (:url objectpoint 2)) +@end lisp + +With some well-placed Emacs @code{query-replace-regexp}s, you could +probably similarly define the entire @code{CURLoption} enumeration. I +have selected to transcribe a few that we will use in this tutorial. + +If you're having trouble following the macrology, just macroexpand the +@code{curl-option} definition, or see the following macroexpansion, +conveniently downcased and reformatted: + +@tutorialsource{DEFINE-CURL-OPTIONS macroexpansion} +@lisp +(progn + (defcenum curl-option + (:noprogress 43) + (:nosignal 99) + (:errorbuffer 10010) + (:url 10002)) + 'curl-option) +@end lisp + +@noindent +That seems more than reasonable. You may notice that we only use the +@var{type} to compute the real enumeration offset; we will also need +the type information later. + +First, however, let's make sure a simple call to the foreign function +works: + +@example +@sc{cffi-user>} (foreign-funcall "curl_easy_setopt" + :pointer *easy-handle* + curl-option :nosignal :long 1 curl-code) +@result{} 0 +@end example + +@code{foreign-funcall}, despite its surface simplicity, can be used to +call any C function. Its first argument is a string, naming the +function to be called. Next, for each argument, we pass the name of +the C type, which is the same as in @code{defcfun}, followed by a Lisp +object representing the data to be passed as the argument. The final +argument is the return type, for which we use the @code{curl-code} +type defined earlier. + +@code{defcfun} just puts a convenient fa@,cade on +@code{foreign-funcall}.@footnote{This isn't entirely true; some Lisps +don't support @code{foreign-funcall}, so @code{defcfun} is implemented +without it. @code{defcfun} may also perform optimizations that +@code{foreign-funcall} cannot.} Our earlier call to +@code{curl-global-init} could have been written as follows: + +@example +@sc{cffi-user>} (foreign-funcall "curl_global_init" :long 0 + curl-code) +@result{} 0 +@end example + +Before we continue, we will take a look at what @cffi{} can and can't +do, and why this is so. + + +@node Tutorial-Abstraction +@section Breaking the abstraction + +@cindex breaking the abstraction +@cindex abstraction breaking +In @ref{Tutorial-Comparison,, What makes Lisp different}, we mentioned +that writing an @acronym{FFI} sometimes requires depending on +information not provided as part of the interface. The easy option +@code{CURLOPT_WRITEDATA}, which we will not provide as part of the +Lisp interface, illustrates this issue. + +Strictly speaking, the @code{curl-option} enumeration is not +necessary; we could have used @code{:int 99} instead of +@code{curl-option :nosignal} in our call to @code{curl_easy_setopt} +above. We defined it anyway, in part to hide the fact that we are +breaking the abstraction that the C @code{enum} provides. If the +c@acronym{URL} developers decide to change those numbers later, we +must change the Lisp enumeration, because enumeration values are not +provided in the compiled C library, @code{libcurl.so.3}. + +@cffi{} works because the most useful things in C libraries --- +non-static functions and non-static variables --- are included +accessibly in @code{libcurl.so.3}. A C compiler that violated this +would be considered a worthless compiler. + +The other thing @code{define-curl-options} does is give the ``type'' +of the third argument passed to @code{curl_easy_setopt}. Using this +information, we can tell that the @code{:nosignal} option should +accept a long integer argument. We can implicitly assume @code{t} +@equiv{} 1 and @code{nil} @equiv{} 0, as it is in C, which takes care +of the fact that @code{CURLOPT_NOSIGNAL} is really asking for a +boolean. + +The ``type'' of @code{CURLOPT_WRITEDATA} is @code{objectpoint}. +However, it is really looking for a @code{FILE*}. +@code{CURLOPT_ERRORBUFFER} is looking for a @code{char*}, so there is +no obvious @cffi{} type but @code{:pointer}. + +The first thing to note is that nowhere in the C interface includes +this information; it can only be found in the manual. We could +disjoin these clearly different types ourselves, by splitting +@code{objectpoint} into @code{filepoint} and @code{charpoint}, but we +are still breaking the abstraction, because we have to augment the +entire enumeration form with this additional +information.@footnote{Another possibility is to allow the caller to +specify the desired C type of the third argument. This is essentially +what happens in a call to the function written in C.} + +@cindex streams and C +@cindex @sc{file}* and streams +The second is that the @code{CURLOPT_WRITEDATA} argument is completely +incompatible with the desired Lisp data, a +stream.@footnote{@xref{Other Kinds of Streams,,, libc, GNU C Library +Reference}, for a @acronym{GNU}-only way to extend the @code{FILE*} +type. You could use this to convert Lisp streams to the needed C +data. This would be quite involved and far outside the scope of this +tutorial.} It is probably acceptable if we are controlling every file +we might want to use as this argument, in which case we can just call +the foreign function @code{fopen}. Regardless, though, we can't write +to arbitrary streams, which is exactly what we want to do for this +application. + +Finally, note that the @code{curl_easy_setopt} interface itself is a +hack, intended to work around some of the drawbacks of C. The +definition of @code{Curl_setopt}, while long, is far less cluttered +than the equivalent disjoint-function set would be; in addition, +setting a new option in an old @code{libcurl} can generate a run-time +error rather than breaking the compile. Lisp can just as concisely +generate functions as compare values, and the ``undefined function'' +error is just as useful as any explicit error we could define here +might be. + + +@node Tutorial-Lisp easy_setopt +@section Option functions in Lisp + +We could use @code{foreign-funcall} directly every time we wanted to +call @code{curl_easy_setopt}. However, we can encapsulate some of the +necessary information with the following. + +@lisp +;;; @lispcmt{We will use this type later in a more creative way. For} +;;; @lispcmt{now, just consider it a marker that this isn't just any} +;;; @lispcmt{pointer.} +(defctype easy-handle :pointer) + +(defmacro curl-easy-setopt (easy-handle enumerated-name + value-type new-value) + "Call `curl_easy_setopt' on EASY-HANDLE, using ENUMERATED-NAME +as the OPTION. VALUE-TYPE is the CFFI foreign type of the third +argument, and NEW-VALUE is the Lisp data to be translated to the +third argument. VALUE-TYPE is not evaluated." + `(foreign-funcall "curl_easy_setopt" easy-handle ,easy-handle + curl-option ,enumerated-name + ,value-type ,new-value curl-code)) +@end lisp + +Now we define a function for each kind of argument that encodes the +correct @code{value-type} in the above. This can be done reasonably +in the @code{define-curl-options} macroexpansion; after all, that is +where the different options are listed! + +@cindex Lispy C functions +We could make @code{cl:defun} forms in the expansion that simply call +@code{curl-easy-setopt}; however, it is probably easier and clearer to +use @code{defcfun}. @code{define-curl-options} was becoming unwieldy, +so I defined some helpers in this new definition. + +@smalllisp +(defun curry-curl-option-setter (function-name option-keyword) + "Wrap the function named by FUNCTION-NAME with a version that +curries the second argument as OPTION-KEYWORD. + +This function is intended for use in DEFINE-CURL-OPTION-SETTER." + (setf (symbol-function function-name) + (let ((c-function (symbol-function function-name))) + (lambda (easy-handle new-value) + (funcall c-function easy-handle option-keyword + new-value))))) + +(defmacro define-curl-option-setter (name option-type + option-value foreign-type) + "Define (with DEFCFUN) a function NAME that calls +curl_easy_setopt. OPTION-TYPE and OPTION-VALUE are the CFFI +foreign type and value to be passed as the second argument to +easy_setopt, and FOREIGN-TYPE is the CFFI foreign type to be used +for the resultant function's third argument. + +This macro is intended for use in DEFINE-CURL-OPTIONS." + `(progn + (defcfun ("curl_easy_setopt" ,name) curl-code + (easy-handle easy-handle) + (option ,option-type) + (new-value ,foreign-type)) + (curry-curl-option-setter ',name ',option-value))) + +(defmacro define-curl-options (type-name type-offsets &rest enum-args) + "As with CFFI:DEFCENUM, except each of ENUM-ARGS is as follows: + + (NAME TYPE NUMBER) + +Where the arguments are as they are with the CINIT macro defined +in curl.h, except NAME is a keyword. + +TYPE-OFFSETS is a plist of TYPEs to their integer offsets, as +defined by the CURLOPTTYPE_LONG et al constants in curl.h. + +Also, define functions for each option named +set-`TYPE-NAME'-`OPTION-NAME', where OPTION-NAME is the NAME from +the above destructuring." + (flet ((enumerated-value (type offset) + (+ (getf type-offsets type) offset)) + ;;@lispcmt{map PROCEDURE, destructuring each of ENUM-ARGS} + (map-enum-args (procedure) + (mapcar (lambda (arg) (apply procedure arg)) enum-args)) + ;;@lispcmt{build a name like SET-CURL-OPTION-NOSIGNAL} + (make-setter-name (option-name) + (intern (concatenate + 'string "SET-" (symbol-name type-name) + "-" (symbol-name option-name))))) + `(progn + (defcenum ,type-name + ,@@(map-enum-args + (lambda (name type number) + (list name (enumerated-value type number))))) + ,@@(map-enum-args + (lambda (name type number) + (declare (ignore number)) + `(define-curl-option-setter ,(make-setter-name name) + ,type-name ,name ,(ecase type + (long :long) + (objectpoint :pointer) + (functionpoint :pointer) + (off-t :long))))) + ',type-name))) +@end smalllisp + +@noindent +Macroexpanding our @code{define-curl-options} form once more, we +see something different: + +@lisp +(progn + (defcenum curl-option + (:noprogress 43) + (:nosignal 99) + (:errorbuffer 10010) + (:url 10002)) + (define-curl-option-setter set-curl-option-noprogress + curl-option :noprogress :long) + (define-curl-option-setter set-curl-option-nosignal + curl-option :nosignal :long) + (define-curl-option-setter set-curl-option-errorbuffer + curl-option :errorbuffer :pointer) + (define-curl-option-setter set-curl-option-url + curl-option :url :pointer) + 'curl-option) +@end lisp + +@noindent +Macroexpanding one of the new @code{define-curl-option-setter} +forms yields the following: + +@lisp +(progn + (defcfun ("curl_easy_setopt" set-curl-option-nosignal) curl-code + (easy-handle easy-handle) + (option curl-option) + (new-value :long)) + (curry-curl-option-setter 'set-curl-option-nosignal ':nosignal)) +@end lisp + +@noindent +Finally, let's try this out: + +@example +@sc{cffi-user>} (set-curl-option-nosignal *easy-handle* 1) +@result{} 0 +@end example + +@noindent +Looks like it works just as well. This interface is now reasonably +high-level to wash out some of the ugliness of the thinnest possible +@code{curl_easy_setopt} @acronym{FFI}, without obscuring the remaining +C bookkeeping details we will explore. + + +@node Tutorial-Memory +@section Memory management + +According to the documentation for @code{curl_easy_setopt}, the type +of the third argument when @var{option} is @code{CURLOPT_ERRORBUFFER} +is @code{char*}. Above, we've defined +@code{set-curl-option-errorbuffer} to accept a @code{:pointer} as the +new option value. However, there is a @cffi{} type @code{:string}, +which translates Lisp strings to C strings when passed as arguments to +foreign function calls. Why not, then, use @code{:string} as the +@cffi{} type of the third argument? There are two reasons, both +related to the necessity of breaking abstraction described in +@ref{Tutorial-Abstraction,, Breaking the abstraction}. + +The first reason also applies to @code{CURLOPT_URL}, which we will use +to illustrate the point. Assuming we have changed the type of the +third argument underlying @code{set-curl-option-url} to +@code{:string}, look at these two equivalent forms. + +@lisp +(set-curl-option-url *easy-handle* "http://www.cliki.net/CFFI") + +@equiv{} (with-foreign-string (url "http://www.cliki.net/CFFI") + (foreign-funcall "curl_easy_setopt" easy-handle *easy-handle* + curl-option :url :pointer url curl-code)) +@end lisp + +@noindent +The latter, in fact, is mostly equivalent to what a foreign function +call's macroexpansion actually does. As you can see, the Lisp string +@code{"@clikicffi{}"} is copied into a @code{char} array and +null-terminated; the pointer to beginning of this array, now a C +string, is passed as a @cffi{} @code{:pointer} to the foreign +function. + +@cindex dynamic extent +@cindex foreign values with dynamic extent +Unfortunately, the C abstraction has failed us, and we must break it. +While @code{:string} works well for many @code{char*} arguments, it +does not for cases like this. As the @code{curl_easy_setopt} +documentation explains, ``The string must remain present until curl no +longer needs it, as it doesn't copy the string.'' The C string +created by @code{with-foreign-string}, however, only has dynamic +extent: it is ``deallocated'' when the body (above containing the +@code{foreign-funcall} form) exits. + +@cindex premature deallocation +If we are supposed to keep the C string around, but it goes away, what +happens when some @code{libcurl} function tries to access the +@acronym{URL} string? We have reentered the dreaded world of C +``undefined behavior''. In some Lisps, it will probably get a chunk +of the Lisp/C stack. You may segfault. You may get some random piece +of other data from the heap. Maybe, in a world where ``dynamic +extent'' is defined to be ``infinite extent'', everything will turn +out fine. Regardless, results are likely to be almost universally +unpleasant.@footnote{``@i{But I thought Lisp was supposed to protect +me from all that buggy C crap!}'' Before asking a question like that, +remember that you are a stranger in a foreign land, whose residents +have a completely different set of values.} + +Returning to the current @code{set-curl-option-url} interface, here is +what we must do: + +@lisp +(let (easy-handle) + (unwind-protect + (with-foreign-string (url "http://www.cliki.net/CFFI") + (setf easy-handle (curl-easy-init)) + (set-curl-option-url easy-handle url) + #|@lispcmt{do more with the easy-handle, like actually get the URL}|#) + (when easy-handle + (curl-easy-cleanup easy-handle)))) +@end lisp + +@c old comment to luis: I go on to say that this isn't obviously +@c extensible to new option settings that require C strings to stick +@c around, as it would involve re-evaluating the unwind-protect form +@c with more dynamic memory allocation. So I plan to show how to +@c write something similar to ObjC's NSAutoreleasePool, to be managed +@c with a simple unwind-protect form. + +@noindent +That is fine for the single string defined here, but for every string +option we want to pass, we have to surround the body of +@code{with-foreign-string} with another @code{with-foreign-string} +wrapper, or else do some extremely error-prone pointer manipulation +and size calculation in advance. We could alleviate some of the pain +with a recursively expanding macro, but this would not remove the need +to modify the block every time we want to add an option, anathema as +it is to a modular interface. + +Before modifying the code to account for this case, consider the other +reason we can't simply use @code{:string} as the foreign type. In C, +a @code{char *} is a @code{char *}, not necessarily a string. The +option @code{CURLOPT_ERRORBUFFER} accepts a @code{char *}, but does +not expect anything about the data there. However, it does expect +that some @code{libcurl} function we call later can write a C string +of up to 255 characters there. We, the callers of the function, are +expected to read the C string at a later time, exactly the opposite of +what @code{:string} implies. + +With the semantics for an input string in mind --- namely, that the +string should be kept around until we @code{curl_easy_cleanup} the +easy handle --- we are ready to extend the Lisp interface: + +@lisp +(defvar *easy-handle-cstrings* (make-hash-table) + "Hashtable of easy handles to lists of C strings that may be +safely freed after the handle is freed.") + +(defun make-easy-handle () + "Answer a new CURL easy interface handle, to which the lifetime +of C strings may be tied. See `add-curl-handle-cstring'." + (let ((easy-handle (curl-easy-init))) + (setf (gethash easy-handle *easy-handle-cstrings*) '()) + easy-handle)) + +(defun free-easy-handle (handle) + "Free CURL easy interface HANDLE and any C strings created to +be its options." + (curl-easy-cleanup handle) + (mapc #'foreign-string-free + (gethash handle *easy-handle-cstrings*)) + (remhash handle *easy-handle-cstrings*)) + +(defun add-curl-handle-cstring (handle cstring) + "Add CSTRING to be freed when HANDLE is, answering CSTRING." + (car (push cstring (gethash handle *easy-handle-cstrings*)))) +@end lisp + +@noindent +Here we have redefined the interface to create and free handles, to +associate a list of allocated C strings with each handle while it +exists. The strategy of using different function names to wrap around +simple foreign functions is more common than the solution implemented +earlier with @code{curry-curl-option-setter}, which was to modify the +function name's function slot.@footnote{There are advantages and +disadvantages to each approach; I chose to @code{(setf +symbol-function)} earlier because it entailed generating fewer magic +function names.} + +Incidentally, the next step is to redefine +@code{curry-curl-option-setter} to allocate C strings for the +appropriate length of time, given a Lisp string as the +@code{new-value} argument: + +@lisp +(defun curry-curl-option-setter (function-name option-keyword) + "Wrap the function named by FUNCTION-NAME with a version that +curries the second argument as OPTION-KEYWORD. + +This function is intended for use in DEFINE-CURL-OPTION-SETTER." + (setf (symbol-function function-name) + (let ((c-function (symbol-function function-name))) + (lambda (easy-handle new-value) + (funcall c-function easy-handle option-keyword + (if (stringp new-value) + (add-curl-handle-cstring + easy-handle + (foreign-string-alloc new-value)) + new-value)))))) +@end lisp + +@noindent +A quick analysis of the code shows that you need only reevaluate the +@code{curl-option} enumeration definition to take advantage of these +new semantics. Now, for good measure, let's reallocate the handle +with the new functions we just defined, and set its @acronym{URL}: + +@example +@sc{cffi-user>} (curl-easy-cleanup *easy-handle*) +@result{} NIL +@sc{cffi-user>} (setf *easy-handle* (make-easy-handle)) +@result{} # +@sc{cffi-user>} (set-curl-option-nosignal *easy-handle* 1) +@result{} 0 +@sc{cffi-user>} (set-curl-option-url *easy-handle* + "http://www.cliki.net/CFFI") +@result{} 0 +@end example + +@cindex strings +For fun, let's inspect the Lisp value of the C string that was created +to hold @code{"@clikicffi{}"}. By virtue of the implementation of +@code{add-curl-handle-cstring}, it should be accessible through the +hash table defined: + +@example +@sc{cffi-user>} (foreign-string-to-lisp + (car (gethash *easy-handle* *easy-handle-cstrings*))) +@result{} "http://www.cliki.net/CFFI" +@end example + +@noindent +Looks like that worked, and @code{libcurl} now knows what +@acronym{URL} we want to retrieve. + +Finally, we turn back to the @code{:errorbuffer} option mentioned at +the beginning of this section. Whereas the abstraction added to +support string inputs works fine for cases like @code{CURLOPT_URL}, it +hides the detail of keeping the C string; for @code{:errorbuffer}, +however, we need that C string. + +In a moment, we'll define something slightly cleaner, but for now, +remember that you can always hack around anything. We're modifying +handle creation, so make sure you free the old handle before +redefining @code{free-easy-handle}. + +@smalllisp +(defvar *easy-handle-errorbuffers* (make-hash-table) + "Hashtable of easy handles to C strings serving as error +writeback buffers.") + +;;; @lispcmt{An extra byte is very little to pay for peace of mind.} +(defparameter *curl-error-size* 257 + "Minimum char[] size used by cURL to report errors.") + +(defun make-easy-handle () + "Answer a new CURL easy interface handle, to which the lifetime +of C strings may be tied. See `add-curl-handle-cstring'." + (let ((easy-handle (curl-easy-init))) + (setf (gethash easy-handle *easy-handle-cstrings*) '()) + (setf (gethash easy-handle *easy-handle-errorbuffers*) + (foreign-alloc :char :count *curl-error-size* + :initial-element 0)) + easy-handle)) + +(defun free-easy-handle (handle) + "Free CURL easy interface HANDLE and any C strings created to +be its options." + (curl-easy-cleanup handle) + (foreign-free (gethash handle *easy-handle-errorbuffers*)) + (remhash handle *easy-handle-errorbuffers*) + (mapc #'foreign-string-free + (gethash handle *easy-handle-cstrings*)) + (remhash handle *easy-handle-cstrings*)) + +(defun get-easy-handle-error (handle) + "Answer a string containing HANDLE's current error message." + (foreign-string-to-lisp + (gethash handle *easy-handle-errorbuffers*))) +@end smalllisp + +Be sure to once again set the options we've set thus far. You may +wish to define yet another wrapper function to do this. + + +@node Tutorial-Callbacks +@section Calling Lisp from C + +If you have been reading +@uref{http://curl.haxx.se/libcurl/c/curl_easy_setopt.html,, +@code{curl_easy_setopt(3)}}, you should have noticed that some options +accept a function pointer. In particular, we need one function +pointer to set as @code{CURLOPT_WRITEFUNCTION}, to be called by +@code{libcurl} rather than the reverse, in order to receive data as it +is downloaded. + +A binding writer without the aid of @acronym{FFI} usually approaches +this problem by writing a C function that accepts C data, converts to +the language's internal objects, and calls the callback provided by +the user, again in a reverse of usual practices. + +The @cffi{} approach to callbacks precisely mirrors its differences +with the non-@acronym{FFI} approach on the ``calling C from Lisp'' +side, which we have dealt with exclusively up to now. That is, you +define a callback function in Lisp using @code{defcallback}, and +@cffi{} effectively creates a C function to be passed as a function +pointer. + +@impnote{This is much trickier than calling C functions from Lisp, as +it literally involves somehow generating a new C function that is as +good as any created by the compiler. Therefore, not all Lisps support +them. @xref{Implementation Support}, for information about @cffi{} +support issues in this and other areas. You may want to consider +changing to a Lisp that supports callbacks in order to continue with +this tutorial.} + +@cindex callback definition +@cindex defining callbacks +Defining a callback is very similar to defining a callout; the main +difference is that we must provide some Lisp forms to be evaluated as +part of the callback. Here is the signature for the function the +@code{:writefunction} option takes: + +@example +size_t +@var{function}(void *ptr, size_t size, size_t nmemb, void *stream); +@end example + +@impnote{size_t is almost always an unsigned int. You can get this +and many other types using feature tests for your system by using +cffi-grovel.} + +The above signature trivially translates into a @cffi{} +@code{defcallback} form, as follows. + +@lisp +;;; @lispcmt{Alias in case size_t changes.} +(defctype size :unsigned-int) + +;;; @lispcmt{To be set as the CURLOPT_WRITEFUNCTION of every easy handle.} +(defcallback easy-write size ((ptr :pointer) (size size) + (nmemb size) (stream :pointer)) + (let ((data-size (* size nmemb))) + (handler-case + ;; @lispcmt{We use the dynamically-bound *easy-write-procedure* to} + ;; @lispcmt{call a closure with useful lexical context.} + (progn (funcall (symbol-value '*easy-write-procedure*) + (foreign-string-to-lisp ptr data-size nil)) + data-size) ;@lispcmt{indicates success} + ;; @lispcmt{The WRITEFUNCTION should return something other than the} + ;; @lispcmt{#bytes available to signal an error.} + (error () (if (zerop data-size) 1 0))))) +@end lisp + +First, note the correlation of the first few forms, used to declare +the C function's signature, with the signature in C syntax. We +provide a Lisp name for the function, its return type, and a name and +type for each argument. + +In the body, we call the dynamically-bound +@code{*easy-write-procedure*} with a ``finished'' translation, of +pulling together the raw data and size into a Lisp string, rather than +deal with the data directly. As part of calling +@code{curl_easy_perform} later, we'll bind that variable to a closure +with more useful lexical bindings than the top-level +@code{defcallback} form. + +Finally, we make a halfhearted effort to prevent non-local exits from +unwinding the C stack, covering the most likely case with an +@code{error} handler, which is usually triggered +unexpectedly.@footnote{Unfortunately, we can't protect against +@emph{all} non-local exits, such as @code{return}s and @code{throw}s, +because @code{unwind-protect} cannot be used to ``short-circuit'' a +non-local exit in Common Lisp, due to proposal @code{minimal} in +@uref{http://www.lisp.org/HyperSpec/Issues/iss152-writeup.html, +@acronym{ANSI} issue @sc{Exit-Extent}}. Furthermore, binding an +@code{error} handler prevents higher-up code from invoking restarts +that may be provided under the callback's dynamic context. Such is +the way of compromise.} The reason is that most C code is written to +understand its own idiosyncratic error condition, implemented above in +the case of @code{curl_easy_perform}, and more ``undefined behavior'' +can result if we just wipe C stack frames without allowing them to +execute whatever cleanup actions as they like. + +Using the @code{CURLoption} enumeration in @file{curl.h} once more, we +can describe the new option by modifying and reevaluating +@code{define-curl-options}. + +@lisp +(define-curl-options curl-option + (long 0 objectpoint 10000 functionpoint 20000 off-t 30000) + (:noprogress long 43) + (:nosignal long 99) + (:errorbuffer objectpoint 10) + (:url objectpoint 2) + (:writefunction functionpoint 11)) ;@lispcmt{new item here} +@end lisp + +Finally, we can use the defined callback and the new +@code{set-curl-option-writefunction} to finish configuring the easy +handle, using the @code{callback} macro to retrieve a @cffi{} +@code{:pointer}, which works like a function pointer in C code. + +@example +@sc{cffi-user>} (set-curl-option-writefunction + *easy-handle* (callback easy-write)) +@result{} 0 +@end example + + +@node Tutorial-Completion +@section A complete @acronym{FFI}? + +@c TeX goes insane on @uref{@clikicffi{}} + +With all options finally set and a medium-level interface developed, +we can finish the definition and retrieve +@uref{http://www.cliki.net/CFFI}, as is done in the tutorial. + +@lisp +(defcfun "curl_easy_perform" curl-code + (handle easy-handle)) +@end lisp + +@example +@sc{cffi-user>} (with-output-to-string (contents) + (let ((*easy-write-procedure* + (lambda (string) + (write-string string contents)))) + (declare (special *easy-write-procedure*)) + (curl-easy-perform *easy-handle*))) +@result{} " +" +@end example + +Of course, that itself is slightly unwieldy, so you may want to define +a function around it that simply retrieves a @acronym{URL}. I will +leave synthesis of all the relevant @acronym{REPL} forms presented +thus far into a single function as an exercise for the reader. + +The remaining sections of this tutorial explore some advanced features +of @cffi{}; the definition of new types will receive special +attention. Some of these features are essential for particular +foreign function calls; some are very helpful when trying to develop a +Lispy interface to C. + + +@node Tutorial-Types +@section Defining new types + +We've occasionally used the @code{defctype} macro in previous sections +as a kind of documentation, much what you'd use @code{typedef} for in +C. We also tried one special kind of type definition, the +@code{defcenum} type. @xref{defcstruct}, for a definition macro that +may come in handy if you need to use C @code{struct}s as data. + +@cindex type definition +@cindex data in Lisp and C +@cindex translating types +However, all of these are mostly sugar for the powerful underlying +foreign type interface called @dfn{type translators}. You can easily +define new translators for any simple named foreign type. Since we've +defined the new type @code{curl-code} to use as the return type for +various @code{libcurl} functions, we can use that to directly convert +c@acronym{URL} errors to Lisp errors. + +@code{defctype}'s purpose is to define simple @code{typedef}-like +aliases. In order to use @dfn{type translators} we must use the +@code{define-foreign-type} macro. So let's redefine @code{curl-code} +using it. + +@lisp +(define-foreign-type curl-code-type () + () + (:actual-type :int) + (:simple-parser curl-code)) +@end lisp + +@code{define-foreign-type} is a thin wrapper around @code{defclass}. +For now, all you need to know in the context of this example is that +it does what @code{(defctype curl-code :int)} would do and, +additionally, defines a new class @code{curl-code-type} which we will +take advantage of shortly. + +The @code{CURLcode} enumeration seems to follow the typical error code +convention of @samp{0} meaning all is well, and each non-zero integer +indicating a different kind of error. We can apply that trivially to +differentiate between normal exits and error exits. + +@lisp +(define-condition curl-code-error (error) + (($code :initarg :curl-code :reader curl-error-code)) + (:report (lambda (c stream) + (format stream "libcurl function returned error ~A" + (curl-error-code c)))) + (:documentation "Signalled when a libcurl function answers +a code other than CURLE_OK.")) + +(defmethod translate-from-foreign (value (type curl-code-type)) + "Raise a CURL-CODE-ERROR if VALUE, a curl-code, is non-zero." + (if (zerop value) + :curle-ok + (error 'curl-code-error :curl-code value))) +@end lisp + +@noindent +The heart of this translator is new method +@code{translate-from-foreign}. By specializing the @var{type} +parameter on @code{curl-code-type}, we immediately modify the behavior +of every function that returns a @code{curl-code} to pass the result +through this new method. + +To see the translator in action, try invoking a function that returns +a @code{curl-code}. You need to reevaluate the respective +@code{defcfun} form so that it picks up the new @code{curl-code} +definition. + +@example +@sc{cffi-user>} (set-curl-option-nosignal *easy-handle* 1) +@result{} :CURLE-OK +@end example + +@noindent +As the result was @samp{0}, the new method returned @code{:curle-ok}, +just as specified.@footnote{It might be better to return +@code{(values)} than @code{:curle-ok} in real code, but this is good +for illustration.} I will leave disjoining the separate +@code{CURLcode}s into condition types and improving the @code{:report} +function as an exercise for you. + +The creation of @code{*easy-handle-cstrings*} and +@code{*easy-handle-errorbuffers*} as properties of @code{easy-handle}s +is a kluge. What we really want is a Lisp structure that stores these +properties along with the C pointer. Unfortunately, +@code{easy-handle} is currently just a fancy name for the foreign type +@code{:pointer}; the actual pointer object varies from Common Lisp +implementation to implementation, needing only to satisfy +@code{pointerp} and be returned from @code{make-pointer} and friends. + +One solution that would allow us to define a new Lisp structure to +represent @code{easy-handle}s would be to write a wrapper around every +function that currently takes an @code{easy-handle}; the wrapper would +extract the pointer and pass it to the foreign function. However, we +can use type translators to more elegantly integrate this +``translation'' into the foreign function calling framework, using +@code{translate-to-foreign}. + +@smalllisp +(defclass easy-handle () + ((pointer :initform (curl-easy-init) + :documentation "Foreign pointer from curl_easy_init") + (error-buffer + :initform (foreign-alloc :char :count *curl-error-size* + :initial-element 0) + :documentation "C string describing last error") + (c-strings :initform '() + :documentation "C strings set as options")) + (:documentation "I am a parameterization you may pass to +curl-easy-perform to perform a cURL network protocol request.")) + +(defmethod initialize-instance :after ((self easy-handle) &key) + (set-curl-option-errorbuffer self (slot-value self 'error-buffer))) + +(defun add-curl-handle-cstring (handle cstring) + "Add CSTRING to be freed when HANDLE is, answering CSTRING." + (car (push cstring (slot-value handle 'c-strings)))) + +(defun get-easy-handle-error (handle) + "Answer a string containing HANDLE's current error message." + (foreign-string-to-lisp + (slot-value handle 'error-buffer))) + +(defun free-easy-handle (handle) + "Free CURL easy interface HANDLE and any C strings created to +be its options." + (with-slots (pointer error-buffer c-strings) handle + (curl-easy-cleanup pointer) + (foreign-free error-buffer) + (mapc #'foreign-string-free c-strings))) + +(define-foreign-type easy-handle-type () + () + (:actual-type :pointer) + (:simple-parser easy-handle)) + +(defmethod translate-to-foreign (handle (type easy-handle-type)) + "Extract the pointer from an easy-HANDLE." + (slot-value handle 'pointer)) +@end smalllisp + +While we changed some of the Lisp functions defined earlier to use +@acronym{CLOS} slots rather than hash tables, the foreign functions +work just as well as they did before. + +@cindex limitations of type translators +The greatest strength, and the greatest limitation, of the type +translator comes from its generalized interface. As stated +previously, we could define all foreign function calls in terms of the +primitive foreign types provided by @cffi{}. The type translator +interface allows us to cleanly specify the relationship between Lisp +and C data, independent of where it appears in a function call. This +independence comes at a price; for example, it cannot be used to +modify translation semantics based on other arguments to a function +call. In these cases, you should rely on other features of Lisp, +rather than the powerful, yet domain-specific, type translator +interface. + + +@node Tutorial-Conclusion +@section What's next? + +@cffi{} provides a rich and powerful foundation for communicating with +foreign libraries; as we have seen, it is up to you to make that +experience a pleasantly Lispy one. This tutorial does not cover all +the features of @cffi{}; please see the rest of the manual for +details. In particular, if something seems obviously missing, it is +likely that either code or a good reason for lack of code is already +present. + +@impnote{There are some other things in @cffi{} that might deserve +tutorial sections, such as define-foreign-type, +free-translated-object, or structs. Let us know which ones you care +about.} + + +@c =================================================================== +@c CHAPTER: Wrapper generators + +@node Wrapper generators +@chapter Wrapper generators + +@cffi{}'s interface is designed for human programmers, being aimed at +aesthetic as well as technical sophistication. However, there are a +few programs aimed at translating C and C++ header files, or +approximations thereof, into @cffi{} forms constituting a foreign +interface to the symbols in those files. + +These wrapper generators are known to support output of @cffi{} forms. + +@table @asis +@item @uref{http://www.cliki.net/Verrazano,Verrazano} +Designed specifically for Common Lisp. Uses @acronym{GCC}'s parser +output in @acronym{XML} format to discover functions, variables, and +other header file data. This means you need @acronym{GCC} to generate +forms; on the other hand, the parser employed is mostly compliant with +@acronym{ANSI} C. + +@item @uref{http://www.cliki.net/SWIG,SWIG} +A foreign interface generator originally designed to generate Python +bindings, it has been ported to many other systems, including @cffi{} +in version 1.3.28. Includes its own C declaration munger, not +intended to be fully-compliant with @acronym{ANSI} C. +@end table + +First, this manual does not describe use of these other programs; they +have documentation of their own. If you have problems using a +generated interface, please look at the output @cffi{} forms and +verify that they are a correct @cffi{} interface to the library in +question; if they are correct, contact @cffi{} developers with +details, keeping in mind that they communicate in terms of those forms +rather than any particular wrapper generator. Otherwise, contact the +maintainers of the wrapper generator you are using, provided you can +reasonably expect more accuracy from the generator. + +When is more accuracy an unreasonable expectation? As described in +the tutorial (@pxref{Tutorial-Abstraction,, Breaking the +abstraction}), the information in C declarations is insufficient to +completely describe every interface. In fact, it is quite common to +run into an interface that cannot be handled automatically, and +generators should be excused from generating a complete interface in +these cases. + +As further described in the tutorial, the thinnest Lisp interface to a +C function is not always the most pleasant one. In many cases, you +will want to manually write a Lispier interface to the C functions +that interest you. + +Wrapper generators should be treated as time-savers, not complete +automation of the full foreign interface writing job. Reports of the +amount of work done by generators vary from 30% to 90%. The +incremental development style enabled by @cffi{} generally reduces +this proportion below that for languages like Python. + +@c Where I got the above 30-90% figures: +@c 30%: lemonodor's post about SWIG +@c 90%: Balooga on #lisp. He said 99%, but that's probably an +@c exaggeration (leave it to me to pass judgement :) +@c -stephen + + +@c =================================================================== +@c CHAPTER: Foreign Types + +@node Foreign Types +@chapter Foreign Types + +Foreign types describe how data is translated back and forth between C +and Lisp. @cffi{} provides various built-in types and allows the user to +define new types. + +@menu +* Built-In Types:: +* Other Types:: +* Defining Foreign Types:: +* Foreign Type Translators:: +* Optimizing Type Translators:: +* Foreign Structure Types:: +* Operations on Types:: +* Allocating Foreign Objects:: + +Dictionary + +* convert-from-foreign:: +* convert-to-foreign:: +* defbitfield:: +* defcstruct:: +* defcunion:: +* defctype:: +* defcenum:: +@c * define-type-spec-parser:: +* define-foreign-type:: +* define-parse-method:: +@c * explain-foreign-slot-value: +* foreign-bitfield-symbols:: +* foreign-bitfield-value:: +* foreign-enum-keyword:: +* foreign-enum-value:: +* foreign-slot-names:: +* foreign-slot-offset:: +* foreign-slot-pointer:: +* foreign-slot-value:: +* foreign-type-alignment:: +* foreign-type-size:: +* free-converted-object:: +* free-translated-object:: +* translate-from-foreign:: +* translate-to-foreign:: +* with-foreign-slots:: +@end menu + +@node Built-In Types +@section Built-In Types + +@ForeignType{:char} +@ForeignType{:unsigned-char} +@ForeignType{:short} +@ForeignType{:unsigned-short} +@ForeignType{:int} +@ForeignType{:unsigned-int} +@ForeignType{:long} +@ForeignType{:unsigned-long} +@ForeignType{:long-long} +@ForeignType{:unsigned-long-long} + +These types correspond to the native C integer types according to the +@acronym{ABI} of the Lisp implementation's host system. + +@ForeignType{:uchar} +@ForeignType{:ushort} +@ForeignType{:uint} +@ForeignType{:ulong} +@ForeignType{:llong} +@ForeignType{:ullong} + +For convenience, the above types are provided as shortcuts for +@code{unsigned-char}, @code{unsigned-short}, @code{unsigned-int}, +@code{unsigned-long}, @code{long-long} and @code{unsigned-long-long}, +respectively. + +@code{:long-long} and @code{:unsigned-long-long} are not supported on +all implementations. When those types are @strong{not} available, the +symbol @code{cffi-features:no-long-long} is pushed into +@code{*features*}. + +@ForeignType{:int8} +@ForeignType{:uint8} +@ForeignType{:int16} +@ForeignType{:uint16} +@ForeignType{:int32} +@ForeignType{:uint32} +@ForeignType{:int64} +@ForeignType{:uint64} + +Foreign integer types of specific sizes, corresponding to the C types +defined in @code{stdint.h}. + +@c @ForeignType{:size} +@c @ForeignType{:ssize} +@c @ForeignType{:ptrdiff} +@c @ForeignType{:time} + +@c Foreign integer types corresponding to the standard C types (without +@c the @code{_t} suffix). + +@c @impnote{These are not implemented yet. --luis} + +@c @impnote{I'm sure there are more of these that could be useful, let's +@c add any types that can't be defined portably to this list as +@c necessary. --james} + +@ForeignType{:float} +@ForeignType{:double} + +On all systems, the @code{:float} and @code{:double} types represent a +C @code{float} and @code{double}, respectively. On most but not all +systems, @code{:float} and @code{:double} represent a Lisp +@code{single-float} and @code{double-float}, respectively. It is not +so useful to consider the relationship between Lisp types and C types +as isomorphic, as simply to recognize the relationship, and relative +precision, among each respective category. + +@ForeignType{:long-double} + +This type is only supported on SCL. + +@ForeignType{:pointer &optional type} + +A foreign pointer to an object of any type, corresponding to +@code{void *}. You can optionally specify type of pointer +(e.g. @code{(:pointer :char)}). Although @cffi{} won't do anything +with that information yet, it is useful for documentation purposes. + +@ForeignType{:void} + +No type at all. Only valid as the return type of a function. + +@node Other Types +@section Other Types + +@cffi{} also provides a few useful types that aren't built-in C +types. + +@ForeignType{:string} + +The @code{:string} type performs automatic conversion between Lisp and +C strings. Note that, in the case of functions the converted C string +will have dynamic extent (i.e.@: it will be automatically freed after +the foreign function returns). + +In addition to Lisp strings, this type will also convert +Lisp arrays of element type @code{(unsigned-byte 8)} and will pass +foreign pointers unmodified. + +A method for @ref{free-translated-object} is specialized for this +type. So, for example, foreign strings allocated by this type and +passed to a foreign function will be freed after the function +returns. + +@lisp +CFFI> (foreign-funcall "getenv" :string "SHELL" :string) +@result{} "/bin/bash" + +CFFI> (with-foreign-string (str "abcdef") + (foreign-funcall "strlen" :string str :int)) +@result{} 6 + +CFFI> (let ((str (make-array 4 :element-type '(unsigned-byte 8) + :initial-element 65))) + (foreign-funcall "strlen" :string str :int)) +@result{} 4 +@end lisp + +@ForeignType{:string+ptr} + +Like @code{:string} but returns a list with two values when convert +from C to Lisp: a Lisp string and the C string's foreign pointer. + +@lisp +CFFI> (foreign-funcall "getenv" :string "SHELL" :string+ptr) +@result{} ("/bin/bash" #.(SB-SYS:INT-SAP #XBFFFFC6F)) +@end lisp + +@ForeignType{:boolean &optional (base-type :int)} + +The @code{:boolean} type converts between a Lisp boolean and a C +boolean. It canonicalizes to @var{base-type} which is @code{:int} by +default. + +@lisp +(convert-to-foreign nil :boolean) @result{} 0 +(convert-to-foreign t :boolean) @result{} 1 +(convert-from-foreign 0 :boolean) @result{} nil +(convert-from-foreign 1 :boolean) @result{} t +@end lisp + +@ForeignType{:wrapper base-type &key to-c from-c} + +The @code{:wrapper} type stores two symbols passed to the @var{to-c} +and @var{from-c} arguments. When a value is being translated to or +from C, this type @code{funcall}s the respective symbol. + +@code{:wrapper} types will be typedefs for @var{base-type} and will +inherit its translators, if any. + +Here's an example of how the @code{:boolean} type could be defined in +terms of @code{:wrapper}. + +@lisp +(defun bool-c-to-lisp (value) + (not (zerop value))) + +(defun bool-lisp-to-c (value) + (if value 1 0)) + +(defctype my-bool (:wrapper :int :from-c bool-c-to-lisp + :to-c bool-lisp-to-c)) + +(convert-to-foreign nil 'my-bool) @result{} 0 +(convert-from-foreign 1 'my-bool) @result{} t +@end lisp + +@node Defining Foreign Types +@section Defining Foreign Types + +You can define simple C-like @code{typedef}s through the +@code{defctype} macro. Defining a typedef is as simple as giving +@code{defctype} a new name and the name of the type to be wrapped. + +@lisp +;;; @lispcmt{Define MY-INT as an alias for the built-in type :INT.} +(defctype my-int :int) +@end lisp + +With this type definition, one can, for instance, declare arguments to +foreign functions as having the type @code{my-int}, and they will be +passed as integers. + +@subheading More complex types + +@cffi{} offers another way to define types through +@code{define-foreign-type}, a thin wrapper macro around +@code{defclass}. As an example, let's go through the steps needed to +define a @code{(my-string &key encoding)} type. First, we need to +define our type class: + +@lisp +(define-foreign-type my-string-type () + ((encoding :reader string-type-encoding :initarg :encoding)) + (:actual-type :pointer)) +@end lisp + +The @code{:actual-type} class option tells CFFI that this type will +ultimately be passed to and received from foreign code as a +@code{:pointer}. Now you need to tell CFFI how to parse a type +specification such as @code{(my-string :encoding :utf8)} into an +instance of @code{my-string-type}. We do that with +@code{define-parse-method}: + +@lisp +(define-parse-method my-string (&key (encoding :utf-8)) + (make-instance 'my-string-type :encoding encoding)) +@end lisp + +The next section describes how make this type actually translate +between C and Lisp strings. + +@node Foreign Type Translators +@section Foreign Type Translators + +Type translators are used to automatically convert Lisp values to or +from foreign values. For example, using type translators, one can +take the @code{my-string} type defined in the previous section and +specify that it should: + +@itemize +@item +convert C strings to Lisp strings; +@item +convert Lisp strings to newly allocated C strings; +@item +free said C strings when they are no longer needed. +@end itemize + +In order to tell @cffi{} how to automatically convert Lisp values to +foreign values, define a specialized method for the +@code{translate-to-foreign} generic function: + +@lisp +;;; @lispcmt{Define a method that converts Lisp strings to C strings.} +(defmethod translate-to-foreign (string (type my-string-type)) + (foreign-string-alloc string :encoding (string-type-encoding type))) +@end lisp + +@noindent +From now on, whenever an object is passed as a @code{my-string} to a +foreign function, this method will be invoked to convert the Lisp +value. To perform the inverse operation, which is needed for functions +that return a @code{my-string}, specialize the +@code{translate-from-foreign} generic function in the same manner: + +@lisp +;;; @lispcmt{Define a method that converts C strings to Lisp strings.} +(defmethod translate-from-foreign (pointer (type my-string-type)) + (foreign-string-to-lisp pointer :encoding (string-type-encoding type))) +@end lisp + +@noindent +When a @code{translate-to-foreign} method requires allocation of +foreign memory, you must also define a @code{free-translated-object} +method to free the memory once the foreign object is no longer needed, +otherwise you'll be faced with memory leaks. This generic function is +called automatically by @cffi{} when passing objects to foreign +functions. Let's do that: + +@lisp +;;; @lispcmt{Free strings allocated by translate-to-foreign.} +(defmethod free-translated-object (pointer (type my-string-type) param) + (declare (ignore param)) + (foreign-string-free pointer)) +@end lisp + +@noindent +In this specific example, we don't need the @var{param} argument, so +we ignore it. See @ref{free-translated-object}, for an explanation of +its purpose and how you can use it. + +A type translator does not necessarily need to convert the value. For +example, one could define a typedef for @code{:pointer} that ensures, +in the @code{translate-to-foreign} method, that the value is not a +null pointer, signalling an error if a null pointer is passed. This +would prevent some pointer errors when calling foreign functions that +cannot handle null pointers. + +@strong{Please note:} these methods are meant as extensible hooks +only, and you should not call them directly. Use +@code{convert-to-foreign}, @code{convert-from-foreign} and +@code{free-converted-object} instead. + +@xref{Tutorial-Types,, Defining new types}, for another example of +type translators. + +@node Optimizing Type Translators +@section Optimizing Type Translators + +@cindex type translators, optimizing +@cindex compiler macros for type translation +@cindex defining type-translation compiler macros +Being based on generic functions, the type translation mechanism +described above can add a bit of overhead. This is usually not +significant, but we nevertheless provide a way of getting rid of the +overhead for the cases where it matters. + +A good way to understand this issue is to look at the code generated +by @code{defcfun}. Consider the following example using the previously +defined @code{my-string} type: + +@lisp +CFFI> (macroexpand-1 '(defcfun foo my-string (x my-string))) +;; (simplified, downcased, etc...) +(defun foo (x) + (multiple-value-bind (#:G2019 #:PARAM3149) + (translate-to-foreign x #) + (unwind-protect + (translate-from-foreign + (foreign-funcall "foo" :pointer #:G2019 :pointer) + #) + (free-translated-object #:G2019 # + #:PARAM3149)))) +@end lisp + +@noindent +In order to get rid of those generic function calls, @cffi{} has +another set of extensible generic functions that provide functionality +similar to @acronym{CL}'s compiler macros: +@code{expand-to-foreign-dyn}, @code{expand-to-foreign} and +@code{expand-from-foreign}. Here's how one could define a +@code{my-boolean} with them: + +@lisp +(define-foreign-type my-boolean-type () + () + (:actual-type :int) + (:simple-parser my-boolean)) + +(defmethod expand-to-foreign (value (type my-boolean-type)) + `(if ,value 1 0)) + +(defmethod expand-from-foreign (value (type my-boolean-type)) + `(not (zerop ,value))) +@end lisp + +@noindent +And here's what the macroexpansion of a function using this type would +look like: + +@lisp +CFFI> (macroexpand-1 '(defcfun bar my-boolean (x my-boolean))) +;; (simplified, downcased, etc...) +(defun bar (x) + (let ((#:g3182 (if x 1 0))) + (not (zerop (foreign-funcall "bar" :int #:g3182 :int))))) +@end lisp + +@noindent +No generic function overhead. + +Let's go back to our @code{my-string} type. The expansion interface +has no equivalent of @code{free-translated-object}; you must instead +define a method on @code{expand-to-foreign-dyn}, the third generic +function in this interface. This is especially useful when you can +allocate something much more efficiently if you know the object has +dynamic extent, as is the case with function calls that don't save the +relevant allocated arguments. + +This exactly what we need for the @code{my-string} type: + +@lisp +(defmethod expand-from-foreign (form (type my-string-type)) + `(foreign-string-to-lisp ,form)) + +(defmethod expand-to-foreign-dyn (value var body (type my-string-type)) + (let ((encoding (string-type-encoding type))) + `(with-foreign-string (,var ,value :encoding ',encoding) + ,@@body))) +@end lisp + +@noindent +So let's look at the macro expansion: + +@lisp +CFFI> (macroexpand-1 '(defcfun foo my-string (x my-string))) +;; (simplified, downcased, etc...) +(defun foo (x) + (with-foreign-string (#:G2021 X :encoding ':utf-8) + (foreign-string-to-lisp + (foreign-funcall "foo" :pointer #:g2021 :pointer)))) +@end lisp + +@noindent +Again, no generic function overhead. + +@subheading Other details + +To short-circuit expansion and use the @code{translate-*} functions +instead, simply call the next method. Return its result in cases +where your method cannot generate an appropriate replacement for it. +This analogous to the @code{&whole form} mechanism compiler macros +provide. + +The @code{expand-*} methods have precedence over their +@code{translate-*} counterparts and are guaranteed to be used in +@code{defcfun}, @code{foreign-funcall}, @code{defcvar} and +@code{defcallback}. If you define a method on each of the +@code{expand-*} generic functions, you are guaranteed to have full +control over the expressions generated for type translation in these +macros. + +They may or may not be used in other @cffi{} operators that need to +translate between Lisp and C data; you may only assume that +@code{expand-*} methods will probably only be called during Lisp +compilation. + +@code{expand-to-foreign-dyn} has precedence over +@code{expand-to-foreign} and is only used in @code{defcfun} and +@code{foreign-funcall}, only making sense in those contexts. + +@strong{Important note:} this set of generic functions is called at +macroexpansion time. Methods are defined when loaded or evaluated, +not compiled. You are responsible for ensuring that your +@code{expand-*} methods are defined when the @code{foreign-funcall} or +other forms that use them are compiled. One way to do this is to put +the method definitions earlier in the file and inside an appropriate +@code{eval-when} form; another way is to always load a separate Lisp +or @acronym{FASL} file containing your @code{expand-*} definitions +before compiling files with forms that ought to use them. Otherwise, +they will not be found and the runtime translators will be used +instead. + +@node Foreign Structure Types +@section Foreign Structure Types + +For more involved C types than simple aliases to built-in types, such +as you can make with @code{defctype}, @cffi{} allows declaration of +structures and unions with @code{defcstruct} and @code{defcunion}. + +For example, consider this fictional C structure declaration holding +some personal information: + +@example +struct person @{ + int number; + char* reason; +@}; +@end example + +@noindent +The equivalent @code{defcstruct} form follows: + +@lisp +(defcstruct person + (number :int) + (reason :string)) +@end lisp + +@cffi{} knows how to align C @code{struct}s, and how to figure in +padding between struct elements. + +Please note that this interface is only for those that must know about +the values contained in a relevant struct. If the library you are +interfacing returns an opaque pointer that needs only be passed to +other C library functions, by all means just use @code{:pointer} or a +type-safe definition munged together with @code{defctype} and type +translation. + +@node Operations on Types +@section Operations on Types + +@impnote{Which ``operations'' are worth going over here? --stephen} + +@node Allocating Foreign Objects +@section Allocating Foreign Objects + +@c I moved this because I moved with-foreign-object to the Pointers +@c chapter, where foreign-alloc is. + +@xref{Allocating Foreign Memory}. + + +@c =================================================================== +@c CONVERT-FROM-FOREIGN + +@node convert-from-foreign +@unnumberedsec convert-from-foreign +@subheading Syntax +@Function{convert-from-foreign foreign-value type @result{} value} + +@subheading Arguments and Values + +@table @var +@item foreign-value +The primitive C value as returned from a primitive foreign function or +from @code{convert-to-foreign}. + +@item type +A @cffi{} type specifier. + +@item value +The Lisp value translated from @var{foreign-value}. +@end table + +@subheading Description + +This is an external interface to the type translation facility. In +the implementation, all foreign functions are ultimately defined as +type translation wrappers around primitive foreign function +invocations. + +This function is available mostly for inspection of the type +translation process, and possibly optimization of special cases of +your foreign function calls. + +Its behavior is better described under @code{translate-from-foreign}'s +documentation. + +@subheading Examples + +@lisp +CFFI-USER> (convert-to-foreign "a boat" :string) +@result{} # +@result{} (T) +CFFI-USER> (convert-from-foreign * :string) +@result{} "a boat" +@end lisp + +@subheading See Also +@seealso{convert-to-foreign} @* +@seealso{translate-from-foreign} + + +@c =================================================================== +@c CONVERT-TO-FOREIGN + +@node convert-to-foreign +@unnumberedsec convert-to-foreign +@subheading Syntax +@Function{convert-to-foreign value type @result{} foreign-value, alloc-params} + +@subheading Arguments and Values + +@table @var +@item value +The Lisp object to be translated to a foreign object. + +@item type +A @cffi{} type specifier. + +@item foreign-value +The primitive C value, ready to be passed to a primitive foreign +function. + +@item alloc-params +Something of a translation state; you must pass it to +@code{free-converted-object} along with the foreign value for that to +work. +@end table + +@subheading Description + +This is an external interface to the type translation facility. In +the implementation, all foreign functions are ultimately defined as +type translation wrappers around primitive foreign function +invocations. + +This function is available mostly for inspection of the type +translation process, and possibly optimization of special cases of +your foreign function calls. + +Its behavior is better described under @code{translate-to-foreign}'s +documentation. + +@subheading Examples + +@lisp +CFFI-USER> (convert-to-foreign t :boolean) +@result{} 1 +@result{} (NIL) +CFFI-USER> (convert-to-foreign "hello, world" :string) +@result{} # +@result{} (T) +CFFI-USER> (code-char (mem-aref * :char 5)) +@result{} #\, +@end lisp + +@subheading See Also +@seealso{convert-from-foreign} @* +@seealso{free-converted-object} @* +@seealso{translate-to-foreign} + + +@c =================================================================== +@c DEFBITFIELD + +@node defbitfield +@unnumberedsec defbitfield +@subheading Syntax +@Macro{defbitfield name-and-options &body masks} + +masks ::= [docstring] @{ (symbol value) @}* @* +name-and-options ::= name | (name &optional (base-type :int)) + +@subheading Arguments and Values + +@table @var +@item name +The name of the new bitfield type. + +@item docstring +A documentation string, ignored. + +@item base-type +A symbol denoting a foreign type. + +@item symbol +A Lisp symbol. + +@item value +An integer representing a bitmask. +@end table + +@subheading Description +The @code{defbitfield} macro is used to define foreign types that map +lists of symbols to integer values. + +If @var{value} is omitted, it will be computed as follows: find the +greatest @var{value} previously used, including those so computed, +with only a single 1-bit in its binary representation (that is, powers +of two), and left-shift it by one. This rule guarantees that a +computed @var{value} cannot clash with previous values, but may clash +with future explicitly specified values. + +Symbol lists will be automatically converted to values and vice versa +when being passed as arguments to or returned from foreign functions, +respectively. The same applies to any other situations where an object +of a bitfield type is expected. + +Types defined with @code{defbitfield} canonicalize to @var{base-type} +which is @code{:int} by default. + +@subheading Examples +@lisp +(defbitfield open-flags + (:rdonly #x0000) + :wronly ;@lispcmt{#x0001} + :rdwr ;@lispcmt{@dots{}} + :nonblock + :append + (:creat #x0200)) + ;; @lispcmt{etc@dots{}} + +CFFI> (foreign-bitfield-symbols 'open-flags #b1101) +@result{} (:RDONLY :WRONLY :NONBLOCK :APPEND) + +CFFI> (foreign-bitfield-value 'open-flags '(:rdwr :creat)) +@result{} 514 ; #x0202 + +(defcfun ("open" unix-open) :int + (path :string) + (flags open-flags) + (mode :uint16)) ; unportable + +CFFI> (unix-open "/tmp/foo" '(:wronly :creat) #o644) +@result{} # + +;;; @lispcmt{Consider also the following lispier wrapper around open()} +(defun lispier-open (path mode &rest flags) + (unix-open path flags mode)) +@end lisp + +@subheading See Also +@seealso{foreign-bitfield-value} @* +@seealso{foreign-bitfield-symbols} + + +@c =================================================================== +@c DEFCSTRUCT + +@node defcstruct +@unnumberedsec defcstruct +@subheading Syntax +@Macro{defcstruct name-and-options &body doc-and-slots @result{} name} + +name-and-options ::= structure-name | (structure-name &key size) + +doc-and-slots ::= [docstring] @{ (slot-name slot-type &key count offset) @}* + +@subheading Arguments and Values + +@table @var +@item structure-name +The name of new structure type. + +@item docstring +A documentation string, ignored. + +@item slot-name +A symbol naming the slot. It must be unique among slot names in this +structure. + +@item size +Use this option to override the size (in bytes) of the struct. + +@item slot-type +The type specifier for the slot. + +@item count +Used to declare an array of size @var{count} inside the +structure. Defaults to @code{1} as such an array and a single element +are semantically equivalent. + +@item offset +Overrides the slot's offset. The next slot's offset is calculated +based on this one. +@end table + +@subheading Description +This defines a new @cffi{} aggregate type akin to C @code{struct}s. +In other words, it specifies that foreign objects of the type +@var{structure-name} are groups of different pieces of data, or +``slots'', of the @var{slot-type}s, distinguished from each other by +the @var{slot-name}s. Each structure is located in memory at a +position, and the slots are allocated sequentially beginning at that +point in memory (with some padding allowances as defined by the C +@acronym{ABI}, unless otherwise requested by specifying an +@var{offset} from the beginning of the structure (offset 0). + +In other words, it is isomorphic to the C @code{struct}, giving +several extra features. + +There are two kinds of slots, for the two kinds of @cffi{} types: + +@table @dfn +@item Simple +Contain a single instance of a type that canonicalizes to a built-in +type, such as @code{:long} or @code{:pointer}. Used for simple +@cffi{} types. + +@item Aggregate +Contain an embedded structure or union, or an array of objects. Used +for aggregate @cffi{} types. +@end table + +The use of @acronym{CLOS} terminology for the structure-related +features is intentional; structure definitions are very much like +classes with (far) fewer features. + +@subheading Examples +@lisp +(defcstruct point + "Pointer structure." + (x :int) + (y :int)) + +CFFI> (with-foreign-object (ptr 'point) + ;; @lispcmt{Initialize the slots} + (setf (foreign-slot-value ptr 'point 'x) 42 + (foreign-slot-value ptr 'point 'y) 42) + ;; @lispcmt{Return a list with the coordinates} + (with-foreign-slots ((x y) ptr point) + (list x y))) +@result{} (42 42) +@end lisp + +@lisp +;; @lispcmt{Using the :size and :offset options to define a partial structure.} +;; @lispcmt{(this is useful when you are interested in only a few slots} +;; @lispcmt{of a big foreign structure)} + +(defcstruct (foo :size 32) + "Some struct with 32 bytes." + ; @lispcmt{<16 bytes we don't care about>} + (x :int :offset 16) ; @lispcmt{an int at offset 16} + (y :int) ; @lispcmt{another int at offset 16+sizeof(int)} + ; @lispcmt{} + (z :char :offset 24)) ; @lispcmt{a char at offset 24} + ; @lispcmt{<7 more bytes ignored (since size is 32)>} + +CFFI> (foreign-type-size 'foo) +@result{} 32 +@end lisp + +@lisp +;;; @lispcmt{Using :count to define arrays inside of a struct.} +(defcstruct video_tuner + (name :char :count 32)) +@end lisp + +@subheading See Also +@seealso{foreign-slot-pointer} @* +@seealso{foreign-slot-value} @* +@seealso{with-foreign-slots} + + +@c =================================================================== +@c DEFCUNION + +@node defcunion +@unnumberedsec defcunion +@subheading Syntax +@Macro{defcunion name &body doc-and-slots @result{} name} + +doc-and-slots ::= [docstring] @{ (slot-name slot-type &key count) @}* + +@subheading Arguments and Values + +@table @var +@item name +The name of new union type. + +@item docstring +A documentation string, ignored. + +@item slot-name +A symbol naming the slot. + +@item slot-type +The type specifier for the slot. + +@item count +Used to declare an array of size @var{count} inside the +structure. +@end table + +@subheading Description +A union is a structure in which all slots have an offset of zero. It +is isomorphic to the C @code{union}. Therefore, you should use the +usual foreign structure operations for accessing a union's slots. + +@subheading Examples +@lisp +(defcunion uint32-bytes + (int-value :unsigned-int) + (bytes :unsigned-char :count 4)) +@end lisp + +@subheading See Also +@seealso{foreign-slot-pointer} @* +@seealso{foreign-slot-value} + + +@c =================================================================== +@c DEFCTYPE + +@node defctype +@unnumberedsec defctype +@subheading Syntax +@Macro{defctype name base-type &optional documentation} + +@subheading Arguments and Values + +@table @var +@item name +The name of the new foreign type. + +@item base-type +A symbol or a list defining the new type. + +@item documentation +A documentation string, currently ignored. +@end table + +@subheading Description +The @code{defctype} macro provides a mechanism similar to C's +@code{typedef} to define new types. The new type inherits +@var{base-type}'s translators, if any. + +There is no way to define translations for types for types defined +with @code{defctype}. For that, you should use +@ref{define-foreign-type}. + +@subheading Examples +@lisp +(defctype my-string :string + "My own string type.") + +(defctype long-bools (:boolean :long) + "Booleans that map to C longs.") +@end lisp + +@subheading See Also +@seealso{define-foreign-type} + + +@c =================================================================== +@c DEFCENUM + +@node defcenum +@unnumberedsec defcenum +@subheading Syntax +@Macro{defcenum name-and-options &body enum-list} + +enum-list ::= [docstring] @{ keyword | (keyword value) @}* +name-and-options ::= name | (name &optional (base-type :int)) + +@subheading Arguments and Values + +@table @var +@item name +The name of the new enum type. + +@item docstring +A documentation string, ignored. + +@item base-type +A symbol denoting a foreign type. + +@item keyword +A keyword symbol. + +@item value +An index value for a keyword. +@end table + +@subheading Description +The @code{defcenum} macro is used to define foreign types that map +keyword symbols to integer values, similar to the C @code{enum} type. + +If @var{value} is omitted its value will either be 0, if it's the +first entry, or it it will continue the progression from the last +specified value. + +Keywords will be automatically converted to values and vice-versa when +being passed as arguments to or returned from foreign functions, +respectively. The same applies to any other situations where an object +of an @code{enum} type is expected. + +Types defined with @code{defcenum} canonicalize to @var{base-type} +which is @code{:int} by default. + +@subheading Examples +@lisp +(defcenum boolean + :no + :yes) + +CFFI> (foreign-enum-value 'boolean :no) +@result{} 0 +@end lisp + +@lisp +(defcenum numbers + (:one 1) + :two + (:four 4)) + +CFFI> (foreign-enum-keyword 'numbers 2) +@result{} :TWO +@end lisp + +@subheading See Also +@seealso{foreign-enum-value} @* +@seealso{foreign-enum-keyword} + + +@c =================================================================== +@c DEFINE-FOREIGN-TYPE + +@node define-foreign-type +@unnumberedsec define-foreign-type +@subheading Syntax +@Macro{define-foreign-type class-name supers slots &rest options @result{} class-name} + +options ::= (@code{:actual-type} @var{type}) | @ + (@code{:simple-parser} @var{symbol}) | @ + @emph{regular defclass option} + +@subheading Arguments and Values + +@table @var +@item class-name +A symbol naming the new foreign type class. + +@item supers +A list of symbols naming the super classes. + +@item slots +A list of slot definitions, passed to @code{defclass}. +@end table + +@subheading Description + +@c TODO rewrite + +The macro @code{define-foreign-type} defines a new class +@var{class-name}. It is a thin wrapper around @code{defclass}. Among +other things, it ensures that @var{class-name} becomes a subclass of +@var{foreign-type}, what you need to know about that is that there's +an initarg @code{:actual-type} which serves the same purpose as +@code{defctype}'s @var{base-type} argument. + +@c TODO mention the type translators here +@c FIX FIX + +@subheading Examples +Taken from @cffi{}'s @code{:boolean} type definition: + +@lisp +(define-foreign-type :boolean (&optional (base-type :int)) + "Boolean type. Maps to an :int by default. Only accepts integer types." + (ecase base-type + ((:char + :unsigned-char + :int + :unsigned-int + :long + :unsigned-long) base-type))) + +CFFI> (canonicalize-foreign-type :boolean) +@result{} :INT +CFFI> (canonicalize-foreign-type '(:boolean :long)) +@result{} :LONG +CFFI> (canonicalize-foreign-type '(:boolean :float)) +;; @lispcmt{@error{} signalled by ECASE.} +@end lisp + +@subheading See Also +@seealso{defctype} @* +@seealso{define-parse-method} + + +@c =================================================================== +@c DEFINE-PARSE-METHOD + +@node define-parse-method +@unnumberedsec define-parse-method +@subheading Syntax +@Macro{define-parse-method name lambda-list &body body @result{} name} + +@subheading Arguments and Values + +@table @var +@item type-name +A symbol naming the new foreign type. + +@item lambda-list +A lambda list which is the argument list of the new foreign type. + +@item body +One or more forms that provide a definition of the new foreign type. +@end table + +@subheading Description + + +@c TODO: update example. The boolean type is probably a good choice. + +@subheading Examples +Taken from @cffi{}'s @code{:boolean} type definition: + +@lisp +(define-foreign-type :boolean (&optional (base-type :int)) + "Boolean type. Maps to an :int by default. Only accepts integer types." + (ecase base-type + ((:char + :unsigned-char + :int + :unsigned-int + :long + :unsigned-long) base-type))) + +CFFI> (canonicalize-foreign-type :boolean) +@result{} :INT +CFFI> (canonicalize-foreign-type '(:boolean :long)) +@result{} :LONG +CFFI> (canonicalize-foreign-type '(:boolean :float)) +;; @lispcmt{@error{} signalled by ECASE.} +@end lisp + +@subheading See Also +@seealso{define-foreign-type} + + +@c =================================================================== +@c EXPLAIN-FOREIGN-SLOT-VALUE + +@c @node explain-foreign-slot-value +@c @unnumberedsec explain-foreign-slot-value +@c @subheading Syntax +@c @Macro{explain-foreign-slot-value ptr type &rest slot-names} + +@c @subheading Arguments and Values + +@c @table @var +@c @item ptr +@c ... + +@c @item type +@c ... + +@c @item slot-names +@c ... +@c @end table + +@c @subheading Description +@c This macro translates the slot access that would occur by calling +@c @code{foreign-slot-value} with the same arguments into an equivalent +@c expression in C and prints it to @code{*standard-output*}. + +@c @emph{Note: this is not implemented yet.} + +@c @subheading Examples +@c @lisp +@c CFFI> (explain-foreign-slot-value ptr 'timeval 'tv-secs) +@c @result{} ptr->tv_secs + +@c CFFI> (explain-foreign-slot-value emp 'employee 'hire-date 'tv-usecs) +@c @result{} emp->hire_date.tv_usecs +@c @end lisp + +@c @subheading See Also + + +@c =================================================================== +@c FOREIGN-BITFIELD-SYMBOLS + +@node foreign-bitfield-symbols +@unnumberedsec foreign-bitfield-symbols +@subheading Syntax +@Function{foreign-bitfield-symbols type value @result{} symbols} + +@subheading Arguments and Values + +@table @var +@item type +A bitfield type. + +@item value +An integer. + +@item symbols +A potentially shared list of symbols. +@code{nil}. +@end table + +@subheading Description +The function @code{foreign-bitfield-symbols} returns a possibly shared +list of symbols that correspond to @var{value} in @var{type}. + +@subheading Examples +@lisp +(defbitfield flags + (flag-a 1) + (flag-b 2) + (flag-c 4)) + +CFFI> (foreign-bitfield-symbols 'boolean #b101) +@result{} (FLAG-A FLAG-C) +@end lisp + +@subheading See Also +@seealso{defbitfield} @* +@seealso{foreign-bitfield-value} + + +@c =================================================================== +@c FOREIGN-BITFIELD-VALUE + +@node foreign-bitfield-value +@unnumberedsec foreign-bitfield-value +@subheading Syntax +@Function{foreign-bitfield-value type symbols @result{} value} + +@subheading Arguments and Values + +@table @var +@item type +A @code{bitfield} type. + +@item symbol +A Lisp symbol. + +@item value +An integer. +@end table + +@subheading Description +The function @code{foreign-bitfield-value} returns the @var{value} that +corresponds to the symbols in the @var{symbols} list. + +@subheading Examples +@lisp +(defbitfield flags + (flag-a 1) + (flag-b 2) + (flag-c 4)) + +CFFI> (foreign-bitfield-value 'flags '(flag-a flag-c)) +@result{} 5 ; #b101 +@end lisp + +@subheading See Also +@seealso{defbitfield} @* +@seealso{foreign-bitfield-symbols} + + +@c =================================================================== +@c FOREIGN-ENUM-KEYWORD + +@node foreign-enum-keyword +@unnumberedsec foreign-enum-keyword +@subheading Syntax +@Function{foreign-enum-keyword type value &key errorp @result{} keyword} + +@subheading Arguments and Values + +@table @var +@item type +An @code{enum} type. + +@item value +An integer. + +@item errorp +If true (the default), signal an error if @var{value} is not defined +in @var{type}. If false, @code{foreign-enum-keyword} returns +@code{nil}. + +@item keyword +A keyword symbol. +@end table + +@subheading Description +The function @code{foreign-enum-keyword} returns the keyword symbol +that corresponds to @var{value} in @var{type}. + +An error is signaled if @var{type} doesn't contain such @var{value} +and @var{errorp} is true. + +@subheading Examples +@lisp +(defcenum boolean + :no + :yes) + +CFFI> (foreign-enum-keyword 'boolean 1) +@result{} :YES +@end lisp + +@subheading See Also +@seealso{defcenum} @* +@seealso{foreign-enum-value} + + +@c =================================================================== +@c FOREIGN-ENUM-VALUE + +@node foreign-enum-value +@unnumberedsec foreign-enum-value +@subheading Syntax +@Function{foreign-enum-value type keyword &key errorp @result{} value} + +@subheading Arguments and Values + +@table @var +@item type +An @code{enum} type. + +@item keyword +A keyword symbol. + +@item errorp +If true (the default), signal an error if @var{keyword} is not +defined in @var{type}. If false, @code{foreign-enum-value} returns +@code{nil}. + +@item value +An integer. +@end table + +@subheading Description +The function @code{foreign-enum-value} returns the @var{value} that +corresponds to @var{keyword} in @var{type}. + +An error is signaled if @var{type} doesn't contain such +@var{keyword}, and @var{errorp} is true. + +@subheading Examples +@lisp +(defcenum boolean + :no + :yes) + +CFFI> (foreign-enum-value 'boolean :yes) +@result{} 1 +@end lisp + +@subheading See Also +@seealso{defcenum} @* +@seealso{foreign-enum-keyword} + + +@c =================================================================== +@c FOREIGN-SLOT-NAMES + +@node foreign-slot-names +@unnumberedsec foreign-slot-names +@subheading Syntax +@Function{foreign-slot-names type @result{} names} + +@subheading Arguments and Values + +@table @var +@item type +A foreign struct type. + +@item names +A list. +@end table + +@subheading Description +The function @code{foreign-slot-names} returns a potentially shared +list of slot @var{names} for the given structure @var{type}. This list +has no particular order. + +@subheading Examples +@lisp +(defcstruct timeval + (tv-secs :long) + (tv-usecs :long)) + +CFFI> (foreign-slot-names 'timeval) +@result{} (TV-SECS TV-USECS) +@end lisp + +@subheading See Also +@seealso{defcstruct} @* +@seealso{foreign-slot-offset} @* +@seealso{foreign-slot-value} @* +@seealso{foreign-slot-pointer} + + +@c =================================================================== +@c FOREIGN-SLOT-OFFSET + +@node foreign-slot-offset +@unnumberedsec foreign-slot-offset +@subheading Syntax +@Function{foreign-slot-offset type slot-name @result{} offset} + +@subheading Arguments and Values + +@table @var +@item type +A foreign struct type. + +@item slot-name +A symbol. + +@item offset +An integer. +@end table + +@subheading Description +The function @code{foreign-slot-offset} returns the @var{offset} in +bytes of a slot in a foreign struct type. + +@subheading Examples +@lisp +(defcstruct timeval + (tv-secs :long) + (tv-usecs :long)) + +CFFI> (foreign-slot-offset 'timeval 'tv-secs) +@result{} 0 +CFFI> (foreign-slot-offset 'timeval 'tv-usecs) +@result{} 4 +@end lisp + +@subheading See Also +@seealso{defcstruct} @* +@seealso{foreign-slot-names} @* +@seealso{foreign-slot-pointer} @* +@seealso{foreign-slot-value} + + +@c =================================================================== +@c FOREIGN-SLOT-POINTER + +@node foreign-slot-pointer +@unnumberedsec foreign-slot-pointer +@subheading Syntax +@Function{foreign-slot-pointer ptr type slot-name @result{} pointer} + +@subheading Arguments and Values + +@table @var +@item ptr +A pointer to a structure. + +@item type +A foreign structure type. + +@item slot-names +A slot name in the @var{type}. + +@item pointer +A pointer to the slot @var{slot-name}. +@end table + +@subheading Description +Returns a pointer to the location of the slot @var{slot-name} in a +foreign object of type @var{type} at @var{ptr}. The returned pointer +points inside the structure. Both the pointer and the memory it points +to have the same extent as @var{ptr}. + +For aggregate slots, this is the same value returned by +@code{foreign-slot-value}. + +@subheading Examples +@lisp +(defcstruct point + "Pointer structure." + (x :int) + (y :int)) + +CFFI> (with-foreign-object (ptr 'point) + (foreign-slot-pointer ptr 'point 'x)) +@result{} # +;; @lispcmt{Note: the exact pointer representation varies from lisp to lisp.} +@end lisp + +@subheading See Also +@seealso{defcstruct} @* +@seealso{foreign-slot-value} @* +@seealso{foreign-slot-names} @* +@seealso{foreign-slot-offset} + + +@c =================================================================== +@c FOREIGN-SLOT-VALUE + +@node foreign-slot-value +@unnumberedsec foreign-slot-value +@subheading Syntax +@Accessor{foreign-slot-value ptr type slot-name @result{} object} + +@subheading Arguments and Values + +@table @var +@item ptr +A pointer to a structure. + +@item type +A foreign structure type. + +@item slot-name +A symbol naming a slot in the structure type. + +@item object +The object contained in the slot specified by @var{slot-name}. +@end table + +@subheading Description +For simple slots, @code{foreign-slot-value} returns the value of the +object, such as a Lisp integer or pointer. In C, this would be +expressed as @code{ptr->slot}. + +For aggregate slots, a pointer inside the structure to the beginning +of the slot's data is returned. In C, this would be expressed as +@code{&ptr->slot}. This pointer and the memory it points to have the +same extent as @var{ptr}. + +There are compiler macros for @code{foreign-slot-value} and its +@code{setf} expansion that open code the memory access when +@var{type} and @var{slot-names} are constant at compile-time. + +@subheading Examples +@lisp +(defcstruct point + "Pointer structure." + (x :int) + (y :int)) + +CFFI> (with-foreign-object (ptr 'point) + ;; @lispcmt{Initialize the slots} + (setf (foreign-slot-value ptr 'point 'x) 42 + (foreign-slot-value ptr 'point 'y) 42) + ;; @lispcmt{Return a list with the coordinates} + (with-foreign-slots ((x y) ptr point) + (list x y))) +@result{} (42 42) +@end lisp + +@subheading See Also +@seealso{defcstruct} @* +@seealso{foreign-slot-names} @* +@seealso{foreign-slot-offset} @* +@seealso{foreign-slot-pointer} @* +@seealso{with-foreign-slots} + + +@c =================================================================== +@c FOREIGN-TYPE-ALIGNMENT + +@node foreign-type-alignment +@unnumberedsec foreign-type-alignment +@subheading Syntax +@c XXX: This is actually a generic function. +@Function{foreign-type-alignment type @result{} alignment} + +@subheading Arguments and Values + +@table @var +@item type +A foreign type. + +@item alignment +An integer. +@end table + +@subheading Description +The function @code{foreign-type-alignment} returns the +@var{alignment} of @var{type} in bytes. + +@subheading Examples +@lisp +CFFI> (foreign-type-alignment :char) +@result{} 1 +CFFI> (foreign-type-alignment :short) +@result{} 2 +CFFI> (foreign-type-alignment :int) +@result{} 4 +@end lisp + +@lisp +(defcstruct foo + (a :char)) + +CFFI> (foreign-type-alignment 'foo) +@result{} 1 +@end lisp + +@subheading See Also +@seealso{foreign-type-size} + + +@c =================================================================== +@c FOREIGN-TYPE-SIZE + +@node foreign-type-size +@unnumberedsec foreign-type-size +@subheading Syntax +@c XXX: this is actually a generic function. +@Function{foreign-type-size type @result{} size} + +@subheading Arguments and Values + +@table @var +@item type +A foreign type. + +@item size +An integer. +@end table + +@subheading Description +The function @code{foreign-type-size} return the @var{size} of +@var{type} in bytes. This includes any padding within and following +the in-memory representation as needed to create an array of +@var{type} objects. + +@subheading Examples +@lisp +(defcstruct foo + (a :double) + (c :char)) + +CFFI> (foreign-type-size :double) +@result{} 8 +CFFI> (foreign-type-size :char) +@result{} 1 +CFFI> (foreign-type-size 'foo) +@result{} 16 +@end lisp + +@subheading See Also +@seealso{foreign-type-alignment} + + +@c =================================================================== +@c FREE-CONVERTED-OBJECT + +@node free-converted-object +@unnumberedsec free-converted-object +@subheading Syntax +@Function{free-converted-object foreign-value type params} + +@subheading Arguments and Values + +@table @var +@item foreign-value +The C object to be freed. + +@item type +A @cffi{} type specifier. + +@item params +The state returned as the second value from @code{convert-to-foreign}; +used to implement the third argument to @code{free-translated-object}. +@end table + +@subheading Description + +The return value is unspecified. + +This is an external interface to the type translation facility. In +the implementation, all foreign functions are ultimately defined as +type translation wrappers around primitive foreign function +invocations. + +This function is available mostly for inspection of the type +translation process, and possibly optimization of special cases of +your foreign function calls. + +Its behavior is better described under @code{free-translated-object}'s +documentation. + +@subheading Examples + +@lisp +CFFI-USER> (convert-to-foreign "a boat" :string) +@result{} # +@result{} (T) +CFFI-USER> (free-converted-object * :string '(t)) +@result{} NIL +@end lisp + +@subheading See Also +@seealso{convert-from-foreign} @* +@seealso{convert-to-foreign} @* +@seealso{free-translated-object} + + +@c =================================================================== +@c FREE-TRANSLATED-OBJECT + +@c TODO: update + +@node free-translated-object +@unnumberedsec free-translated-object +@subheading Syntax +@GenericFunction{free-translated-object value type-name param} + +@subheading Arguments and Values + +@table @var +@item pointer +The foreign value returned by @code{translate-to-foreign}. + +@item type-name +A symbol naming a foreign type defined by @code{defctype}. + +@item param +The second value, if any, returned by @code{translate-to-foreign}. +@end table + +@subheading Description +This generic function may be specialized by user code to perform +automatic deallocation of foreign objects as they are passed to C +functions. + +Any methods defined on this generic function must EQL-specialize the +@var{type-name} parameter on a symbol defined as a foreign type by +the @code{defctype} macro. + +@subheading See Also +@seealso{Foreign Type Translators} @* +@seealso{translate-to-foreign} + + +@c =================================================================== +@c TRANSLATE-FROM-FOREIGN + +@c TODO: update + +@node translate-from-foreign +@unnumberedsec translate-from-foreign +@subheading Syntax +@GenericFunction{translate-from-foreign foreign-value type-name @ + @result{} lisp-value} + +@subheading Arguments and Values + +@table @var +@item foreign-value +The foreign value to convert to a Lisp object. + +@item type-name +A symbol naming a foreign type defined by @code{defctype}. + +@item lisp-value +The lisp value to pass in place of @code{foreign-value} to Lisp code. +@end table + +@subheading Description +This generic function is invoked by @cffi{} to convert a foreign value to +a Lisp value, such as when returning from a foreign function, passing +arguments to a callback function, or accessing a foreign variable. + +To extend the @cffi{} type system by performing custom translations, this +method may be specialized by @sc{eql}-specializing @code{type-name} on a +symbol naming a foreign type defined with @code{defctype}. This +method should return the appropriate Lisp value to use in place of the +foreign value. + +The results are undefined if the @code{type-name} parameter is +specialized in any way except an @sc{eql} specializer on a foreign type +defined with @code{defctype}. Specifically, translations may not be +defined for built-in types. + +@subheading See Also +@seealso{Foreign Type Translators} @* +@seealso{translate-to-foreign} @* +@seealso{free-translated-object} + + +@c =================================================================== +@c TRANSLATE-TO-FOREIGN + +@c TODO: update + +@node translate-to-foreign +@unnumberedsec translate-to-foreign +@subheading Syntax +@GenericFunction{translate-to-foreign lisp-value type-name @ + @result{} foreign-value, alloc-param} + +@subheading Arguments and Values + +@table @var +@item lisp-value +The Lisp value to convert to foreign representation. + +@item type-name +A symbol naming a foreign type defined by @code{defctype}. + +@item foreign-value +The foreign value to pass in place of @code{lisp-value} to foreign code. + +@item alloc-param +If present, this value will be passed to +@code{free-translated-object}. +@end table + +@subheading Description +This generic function is invoked by @cffi{} to convert a Lisp value to a +foreign value, such as when passing arguments to a foreign function, +returning a value from a callback, or setting a foreign variable. A +``foreign value'' is one appropriate for passing to the next-lowest +translator, including the low-level translators that are ultimately +invoked invisibly with @cffi{}. + +To extend the @cffi{} type system by performing custom translations, this +method may be specialized by @sc{eql}-specializing @code{type-name} on a +symbol naming a foreign type defined with @code{defctype}. This +method should return the appropriate foreign value to use in place of +the Lisp value. + +In cases where @cffi{} can determine the lifetime of the foreign object +returned by this method, it will invoke @code{free-translated-object} +on the foreign object at the appropriate time. If +@code{translate-to-foreign} returns a second value, it will be passed +as the @code{param} argument to @code{free-translated-object}. This +can be used to establish communication between the allocation and +deallocation methods. + +The results are undefined if the @code{type-name} parameter is +specialized in any way except an @sc{eql} specializer on a foreign type +defined with @code{defctype}. Specifically, translations may not be +defined for built-in types. + +@subheading See Also +@seealso{Foreign Type Translators} @* +@seealso{translate-from-foreign} @* +@seealso{free-translated-object} + + +@c =================================================================== +@c WITH-FOREIGN-SLOTS + +@node with-foreign-slots +@unnumberedsec with-foreign-slots +@subheading Syntax +@Macro{with-foreign-slots (vars ptr type) &body body} + +@subheading Arguments and Values + +@table @var +@item vars +A list of symbols. + +@item ptr +A foreign pointer to a structure. + +@item type +A structure type. + +@item body +A list of forms to be executed. +@end table + +@subheading Description +The @code{with-foreign-slots} macro creates local symbol macros for +each var in @var{vars} to reference foreign slots in @var{ptr} of +@var{type}. It is similar to Common Lisp's @code{with-slots} macro. + +@subheading Examples +@lisp +(defcstruct tm + (sec :int) + (min :int) + (hour :int) + (mday :int) + (mon :int) + (year :int) + (wday :int) + (yday :int) + (isdst :boolean) + (zone :string) + (gmtoff :long)) + +CFFI> (with-foreign-object (time :int) + (setf (mem-ref time :int) + (foreign-funcall "time" :pointer (null-pointer) :int)) + (foreign-funcall "gmtime" :pointer time tm)) +@result{} # +CFFI> (with-foreign-slots ((sec min hour mday mon year) * tm) + (format nil "~A:~A:~A, ~A/~A/~A" + hour min sec (+ 1900 year) mon mday)) +@result{} "7:22:47, 2005/8/2" +@end lisp + +@subheading See Also +@seealso{defcstruct} @* +@seealso{defcunion} @* +@seealso{foreign-slot-value} + + +@c =================================================================== +@c CHAPTER: Pointers + +@node Pointers +@chapter Pointers + +All C data in @cffi{} is referenced through pointers. This includes +defined C variables that hold immediate values, and integers. + +To see why this is, consider the case of the C integer. It is not +only an arbitrary representation for an integer, congruent to Lisp's +fixnums; the C integer has a specific bit pattern in memory defined by +the C @acronym{ABI}. Lisp has no such constraint on its fixnums; +therefore, it only makes sense to think of fixnums as C integers if +you assume that @cffi{} converts them when necessary, such as when +storing one for use in a C function call, or as the value of a C +variable. This requires defining an area of memory@footnote{The +definition of @dfn{memory} includes the @acronym{CPU} registers.}, +represented through an effective address, and storing it there. + +Due to this compartmentalization, it only makes sense to manipulate +raw C data in Lisp through pointers to it. For example, while there +may be a Lisp representation of a @code{struct} that is converted to C +at store time, you may only manipulate its raw data through a pointer. +The C compiler does this also, albeit informally. + +@menu +* Basic Pointer Operations:: +* Allocating Foreign Memory:: +* Accessing Foreign Memory:: + +Dictionary + +* foreign-free:: +* foreign-alloc:: +* foreign-symbol-pointer:: +* inc-pointer:: +* incf-pointer:: +* make-pointer:: +* mem-aref:: +* mem-ref:: +* null-pointer:: +* null-pointer-p:: +* pointerp:: +* pointer-address:: +* pointer-eq:: +* with-foreign-object:: +* with-foreign-pointer:: +@end menu + +@node Basic Pointer Operations +@section Basic Pointer Operations + +Manipulating pointers proper can be accomplished through most of the +other operations defined in the Pointers dictionary, such as +@code{make-pointer}, @code{pointer-address}, and @code{pointer-eq}. +When using them, keep in mind that they merely manipulate the Lisp +representation of pointers, not the values they point to. + +@deftp {Lisp Type} foreign-pointer +The pointers' representations differ from implementation to +implementation and have different types. @code{foreign-pointer} +provides a portable type alias to each of these types. +@end deftp + + +@node Allocating Foreign Memory +@section Allocating Foreign Memory + +@cffi{} provides support for stack and heap C memory allocation. +Stack allocation, done with @code{with-foreign-object}, is sometimes +called ``dynamic'' allocation in Lisp, because memory allocated as +such has dynamic extent, much as with @code{let} bindings of special +variables. + +This should not be confused with what C calls ``dynamic'' allocation, +or that done with @code{malloc} and friends. This sort of heap +allocation is done with @code{foreign-alloc}, creating objects that +exist until freed with @code{foreign-free}. + + +@node Accessing Foreign Memory +@section Accessing Foreign Memory + +When manipulating raw C data, consider that all pointers are pointing +to an array. When you only want one C value, such as a single +@code{struct}, this array only has one such value. It is worthwhile +to remember that everything is an array, though, because this is also +the semantic that C imposes natively. + +C values are accessed as the @code{setf}-able places defined by +@code{mem-aref} and @code{mem-ref}. Given a pointer and a @cffi{} +type (@pxref{Foreign Types}), either of these will dereference the +pointer, translate the C data there back to Lisp, and return the +result of said translation, performing the reverse operation when +@code{setf}-ing. To decide which one to use, consider whether you +would use the array index operator @code{[@var{n}]} or the pointer +dereference @code{*} in C; use @code{mem-aref} for array indexing and +@code{mem-ref} for pointer dereferencing. + + +@c =================================================================== +@c FOREIGN-FREE + +@node foreign-free +@unnumberedsec foreign-free +@subheading Syntax +@Function{foreign-free ptr @result{} undefined} + +@subheading Arguments and Values + +@table @var +@item ptr +A foreign pointer. +@end table + +@subheading Description +The @code{foreign-free} function frees a @code{ptr} previously +allocated by @code{foreign-alloc}. The consequences of freeing a given +pointer twice are undefined. + +@subheading Examples + +@lisp +CFFI> (foreign-alloc :int) +@result{} # +CFFI> (foreign-free *) +@result{} NIL +@end lisp + +@subheading See Also +@seealso{foreign-alloc} @* +@seealso{with-foreign-pointer} + + +@c =================================================================== +@c FOREIGN-ALLOC + +@node foreign-alloc +@unnumberedsec foreign-alloc +@subheading Syntax +@Function{foreign-alloc type &key initial-element initial-contents (count 1) @ + null-terminated-p @result{} pointer} + +@subheading Arguments and Values + +@table @var +@item type +A foreign type. + +@item initial-element +A Lisp object. + +@item initial-contents +A sequence. + +@item count +An integer. Defaults to 1 or the length of @var{initial-contents} if +supplied. + +@item null-terminated-p +A boolean, false by default. + +@item pointer +A foreign pointer to the newly allocated memory. +@end table + +@subheading Description +The @code{foreign-alloc} function allocates enough memory to hold +@var{count} objects of type @var{type} and returns a +@var{pointer}. This memory must be explicitly freed using +@code{foreign-free} once it is no longer needed. + +If @var{initial-element} is supplied, it is used to initialize the +@var{count} objects the newly allocated memory holds. + +If an @var{initial-contents} sequence is supplied, it must have a +length less than or equal to @var{count} and each of its elements +will be used to initialize the contents of the newly allocated +memory. + +If @var{count} is omitted and @var{initial-contents} is specified, it +will default to @code{(length @var{initial-contents})}. + +@var{initial-element} and @var{initial-contents} are mutually +exclusive. + +When @var{null-terminated-p} is true, +@code{(1+ (max @var{count} (length @var{initial-contents})))} elements +are allocated and the last one is set to @code{NULL}. Note that in +this case @var{type} must be a pointer type (ie. a type that +canonicalizes to @code{:pointer}), otherwise an error is signaled. + +@subheading Examples +@lisp +CFFI> (foreign-alloc :char) +@result{} # ; @lispcmt{A pointer to 1 byte of memory.} + +CFFI> (foreign-alloc :char :count 20) +@result{} # ; @lispcmt{A pointer to 20 bytes of memory.} + +CFFI> (foreign-alloc :int :initial-element 12) +@result{} # +CFFI> (mem-ref * :int) +@result{} 12 + +CFFI> (foreign-alloc :int :initial-contents '(1 2 3)) +@result{} # +CFFI> (loop for i from 0 below 3 + collect (mem-aref * :int i)) +@result{} (1 2 3) + +CFFI> (foreign-alloc :int :initial-contents #(1 2 3)) +@result{} # +CFFI> (loop for i from 0 below 3 + collect (mem-aref * :int i)) +@result{} (1 2 3) + +;;; Allocate a char** pointer that points to newly allocated memory +;;; by the :string type translator for the string "foo". +CFFI> (foreign-alloc :string :initial-element "foo") +@result{} # +@end lisp + +@lisp +;;; Allocate a null-terminated array of strings. +;;; (Note: FOREIGN-STRING-TO-LISP returns NIL when passed a null pointer) +CFFI> (foreign-alloc :string + :initial-contents '("foo" "bar" "baz") + :null-terminated-p t) +@result{} # +CFFI> (loop for i from 0 below 4 + collect (mem-aref * :string i)) +@result{} ("foo" "bar" "baz" NIL) +CFFI> (progn + (dotimes (i 3) + (foreign-free (mem-aref ** :pointer i))) + (foreign-free **)) +@result{} nil +@end lisp + +@subheading See Also +@seealso{foreign-free} @* +@seealso{with-foreign-object} @* +@seealso{with-foreign-pointer} + + +@c =================================================================== +@c FOREIGN-SYMBOL-POINTER + +@node foreign-symbol-pointer +@unnumberedsec foreign-symbol-pointer +@subheading Syntax +@Function{foreign-symbol-pointer foreign-name &key library @result{} pointer} + +@subheading Arguments and Values + +@table @var +@item foreign-name +A string. + +@item pointer +A foreign pointer, or @code{nil}. + +@item library +A Lisp symbol or an instance of @code{foreign-library}. +@end table + +@subheading Description +The function @code{foreign-symbol-pointer} will return a foreign +pointer corresponding to the foreign symbol denoted by the string +@var{foreign-name}. If a foreign symbol named @var{foreign-name} +doesn't exist, @code{nil} is returned. + +ABI name manglings will be performed on @var{foreign-name} by +@code{foreign-symbol-pointer} if necessary. (eg: adding a leading +underscore on darwin/ppc) + +@var{library} should name a foreign library as defined by +@code{define-foreign-library}, @code{:default} (which is the default) +or an instance of @code{foreign-library} as returned by +@code{load-foreign-library}. + +@strong{Important note:} do not keep these pointers across saved Lisp +cores as the foreign-library may move across sessions. + +@subheading Examples + +@lisp +CFFI> (foreign-symbol-pointer "errno") +@result{} # +CFFI> (foreign-symbol-pointer "strerror") +@result{} # +CFFI> (foreign-funcall-pointer * () :int (mem-ref ** :int) :string) +@result{} "No such file or directory" + +CFFI> (foreign-symbol-pointer "inexistent symbol") +@result{} NIL +@end lisp + +@subheading See Also +@seealso{defcvar} + + +@c =================================================================== +@c INC-POINTER + +@node inc-pointer +@unnumberedsec inc-pointer +@subheading Syntax +@Function{inc-pointer pointer offset @result{} new-pointer} + +@subheading Arguments and Values + +@table @var +@item pointer +@itemx new-pointer +A foreign pointer. + +@item offset +An integer. +@end table + +@subheading Description +The function @code{inc-pointer} will return a @var{new-pointer} pointing +@var{offset} bytes past @var{pointer}. + +@subheading Examples + +@lisp +CFFI> (foreign-string-alloc "Common Lisp") +@result{} # +CFFI> (inc-pointer * 7) +@result{} # +CFFI> (foreign-string-to-lisp *) +@result{} "Lisp" +@end lisp + +@subheading See Also +@seealso{incf-pointer} @* +@seealso{make-pointer} @* +@seealso{pointerp} @* +@seealso{null-pointer} @* +@seealso{null-pointer-p} + + +@c =================================================================== +@c INCF-POINTER + +@node incf-pointer +@unnumberedsec inc-pointer +@subheading Syntax +@Macro{incf-pointer place &optional (offset 1) @result{} new-pointer} + +@subheading Arguments and Values + +@table @var +@item place +A @code{setf} place. + +@item new-pointer +A foreign pointer. + +@item offset +An integer. +@end table + +@subheading Description +The @code{incf-pointer} macro takes the foreign pointer from +@var{place} and creates a @var{new-pointer} incremented by +@var{offset} bytes and which is stored in @var{place}. + +@subheading Examples + +@lisp +CFFI> (defparameter *two-words* (foreign-string-alloc "Common Lisp")) +@result{} *TWO-WORDS* +CFFI> (defparameter *one-word* *two-words*) +@result{} *ONE-WORD* +CFFI> (incf-pointer *one-word* 7) +@result{} #.(SB-SYS:INT-SAP #X00600457) +CFFI> (foreign-string-to-lisp *one-word*) +@result{} "Lisp" +CFFI> (foreign-string-to-lisp *two-words*) +@result{} "Common Lisp" +@end lisp + +@subheading See Also +@seealso{inc-pointer} @* +@seealso{make-pointer} @* +@seealso{pointerp} @* +@seealso{null-pointer} @* +@seealso{null-pointer-p} + + +@c =================================================================== +@c MAKE-POINTER + +@node make-pointer +@unnumberedsec make-pointer +@subheading Syntax +@Function{make-pointer address @result{} ptr} + +@subheading Arguments and Values + +@table @var +@item address +An integer. + +@item ptr +A foreign pointer. +@end table + +@subheading Description +The function @code{make-pointer} will return a foreign pointer +pointing to @var{address}. + +@subheading Examples + +@lisp +CFFI> (make-pointer 42) +@result{} # +CFFI> (pointerp *) +@result{} T +CFFI> (pointer-address **) +@result{} 42 +CFFI> (inc-pointer *** -42) +@result{} # +CFFI> (null-pointer-p *) +@result{} T +CFFI> (typep ** 'foreign-pointer) +@result{} T +@end lisp + +@subheading See Also +@seealso{inc-pointer} @* +@seealso{null-pointer} @* +@seealso{null-pointer-p} @* +@seealso{pointerp} @* +@seealso{pointer-address} @* +@seealso{pointer-eq} @* +@seealso{mem-ref} + + +@c =================================================================== +@c MEM-AREF + +@node mem-aref +@unnumberedsec mem-aref +@subheading Syntax +@Accessor{mem-aref ptr type &optional (index 0)} + +(setf (@strong{mem-aref} @emph{ptr type &optional (index 0)) new-value}) + +@subheading Arguments and Values + +@table @var +@item ptr +A foreign pointer. + +@item type +A foreign type. + +@item index +An integer. + +@item new-value +A Lisp value compatible with @var{type}. +@end table + +@subheading Description +The @code{mem-aref} function is similar to @code{mem-ref} but will +automatically calculate the offset from an @var{index}. + +@lisp +(mem-aref ptr type n) + +;; @lispcmt{is identical to:} + +(mem-ref ptr type (* n (foreign-type-size type))) +@end lisp + +@subheading Examples + +@lisp +CFFI> (with-foreign-string (str "Hello, foreign world!") + (mem-aref str :char 6)) +@result{} 32 +CFFI> (code-char *) +@result{} #\Space + +CFFI> (with-foreign-object (array :int 10) + (loop for i below 10 + do (setf (mem-aref array :int i) (random 100))) + (loop for i below 10 collect (mem-aref array :int i))) +@result{} (22 7 22 52 69 1 46 93 90 65) +@end lisp + +@subheading See Also +@seealso{mem-ref} + + +@c =================================================================== +@c MEM-REF + +@node mem-ref +@unnumberedsec mem-ref +@subheading Syntax +@Accessor{mem-ref ptr type &optional offset @result{} object} + +@subheading Arguments and Values + +@table @var +@item ptr +A pointer. + +@item type +A foreign type. + +@item offset +An integer (in byte units). + +@item object +The value @var{ptr} points to. +@end table + +@subheading Description +@subheading Examples + +@lisp +CFFI> (with-foreign-string (ptr "Saluton") + (setf (mem-ref ptr :char 3) (char-code #\a)) + (loop for i from 0 below 8 + collect (code-char (mem-ref ptr :char i)))) +@result{} (#\S #\a #\l #\a #\t #\o #\n #\Null) +CFFI> (setq ptr-to-int (foreign-alloc :int)) +@result{} # +CFFI> (mem-ref ptr-to-int :int) +@result{} 1054619 +CFFI> (setf (mem-ref ptr-to-int :int) 1984) +@result{} 1984 +CFFI> (mem-ref ptr-to-int :int) +@result{} 1984 +@end lisp + +@subheading See Also +@seealso{mem-aref} + + +@c =================================================================== +@c NULL-POINTER + +@node null-pointer +@unnumberedsec null-pointer +@subheading Syntax +@Function{null-pointer @result{} pointer} + +@subheading Arguments and Values + +@table @var +@item pointer +A @code{NULL} pointer. +@end table + +@subheading Description +The function @code{null-pointer} returns a null pointer. + +@subheading Examples + +@lisp +CFFI> (null-pointer) +@result{} # +CFFI> (pointerp *) +@result{} T +@end lisp + +@subheading See Also +@seealso{null-pointer-p} @* +@seealso{make-pointer} + + +@c =================================================================== +@c NULL-POINTER-P + +@node null-pointer-p +@unnumberedsec null-pointer-p +@subheading Syntax +@Function{null-pointer-p ptr @result{} boolean} + +@subheading Arguments and Values + +@table @var +@item ptr +A foreign pointer that may be a null pointer. + +@item boolean +@code{T} or @code{NIL}. +@end table + +@subheading Description +The function @code{null-pointer-p} returns true if @var{ptr} is a null +pointer and false otherwise. + +@subheading Examples + +@lisp +CFFI> (null-pointer-p (null-pointer)) +@result{} T +@end lisp + +@lisp +(defun contains-str-p (big little) + (not (null-pointer-p + (foreign-funcall "strstr" :string big :string little :pointer)))) + +CFFI> (contains-str-p "Popcorns" "corn") +@result{} T +CFFI> (contains-str-p "Popcorns" "salt") +@result{} NIL +@end lisp + +@subheading See Also +@seealso{null-pointer} @* +@seealso{pointerp} + + +@c =================================================================== +@c POINTERP + +@node pointerp +@unnumberedsec pointerp +@subheading Syntax +@Function{pointerp ptr @result{} boolean} + +@subheading Arguments and Values + +@table @var +@item ptr +An object that may be a foreign pointer. + +@item boolean +@code{T} or @code{NIL}. +@end table + +@subheading Description +The function @code{pointerp} returns true if @var{ptr} is a foreign +pointer and false otherwise. + +@subheading Implementation-specific Notes +In Allegro CL, foreign pointers are integers thus in this +implementation @code{pointerp} will return true for any ordinary integer. + +@subheading Examples + +@lisp +CFFI> (foreign-alloc 32) +@result{} # +CFFI> (pointerp *) +@result{} T +CFFI> (pointerp "this is not a pointer") +@result{} NIL +@end lisp + +@subheading See Also +@seealso{make-pointer} +@seealso{null-pointer-p} + + +@c =================================================================== +@c POINTER-ADDRESS + +@node pointer-address +@unnumberedsec pointer-address +@subheading Syntax +@Function{pointer-address ptr @result{} address} + +@subheading Arguments and Values + +@table @var +@item ptr +A foreign pointer. + +@item address +An integer. +@end table + +@subheading Description +The function @code{pointer-address} will return the @var{address} of +a foreign pointer @var{ptr}. + +@subheading Examples + +@lisp +CFFI> (pointer-address (null-pointer)) +@result{} 0 +CFFI> (pointer-address (make-pointer 123)) +@result{} 123 +@end lisp + +@subheading See Also +@seealso{make-pointer} @* +@seealso{inc-pointer} @* +@seealso{null-pointer} @* +@seealso{null-pointer-p} @* +@seealso{pointerp} @* +@seealso{pointer-eq} @* +@seealso{mem-ref} + + +@c =================================================================== +@c POINTER-EQ + +@node pointer-eq +@unnumberedsec pointer-eq +@subheading Syntax +@Function{pointer-eq ptr1 ptr2 @result{} boolean} + +@subheading Arguments and Values + +@table @var +@item ptr1 +@itemx ptr2 +A foreign pointer. + +@item boolean +@code{T} or @code{NIL}. +@end table + +@subheading Description +The function @code{pointer-eq} returns true if @var{ptr1} and +@var{ptr2} point to the same memory address and false otherwise. + +@subheading Implementation-specific Notes +The representation of foreign pointers varies across the various Lisp +implementations as does the behaviour of the built-in Common Lisp +equality predicates. Comparing two pointers that point to the same +address with @code{EQ} Lisps will return true on some Lisps, others require +more general predicates like @code{EQL} or @code{EQUALP} and finally +some will return false using any of these predicates. Therefore, for +portability, you should use @code{POINTER-EQ}. + +@subheading Examples +This is an example using @acronym{SBCL}, see the +implementation-specific notes above. + +@lisp +CFFI> (eql (null-pointer) (null-pointer)) +@result{} NIL +CFFI> (pointer-eq (null-pointer) (null-pointer)) +@result{} T +@end lisp + +@subheading See Also +@seealso{inc-pointer} + + +@c =================================================================== +@c WITH-FOREIGN-OBJECT + +@node with-foreign-object +@unnumberedsec with-foreign-object +@subheading Syntax +@Macro{with-foreign-object (var type &optional count) &body body} + +@Macro{with-foreign-objects (bindings) &body body} + +bindings ::= @{(var type &optional count)@}* + +@subheading Arguments and Values + +@table @var +@item var +A symbol. + +@item type +A foreign type, evaluated. + +@item count +An integer. +@end table + +@subheading Description +The macros @code{with-foreign-object} and @code{with-foreign-objects} +bind @var{var} to a pointer to @var{count} newly allocated objects +of type @var{type} during @var{body}. The buffer has dynamic extent +and may be stack allocated if supported by the host Lisp. + +@subheading Examples + +@lisp +CFFI> (with-foreign-object (array :int 10) + (dotimes (i 10) + (setf (mem-aref array :int i) (random 100))) + (loop for i below 10 + collect (mem-aref array :int i))) +@result{} (22 7 22 52 69 1 46 93 90 65) +@end lisp + +@subheading See Also +@seealso{foreign-alloc} + + +@c =================================================================== +@c WITH-FOREIGN-POINTER + +@node with-foreign-pointer +@unnumberedsec with-foreign-pointer +@subheading Syntax +@Macro{with-foreign-pointer (var size &optional size-var) &body body} + +@subheading Arguments and Values + +@table @var +@item var +@itemx size-var +A symbol. + +@item size +An integer. + +@item body +A list of forms to be executed. +@end table + +@subheading Description +The @code{with-foreign-pointer} macro, binds @var{var} to @var{size} +bytes of foreign memory during @var{body}. The pointer in @var{var} +is invalid beyond the dynamic extend of @var{body} and may be +stack-allocated if supported by the implementation. + +If @var{size-var} is supplied, it will be bound to @var{size} during +@var{body}. + +@subheading Examples + +@lisp +CFFI> (with-foreign-pointer (string 4 size) + (setf (mem-ref string :char (1- size)) 0) + (lisp-string-to-foreign "Popcorns" string size) + (loop for i from 0 below size + collect (code-char (mem-ref string :char i)))) +@result{} (#\P #\o #\p #\Null) +@end lisp + +@subheading See Also +@seealso{foreign-alloc} @* +@seealso{foreign-free} + + +@c =================================================================== +@c CHAPTER: Strings + +@node Strings +@chapter Strings + +As with many languages, Lisp and C have special support for logical +arrays of characters, going so far as to give them a special name, +``strings''. In that spirit, @cffi{} provides special support for +translating between Lisp and C strings. + +The @code{:string} type and the symbols related below also serve as an +example of what you can do portably with @cffi{}; were it not +included, you could write an equally functional @file{strings.lisp} +without referring to any implementation-specific symbols. + +@menu +Dictionary + +* foreign-string-alloc:: +* foreign-string-free:: +* foreign-string-to-lisp:: +* lisp-string-to-foreign:: +* with-foreign-string:: +* with-foreign-pointer-as-string:: +@end menu + + +@c =================================================================== +@c FOREIGN-STRING-ALLOC + +@node foreign-string-alloc +@unnumberedsec foreign-string-alloc +@subheading Syntax +@Function{foreign-string-alloc string-or-ub8-array @result{} pointer} + +@subheading Arguments and Values + +@table @var +@item string-or-ub8-array +A Lisp string or a Lisp array with element-type @code{(unsigned-byte 8)}. + +@item pointer +A pointer to the newly allocated foreign string. +@end table + +@subheading Description +The @code{foreign-string-alloc} function allocates a foreign string +containing a Lisp string or @code{(unsigned-byte 8)} array. + +This string must be freed with @code{foreign-string-free}. + +@subheading Examples + +@lisp +CFFI> (setq str (foreign-string-alloc "Hello, foreign world!")) +@result{} # +CFFI> (foreign-funcall "strlen" :pointer str :int) +@result{} 21 +@end lisp + +@subheading See Also +@seealso{foreign-string-free} @* +@seealso{with-foreign-string} +@c @seealso{:string} + + +@c =================================================================== +@c FOREIGN-STRING-FREE + +@node foreign-string-free +@unnumberedsec foreign-string-free +@subheading Syntax +@Function{foreign-string-free pointer} + +@subheading Arguments and Values + +@table @var +@item pointer +A pointer to a string allocated by @code{foreign-string-alloc}. +@end table + +@subheading Description +The @code{foreign-string-free} function frees a foreign string +allocated by @code{foreign-string-alloc}. + +@subheading Examples + +@subheading See Also +@seealso{foreign-string-alloc} + + +@c =================================================================== +@c FOREIGN-STRING-TO-LISP + +@node foreign-string-to-lisp +@unnumberedsec foreign-string-to-lisp +@subheading Syntax +@Function{foreign-string-to-lisp ptr &optional size null-terminated-p @ + @result{} string} + +@subheading Arguments and Values + +@table @var +@item ptr +A pointer. + +@item size +The maximum string size. @code{array-total-size-limit}, by default. + +@item null-terminated-p +Specifies if the string @var{ptr} points to is null terminated. True, +by default. +@end table + +@subheading Description +The @code{foreign-string-to-lisp} function copies at most @var{size} +characters from @var{ptr} into a Lisp string. + +When @var{null-terminated-p} is true (the default), characters are +copied until @var{size} is reached or a @code{NULL} character is +found. + +If @var{ptr} is a null pointer, returns nil. + +Note that the @code{:string} type will automatically convert between +Lisp strings and foreign strings. + +@subheading Examples + +@lisp +CFFI> (foreign-funcall "getenv" :string "HOME" :pointer) +@result{} # +CFFI> (foreign-string-to-lisp *) +@result{} "/Users/luis" +@end lisp + +@subheading See Also +@seealso{lisp-string-to-foreign} @* +@seealso{foreign-string-alloc} +@c @seealso{:string} + + +@c =================================================================== +@c LISP-STRING-TO-FOREIGN + +@node lisp-string-to-foreign +@unnumberedsec lisp-string-to-foreign +@subheading Syntax +@Function{lisp-string-to-foreign string-or-ub8-array ptr size} + +@subheading Arguments and Values + +@table @var +@item string-or-ub8-array +A Lisp string or a Lisp @code{(unsigned-byte 8)} array. + +@item ptr +A foreign pointer. + +@item size +An integer. +@end table + +@subheading Description +The @code{lisp-string-to-foreign} function copies at most @var{size}-1 +characters from a Lisp string or @code{(unsigned-byte 8)} arrayto +@var{ptr}. The foreign string will be null-terminated. + +@subheading Examples + +@lisp +CFFI> (with-foreign-pointer-as-string (str 255) + (lisp-string-to-foreign "Hello, foreign world!" str 6)) +@result{} "Hello" + +CFFI> (with-foreign-pointer-as-string (str 255) + (lisp-string-to-foreign + (make-array 6 :element-type '(unsigned-byte 8) + :initial-contents '(65 66 67 68 69 60)) + str 4)) +@result{} "ABC" +@end lisp + +@subheading See Also +@seealso{foreign-string-alloc} @* +@seealso{foreign-string-to-lisp} @* +@seealso{with-foreign-pointer-as-string} + + +@c =================================================================== +@c WITH-FOREIGN-STRING + +@node with-foreign-string +@unnumberedsec with-foreign-string +@subheading Syntax +@Macro{with-foreign-string (var lisp-string-or-ub8-array) &body body} + +@subheading Arguments and Values + +@table @var +@item var +A symbol. + +@item lisp-string-or-ub8-array +A Lisp string or a Lisp array with element type @code{(unsigned-byte 8)}. + +@item body +A list of forms to be executed. +@end table + +@subheading Description +The @code{with-foreign-string} macro will bind @var{var} to a newly +allocated foreign string containing @var{lisp-string-or-ub8-array}. + +@subheading Examples + +@lisp +CFFI> (with-foreign-string (foo "12345") + (foreign-funcall "strlen" :pointer foo :int)) +@result{} 5 + +CFFI> (let ((array (coerce #(84 117 114 97 110 103 97) + '(array (unsigned-byte 8))))) + (with-foreign-string (foreign-string array) + (foreign-string-to-lisp foreign-string))) +@result{} "Turanga" +@end lisp + +@subheading See Also +@seealso{foreign-string-alloc} @* +@seealso{with-foreign-pointer-as-string} + + +@c =================================================================== +@c WITH-FOREIGN-POINTER-AS-STRING + +@node with-foreign-pointer-as-string +@unnumberedsec with-foreign-pointer-as-string +@subheading Syntax +@Macro{with-foreign-pointer-as-string (var size &optional size-var) &body body} + +@subheading Arguments and Values + +@table @var +@item var +A symbol. + +@item lisp-string +A Lisp string. + +@item body +List of forms to be executed. +@end table + +@subheading Description +The @code{with-foreign-pointer-as-string} macro is similar to +@code{with-foreign-pointer} except that @var{var}, as a Lisp string, is +used as the returned value of an implicit @code{progn} around @var{body}. + +@subheading Examples + +@lisp +CFFI> (with-foreign-pointer-as-string (str 6 str-size) + (lisp-string-to-foreign "Hello, foreign world!" str str-size)) +@result{} "Hello" +@end lisp + +@subheading See Also +@seealso{foreign-string-alloc} @* +@seealso{with-foreign-string} + + +@c =================================================================== +@c CHAPTER: Variables + +@node Variables +@chapter Variables + +@menu +Dictionary + +* defcvar:: +* get-var-pointer:: +@end menu + + +@c =================================================================== +@c DEFCVAR + +@node defcvar +@unnumberedsec defcvar +@subheading Syntax +@Macro{defcvar name-and-options type documentation @result{} lisp-name} + +name-and-options ::= name | (name &key read-only (library :default)) +name ::= lisp-name [foreign-name] | foreign-name [lisp-name] + +@subheading Arguments and Values + +@table @var +@item foreign-name +A string denoting a foreign function. + +@item lisp-name +A symbol naming the Lisp function to be created. + +@item type +A foreign type. + +@item read-only +A boolean. + +@item documentation +A Lisp string; not evaluated. +@end table + +@subheading Description +The @code{defcvar} macro defines a symbol macro @var{lisp-name} that looks +up @var{foreign-name} and dereferences it acording to @var{type}. It +can also be @code{setf}ed, unless @var{read-only} is true, in which +case an error will be signaled. + +When one of @var{lisp-name} or @var{foreign-name} is omitted, the +other is automatically derived using the following rules: + +@itemize +@item +Foreign names are converted to Lisp names by uppercasing, replacing +underscores with hyphens, and wrapping around asterisks. +@item +Lisp names are converted to foreign names by lowercasing, replacing +hyphens with underscores, and removing asterisks, if any. +@end itemize + +@subheading Examples + +@lisp +CFFI> (defcvar "errno" :int) +@result{} *ERRNO* +CFFI> (foreign-funcall "strerror" :int *errno* :string) +@result{} "Inappropriate ioctl for device" +CFFI> (setf *errno* 1) +@result{} 1 +CFFI> (foreign-funcall "strerror" :int *errno* :string) +@result{} "Operation not permitted" +@end lisp + +Trying to modify a read-only foreign variable: + +@lisp +CFFI> (defcvar ("errno" +error-number+) :int :read-only t) +@result{} +ERROR-NUMBER+ +CFFI> (setf +error-number+ 12) +;; @lispcmt{@error{} Trying to modify read-only foreign var: +ERROR-NUMBER+.} +@end lisp + +@emph{Note that accessing @code{errno} this way won't work with every +C standard library.} + +@subheading See Also +@seealso{get-var-pointer} + + +@c =================================================================== +@c GET-VAR-POINTER + +@node get-var-pointer +@unnumberedsec get-var-pointer +@subheading Syntax +@Function{get-var-pointer symbol @result{} pointer} + +@subheading Arguments and Values + +@table @var +@item symbol +A symbol denoting a foreign variable defined with @code{defcvar}. + +@item pointer +A foreign pointer. +@end table + +@subheading Description +The function @code{get-var-pointer} will return a @var{pointer} to the +foreign global variable @var{symbol} previously defined with +@code{defcvar}. + +@subheading Examples + +@lisp +CFFI> (defcvar "errno" :int :read-only t) +@result{} *ERRNO* +CFFI> *errno* +@result{} 25 +CFFI> (get-var-pointer '*errno*) +@result{} # +CFFI> (mem-ref * :int) +@result{} 25 +@end lisp + +@subheading See Also +@seealso{defcvar} + + +@c =================================================================== +@c CHAPTER: Functions + +@node Functions +@chapter Functions + +@menu +* Calling Foreign Functions:: +* Defining Foreign Functions:: + +Dictionary + +* defcfun:: +* foreign-funcall:: +* foreign-funcall-pointer:: +@end menu + +@node Calling Foreign Functions +@section Calling Foreign Functions + +@node Defining Foreign Functions +@section Defining Foreign Functions + + +@c =================================================================== +@c DEFCFUN + +@node defcfun +@unnumberedsec defcfun +@subheading Syntax +@Macro{defcfun name-and-options return-type &body arguments [&rest] @ + @result{} lisp-name} + +@table @asis +@item @var{name-and-options} name | (name &key library calling-convention cconv) +@item @var{name} ::= @var{lisp-name} [@var{foreign-name}] | @var{foreign-name} [@var{lisp-name}] +@item @var{arguments} ::= @{ (arg-name arg-type) @}* +@end table + +@subheading Arguments and Values + +@table @var +@item foreign-name +A string denoting a foreign function. + +@item lisp-name +A symbol naming the Lisp function to be created. + +@item arg-name +A symbol. + +@item return-type +@itemx arg-type +A foreign type. + +@item calling-convention +@itemx cconv +One of @code{:cdecl} (default) or @code{stdcall}. + +@item library +A symbol designating a foreign library. +@end table + +@subheading Description +The @code{defcfun} macro provides a declarative interface for defining +Lisp functions that call foreign functions. + +When one of @var{lisp-name} or @var{foreign-name} is omitted, the +other is automatically derived using the following rules: + +@itemize +@item +Foreign names are converted to Lisp names by uppercasing and replacing +underscores with hyphens. +@item +Lisp names are converted to foreign names by lowercasing and replacing +hyphens with underscores. +@end itemize + +If you place the symbol @code{&rest} in the end of the argument list +after the fixed arguments, @code{defcfun} will treat the foreign +function as a @strong{variadic function}. The variadic arguments +should be passed in a way similar to what @code{foreign-funcall} would +expect. Unlike @code{foreign-funcall} though, @code{defcfun} will take +care of doing argument promotion. Note that in this case +@code{defcfun} will generate a Lisp @emph{macro} instead of a +function and will only work for Lisps that support +@code{foreign-funcall.} + + +@subheading Examples + +@lisp +(defcfun "strlen" :int (n :string)) + +CFFI> (strlen "123") +@result{} 3 +@end lisp + +@lisp +(defcfun ("abs" c-abs) :int (n :int)) + +CFFI> (c-abs -42) +@result{} 42 +@end lisp + +Variadic function example: + +@lisp +(defcfun "sprintf" :int + (str :pointer) + (control :string) + &rest) + +CFFI> (with-foreign-pointer-as-string (s 100) + (sprintf s "%c %d %.2f %s" :char 90 :short 42 :float pi + :string "super-locrian")) +@result{} "A 42 3.14 super-locrian" +@end lisp + +@subheading See Also +@seealso{foreign-funcall} @* +@seealso{foreign-funcall-pointer} + + +@c =================================================================== +@c FOREIGN-FUNCALL + +@node foreign-funcall +@unnumberedsec foreign-funcall +@subheading Syntax +@Macro{foreign-funcall name-and-options &rest arguments @result{} return-value} + +arguments ::= @{ arg-type arg @}* [return-type] +name-and-options ::= name | ( name &key library calling-convention cconv) + +@subheading Arguments and Values + +@table @var +@item name +A Lisp string. + +@item arg-type +A foreign type. + +@item arg +An argument of type @var{arg-type}. + +@item return-type +A foreign type, @code{:void} by default. + +@item return-value +A lisp object. + +@item library +A lisp symbol; not evaluated. + +@item calling-convention +@itemx cconv +One of @code{:cdecl} (default) or @code{:stdcall}. +@end table + +@subheading Description +The @code{foreign-funcall} macro is the main primitive for calling +foreign functions. + +@emph{Note: The return value of foreign-funcall on functions with a +:void return type is still undefined.} + +@subheading Implementation-specific Notes +@itemize +@item +Corman Lisp does not support @code{foreign-funcall}. On +implementations that @strong{don't} support @code{foreign-funcall} +@code{cffi-features:no-foreign-funcall} will be present in +@code{*features*}. Note: in these Lisps you can still use the +@code{defcfun} interface. +@end itemize + +@subheading Examples + +@lisp +CFFI> (foreign-funcall "strlen" :string "foo" :int) +@result{} 3 +@end lisp + +Given the C code: + +@example +void print_number(int n) +@{ + printf("N: %d\n", n); +@} +@end example + +@lisp +CFFI> (foreign-funcall "print_number" :int 123456) +@print{} N: 123456 +@result{} NIL +@end lisp + +@noindent +Or, equivalently: + +@lisp +CFFI> (foreign-funcall "print_number" :int 123456 :void) +@print{} N: 123456 +@result{} NIL +@end lisp + +@lisp +CFFI> (foreign-funcall "printf" :string (format nil "%s: %d.~%") + :string "So long and thanks for all the fish" + :int 42 :int) +@print{} So long and thanks for all the fish: 42. +@result{} 41 +@end lisp + +@subheading See Also +@seealso{defcfun} @* +@seealso{foreign-funcall-pointer} + + +@c =================================================================== +@c FOREIGN-FUNCALL-POINTER + +@node foreign-funcall-pointer +@unnumberedsec foreign-funcall-pointer +@subheading Syntax +@Macro{foreign-funcall pointer options &rest arguments @result{} return-value} + +arguments ::= @{ arg-type arg @}* [return-type] +options ::= ( &key calling-convention cconv ) + +@subheading Arguments and Values + +@table @var +@item pointer +A foreign pointer. + +@item arg-type +A foreign type. + +@item arg +An argument of type @var{arg-type}. + +@item return-type +A foreign type, @code{:void} by default. + +@item return-value +A lisp object. + +@item calling-convention +@itemx cconv +One of @code{:cdecl} (default) or @code{:stdcall}. +@end table + +@subheading Description +The @code{foreign-funcall} macro is the main primitive for calling +foreign functions. + +@emph{Note: The return value of foreign-funcall on functions with a +:void return type is still undefined.} + +@subheading Implementation-specific Notes +@itemize +@item +Corman Lisp does not support @code{foreign-funcall}. On +implementations that @strong{don't} support @code{foreign-funcall} +@code{cffi-features:no-foreign-funcall} will be present in +@code{*features*}. Note: in these Lisps you can still use the +@code{defcfun} interface. +@end itemize + +@subheading Examples + +@lisp +CFFI> (foreign-funcall-pointer (foreign-symbol-pointer "abs") + :int -42 :int) +@result{} 42 +@end lisp + +@subheading See Also +@seealso{defcfun} @* +@seealso{foreign-funcall} + + +@c =================================================================== +@c CHAPTER: Libraries + +@node Libraries +@chapter Libraries + +@menu +* Defining a library:: +* Library definition style:: + +Dictionary + +* close-foreign-library:: Close a foreign library. +* *darwin-framework-directories*:: Search path for Darwin frameworks. +* define-foreign-library:: Explain how to load a foreign library. +* *foreign-library-directories*:: Search path for shared libraries. +* load-foreign-library:: Load a foreign library. +* load-foreign-library-error:: Signalled on failure of its namesake. +* use-foreign-library:: Load a foreign library when needed. +@end menu + + +@node Defining a library +@section Defining a library + +Almost all foreign code you might want to access exists in some kind +of shared library. The meaning of @dfn{shared library} varies among +platforms, but for our purposes, we will consider it to include +@file{.so} files on @sc{unix}, frameworks on Darwin (and derivatives +like Mac @acronym{OS X}), and @file{.dll} files on Windows. + +Bringing one of these libraries into the Lisp image is normally a +two-step process. + +@enumerate +@item +Describe to @cffi{} how to load the library at some future point, +depending on platform and other factors, with a +@code{define-foreign-library} top-level form. + +@item +Load the library so defined with either a top-level +@code{use-foreign-library} form or by calling the function +@code{load-foreign-library}. +@end enumerate + +@xref{Tutorial-Loading,, Loading foreign libraries}, for a working +example of the above two steps. + + +@node Library definition style +@section Library definition style + +Looking at the @code{libcurl} library definition presented earlier, +you may ask why we did not simply do this: + +@lisp +(define-foreign-library libcurl + (t (:default "libcurl"))) +@end lisp + +@noindent +Indeed, this would work just as well on the computer on which I tested +the tutorial. There are a couple of good reasons to provide the +@file{.so}'s current version number, however. Namely, the versionless +@file{.so} is not packaged on most @sc{unix} systems along with the +actual, fully-versioned library; instead, it is included in the +``development'' package along with C headers and static @file{.a} +libraries. + +The reason @cffi{} does not try to account for this lies in the +meaning of the version numbers. A full treatment of shared library +versions is beyond this manual's scope; see @ref{Versioning,, Library +interface versions, libtool, @acronym{GNU} Libtool}, for helpful +information for the unfamiliar. For our purposes, consider that a +mismatch between the library version with which you tested and the +installed library version may cause undefined +behavior.@footnote{Windows programmers may chafe at adding a +@sc{unix}-specific clause to @code{define-foreign-library}. Instead, +ask why the Windows solution to library incompatibility is ``include +your own version of every library you use with every program''.} + +@impnote{Maybe some notes should go here about OS X, which I know +little about. --stephen} + + +@c =================================================================== +@c CLOSE-FOREIGN-LIBRARY + +@node close-foreign-library +@unnumberedsec close-foreign-library +@subheading Syntax +@Function{close-foreign-library library @result{} success} + +@subheading Arguments and Values + +@table @var +@item library +A symbol or an instance of @code{foreign-library}. + +@item success +A Lisp boolean. +@end table + +@subheading Description + +Closes @var{library} which can be a symbol designating a library +define through @code{define-foreign-library} or an instance of +@code{foreign-library} as returned by @code{load-foreign-library}. + +@c @subheading Examples +@c @xref{Tutorial-Loading,, Loading foreign libraries}. + +@subheading See Also + +@seealso{define-foreign-library} @* +@seealso{load-foreign-library} @* +@seealso{use-foreign-library} + + +@c =================================================================== +@c *DARWIN-FRAMEWORK-DIRECTORIES* + +@node *darwin-framework-directories* +@unnumberedsec *darwin-framework-directories* +@subheading Syntax + +@Variable{*darwin-framework-directories*} + +@subheading Value type + +A list, in which each element is a string, a pathname, or a simple +Lisp expression. + +@subheading Initial value + +A list containing the following, in order: an expression corresponding +to Darwin path @file{~/Library/Frameworks/}, +@code{#P"/Library/Frameworks/"}, and +@code{#P"/System/Library/Frameworks/"}. + +@subheading Description + +The meaning of ``simple Lisp expression'' is explained in +@ref{*foreign-library-directories*}. In contrast to that variable, +this is not a fallback search path; the default value described above +is intended to be a reasonably complete search path on Darwin systems. + +@subheading Examples + +@lisp +CFFI> (load-foreign-library '(:framework "OpenGL")) +@result{} #P"/System/Library/Frameworks/OpenGL.framework/OpenGL" +@end lisp + +@subheading See also + +@seealso{*foreign-library-directories*} @* +@seealso{define-foreign-library} + + +@c =================================================================== +@c DEFINE-FOREIGN-LIBRARY + +@node define-foreign-library +@unnumberedsec define-foreign-library + +@subheading Syntax + +@Macro{define-foreign-library name-and-options @{ load-clause @}* @result{} name} + +name-and-options ::= name | (name &key calling-convention cconv) +load-clause ::= (feature library &key calling-convention cconv) + +@subheading Arguments and Values + +@table @var +@item name +A symbol. + +@item feature +A feature expression. + +@item library +A library designator. + +@item calling-convention +@itemx cconv +One of @code{:cdecl} (default) or @code{:stdcall} +@end table + +@subheading Description + +Creates a new library designator called @var{name}. The +@var{load-clause}s describe how to load that designator when passed to +@code{load-foreign-library} or @code{use-foreign-library}. + +When trying to load the library @var{name}, the relevant function +searches the @var{load-clause}s in order for the first one where +@var{feature} evaluates to true. That happens for any of the +following situations:@footnote{This is described in +@code{cffi-feature-p} in @file{libraries.lisp}.} + +@enumerate 1 +@item +If @var{feature} is a symbol (idiomatically a keyword), a symbol with +the same name, but interned into the @code{cffi-features} package, is +present in @code{common-lisp:*features*}. + +@item +If @var{feature} is a list, depending on @code{(first @var{feature})}, +a keyword: + +@table @code +@item :and +All of the feature expressions in @code{(rest @var{feature})} are +true. + +@item :or +At least one of the feature expressions in @code{(rest @var{feature})} +is true. + +@item :not +The feature expression @code{(second @var{feature})} is not true. +@end table + +@item +Finally, if @var{feature} is @code{t}, this @var{load-clause} is +picked unconditionally. +@end enumerate + +Upon finding the first true @var{feature}, the library loader then +loads the @var{library}. The meaning of ``library designator'' is +described in @ref{load-foreign-library}. + +Functions associated to a library defined by +@code{define-foreign-library} (e.g. through @code{defcfun}'s +@code{:library} option, will inherit the library's options. The +precedence is as follows: + +@enumerate 1 +@item +@code{defcfun}/@code{foreign-funcall} specific options; + +@item +@var{load-clause} options; + +@item +global library options (the @var{name-and-options} argument) +@end enumerate + + +@subheading Examples + +@xref{Tutorial-Loading,, Loading foreign libraries}. + + +@subheading See Also + +@seealso{close-foreign-library} @* +@seealso{load-foreign-library} + + +@c =================================================================== +@c *FOREIGN-LIBRARY-DIRECTORIES* + +@node *foreign-library-directories* +@unnumberedsec *foreign-library-directories* +@subheading Syntax + +@Variable{*foreign-library-directories*} + +@subheading Value type + +A list, in which each element is a string, a pathname, or a simple +Lisp expression. + +@subheading Initial value + +The empty list. + +@subheading Description + +You should not have to use this variable. + +Most, if not all, Lisps supported by @cffi{} have a reasonable default +search algorithm for foreign libraries. For example, Lisps for +@sc{unix} usually call +@uref{http://www.opengroup.org/onlinepubs/009695399/functions/dlopen.html,, +@code{dlopen(3)}}, which in turn looks in the system library +directories. Only if that fails does @cffi{} look for the named +library file in these directories, and load it from there if found. + +Thus, this is intended to be a @cffi{}-only fallback to the library +search configuration provided by your operating system. For example, +if you distribute a foreign library with your Lisp package, you can +add the library's containing directory to this list and portably +expect @cffi{} to find it. + +A @dfn{simple Lisp expression} is intended to provide functionality +commonly used in search paths such as +@acronym{ASDF}'s@footnote{@xref{Using asdf to load systems,,, asdf, +asdf: another system definition facility}, for information on +@code{asdf:*central-registry*}.}, and is defined recursively as +follows:@footnote{See @code{mini-eval} in @file{libraries.lisp} for +the source of this definition. As is always the case with a Lisp +@code{eval}, it's easier to understand the Lisp definition than the +english.} + +@enumerate +@item +A list, whose @samp{first} is a function designator, and whose +@samp{rest} is a list of simple Lisp expressions to be evaluated and +passed to the so-designated function. The result is the result of the +function call. + +@item +A symbol, whose result is its symbol value. + +@item +Anything else evaluates to itself. +@end enumerate + + +@subheading Examples + +@example +$ ls +@print{} liblibli.so libli.lisp +@end example + +@noindent +In @file{libli.lisp}: + +@lisp +(pushnew #P"/home/sirian/lisp/libli/" *foreign-library-directories* + :test #'equal) + +(load-foreign-library '(:default "liblibli")) +@end lisp + +@noindent +The following example would achieve the same effect: + +@lisp +(pushnew '(merge-pathnames #p"lisp/libli/" (user-homedir-pathname)) + *foreign-library-directories* + :test #'equal) +@result{} ((MERGE-PATHNAMES #P"lisp/libli/" (USER-HOMEDIR-PATHNAME))) + +(load-foreign-library '(:default "liblibli")) +@end lisp + +@subheading See also + +@seealso{*darwin-framework-directories*} @* +@seealso{define-foreign-library} + + +@c =================================================================== +@c LOAD-FOREIGN-LIBRARY + +@node load-foreign-library +@unnumberedsec load-foreign-library +@subheading Syntax +@Function{load-foreign-library library @result{} handler} + +@subheading Arguments and Values + +@table @var +@item library +A library designator. + +@item handler +An instance of @code{foreign-library}. +@end table + +@subheading Description + +Load the library indicated by @var{library}. A @dfn{library +designator} is defined as follows: + +@enumerate +@item +If a symbol, is considered a name previously defined with +@code{define-foreign-library}. + +@item +If a string or pathname, passed as a namestring directly to the +implementation's foreign library loader. If that fails, search the +directories in @code{*foreign-library-directories*} with +@code{cl:probe-file}; if found, the absolute path is passed to the +implementation's loader. + +@item +If a list, the meaning depends on @code{(first @var{library})}: + +@table @code +@item :framework +The second list element is taken to be a Darwin framework name, which +is then searched in @code{*darwin-framework-directories*}, and loaded +when found. + +@item :or +Each remaining list element, itself a library designator, is loaded in +order, until one succeeds. + +@item :default +The name is transformed according to the platform's naming convention +to shared libraries, and the resultant string is loaded as a library +designator. For example, on @sc{unix}, the name is suffixed with +@file{.so}. +@end table +@end enumerate + +If the load fails, signal a @code{load-foreign-library-error}. + +@strong{Please note:} For system libraries, you should not need to +specify the directory containing the library. Each operating system +has its own idea of a default search path, and you should rely on it +when it is reasonable. + +@subheading Implementation-specific Notes +On ECL platforms where its dynamic FFI is not supported (ie. when +@code{:dffi} is not present in @code{*features*}), +@code{cffi:load-foreign-library} does not work and you must use ECL's +own @code{ffi:load-foreign-library} with a constant string argument. + +@subheading Examples + +@xref{Tutorial-Loading,, Loading foreign libraries}. + +@subheading See Also + +@seealso{close-foreign-library} @* +@seealso{*darwin-framework-directories*} @* +@seealso{define-foreign-library} @* +@seealso{*foreign-library-directories*} @* +@seealso{load-foreign-library-error} @* +@seealso{use-foreign-library} + + +@c =================================================================== +@c LOAD-FOREIGN-LIBRARY-ERROR + +@node load-foreign-library-error +@unnumberedsec load-foreign-library-error + +@subheading Syntax + +@Condition{load-foreign-library-error} + +@subheading Class precedence list + +@code{load-foreign-library-error}, @code{error}, +@code{serious-condition}, @code{condition}, @code{t} + +@subheading Description + +Signalled when a foreign library load completely fails. The exact +meaning of this varies depending on the real conditions at work, but +almost universally, the implementation's error message is useless. +However, @cffi{} does provide the useful restarts @code{retry} and +@code{use-value}; invoke the @code{retry} restart to try loading the +foreign library again, or the @code{use-value} restart to try loading +a different foreign library designator. + +@subheading See also + +@seealso{load-foreign-library} + + +@c =================================================================== +@c USE-FOREIGN-LIBRARY + +@node use-foreign-library +@unnumberedsec use-foreign-library + +@subheading Syntax + +@Macro{use-foreign-library name} + +@subheading Arguments and values + +@table @var +@item name +A library designator; unevaluated. +@end table + + +@subheading Description + +@xref{load-foreign-library}, for the meaning of ``library +designator''. This is intended to be the top-level form used +idiomatically after a @code{define-foreign-library} form to go ahead +and load the library. @c ; it also sets the ``current foreign library''. +Finally, on implementations where the regular evaluation rule is +insufficient for foreign library loading, it loads it at the required +time.@footnote{Namely, @acronym{CMUCL}. See +@code{use-foreign-library} in @file{libraries.lisp} for details.} + +@c current foreign library is a concept created a few hours ago as of +@c this writing. It is not actually used yet, but probably will be. + +@subheading Examples + +@xref{Tutorial-Loading,, Loading foreign libraries}. + + +@subheading See also + +@seealso{load-foreign-library} + + +@c =================================================================== +@c CHAPTER: Callbacks + +@node Callbacks +@chapter Callbacks + +@menu +Dictionary + +* callback:: +* defcallback:: +* get-callback:: +@end menu + + +@c =================================================================== +@c CALLBACK + +@node callback +@unnumberedsec callback +@subheading Syntax +@Macro{callback symbol @result{} pointer} + +@subheading Arguments and Values + +@table @var +@item symbol +A symbol denoting a callback. + +@item pointer +@itemx new-value +A pointer. +@end table + +@subheading Description +The @code{callback} macro is analogous to the standard CL special +operator @code{function} and will return a pointer to the callback +denoted by the symbol @var{name}. + +@subheading Examples + +@lisp +CFFI> (defcallback sum :int ((a :int) (b :int)) + (+ a b)) +@result{} SUM +CFFI> (callback sum) +@result{} # +@end lisp + +@subheading See Also +@seealso{get-callback} @* +@seealso{defcallback} + + +@c =================================================================== +@c DEFCALLBACK + +@node defcallback +@unnumberedsec defcallback +@subheading Syntax +@Macro{defcallback name-and-options return-type arguments &body body @result{} name} + +name-and-options ::= name | (name &key calling-convention cconv) +arguments ::= (@{ (arg-name arg-type) @}*) + +@subheading Arguments and Values + +@table @var +@item name +A symbol naming the callback created. + +@item return-type +The foreign type for the callback's return value. + +@item arg-name +A symbol. + +@item arg-type +A foreign type. + +@item calling-convention +@itemx cconv +One of @code{:cdecl} (default) or @code{:stdcall}. +@end table + +@subheading Description +The macro @code{defcallback} defines a Lisp function the can be called +from C (but not from Lisp). The arguments passed to this function will +be converted to the appropriate Lisp representation and its return +value will be converted to its C representation. + +This Lisp function can be accessed by the @code{callback} macro or the +@code{get-callback} function. + +@strong{Portability note:} @code{defcallback} will not work correctly +on some Lisps if it's not a top-level form. + +@subheading Examples + +@lisp +(defcfun "qsort" :void + (base :pointer) + (nmemb :int) + (size :int) + (fun-compar :pointer)) + +(defcallback < :int ((a :pointer) (b :pointer)) + (let ((x (mem-ref a :int)) + (y (mem-ref b :int))) + (cond ((> x y) 1) + ((< x y) -1) + (t 0)))) + +CFFI> (with-foreign-object (array :int 10) + ;; @lispcmt{Initialize array.} + (loop for i from 0 and n in '(7 2 10 4 3 5 1 6 9 8) + do (setf (mem-aref array :int i) n)) + ;; @lispcmt{Sort it.} + (qsort array 10 (foreign-type-size :int) (callback <)) + ;; @lispcmt{Return it as a list.} + (loop for i from 0 below 10 + collect (mem-aref array :int i))) +@result{} (1 2 3 4 5 6 7 8 9 10) +@end lisp + +@subheading See Also +@seealso{callback} @* +@seealso{get-callback} + + +@c =================================================================== +@c GET-CALLBACK + +@node get-callback +@unnumberedsec get-callback +@subheading Syntax +@Accessor{get-callback symbol @result{} pointer} + +@subheading Arguments and Values + +@table @var +@item symbol +A symbol denoting a callback. + +@item pointer +A pointer. +@end table + +@subheading Description +This is the functional version of the @code{callback} macro. It +returns a pointer to the callback named by @var{symbol} suitable, for +example, to pass as arguments to foreign functions. + +@subheading Examples + +@lisp +CFFI> (defcallback sum :int ((a :int) (b :int)) + (+ a b)) +@result{} SUM +CFFI> (get-callback 'sum) +@result{} # +@end lisp + +@subheading See Also +@seealso{callback} @* +@seealso{defcallback} + +@c =================================================================== +@c CHAPTER: Limitations + +@node Limitations +@chapter Limitations + +These are @cffi{}'s limitations across all platforms; for information +on the warts on particular Lisp implementations, see +@ref{Implementation Support}. + +@itemize @bullet +@item +The tutorial includes a treatment of the primary, intractable +limitation of @cffi{}, or any @acronym{FFI}: that the abstractions +commonly used by C are insufficiently expressive. +@xref{Tutorial-Abstraction,, Breaking the abstraction}, for more +details. + +@item +C @code{struct}s cannot be passed by value. +@end itemize + +@c more? + + +@node Platform-specific features +@appendix Platform-specific features + +@cffi{} does some platform tests on loading. The details vary between +Lisps; in fact, the purpose is to unify the list of available platform +features for use elsewhere in the @cffi{} code. These features are +also part of the public interface; see @ref{define-foreign-library}. + +The exact meanings of the features follow. Though you will usually +refer to these symbols as keywords, @cffi{} internally views them in +the package @code{cffi-features}. + +@table @code +@item flat-namespace +This Lisp has a flat namespace for foreign symbols meaning that you +won't be able to load two different libraries with homograph functions +and successfully differentiate them through the @code{:library} +option to @code{defcfun}, @code{defcvar}, etc@dots{} + +@item darwin +This operating system is Darwin or a derivative thereof, such as +Mac @acronym{OS X}. + +@item no-foreign-funcall +The macro @code{foreign-funcall} is @strong{not} available. On such +platforms, the only way to call a foreign function is through +@code{defcfun}. @xref{foreign-funcall}, and @ref{defcfun}. + +@item no-long-long +The C @code{long long} type is @strong{not} available as a foreign +type. + +@item no-stdcall +This Lisp doesn't support the @code{stdcall} calling convention. Note +that it only makes sense to support @code{stdcall} on (32-bit) x86 +platforms. + +@item ppc32 +The underlying @acronym{CPU} architecture is 32-bit PowerPC. + +@item unix +This operating system is a @sc{unix}-like, such as +@acronym{GNU}/Linux, Darwin, or even Cygwin on Lisps that show the +@sc{unix}-like interface provided by Cygwin to Lisp code. + +@item windows +This operating system is Windows. + +@item x86 +The underlying @acronym{CPU} architecture is x86, such as on +processors from Intel or @acronym{AMD}. +@end table + + +@node Glossary +@appendix Glossary + +@table @dfn +@item aggregate type +A @cffi{} type for C data defined as an organization of data of simple +type; in structures and unions, which are themselves aggregate types, +they are represented by value. + +@item foreign value +This has two meanings; in any context, only one makes sense. + +When using type translators, the foreign value is the lower-level Lisp +value derived from the object passed to @code{translate-to-foreign} +(@pxref{translate-to-foreign}). This value should be a Lisp number or +a pointer (satisfies @code{pointerp}), and it can be treated like any +general Lisp object; it only completes the transformation to a true +foreign value when passed through low-level code in the Lisp +implementation, such as the foreign function caller or indirect memory +addressing combined with a data move. + +In other contexts, this refers to a value accessible by C, but which +may only be accessed through @cffi{} functions. The closest you can +get to such a foreign value is through a pointer Lisp object, which +itself counts as a foreign value in only the previous sense. + +@item simple type +A @cffi{} type that is ultimately represented as a builtin type; +@cffi{} only provides extra semantics for Lisp that are invisible to C +code or data. +@end table + +@node Comprehensive Index +@unnumbered Index +@printindex cp + +@bye diff --git a/external/cffi.darcs/doc/cffi-sys-spec.texinfo b/external/cffi.darcs/doc/cffi-sys-spec.texinfo new file mode 100644 index 0000000..36f56a8 --- /dev/null +++ b/external/cffi.darcs/doc/cffi-sys-spec.texinfo @@ -0,0 +1,309 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header +@setfilename cffi-sys.info +@settitle CFFI-SYS Interface Specification + +@c Show types in the same index as the functions. +@synindex tp fn + +@copying +Copyright @copyright{} 2005-2006, James Bielman + +@quotation +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the ``Software''), to deal in the Software without +restriction, including without limitation the rights to use, copy, +modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +@sc{The software is provided ``as is'', without warranty of any kind, +express or implied, including but not limited to the warranties of +merchantability, fitness for a particular purpose and +noninfringement. In no event shall the authors or copyright +holders be liable for any claim, damages or other liability, +whether in an action of contract, tort or otherwise, arising from, +out of or in connection with the software or the use or other +dealings in the software.} +@end quotation +@end copying + +@macro impnote {text} +@emph{Implementor's note: \text\} +@end macro +@c %**end of header + +@titlepage +@title CFFI-SYS Interface Specification +@c @subtitle Version X.X +@c @author James Bielman + +@page +@vskip 0pt plus 1filll +@insertcopying +@end titlepage + +@contents + +@ifnottex +@node Top +@top cffi-sys +@insertcopying +@end ifnottex + +@menu +* Introduction:: +* Built-In Foreign Types:: +* Operations on Foreign Types:: +* Basic Pointer Operations:: +* Foreign Memory Allocation:: +* Memory Access:: +* Foreign Function Calling:: +* Loading Foreign Libraries:: +* Foreign Globals:: +* Symbol Index:: +@end menu + +@node Introduction +@chapter Introduction + +@acronym{CFFI}, the Common Foreign Function Interface, purports to be +a portable foreign function interface for Common Lisp. + +This specification defines a set of low-level primitives that must be +defined for each Lisp implementation supported by @acronym{CFFI}. +These operators are defined in the @code{CFFI-SYS} package. + +The @code{CFFI} package uses the @code{CFFI-SYS} interface +to implement an extensible foreign type system with support for +typedefs, structures, and unions, a declarative interface for +defining foreign function calls, and automatic conversion of +foreign function arguments to/from Lisp types. + +Please note the following conventions that apply to everything in +@code{CFFI-SYS}: + +@itemize @bullet +@item +Functions in @code{CFFI-SYS} that are low-level versions of functions +exported from the @code{CFFI} package begin with a leading +percent-sign (eg. @code{%mem-ref}). + +@item +Where ``foreign type'' is mentioned as the kind of an argument, the +meaning is restricted to that subset of all foreign types defined in +@ref{Built-In Foreign Types}. Support for higher-level types is +always defined in terms of those lower-level types in @code{CFFI} +proper. +@end itemize + + +@node Built-In Foreign Types +@chapter Built-In Foreign Types + +@deftp {Foreign Type} :char +@deftpx {Foreign Type} :unsigned-char +@deftpx {Foreign Type} :short +@deftpx {Foreign Type} :unsigned-short +@deftpx {Foreign Type} :int +@deftpx {Foreign Type} :unsigned-int +@deftpx {Foreign Type} :long +@deftpx {Foreign Type} :unsigned-long +@deftpx {Foreign Type} :long-long +@deftpx {Foreign Type} :unsigned-long-long +These types correspond to the native C integer types according to the +ABI of the system the Lisp implementation is compiled against. +@end deftp + +@deftp {Foreign Type} :int8 +@deftpx {Foreign Type} :uint8 +@deftpx {Foreign Type} :int16 +@deftpx {Foreign Type} :uint16 +@deftpx {Foreign Type} :int32 +@deftpx {Foreign Type} :uint32 +@deftpx {Foreign Type} :int64 +@deftpx {Foreign Type} :uint64 +Foreign integer types of specific sizes, corresponding to the C types +defined in @code{stdint.h}. +@end deftp + +@deftp {Foreign Type} :size +@deftpx {Foreign Type} :ssize +@deftpx {Foreign Type} :ptrdiff +@deftpx {Foreign Type} :time +Foreign integer types corresponding to the standard C types (without +the @code{_t} suffix). +@end deftp + +@impnote{I'm sure there are more of these that could be useful, let's +add any types that can't be defined portably to this list as +necessary.} + +@deftp {Foreign Type} :float +@deftpx {Foreign Type} :double +The @code{:float} type represents a C @code{float} and a Lisp +@code{single-float}. @code{:double} represents a C @code{double} and a +Lisp @code{double-float}. +@end deftp + +@deftp {Foreign Type} :pointer +A foreign pointer to an object of any type, corresponding to +@code{void *}. +@end deftp + +@deftp {Foreign Type} :void +No type at all. Only valid as the return type of a function. +@end deftp + + +@node Operations on Foreign Types +@chapter Operations on Built-in Foreign Types + +@defun %foreign-type-size type @result{} size +Return the @var{size}, in bytes, of objects having foreign type +@var{type}. An error is signalled if @var{type} is not a known +built-in foreign type. +@end defun + +@defun %foreign-type-alignment type @result{} alignment +Return the default alignment in bytes for structure members of foreign +type @var{type}. An error is signalled if @var{type} is not a known +built-in foreign type. + +@impnote{Maybe this should take an optional keyword argument specifying an +alternate alignment system, eg. :mac68k for 68000-compatible alignment +on Darwin.} +@end defun + + +@node Basic Pointer Operations +@chapter Basic Pointer Operations + +@defun pointerp ptr @result{} boolean +Return true if @var{ptr} is a foreign pointer. +@end defun + +@defun null-pointer @result{} pointer +Return a null foreign pointer. +@end defun + +@defun null-pointer-p ptr @result{} boolean +Return true if @var{ptr} is a null foreign pointer. +@end defun + +@defun make-pointer address @result{} pointer +Return a pointer corresponding to the numeric integer @var{address}. +@end defun + +@defun inc-pointer ptr offset @result{} pointer +Return the result of numerically incrementing @var{ptr} by @var{offset}. +@end defun + + +@node Foreign Memory Allocation +@chapter Foreign Memory Allocation + +@defun foreign-alloc size @result{} pointer +Allocate @var{size} bytes of foreign-addressable memory and return +a @var{pointer} to the allocated block. An implementation-specific +error is signalled if the memory cannot be allocated. +@end defun + +@defun foreign-free ptr @result{} unspecified +Free a pointer @var{ptr} allocated by @code{foreign-alloc}. The +results are undefined if @var{ptr} is used after being freed. +@end defun + +@defmac with-foreign-pointer (var size &optional size-var) &body body +Bind @var{var} to a pointer to @var{size} bytes of +foreign-accessible memory during @var{body}. Both @var{ptr} and the +memory block it points to have dynamic extent and may be stack +allocated if supported by the implementation. If @var{size-var} is +supplied, it will be bound to @var{size} during @var{body}. +@end defmac + + +@node Memory Access +@chapter Memory Access + +@deffn {Accessor} %mem-ref ptr type &optional offset +Dereference a pointer @var{offset} bytes from @var{ptr} to an object +for reading (or writing when used with @code{setf}) of built-in type +@var{type}. +@end deffn + +@heading Example + +@lisp +;; An impractical example, since time returns the time as well, +;; but it demonstrates %MEM-REF. Better (simple) examples wanted! +(with-foreign-pointer (p (foreign-type-size :time)) + (foreign-funcall "time" :pointer p :time) + (%mem-ref p :time)) +@end lisp + + +@node Foreign Function Calling +@chapter Foreign Function Calling + +@defmac %foreign-funcall name @{arg-type arg@}* &optional result-type @result{} object +@defmacx %foreign-funcall-pointer ptr @{arg-type arg@}* &optional result-type @result{} object +Invoke a foreign function called @var{name} in the foreign source code. + +Each @var{arg-type} is a foreign type specifier, followed by +@var{arg}, Lisp data to be converted to foreign data of type +@var{arg-type}. @var{result-type} is the foreign type of the +function's return value, and is assumed to be @code{:void} if not +supplied. + +@code{%foreign-funcall-pointer} takes a pointer @var{ptr} to the +function, as returned by @code{foreign-symbol-pointer}, rather than a +string @var{name}. +@end defmac + +@heading Examples + +@lisp +;; Calling a standard C library function: +(%foreign-funcall "sqrtf" :float 16.0 :float) @result{} 4.0 +@end lisp + +@lisp +;; Dynamic allocation of a buffer and passing to a function: +(with-foreign-ptr (buf 255 buf-size) + (%foreign-funcall "gethostname" :pointer buf :size buf-size :int) + ;; Convert buf to a Lisp string using MAKE-STRING and %MEM-REF or + ;; a portable CFFI function such as CFFI:FOREIGN-STRING-TO-LISP. + ) +@end lisp + + +@node Loading Foreign Libraries +@chapter Loading Foreign Libraries + +@defun %load-foreign-library name @result{} unspecified +Load the foreign shared library @var{name}. + +@impnote{There is a lot of behavior to decide here. Currently I lean +toward not requiring NAME to be a full path to the library so +we can search the system library directories (maybe even get +LD_LIBRARY_PATH from the environment) as necessary.} +@end defun + + +@node Foreign Globals +@chapter Foreign Globals + +@defun foreign-symbol-pointer name @result{} pointer +Return a pointer to a foreign symbol @var{name}. +@end defun + +@node Symbol Index +@unnumbered Symbol Index +@printindex fn + +@bye diff --git a/external/cffi.darcs/doc/colorize-lisp-examples.lisp b/external/cffi.darcs/doc/colorize-lisp-examples.lisp new file mode 100644 index 0000000..420ff42 --- /dev/null +++ b/external/cffi.darcs/doc/colorize-lisp-examples.lisp @@ -0,0 +1,1051 @@ +;;; This is code was taken from lisppaste2 and is a quick hack +;;; to colorize lisp examples in the html generated by Texinfo. +;;; It is not general-purpose utility, though it could easily be +;;; turned into one. + +;;;; colorize-package.lisp + +(defpackage :colorize + (:use :common-lisp) + (:export :scan-string :format-scan :html-colorization + :find-coloring-type :autodetect-coloring-type + :coloring-types :scan :scan-any :advance :call-parent-formatter + :*coloring-css* :make-background-css :*css-background-class* + :colorize-file :colorize-file-to-stream :*version-token*)) + +;;;; coloring-css.lisp + +(in-package :colorize) + +(defparameter *coloring-css* + ".symbol { color: #770055; background-color: transparent; border: 0px; margin: 0px;} +a.symbol:link { color: #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } +a.symbol:active { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } +a.symbol:visited { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } +a.symbol:hover { color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } +.special { color : #FF5000; background-color : inherit; } +.keyword { color : #770000; background-color : inherit; } +.comment { color : #007777; background-color : inherit; } +.string { color : #777777; background-color : inherit; } +.character { color : #0055AA; background-color : inherit; } +.syntaxerror { color : #FF0000; background-color : inherit; } +span.paren1:hover { color : inherit; background-color : #BAFFFF; } +span.paren2:hover { color : inherit; background-color : #FFCACA; } +span.paren3:hover { color : inherit; background-color : #FFFFBA; } +span.paren4:hover { color : inherit; background-color : #CACAFF; } +span.paren5:hover { color : inherit; background-color : #CAFFCA; } +span.paren6:hover { color : inherit; background-color : #FFBAFF; } +") + +(defvar *css-background-class* "lisp-bg") + +(defun for-css (thing) + (if (symbolp thing) (string-downcase (symbol-name thing)) + thing)) + +(defun make-background-css (color &key (class *css-background-class*) (extra nil)) + (format nil ".~A { background-color: ~A; color: black; ~{~A; ~}}~:*~:*~:* +.~A:hover { background-color: ~A; color: black; ~{~A; ~}}~%" + class color + (mapcar #'(lambda (extra) + (format nil "~A : ~{~A ~}" + (for-css (first extra)) + (mapcar #'for-css (cdr extra)))) + extra))) + +;;;; colorize.lisp + +;(in-package :colorize) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *coloring-types* nil) + (defparameter *version-token* (gensym))) + +(defclass coloring-type () + ((modes :initarg :modes :accessor coloring-type-modes) + (default-mode :initarg :default-mode :accessor coloring-type-default-mode) + (transition-functions :initarg :transition-functions :accessor coloring-type-transition-functions) + (fancy-name :initarg :fancy-name :accessor coloring-type-fancy-name) + (term-formatter :initarg :term-formatter :accessor coloring-type-term-formatter) + (formatter-initial-values :initarg :formatter-initial-values :accessor coloring-type-formatter-initial-values :initform nil) + (formatter-after-hook :initarg :formatter-after-hook :accessor coloring-type-formatter-after-hook :initform (constantly "")) + (autodetect-function :initarg :autodetect-function :accessor coloring-type-autodetect-function + :initform (constantly nil)) + (parent-type :initarg :parent-type :accessor coloring-type-parent-type + :initform nil) + (visible :initarg :visible :accessor coloring-type-visible + :initform t))) + +(defun find-coloring-type (type) + (if (typep type 'coloring-type) + type + (cdr (assoc (symbol-name type) *coloring-types* :test #'string-equal :key #'symbol-name)))) + +(defun autodetect-coloring-type (name) + (car + (find name *coloring-types* + :key #'cdr + :test #'(lambda (name type) + (and (coloring-type-visible type) + (funcall (coloring-type-autodetect-function type) name)))))) + +(defun coloring-types () + (loop for type-pair in *coloring-types* + if (coloring-type-visible (cdr type-pair)) + collect (cons (car type-pair) + (coloring-type-fancy-name (cdr type-pair))))) + +(defun (setf find-coloring-type) (new-value type) + (if new-value + (let ((found (assoc type *coloring-types*))) + (if found + (setf (cdr found) new-value) + (setf *coloring-types* + (nconc *coloring-types* + (list (cons type new-value)))))) + (setf *coloring-types* (remove type *coloring-types* :key #'car)))) + +(defvar *scan-calls* 0) + +(defvar *reset-position* nil) + +(defmacro with-gensyms ((&rest names) &body body) + `(let ,(mapcar #'(lambda (name) + (list name `(make-symbol ,(symbol-name name)))) names) + ,@body)) + +(defmacro with-scanning-functions (string-param position-place mode-place mode-wait-place &body body) + (with-gensyms (num items position not-preceded-by string item new-mode until advancing) + `(labels ((advance (,num) + (setf ,position-place (+ ,position-place ,num)) + t) + (peek-any (,items &key ,not-preceded-by) + (incf *scan-calls*) + (let* ((,items (if (stringp ,items) + (coerce ,items 'list) ,items)) + (,not-preceded-by (if (characterp ,not-preceded-by) + (string ,not-preceded-by) ,not-preceded-by)) + (,position ,position-place) + (,string ,string-param)) + (let ((,item (and + (< ,position (length ,string)) + (find ,string ,items + :test #'(lambda (,string ,item) + #+nil + (format t "looking for ~S in ~S starting at ~S~%" + ,item ,string ,position) + (if (characterp ,item) + (char= (elt ,string ,position) + ,item) + (search ,item ,string :start2 ,position + :end2 (min (length ,string) + (+ ,position (length ,item)))))))))) + (if (characterp ,item) + (setf ,item (string ,item))) + (if + (if ,item + (if ,not-preceded-by + (if (>= (- ,position (length ,not-preceded-by)) 0) + (not (string= (subseq ,string + (- ,position (length ,not-preceded-by)) + ,position) + ,not-preceded-by)) + t) + t) + nil) + ,item + (progn + (and *reset-position* + (setf ,position-place *reset-position*)) + nil))))) + (scan-any (,items &key ,not-preceded-by) + (let ((,item (peek-any ,items :not-preceded-by ,not-preceded-by))) + (and ,item (advance (length ,item))))) + (peek (,item &key ,not-preceded-by) + (peek-any (list ,item) :not-preceded-by ,not-preceded-by)) + (scan (,item &key ,not-preceded-by) + (scan-any (list ,item) :not-preceded-by ,not-preceded-by))) + (macrolet ((set-mode (,new-mode &key ,until (,advancing t)) + (list 'progn + (list 'setf ',mode-place ,new-mode) + (list 'setf ',mode-wait-place + (list 'lambda (list ',position) + (list 'let (list (list '*reset-position* ',position)) + (list 'values ,until ,advancing))))))) + ,@body)))) + +(defvar *formatter-local-variables*) + +(defmacro define-coloring-type (name fancy-name &key modes default-mode transitions formatters + autodetect parent formatter-variables (formatter-after-hook '(constantly "")) + invisible) + (with-gensyms (parent-type term type string current-mode position position-foobage mode-wait new-position advance) + `(let ((,parent-type (or (find-coloring-type ,parent) + (and ,parent + (error "No such coloring type: ~S" ,parent))))) + (setf (find-coloring-type ,name) + (make-instance 'coloring-type + :fancy-name ',fancy-name + :modes (append ',modes (if ,parent-type (coloring-type-modes ,parent-type))) + :default-mode (or ',default-mode + (if ,parent-type (coloring-type-default-mode ,parent-type))) + ,@(if autodetect + `(:autodetect-function ,autodetect)) + :parent-type ,parent-type + :visible (not ,invisible) + :formatter-initial-values (lambda nil + (list* ,@(mapcar #'(lambda (e) + `(cons ',(car e) ,(second e))) + formatter-variables) + (if ,parent-type + (funcall (coloring-type-formatter-initial-values ,parent-type)) + nil))) + :formatter-after-hook (lambda nil + (symbol-macrolet ,(mapcar #'(lambda (e) + `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*)))) + formatter-variables) + (concatenate 'string + (funcall ,formatter-after-hook) + (if ,parent-type + (funcall (coloring-type-formatter-after-hook ,parent-type)) + "")))) + :term-formatter + (symbol-macrolet ,(mapcar #'(lambda (e) + `(,(car e) (cdr (assoc ',(car e) *formatter-local-variables*)))) + formatter-variables) + (lambda (,term) + (labels ((call-parent-formatter (&optional (,type (car ,term)) + (,string (cdr ,term))) + (if ,parent-type + (funcall (coloring-type-term-formatter ,parent-type) + (cons ,type ,string)))) + (call-formatter (&optional (,type (car ,term)) + (,string (cdr ,term))) + (funcall + (case (first ,type) + ,@formatters + (t (lambda (,type text) + (call-parent-formatter ,type text)))) + ,type ,string))) + (call-formatter)))) + :transition-functions + (list + ,@(loop for transition in transitions + collect (destructuring-bind (mode &rest table) transition + `(cons ',mode + (lambda (,current-mode ,string ,position) + (let ((,mode-wait (constantly nil)) + (,position-foobage ,position)) + (with-scanning-functions ,string ,position-foobage + ,current-mode ,mode-wait + (let ((*reset-position* ,position)) + (cond ,@table)) + (values ,position-foobage ,current-mode + (lambda (,new-position) + (setf ,position-foobage ,new-position) + (let ((,advance (nth-value 1 (funcall ,mode-wait ,position-foobage)))) + (values ,position-foobage ,advance))))) + ))))))))))) + +(defun full-transition-table (coloring-type-object) + (let ((parent (coloring-type-parent-type coloring-type-object))) + (if parent + (append (coloring-type-transition-functions coloring-type-object) + (full-transition-table parent)) + (coloring-type-transition-functions coloring-type-object)))) + +(defun scan-string (coloring-type string) + (let* ((coloring-type-object (or (find-coloring-type coloring-type) + (error "No such coloring type: ~S" coloring-type))) + (transitions (full-transition-table coloring-type-object)) + (result nil) + (low-bound 0) + (current-mode (coloring-type-default-mode coloring-type-object)) + (mode-stack nil) + (current-wait (constantly nil)) + (wait-stack nil) + (current-position 0) + (*scan-calls* 0)) + (flet ((finish-current (new-position new-mode new-wait &key (extend t) push pop) + (let ((to (if extend new-position current-position))) + (if (> to low-bound) + (setf result (nconc result + (list (cons (cons current-mode mode-stack) + (subseq string low-bound + to)))))) + (setf low-bound to) + (when pop + (pop mode-stack) + (pop wait-stack)) + (when push + (push current-mode mode-stack) + (push current-wait wait-stack)) + (setf current-mode new-mode + current-position new-position + current-wait new-wait)))) + (loop + (if (> current-position (length string)) + (return-from scan-string + (progn + (format *trace-output* "Scan was called ~S times.~%" + *scan-calls*) + (finish-current (length string) nil (constantly nil)) + result)) + (or + (loop for transition in + (mapcar #'cdr + (remove current-mode transitions + :key #'car + :test-not #'(lambda (a b) + (or (eql a b) + (if (listp b) + (member a b)))))) + if + (and transition + (multiple-value-bind + (new-position new-mode new-wait) + (funcall transition current-mode string current-position) + (when (> new-position current-position) + (finish-current new-position new-mode new-wait :extend nil :push t) + t))) + return t) + (multiple-value-bind + (pos advance) + (funcall current-wait current-position) + #+nil + (format t "current-wait returns ~S ~S (mode is ~S, pos is ~S)~%" pos advance current-mode current-position) + (and pos + (when (> pos current-position) + (finish-current (if advance + pos + current-position) + (car mode-stack) + (car wait-stack) + :extend advance + :pop t) + t))) + (progn + (incf current-position))) + ))))) + +(defun format-scan (coloring-type scan) + (let* ((coloring-type-object (or (find-coloring-type coloring-type) + (error "No such coloring type: ~S" coloring-type))) + (color-formatter (coloring-type-term-formatter coloring-type-object)) + (*formatter-local-variables* (funcall (coloring-type-formatter-initial-values coloring-type-object)))) + (format nil "~{~A~}~A" + (mapcar color-formatter scan) + (funcall (coloring-type-formatter-after-hook coloring-type-object))))) + +(defun encode-for-pre (string) + (declare (simple-string string)) + (let ((output (make-array (truncate (length string) 2/3) + :element-type 'character + :adjustable t + :fill-pointer 0))) + (with-output-to-string (out output) + (loop for char across string + do (case char + ((#\&) (write-string "&" out)) + ((#\<) (write-string "<" out)) + ((#\>) (write-string ">" out)) + (t (write-char char out))))) + (coerce output 'simple-string))) + +(defun string-substitute (string substring replacement-string) + "String substitute by Larry Hunter. Obtained from Google" + (let ((substring-length (length substring)) + (last-end 0) + (new-string "")) + (do ((next-start + (search substring string) + (search substring string :start2 last-end))) + ((null next-start) + (concatenate 'string new-string (subseq string last-end))) + (setq new-string + (concatenate 'string + new-string + (subseq string last-end next-start) + replacement-string)) + (setq last-end (+ next-start substring-length))))) + +(defun decode-from-tt (string) + (string-substitute (string-substitute (string-substitute string "&" "&") + "<" "<") + ">" ">")) + +(defun html-colorization (coloring-type string) + (format-scan coloring-type + (mapcar #'(lambda (p) + (cons (car p) + (let ((tt (encode-for-pre (cdr p)))) + (if (and (> (length tt) 0) + (char= (elt tt (1- (length tt))) #\>)) + (format nil "~A~%" tt) tt)))) + (scan-string coloring-type string)))) + +(defun colorize-file-to-stream (coloring-type input-file-name s2 &key (wrap t) (css-background "default")) + (let* ((input-file (if (pathname-type (merge-pathnames input-file-name)) + (merge-pathnames input-file-name) + (make-pathname :type "lisp" + :defaults (merge-pathnames input-file-name)))) + (*css-background-class* css-background)) + (with-open-file (s input-file :direction :input) + (let ((lines nil) + (string nil)) + (block done + (loop (let ((line (read-line s nil nil))) + (if line + (push line lines) + (return-from done))))) + (setf string (format nil "~{~A~%~}" + (nreverse lines))) + (if wrap + (format s2 + " + +
+~A +
" + *coloring-css* + (make-background-css "white") + *css-background-class* + (html-colorization coloring-type string)) + (write-string (html-colorization coloring-type string) s2)))))) + +(defun colorize-file (coloring-type input-file-name &optional output-file-name) + (let* ((input-file (if (pathname-type (merge-pathnames input-file-name)) + (merge-pathnames input-file-name) + (make-pathname :type "lisp" + :defaults (merge-pathnames input-file-name)))) + (output-file (or output-file-name + (make-pathname :type "html" + :defaults input-file)))) + (with-open-file (s2 output-file :direction :output :if-exists :supersede) + (colorize-file-to-stream coloring-type input-file-name s2)))) + +;; coloring-types.lisp + +;(in-package :colorize) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *version-token* (gensym))) + +(defparameter *symbol-characters* + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ*!%$&+-1234567890") + +(defparameter *non-constituent* + '(#\space #\tab #\newline #\linefeed #\page #\return + #\" #\' #\( #\) #\, #\; #\` #\[ #\])) + +(defparameter *special-forms* + '("let" "load-time-value" "quote" "macrolet" "progn" "progv" "go" "flet" "the" + "if" "throw" "eval-when" "multiple-value-prog1" "unwind-protect" "let*" + "labels" "function" "symbol-macrolet" "block" "tagbody" "catch" "locally" + "return-from" "setq" "multiple-value-call")) + +(defparameter *common-macros* + '("loop" "cond" "lambda")) + +(defparameter *open-parens* '(#\()) +(defparameter *close-parens* '(#\))) + +(define-coloring-type :lisp "Basic Lisp" + :modes (:first-char-on-line :normal :symbol :escaped-symbol :keyword :string :comment + :multiline :character + :single-escaped :in-list :syntax-error) + :default-mode :first-char-on-line + :transitions + (((:in-list) + ((or + (scan-any *symbol-characters*) + (and (scan #\.) (scan-any *symbol-characters*)) + (and (scan #\\) (advance 1))) + (set-mode :symbol + :until (scan-any *non-constituent*) + :advancing nil)) + ((or (scan #\:) (scan "#:")) + (set-mode :keyword + :until (scan-any *non-constituent*) + :advancing nil)) + ((scan "#\\") + (let ((count 0)) + (set-mode :character + :until (progn + (incf count) + (if (> count 1) + (scan-any *non-constituent*))) + :advancing nil))) + ((scan #\") + (set-mode :string + :until (scan #\"))) + ((scan #\;) + (set-mode :comment + :until (scan #\newline))) + ((scan "#|") + (set-mode :multiline + :until (scan "|#"))) + ((scan #\() + (set-mode :in-list + :until (scan #\))))) + ((:normal :first-char-on-line) + ((scan #\() + (set-mode :in-list + :until (scan #\))))) + (:first-char-on-line + ((scan #\;) + (set-mode :comment + :until (scan #\newline))) + ((scan "#|") + (set-mode :multiline + :until (scan "|#"))) + ((advance 1) + (set-mode :normal + :until (scan #\newline)))) + (:multiline + ((scan "#|") + (set-mode :multiline + :until (scan "|#")))) + ((:symbol :keyword :escaped-symbol :string) + ((scan #\\) + (let ((count 0)) + (set-mode :single-escaped + :until (progn + (incf count) + (if (< count 2) + (advance 1)))))))) + :formatter-variables ((paren-counter 0)) + :formatter-after-hook (lambda nil + (format nil "~{~A~}" + (loop for i from paren-counter downto 1 + collect ""))) + :formatters + (((:normal :first-char-on-line) + (lambda (type s) + (declare (ignore type)) + s)) + ((:in-list) + (lambda (type s) + (declare (ignore type)) + (labels ((color-parens (s) + (let ((paren-pos (find-if-not #'null + (mapcar #'(lambda (c) + (position c s)) + (append *open-parens* + *close-parens*))))) + (if paren-pos + (let ((before-paren (subseq s 0 paren-pos)) + (after-paren (subseq s (1+ paren-pos))) + (paren (elt s paren-pos)) + (open nil) + (count 0)) + (when (member paren *open-parens* :test #'char=) + (setf count (mod paren-counter 6)) + (incf paren-counter) + (setf open t)) + (when (member paren *close-parens* :test #'char=) + (decf paren-counter)) + (if open + (format nil "~A~C~A" + before-paren + (1+ count) + paren *css-background-class* + (color-parens after-paren)) + (format nil "~A~C~A" + before-paren + paren (color-parens after-paren)))) + s)))) + (color-parens s)))) + ((:symbol :escaped-symbol) + (lambda (type s) + (declare (ignore type)) + (let* ((colon (position #\: s :from-end t)) + (new-s (or (and colon (subseq s (1+ colon))) s))) + (cond + ((or + (member new-s *common-macros* :test #'string-equal) + (member new-s *special-forms* :test #'string-equal) + (some #'(lambda (e) + (and (> (length new-s) (length e)) + (string-equal e (subseq new-s 0 (length e))))) + '("WITH-" "DEF"))) + (format nil "~A" s)) + ((and (> (length new-s) 2) + (char= (elt new-s 0) #\*) + (char= (elt new-s (1- (length new-s))) #\*)) + (format nil "~A" s)) + (t s))))) + (:keyword (lambda (type s) + (declare (ignore type)) + (format nil "~A" + s))) + ((:comment :multiline) + (lambda (type s) + (declare (ignore type)) + (format nil "~A" + s))) + ((:character) + (lambda (type s) + (declare (ignore type)) + (format nil "~A" + s))) + ((:string) + (lambda (type s) + (declare (ignore type)) + (format nil "~A" + s))) + ((:single-escaped) + (lambda (type s) + (call-formatter (cdr type) s))) + ((:syntax-error) + (lambda (type s) + (declare (ignore type)) + (format nil "~A" + s))))) + +(define-coloring-type :scheme "Scheme" + :autodetect (lambda (text) + (or + (search "scheme" text :test #'char-equal) + (search "chicken" text :test #'char-equal))) + :parent :lisp + :transitions + (((:normal :in-list) + ((scan "...") + (set-mode :symbol + :until (scan-any *non-constituent*) + :advancing nil)) + ((scan #\[) + (set-mode :in-list + :until (scan #\]))))) + :formatters + (((:in-list) + (lambda (type s) + (declare (ignore type s)) + (let ((*open-parens* (cons #\[ *open-parens*)) + (*close-parens* (cons #\] *close-parens*))) + (call-parent-formatter)))) + ((:symbol :escaped-symbol) + (lambda (type s) + (declare (ignore type)) + (let ((result (if (find-package :r5rs-lookup) + (funcall (symbol-function (intern "SYMBOL-LOOKUP" :r5rs-lookup)) + s)))) + (if result + (format nil "~A" + result (call-parent-formatter)) + (call-parent-formatter))))))) + +(define-coloring-type :elisp "Emacs Lisp" + :autodetect (lambda (name) + (member name '("emacs") + :test #'(lambda (name ext) + (search ext name :test #'char-equal)))) + :parent :lisp + :formatters + (((:symbol :escaped-symbol) + (lambda (type s) + (declare (ignore type)) + (let ((result (if (find-package :elisp-lookup) + (funcall (symbol-function (intern "SYMBOL-LOOKUP" :elisp-lookup)) + s)))) + (if result + (format nil "~A" + result (call-parent-formatter)) + (call-parent-formatter))))))) + +(define-coloring-type :common-lisp "Common Lisp" + :autodetect (lambda (text) + (search "lisp" text :test #'char-equal)) + :parent :lisp + :transitions + (((:normal :in-list) + ((scan #\|) + (set-mode :escaped-symbol + :until (scan #\|))))) + :formatters + (((:symbol :escaped-symbol) + (lambda (type s) + (declare (ignore type)) + (let* ((colon (position #\: s :from-end t :test #'char=)) + (to-lookup (if colon (subseq s (1+ colon)) s)) + (result (if (find-package :clhs-lookup) + (funcall (symbol-function (intern "SYMBOL-LOOKUP" :clhs-lookup)) + to-lookup)))) + (if result + (format nil "~A" + result (call-parent-formatter)) + (call-parent-formatter))))))) + +(define-coloring-type :common-lisp-file "Common Lisp File" + :parent :common-lisp + :default-mode :in-list + :invisible t) + +(defvar *c-open-parens* "([{") +(defvar *c-close-parens* ")]}") + +(defvar *c-reserved-words* + '("auto" "break" "case" "char" "const" + "continue" "default" "do" "double" "else" + "enum" "extern" "float" "for" "goto" + "if" "int" "long" "register" "return" + "short" "signed" "sizeof" "static" "struct" + "switch" "typedef" "union" "unsigned" "void" + "volatile" "while" "__restrict" "_Bool")) + +(defparameter *c-begin-word* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789") +(defparameter *c-terminators* '(#\space #\return #\tab #\newline #\. #\/ #\- #\* #\+ #\{ #\} #\( #\) #\' #\" #\[ #\] #\< #\> #\#)) + +(define-coloring-type :basic-c "Basic C" + :modes (:normal :comment :word-ish :paren-ish :string :char :single-escape :preprocessor) + :default-mode :normal + :invisible t + :transitions + ((:normal + ((scan-any *c-begin-word*) + (set-mode :word-ish + :until (scan-any *c-terminators*) + :advancing nil)) + ((scan "/*") + (set-mode :comment + :until (scan "*/"))) + + ((or + (scan-any *c-open-parens*) + (scan-any *c-close-parens*)) + (set-mode :paren-ish + :until (advance 1) + :advancing nil)) + ((scan #\") + (set-mode :string + :until (scan #\"))) + ((or (scan "'\\") + (scan #\')) + (set-mode :character + :until (advance 2)))) + (:string + ((scan #\\) + (set-mode :single-escape + :until (advance 1))))) + :formatter-variables + ((paren-counter 0)) + :formatter-after-hook (lambda nil + (format nil "~{~A~}" + (loop for i from paren-counter downto 1 + collect ""))) + :formatters + ((:normal + (lambda (type s) + (declare (ignore type)) + s)) + (:comment + (lambda (type s) + (declare (ignore type)) + (format nil "~A" + s))) + (:string + (lambda (type s) + (declare (ignore type)) + (format nil "~A" + s))) + (:character + (lambda (type s) + (declare (ignore type)) + (format nil "~A" + s))) + (:single-escape + (lambda (type s) + (call-formatter (cdr type) s))) + (:paren-ish + (lambda (type s) + (declare (ignore type)) + (let ((open nil) + (count 0)) + (if (eql (length s) 1) + (progn + (when (member (elt s 0) (coerce *c-open-parens* 'list)) + (setf open t) + (setf count (mod paren-counter 6)) + (incf paren-counter)) + (when (member (elt s 0) (coerce *c-close-parens* 'list)) + (setf open nil) + (decf paren-counter) + (setf count (mod paren-counter 6))) + (if open + (format nil "~A" + (1+ count) s *css-background-class*) + (format nil "~A" + s))) + s)))) + (:word-ish + (lambda (type s) + (declare (ignore type)) + (if (member s *c-reserved-words* :test #'string=) + (format nil "~A" s) + s))) + )) + +(define-coloring-type :c "C" + :parent :basic-c + :transitions + ((:normal + ((scan #\#) + (set-mode :preprocessor + :until (scan-any '(#\return #\newline)))))) + :formatters + ((:preprocessor + (lambda (type s) + (declare (ignore type)) + (format nil "~A" s))))) + +(defvar *c++-reserved-words* + '("asm" "auto" "bool" "break" "case" + "catch" "char" "class" "const" "const_cast" + "continue" "default" "delete" "do" "double" + "dynamic_cast" "else" "enum" "explicit" "export" + "extern" "false" "float" "for" "friend" + "goto" "if" "inline" "int" "long" + "mutable" "namespace" "new" "operator" "private" + "protected" "public" "register" "reinterpret_cast" "return" + "short" "signed" "sizeof" "static" "static_cast" + "struct" "switch" "template" "this" "throw" + "true" "try" "typedef" "typeid" "typename" + "union" "unsigned" "using" "virtual" "void" + "volatile" "wchar_t" "while")) + +(define-coloring-type :c++ "C++" + :parent :c + :transitions + ((:normal + ((scan "//") + (set-mode :comment + :until (scan-any '(#\return #\newline)))))) + :formatters + ((:word-ish + (lambda (type s) + (declare (ignore type)) + (if (member s *c++-reserved-words* :test #'string=) + (format nil "~A" + s) + s))))) + +(defvar *java-reserved-words* + '("abstract" "boolean" "break" "byte" "case" + "catch" "char" "class" "const" "continue" + "default" "do" "double" "else" "extends" + "final" "finally" "float" "for" "goto" + "if" "implements" "import" "instanceof" "int" + "interface" "long" "native" "new" "package" + "private" "protected" "public" "return" "short" + "static" "strictfp" "super" "switch" "synchronized" + "this" "throw" "throws" "transient" "try" + "void" "volatile" "while")) + +(define-coloring-type :java "Java" + :parent :c++ + :formatters + ((:word-ish + (lambda (type s) + (declare (ignore type)) + (if (member s *java-reserved-words* :test #'string=) + (format nil "~A" + s) + s))))) + +(let ((terminate-next nil)) + (define-coloring-type :objective-c "Objective C" + :autodetect (lambda (text) (search "mac" text :test #'char=)) + :modes (:begin-message-send :end-message-send) + :transitions + ((:normal + ((scan #\[) + (set-mode :begin-message-send + :until (advance 1) + :advancing nil)) + ((scan #\]) + (set-mode :end-message-send + :until (advance 1) + :advancing nil)) + ((scan-any *c-begin-word*) + (set-mode :word-ish + :until (or + (and (peek-any '(#\:)) + (setf terminate-next t)) + (and terminate-next (progn + (setf terminate-next nil) + (advance 1))) + (scan-any *c-terminators*)) + :advancing nil))) + (:word-ish + #+nil + ((scan #\:) + (format t "hi~%") + (set-mode :word-ish :until (advance 1) :advancing nil) + (setf terminate-next t)))) + :parent :c++ + :formatter-variables ((is-keyword nil) (in-message-send nil)) + :formatters + ((:begin-message-send + (lambda (type s) + (setf is-keyword nil) + (setf in-message-send t) + (call-formatter (cons :paren-ish type) s))) + (:end-message-send + (lambda (type s) + (setf is-keyword nil) + (setf in-message-send nil) + (call-formatter (cons :paren-ish type) s))) + (:word-ish + (lambda (type s) + (declare (ignore type)) + (prog1 + (let ((result (if (find-package :cocoa-lookup) + (funcall (symbol-function (intern "SYMBOL-LOOKUP" :cocoa-lookup)) + s)))) + (if result + (format nil "~A" + result s) + (if (member s *c-reserved-words* :test #'string=) + (format nil "~A" s) + (if in-message-send + (if is-keyword + (format nil "~A" s) + s) + s)))) + (setf is-keyword (not is-keyword)))))))) + + +;#!/usr/bin/clisp +;#+sbcl +;(require :asdf) +;(asdf:oos 'asdf:load-op :colorize) + +(defmacro with-each-stream-line ((var stream) &body body) + (let ((eof (gensym)) + (eof-value (gensym)) + (strm (gensym))) + `(let ((,strm ,stream) + (,eof ',eof-value)) + (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof))) + ((eql ,var ,eof)) + ,@body)))) + +(defun system (control-string &rest args) + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and +synchronously execute the result using a Bourne-compatible shell, with +output to *verbose-out*. Returns the shell's exit code." + (let ((command (apply #'format nil control-string args))) + (format t "; $ ~A~%" command) + #+sbcl + (sb-impl::process-exit-code + (sb-ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output *standard-output*)) + #+(or cmu scl) + (ext:process-exit-code + (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output *verbose-out*)) + #+clisp ;XXX not exactly *verbose-out*, I know + (ext:run-shell-command command :output :terminal :wait t) + )) + +(defun strcat (&rest strings) + (apply #'concatenate 'string strings)) + +(defun string-starts-with (start str) + (and (>= (length str) (length start)) + (string-equal start str :end2 (length start)))) + +(defmacro string-append (outputstr &rest args) + `(setq ,outputstr (concatenate 'string ,outputstr ,@args))) + +(defconstant +indent+ 2 + "Indentation used in the examples.") + +(defun texinfo->raw-lisp (code) + "Answer CODE with spurious Texinfo output removed. For use in +preprocessing output in a @lisp block before passing to colorize." + (decode-from-tt + (with-output-to-string (output) + (do* ((last-position 0) + (next-position + #0=(search #1="" code + :start2 last-position :test #'char-equal) + #0#)) + ((eq nil next-position) + (write-string code output :start last-position)) + (write-string code output :start last-position :end next-position) + (let ((end (search #2="" code + :start2 (+ next-position (length #1#)) + :test #'char-equal))) + (assert (integerp end) () + "Missing ~A tag in HTML for @lisp block~%~ + HTML contents of block:~%~A" #2# code) + (write-string code output + :start (+ next-position (length #1#)) + :end end) + (setf last-position (+ end (length #2#)))))))) + +(defun process-file (from to) + (with-open-file (output to :direction :output :if-exists :error) + (with-open-file (input from :direction :input) + (let ((line-processor nil) + (piece-of-code '())) + (labels + ((process-line-inside-pre (line) + (cond ((string-starts-with "" line) + (with-input-from-string + (stream (colorize:html-colorization + :common-lisp + (texinfo->raw-lisp + (apply #'concatenate 'string + (nreverse piece-of-code))))) + (with-each-stream-line (cline stream) + (format output " ~A~%" cline))) + (write-line line output) + (setq piece-of-code '() + line-processor #'process-regular-line)) + (t (let ((to-append (subseq line +indent+))) + (push (if (string= "" to-append) + " " + to-append) piece-of-code) + (push (string #\Newline) piece-of-code))))) + (process-regular-line (line) + (let ((len (some (lambda (test-string) + (when (string-starts-with test-string line) + (length test-string))) + '("
"
+                                 "
"))))
+                 (cond (len
+                         (setq line-processor #'process-line-inside-pre)
+                         (write-string "
" output)
+                         (push (subseq line (+ len +indent+)) piece-of-code)
+                         (push (string #\Newline) piece-of-code))
+                       (t (write-line line output))))))
+          (setf line-processor #'process-regular-line)
+          (with-each-stream-line (line input)
+            (funcall line-processor line)))))))
+
+(defun process-dir (dir)
+  (dolist (html-file (directory dir))
+    (let* ((name (namestring html-file))
+           (temp-name (strcat name ".temp")))
+      (process-file name temp-name)
+      (system "mv ~A ~A" temp-name name))))
+
+;; (go "/tmp/doc/manual/html_node/*.html")
+
+#+clisp
+(progn
+  (assert (first ext:*args*))
+  (process-dir (first ext:*args*)))
+
+#+sbcl
+(progn
+  (assert (second sb-ext:*posix-argv*))
+  (process-dir (second sb-ext:*posix-argv*))
+  (sb-ext:quit))
diff --git a/external/cffi.darcs/doc/gendocs.sh b/external/cffi.darcs/doc/gendocs.sh
new file mode 100644
index 0000000..1426020
--- /dev/null
+++ b/external/cffi.darcs/doc/gendocs.sh
@@ -0,0 +1,310 @@
+#!/bin/sh
+# gendocs.sh -- generate a GNU manual in many formats.  This script is
+#   mentioned in maintain.texi.  See the help message below for usage details.
+# $Id: gendocs.sh,v 1.16 2005/05/15 00:00:08 karl Exp $
+# 
+# Copyright (C) 2003, 2004, 2005 Free Software Foundation, Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, you can either send email to this
+# program's maintainer or write to: The Free Software Foundation,
+# Inc.; 51 Franklin Street, Fifth Floor; Boston, MA 02110-1301, USA.
+#
+# Original author: Mohit Agarwal.
+# Send bug reports and any other correspondence to bug-texinfo@gnu.org.
+
+prog="`basename \"$0\"`"
+srcdir=`pwd`
+
+scripturl="http://common-lisp.net/project/cffi/darcs/cffi/doc/gendocs.sh"
+templateurl="http://savannah.gnu.org/cgi-bin/viewcvs/texinfo/texinfo/util/gendocs_template"
+
+: ${MAKEINFO="makeinfo"}
+: ${TEXI2DVI="texi2dvi -t @finalout"}
+: ${DVIPS="dvips"}
+: ${DOCBOOK2TXT="docbook2txt"}
+: ${DOCBOOK2HTML="docbook2html"}
+: ${DOCBOOK2PDF="docbook2pdf"}
+: ${DOCBOOK2PS="docbook2ps"}
+: ${GENDOCS_TEMPLATE_DIR="."}
+unset CDPATH
+
+rcs_revision='$Revision: 1.16 $'
+rcs_version=`set - $rcs_revision; echo $2`
+program=`echo $0 | sed -e 's!.*/!!'`
+version="gendocs.sh $rcs_version
+
+Copyright (C) 2005 Free Software Foundation, Inc.
+There is NO warranty.  You may redistribute this software
+under the terms of the GNU General Public License.
+For more information about these matters, see the files named COPYING."
+
+usage="Usage: $prog [OPTION]... PACKAGE MANUAL-TITLE
+
+Generate various output formats from PACKAGE.texinfo (or .texi or .txi) source.
+See the GNU Maintainers document for a more extensive discussion:
+  http://www.gnu.org/prep/maintain_toc.html
+
+Options:
+  -o OUTDIR   write files into OUTDIR, instead of manual/.
+  --docbook   convert to DocBook too (xml, txt, html, pdf and ps).
+  --html ARG  pass indicated ARG to makeinfo for HTML targets.
+  --help      display this help and exit successfully.
+  --version   display version information and exit successfully.
+
+Simple example: $prog emacs \"GNU Emacs Manual\"
+
+Typical sequence:
+  cd YOURPACKAGESOURCE/doc
+  wget \"$scripturl\"
+  wget \"$templateurl\"
+  $prog YOURMANUAL \"GNU YOURMANUAL - One-line description\"
+
+Output will be in a new subdirectory \"manual\" (by default, use -o OUTDIR
+to override).  Move all the new files into your web CVS tree, as
+explained in the Web Pages node of maintain.texi.
+
+MANUAL-TITLE is included as part of the HTML  of the overall
+manual/index.html file.  It should include the name of the package being
+documented.  manual/index.html is created by substitution from the file
+$GENDOCS_TEMPLATE_DIR/gendocs_template.  (Feel free to modify the
+generic template for your own purposes.)
+
+If you have several manuals, you'll need to run this script several
+times with different YOURMANUAL values, specifying a different output
+directory with -o each time.  Then write (by hand) an overall index.html
+with links to them all.
+
+You can set the environment variables MAKEINFO, TEXI2DVI, and DVIPS to
+control the programs that get executed, and GENDOCS_TEMPLATE_DIR to
+control where the gendocs_template file is looked for.
+
+Email bug reports or enhancement requests to bug-texinfo@gnu.org.
+"
+
+calcsize()
+{
+  size="`ls -ksl $1 | awk '{print $1}'`"
+  echo $size
+}
+
+outdir=manual
+html=
+PACKAGE=
+MANUAL_TITLE=
+
+while test $# -gt 0; do
+  case $1 in
+    --help) echo "$usage"; exit 0;;
+    --version) echo "$version"; exit 0;;
+    -o) shift; outdir=$1;;
+    --docbook) docbook=yes;;
+    --html) shift; html=$1;;
+    -*)
+      echo "$0: Unknown or ambiguous option \`$1'." >&2
+      echo "$0: Try \`--help' for more information." >&2
+      exit 1;;
+    *)
+      if test -z "$PACKAGE"; then
+        PACKAGE=$1
+      elif test -z "$MANUAL_TITLE"; then
+        MANUAL_TITLE=$1
+      else
+        echo "$0: extra non-option argument \`$1'." >&2
+        exit 1
+      fi;;
+  esac
+  shift
+done
+
+if test -s $srcdir/$PACKAGE.texinfo; then
+  srcfile=$srcdir/$PACKAGE.texinfo
+elif test -s $srcdir/$PACKAGE.texi; then
+  srcfile=$srcdir/$PACKAGE.texi
+elif test -s $srcdir/$PACKAGE.txi; then
+  srcfile=$srcdir/$PACKAGE.txi
+else
+  echo "$0: cannot find .texinfo or .texi or .txi for $PACKAGE in $srcdir." >&2
+  exit 1
+fi
+
+if test ! -r $GENDOCS_TEMPLATE_DIR/gendocs_template; then
+  echo "$0: cannot read $GENDOCS_TEMPLATE_DIR/gendocs_template." >&2
+  echo "$0: it is available from $templateurl." >&2
+  exit 1
+fi
+
+echo Generating output formats for $srcfile
+
+cmd="${MAKEINFO} -o $PACKAGE.info $srcfile"
+echo "Generating info files... ($cmd)"
+eval $cmd
+mkdir -p $outdir/
+tar czf $outdir/$PACKAGE.info.tar.gz $PACKAGE.info*
+info_tgz_size="`calcsize $outdir/$PACKAGE.info.tar.gz`"
+# do not mv the info files, there's no point in having them available
+# separately on the web.
+
+cmd="${TEXI2DVI} $srcfile"
+echo "Generating dvi ... ($cmd)"
+eval $cmd
+
+# now, before we compress dvi:
+echo Generating postscript...
+${DVIPS} $PACKAGE -o
+gzip -f -9 $PACKAGE.ps
+ps_gz_size="`calcsize $PACKAGE.ps.gz`"
+mv $PACKAGE.ps.gz $outdir/
+
+# compress/finish dvi:
+gzip -f -9 $PACKAGE.dvi
+dvi_gz_size="`calcsize $PACKAGE.dvi.gz`"
+mv $PACKAGE.dvi.gz $outdir/
+
+cmd="${TEXI2DVI} --pdf $srcfile"
+echo "Generating pdf ... ($cmd)"
+eval $cmd
+pdf_size="`calcsize $PACKAGE.pdf`"
+mv $PACKAGE.pdf $outdir/
+
+cmd="${MAKEINFO} -o $PACKAGE.txt --no-split --no-headers $srcfile"
+echo "Generating ASCII... ($cmd)"
+eval $cmd
+ascii_size="`calcsize $PACKAGE.txt`"
+gzip -f -9 -c $PACKAGE.txt >$outdir/$PACKAGE.txt.gz
+ascii_gz_size="`calcsize $outdir/$PACKAGE.txt.gz`"
+mv $PACKAGE.txt $outdir/
+
+# Print a SED expression that will translate references to MANUAL to
+# the proper page on gnu.org.  This is a horrible shell hack done
+# because \| in sed regexps is a GNU extension.
+monognuorg () {
+    case "$1" in
+	libtool) echo "s!$1.html!http://www.gnu.org/software/$1/manual.html!" ;;
+	*) echo "s!$1.html!http://www.gnu.org/software/$1/manual/html_mono/$1.html!" ;;
+    esac
+}
+polygnuorg () {
+    case "$1" in
+	libtool) echo 's!\.\./'"$1/.*\.html!http://www.gnu.org/software/$1/manual.html!" ;;
+	*) echo 's!\.\./'"$1!http://www.gnu.org/software/$1/manual/html_node!" ;;
+    esac
+}
+
+cmd="${MAKEINFO} --no-split --html -o $PACKAGE.html $html $srcfile"
+echo "Generating monolithic html... ($cmd)"
+rm -rf $PACKAGE.html  # in case a directory is left over
+eval $cmd
+sbcl --load colorize-lisp-examples.lisp $PACKAGE.html
+#fix libc/libtool xrefs
+sed -e `monognuorg libc` -e `monognuorg libtool` $PACKAGE.html >$outdir/$PACKAGE.html
+rm $PACKAGE.html
+html_mono_size="`calcsize $outdir/$PACKAGE.html`"
+gzip -f -9 -c $outdir/$PACKAGE.html >$outdir/$PACKAGE.html.gz
+html_mono_gz_size="`calcsize $outdir/$PACKAGE.html.gz`"
+
+cmd="${MAKEINFO} --html -o $PACKAGE.html $html $srcfile"
+echo "Generating html by node... ($cmd)"
+eval $cmd
+split_html_dir=$PACKAGE.html
+sbcl --load colorize-lisp-examples.lisp "${split_html_dir}/*.html"
+(
+  cd ${split_html_dir} || exit 1
+  #fix libc xrefs
+  for broken_file in *.html; do
+      sed -e `polygnuorg libc` -e `polygnuorg libtool` "$broken_file" > "$broken_file".temp
+      mv -f "$broken_file".temp "$broken_file"
+  done
+  tar -czf ../$outdir/${PACKAGE}.html_node.tar.gz -- *.html
+)
+html_node_tgz_size="`calcsize $outdir/${PACKAGE}.html_node.tar.gz`"
+rm -f $outdir/html_node/*.html
+mkdir -p $outdir/html_node/
+mv ${split_html_dir}/*.html $outdir/html_node/
+rmdir ${split_html_dir}
+
+echo Making .tar.gz for sources...
+srcfiles=`ls *.texinfo *.texi *.txi *.eps 2>/dev/null`
+tar cvzfh $outdir/$PACKAGE.texi.tar.gz $srcfiles
+texi_tgz_size="`calcsize $outdir/$PACKAGE.texi.tar.gz`"
+
+if test -n "$docbook"; then
+  cmd="${MAKEINFO} -o - --docbook $srcfile > ${srcdir}/$PACKAGE-db.xml"
+  echo "Generating docbook XML... $(cmd)"
+  eval $cmd
+  docbook_xml_size="`calcsize $PACKAGE-db.xml`"
+  gzip -f -9 -c $PACKAGE-db.xml >$outdir/$PACKAGE-db.xml.gz
+  docbook_xml_gz_size="`calcsize $outdir/$PACKAGE-db.xml.gz`"
+  mv $PACKAGE-db.xml $outdir/
+
+  cmd="${DOCBOOK2HTML} -o $split_html_db_dir ${outdir}/$PACKAGE-db.xml"
+  echo "Generating docbook HTML... ($cmd)"
+  eval $cmd
+  split_html_db_dir=html_node_db
+  (
+    cd ${split_html_db_dir} || exit 1
+    tar -czf ../$outdir/${PACKAGE}.html_node_db.tar.gz -- *.html
+  )
+  html_node_db_tgz_size="`calcsize $outdir/${PACKAGE}.html_node_db.tar.gz`"
+  rm -f $outdir/html_node_db/*.html
+  mkdir -p $outdir/html_node_db
+  mv ${split_html_db_dir}/*.html $outdir/html_node_db/
+  rmdir ${split_html_db_dir}
+
+  cmd="${DOCBOOK2TXT} ${outdir}/$PACKAGE-db.xml"
+  echo "Generating docbook ASCII... ($cmd)"
+  eval $cmd
+  docbook_ascii_size="`calcsize $PACKAGE-db.txt`"
+  mv $PACKAGE-db.txt $outdir/
+
+  cmd="${DOCBOOK2PS} ${outdir}/$PACKAGE-db.xml"
+  echo "Generating docbook PS... $(cmd)"
+  eval $cmd
+  gzip -f -9 -c $PACKAGE-db.ps >$outdir/$PACKAGE-db.ps.gz
+  docbook_ps_gz_size="`calcsize $outdir/$PACKAGE-db.ps.gz`"
+  mv $PACKAGE-db.ps $outdir/
+
+  cmd="${DOCBOOK2PDF} ${outdir}/$PACKAGE-db.xml"
+  echo "Generating docbook PDF... ($cmd)"
+  eval $cmd
+  docbook_pdf_size="`calcsize $PACKAGE-db.pdf`"
+  mv $PACKAGE-db.pdf $outdir/
+fi
+
+echo Writing index file...
+curdate="`date '+%B %d, %Y'`"
+sed \
+   -e "s!%%TITLE%%!$MANUAL_TITLE!g" \
+   -e "s!%%DATE%%!$curdate!g" \
+   -e "s!%%PACKAGE%%!$PACKAGE!g" \
+   -e "s!%%HTML_MONO_SIZE%%!$html_mono_size!g" \
+   -e "s!%%HTML_MONO_GZ_SIZE%%!$html_mono_gz_size!g" \
+   -e "s!%%HTML_NODE_TGZ_SIZE%%!$html_node_tgz_size!g" \
+   -e "s!%%INFO_TGZ_SIZE%%!$info_tgz_size!g" \
+   -e "s!%%DVI_GZ_SIZE%%!$dvi_gz_size!g" \
+   -e "s!%%PDF_SIZE%%!$pdf_size!g" \
+   -e "s!%%PS_GZ_SIZE%%!$ps_gz_size!g" \
+   -e "s!%%ASCII_SIZE%%!$ascii_size!g" \
+   -e "s!%%ASCII_GZ_SIZE%%!$ascii_gz_size!g" \
+   -e "s!%%TEXI_TGZ_SIZE%%!$texi_tgz_size!g" \
+   -e "s!%%DOCBOOK_HTML_NODE_TGZ_SIZE%%!$html_node_db_tgz_size!g" \
+   -e "s!%%DOCBOOK_ASCII_SIZE%%!$docbook_ascii_size!g" \
+   -e "s!%%DOCBOOK_PS_GZ_SIZE%%!$docbook_ps_gz_size!g" \
+   -e "s!%%DOCBOOK_PDF_SIZE%%!$docbook_pdf_size!g" \
+   -e "s!%%DOCBOOK_XML_SIZE%%!$docbook_xml_size!g" \
+   -e "s!%%DOCBOOK_XML_GZ_SIZE%%!$docbook_xml_gz_size!g" \
+   -e "s,%%SCRIPTURL%%,$scripturl,g" \
+   -e "s!%%SCRIPTNAME%%!$prog!g" \
+$GENDOCS_TEMPLATE_DIR/gendocs_template >$outdir/index.html
+
+echo "Done!  See $outdir/ subdirectory for new files."
diff --git a/external/cffi.darcs/doc/gendocs_template b/external/cffi.darcs/doc/gendocs_template
new file mode 100644
index 0000000..5ff3351
--- /dev/null
+++ b/external/cffi.darcs/doc/gendocs_template
@@ -0,0 +1,259 @@
+<?xml version="1.0" encoding="utf-8" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<!-- $Id: gendocs_template,v 1.7 2005/05/15 00:00:08 karl Exp $ -->
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
+
+<!--
+
+ This template was adapted from Texinfo:
+ http://savannah.gnu.org/cgi-bin/viewcvs/texinfo/texinfo/util/gendocs_template
+
+-->
+
+
+<head>
+<title>%%TITLE%%
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
%%TITLE%%

+
+
+
last updated %%DATE%%

+
+
+
+

+
+
This document  is available in the following formats:

+
+
+
+
(This page was generated by the %%SCRIPTNAME%%
+script.)

+
+

+

+Return to CFFI's home page.
+

+
+
+
+

+Copyright (C) 2005 James Bielman  <jamesjb at jamesjb.com>

+Copyright (C) 2005 Luís Oliveira  <loliveira at common-lisp.net>
+
+

+
+

+Updated: %%DATE%%
+
+
+
+

+

+
+
+
diff --git a/external/cffi.darcs/doc/mem-vector.txt b/external/cffi.darcs/doc/mem-vector.txt
new file mode 100644
index 0000000..51b0c4f
--- /dev/null
+++ b/external/cffi.darcs/doc/mem-vector.txt
@@ -0,0 +1,75 @@
+
+# Block Memory Operations
+
+Function: mem-fill ptr type count value &optional (offset 0)
+
+Fill COUNT objects of TYPE, starting at PTR plus offset, with VALUE.
+
+;; Equivalent to (but possibly more efficient than):
+(loop for i below count
+      for off from offset by (%foreign-type-size type)
+      do (setf (%mem-ref ptr type off) value))
+
+Function: mem-read-vector vector ptr type count &optional (offset 0)
+
+Copy COUNT objects of TYPE from foreign memory at PTR plus OFFSET into
+VECTOR.  If VECTOR is not large enough to contain COUNT objects, it
+will copy as many objects as necessary to fill the vector.  The
+results are undefined if the foreign memory block is not large enough
+to supply the data to copy.
+
+TYPE must be a built-in foreign type (integer, float, double, or
+pointer).
+
+Returns the number of objects copied.
+
+;; Equivalent to (but possibly more efficient than):
+(loop for i below (min count (length vector))
+      for off from offset by (%foreign-type-size type)
+      do (setf (aref vector i) (%mem-ref ptr type off))
+      finally (return i))
+
+
+Function: mem-read-c-string string ptr &optional (offset 0)
+
+Copy a null-terminated C string from PTR plus OFFSET into STRING, a
+Lisp string.  If STRING is not large enough to contain the data at PTR
+it will be truncated.
+
+Returns the number of characters copied into STRING.
+
+;; Equivalent to (but possibly more efficient than):
+(loop for i below (length string)
+      for off from offset
+      for char = (%mem-ref ptr :char off)
+      until (zerop char)
+      do (setf (char string i) char)
+      finally (return i))
+
+Function: mem-write-vector vector ptr type &optional
+                           (count (length vector)) (offset 0)
+
+Copy COUNT objects from VECTOR into objects of TYPE in foreign memory,
+starting at PTR plus OFFSET.  The results are undefined if PTR does
+not point to a memory block large enough to hold the data copied.
+
+TYPE must be a built-in type (integer, float, double, or pointer).
+
+Returns the number of objects copied from VECTOR to PTR.
+
+;; Equivalent to (but possibly more efficient than):
+(loop for i below count
+      for off from offset by (%foreign-type-size type)
+      do (setf (%mem-ref ptr type off) (aref vector i))
+      finally (return i))
+
+
+Function: mem-write-c-string string ptr &optional (offset 0)
+
+Copy the characters from a Lisp STRING to PTR plus OFFSET, adding a
+final null terminator at the end.  The results are undefined if the
+memory at PTR is not large enough to accomodate the data.
+
+This interface is currently equivalent to MEM-WRITE-VECTOR with a TYPE
+of :CHAR, but will be useful when proper support for Unicode strings
+is implemented.
diff --git a/external/cffi.darcs/doc/shareable-vectors.txt b/external/cffi.darcs/doc/shareable-vectors.txt
new file mode 100644
index 0000000..7418a45
--- /dev/null
+++ b/external/cffi.darcs/doc/shareable-vectors.txt
@@ -0,0 +1,44 @@
+
+# Shareable Byte Vectors
+
+Function: make-shareable-byte-vector size
+
+Create a vector of element type (UNSIGNED-BYTE 8) suitable for passing
+to WITH-POINTER-TO-VECTOR-DATA.
+
+;; Minimal implementation:
+(defun make-shareable-byte-vector (size)
+  (make-array size :element-type '(unsigned-byte 8)))
+
+
+Macro: with-pointer-to-vector-data (ptr-var vector) &body body
+
+Bind PTR-VAR to a pointer to the data contained in a shareable byte
+vector.
+
+VECTOR must be a shareable vector created by MAKE-SHAREABLE-BYTE-VECTOR.
+
+PTR-VAR may point directly into the Lisp vector data, or it may point
+to a temporary block of foreign memory which will be copied to and
+from VECTOR.
+
+Both the pointer object in PTR-VAR and the memory it points to have
+dynamic extent.  The results are undefined if foreign code attempts to
+access this memory outside this dynamic contour.
+
+The implementation must guarantee the memory pointed to by PTR-VAR
+will not be moved during the dynamic contour of this operator, either
+by creating the vector in a static area or temporarily disabling the
+garbage collector.
+
+;; Minimal (copying) implementation:
+(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+  (let ((vector-var (gensym))
+        (size-var (gensym)))
+    `(let* ((,vector-var ,vector)
+            (,size-var (length ,vector-var)))
+       (with-foreign-ptr (,ptr-var ,size-var)
+         (mem-write-vector ,vector-var ,ptr :uint8)
+         (prog1
+             (progn ,@body)
+           (mem-read-vector ,vector-var ,ptr-var :uint8 ,size-var))))))
diff --git a/external/cffi.darcs/doc/style.css b/external/cffi.darcs/doc/style.css
new file mode 100644
index 0000000..4618956
--- /dev/null
+++ b/external/cffi.darcs/doc/style.css
@@ -0,0 +1,48 @@
+body {font-family: century schoolbook, serif;
+      line-height: 1.3;
+      padding-left: 5em; padding-right: 1em;
+      padding-bottom: 1em; max-width: 60em;}
+table {border-collapse: collapse}
+span.roman { font-family: century schoolbook, serif; font-weight: normal; }
+h1, h2, h3, h4, h5, h6 {font-family:  Helvetica, sans-serif}
+h4 { margin-top: 2.5em; }
+dfn {font-family: inherit; font-variant: italic; font-weight: bolder }
+kbd {font-family: monospace; text-decoration: underline}
+/*var {font-family: Helvetica, sans-serif; font-variant: slanted}*/
+var {font-variant: slanted;}
+td  {padding-right: 1em; padding-left: 1em}
+sub {font-size: smaller}
+.node {padding: 0; margin: 0}
+
+.lisp { font-family: monospace;
+        background-color: #F4F4F4; border: 1px solid #AAA;
+        padding-top: 0.5em; padding-bottom: 0.5em; }
+
+/* coloring */
+
+.lisp-bg { background-color: #F4F4F4 ; color: black; }
+.lisp-bg:hover { background-color: #F4F4F4 ; color: black; }
+
+.symbol { font-weight: bold; color: #770055; background-color : transparent; border: 0px; margin: 0px;}
+a.symbol:link { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+a.symbol:active { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+a.symbol:visited { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+a.symbol:hover { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
+.special { font-weight: bold; color: #FF5000; background-color: inherit; }
+.keyword { font-weight: bold; color: #770000; background-color: inherit; }
+.comment { font-weight: normal; color: #007777; background-color: inherit; }
+.string  { font-weight: bold; color: #777777; background-color: inherit; }
+.character   { font-weight: bold; color: #0055AA; background-color: inherit; }
+.syntaxerror { font-weight: bold; color: #FF0000; background-color: inherit; }
+span.paren1 { font-weight: bold; color: #777777; }
+span.paren1:hover { color: #777777; background-color: #BAFFFF; }
+span.paren2 { color: #777777; }
+span.paren2:hover { color: #777777; background-color: #FFCACA; }
+span.paren3 { color: #777777; }
+span.paren3:hover { color: #777777; background-color: #FFFFBA; }
+span.paren4 { color: #777777; }
+span.paren4:hover { color: #777777; background-color: #CACAFF; }
+span.paren5 { color: #777777; }
+span.paren5:hover { color: #777777; background-color: #CAFFCA; }
+span.paren6 { color: #777777; }
+span.paren6:hover { color: #777777; background-color: #FFBAFF; }
diff --git a/external/cffi.darcs/examples/examples.lisp b/external/cffi.darcs/examples/examples.lisp
new file mode 100644
index 0000000..231eddf
--- /dev/null
+++ b/external/cffi.darcs/examples/examples.lisp
@@ -0,0 +1,78 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; examples.lisp --- Simple test examples of CFFI.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(defpackage #:cffi-examples
+  (:use #:cl #:cffi)
+  (:export
+   #:run-examples
+   #:sqrtf
+   #:getenv))
+
+(in-package #:cffi-examples)
+
+;; A simple libc function.
+(defcfun "sqrtf" :float
+  (n :float))
+
+;; This definition uses the STRING type translator to automatically
+;; convert Lisp strings to foreign strings and vice versa.
+(defcfun "getenv" :string
+  (name :string))
+
+;; Calling a varargs function.
+(defun sprintf-test ()
+  "Test calling a varargs function."
+  (with-foreign-pointer-as-string (buf 255 buf-size)
+    (foreign-funcall
+     "snprintf" :pointer buf :int buf-size
+     :string "%d %f #x%x!" :int 666
+     :double (coerce pi 'double-float)
+     :unsigned-int #xcafebabe
+     :void)))
+
+;; Defining an emerated type.
+(defcenum test-enum
+  (:invalid 0)
+  (:positive 1)
+  (:negative -1))
+
+;; Use the absolute value function to test keyword/enum translation.
+(defcfun ("abs" c-abs) test-enum
+  (n test-enum))
+
+(defun cffi-version ()
+  (asdf:component-version (asdf:find-system 'cffi)))
+
+(defun run-examples ()
+  (format t "~&;;; CFFI version ~A on ~A ~A:~%"
+          (cffi-version) (lisp-implementation-type)
+          (lisp-implementation-version))
+  (format t "~&;; shell:             ~A~%" (getenv "SHELL"))
+  (format t "~&;; sprintf test:      ~A~%" (sprintf-test))
+  (format t "~&;; (c-abs :positive): ~A~%" (c-abs :positive))
+  (format t "~&;; (c-abs :negative): ~A~%" (c-abs :negative))
+  (force-output))
diff --git a/external/cffi.darcs/examples/gethostname.lisp b/external/cffi.darcs/examples/gethostname.lisp
new file mode 100644
index 0000000..d079639
--- /dev/null
+++ b/external/cffi.darcs/examples/gethostname.lisp
@@ -0,0 +1,51 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; gethostname.lisp --- A simple CFFI example.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# CFFI Example: gethostname binding
+;;;
+;;; This is a very simple CFFI example that illustrates calling a C
+;;; function that fills in a user-supplied string buffer.
+
+(defpackage #:cffi-example-gethostname
+  (:use #:common-lisp #:cffi)
+  (:export #:gethostname))
+
+(in-package #:cffi-example-gethostname)
+
+;;; Define the Lisp function %GETHOSTNAME to call the C 'gethostname'
+;;; function, which will fill BUF with up to BUFSIZE characters of the
+;;; system's hostname.
+(defcfun ("gethostname" %gethostname) :int
+  (buf :pointer)
+  (bufsize :int))
+
+;;; Define a Lispy interface to 'gethostname'.  The utility macro
+;;; WITH-FOREIGN-POINTER-AS-STRING is used to allocate a temporary
+;;; buffer and return it as a Lisp string.
+(defun gethostname ()
+  (with-foreign-pointer-as-string (buf 255 bufsize)
+    (%gethostname buf bufsize)))
diff --git a/external/cffi.darcs/examples/gettimeofday.lisp b/external/cffi.darcs/examples/gettimeofday.lisp
new file mode 100644
index 0000000..d07d7fe
--- /dev/null
+++ b/external/cffi.darcs/examples/gettimeofday.lisp
@@ -0,0 +1,93 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; gettimeofday.lisp --- Example CFFI binding to gettimeofday(2)
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# CFFI Example: gettimeofday binding
+;;;
+;;; This example illustrates the use of foreign structures, typedefs,
+;;; and using type translators to do checking of input and output
+;;; arguments to a foreign function.
+
+(defpackage #:cffi-example-gettimeofday
+  (:use #:common-lisp #:cffi #:cffi-utils)
+  (:export #:gettimeofday))
+
+(in-package #:cffi-example-gettimeofday)
+
+;;; Define the TIMEVAL structure used by 'gettimeofday'.  This assumes
+;;; that 'time_t' is a 'long' --- it would be nice if CFFI could
+;;; provide a proper :TIME-T type to help make this portable.
+(defcstruct timeval
+  (tv-sec :long)
+  (tv-usec :long))
+
+;;; A NULL-POINTER is a foreign :POINTER that must always be NULL.
+;;; Both a NULL pointer and NIL are legal values---any others will
+;;; result in a runtime error.
+(define-foreign-type null-pointer-type ()
+  ()
+  (:actual-type :pointer)
+  (:simple-parser null-pointer))
+
+;;; This type translator is used to ensure that a NULL-POINTER has a
+;;; null value.  It also converts NIL to a null pointer.
+(defmethod translate-to-foreign (value (type null-pointer-type))
+  (cond
+    ((null value) (null-pointer))
+    ((null-pointer-p value) value)
+    (t (error "~A is not a null pointer." value))))
+
+;;; The SYSCALL-RESULT type is an integer type used for the return
+;;; value of C functions that return -1 and set errno on errors.
+;;; Someday when CFFI has a portable interface for dealing with
+;;; 'errno', this error reporting can be more useful.
+(define-foreign-type syscall-result-type ()
+  ()
+  (:actual-type :int)
+  (:simple-parser syscall-result))
+
+;;; Type translator to check a SYSCALL-RESULT and signal a Lisp error
+;;; if the value is negative.
+(defmethod translate-from-foreign (value (type syscall-result-type))
+  (if (minusp value)
+      (error "System call failed with return value ~D." value)
+      value))
+
+;;; Define the Lisp function %GETTIMEOFDAY to call the C function
+;;; 'gettimeofday', passing a pointer to the TIMEVAL structure to fill
+;;; in.  The TZP parameter is deprecated and should be NULL --- we can
+;;; enforce this by using our NULL-POINTER type defined above.
+(defcfun ("gettimeofday" %gettimeofday) syscall-result
+  (tp :pointer)
+  (tzp null-pointer))
+
+;;; Define a Lispy interface to 'gettimeofday' that returns the
+;;; seconds and microseconds as multiple values.
+(defun gettimeofday ()
+  (with-foreign-object (tv 'timeval)
+    (%gettimeofday tv nil)
+    (with-foreign-slots ((tv-sec tv-usec) tv timeval)
+      (values tv-sec tv-usec))))
diff --git a/external/cffi.darcs/examples/mapping.lisp b/external/cffi.darcs/examples/mapping.lisp
new file mode 100644
index 0000000..5e9a371
--- /dev/null
+++ b/external/cffi.darcs/examples/mapping.lisp
@@ -0,0 +1,76 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; mapping.lisp --- An example for mapping Lisp objects to ints.
+;;;
+;;; Copyright (C) 2007, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;; This is an example on how to tackle the problem of passing Lisp
+;;; object identifiers to foreign code.  It is not a great example,
+;;; but might be useful nevertheless.
+;;;
+;;; Requires trivial-garbage: 
+
+(defpackage #:cffi-mapping-test
+  (:use #:common-lisp #:cffi #:trivial-garbage)
+  (:export #:run))
+
+(in-package #:cffi-mapping-test)
+
+(define-foreign-type lisp-object-type ()
+  ((weakp :initarg :weakp))
+  (:actual-type :unsigned-int))
+
+(define-parse-method lisp-object (&key weak-mapping)
+  (make-instance 'lisp-object-type :weakp weak-mapping))
+
+(defvar *regular-hashtable* (make-hash-table))
+(defvar *weak-hashtable* (make-weak-hash-table :weakness :value))
+(defvar *regular-counter* 0)
+(defvar *weak-counter* 0)
+
+(defun increment-counter (value)
+  (mod (1+ value) (expt 2 (* 8 (foreign-type-size :unsigned-int)))))
+
+(define-modify-macro incf-counter () increment-counter)
+
+(defmethod translate-to-foreign (value (type lisp-object-type))
+  (with-slots (weakp) type
+    (let ((id (if weakp
+                  (incf-counter *weak-counter*)
+                  (incf-counter *regular-counter*)))
+          (ht (if weakp *weak-hashtable* *regular-hashtable*)))
+      (setf (gethash id ht) value)
+      id)))
+
+(defmethod translate-from-foreign (int (type lisp-object-type))
+  (with-slots (weakp) type
+    (gethash int (if weakp *weak-hashtable* *regular-hashtable*))))
+
+;;;; Silly example.
+
+(defctype weak-mapping (lisp-object :weak-mapping t))
+
+;;; (run) => #
+(defun run ()
+  (foreign-funcall "abs" weak-mapping (lambda (x) x) weak-mapping))
diff --git a/external/cffi.darcs/examples/run-examples.lisp b/external/cffi.darcs/examples/run-examples.lisp
new file mode 100644
index 0000000..8eb644c
--- /dev/null
+++ b/external/cffi.darcs/examples/run-examples.lisp
@@ -0,0 +1,38 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; run-examples.lisp --- Simple script to run the examples.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(setf *load-verbose* nil *compile-verbose* nil)
+
+#+(and (not asdf) (or sbcl openmcl))
+(require "asdf")
+#+clisp
+(load "~/Downloads/asdf")
+
+(asdf:operate 'asdf:load-op 'cffi-examples :verbose nil)
+(cffi-examples:run-examples)
+(force-output)
+(quit)
diff --git a/external/cffi.darcs/examples/translator-test.lisp b/external/cffi.darcs/examples/translator-test.lisp
new file mode 100644
index 0000000..84a70c8
--- /dev/null
+++ b/external/cffi.darcs/examples/translator-test.lisp
@@ -0,0 +1,88 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; translator-test.lisp --- Testing type translators.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(defpackage #:cffi-translator-test
+  (:use #:common-lisp #:cffi #:cffi-utils))
+
+(in-package #:cffi-translator-test)
+
+;;;# Verbose Pointer Translator
+;;;
+;;; This is a silly type translator that doesn't actually do any
+;;; translating, but it prints out a debug message when the pointer is
+;;; converted to/from its foreign representation.
+
+(define-foreign-type verbose-pointer-type ()
+  ()
+  (:actual-type :pointer))
+
+(defmethod translate-to-foreign (value (type verbose-pointer-type))
+  (format *debug-io* "~&;; to foreign: VERBOSE-POINTER: ~S~%" value)
+  value)
+
+(defmethod translate-from-foreign (value (type verbose-pointer-type))
+  (format *debug-io* "~&;; from foreign: VERBOSE-POINTER: ~S~%" value)
+  value)
+
+;;;# Verbose String Translator
+;;;
+;;; A VERBOSE-STRING extends VERBOSE-POINTER and converts Lisp strings
+;;; C strings.  If things are working properly, both type translators
+;;; should be called when converting a Lisp string to/from a C string.
+;;;
+;;; The translators should be called most-specific-first when
+;;; translating to C, and most-specific-last when translating from C.
+
+(define-foreign-type verbose-string-type (verbose-pointer-type)
+  ()
+  (:simple-parser verbose-string))
+
+(defmethod translate-to-foreign ((s string) (type verbose-string-type))
+  (let ((value (foreign-string-alloc s)))
+    (format *debug-io* "~&;; to foreign: VERBOSE-STRING: ~S -> ~S~%" s value)
+    (values (call-next-method value type) t)))
+
+(defmethod translate-to-foreign (value (type verbose-string-type))
+  (if (pointerp value)
+      (progn
+        (format *debug-io* "~&;; to foreign: VERBOSE-STRING: ~S -> ~:*~S~%" value)
+        (values (call-next-method) nil))
+      (error "Cannot convert ~S to a foreign string: it is not a Lisp ~
+              string or pointer." value)))
+
+(defmethod translate-from-foreign (ptr (type verbose-string-type))
+  (let ((value (foreign-string-to-lisp (call-next-method))))
+    (format *debug-io* "~&;; from foreign: VERBOSE-STRING: ~S -> ~S~%" ptr value)
+    value))
+
+(defmethod free-translated-object (ptr (type verbose-string-type) free-p)
+  (when free-p
+    (format *debug-io* "~&;; freeing VERBOSE-STRING: ~S~%" ptr)
+    (foreign-string-free ptr)))
+
+(defun test-verbose-string ()
+  (foreign-funcall "getenv" verbose-string "SHELL" verbose-string))
diff --git a/external/cffi.darcs/scripts/release.sh b/external/cffi.darcs/scripts/release.sh
new file mode 100644
index 0000000..cec2716
--- /dev/null
+++ b/external/cffi.darcs/scripts/release.sh
@@ -0,0 +1,45 @@
+#! /bin/sh
+#
+# release.sh --- Create a signed tarball release for ASDF-INSTALL.
+#
+# Copyright (C) 2005-2006, James Bielman  
+#
+# Permission is hereby granted, free of charge, to any person
+# obtaining a copy of this software and associated documentation
+# files (the "Software"), to deal in the Software without
+# restriction, including without limitation the rights to use, copy,
+# modify, merge, publish, distribute, sublicense, and/or sell copies
+# of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be
+# included in all copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+# NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+# DEALINGS IN THE SOFTWARE.
+#
+
+VERSION=${VERSION:=`date +"%Y%m%d"`}
+TARBALL_NAME="cffi_$VERSION"
+TARBALL="$TARBALL_NAME.tar.gz"
+SIGNATURE="$TARBALL.asc"
+RELEASE_DIR=${RELEASE_DIR:="/project/cffi/public_html/releases"}
+
+echo "Creating distribution..."
+darcs dist -d "$TARBALL_NAME"
+
+echo "Signing tarball..."
+gpg -b -a "$TARBALL_NAME.tar.gz"
+
+echo "Copying tarball to web server..."
+scp "$TARBALL" "$SIGNATURE" common-lisp.net:"$RELEASE_DIR"
+
+echo "Uploaded $TARBALL and $SIGNATURE."
+echo "Don't forget to update the link on the CLiki page!"
+
diff --git a/external/cffi.darcs/src/cffi-allegro.lisp b/external/cffi.darcs/src/cffi-allegro.lisp
new file mode 100644
index 0000000..505da48
--- /dev/null
+++ b/external/cffi.darcs/src/cffi-allegro.lisp
@@ -0,0 +1,459 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-allegro.lisp --- CFFI-SYS implementation for Allegro CL.
+;;;
+;;; Copyright (C) 2005-2007, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+  (:use #:common-lisp #:cffi-utils)
+  (:export
+   #:canonicalize-symbol-name-case
+   #:foreign-pointer
+   #:pointerp
+   #:pointer-eq
+   #:null-pointer
+   #:null-pointer-p
+   #:inc-pointer
+   #:make-pointer
+   #:pointer-address
+   #:%foreign-alloc
+   #:foreign-free
+   #:with-foreign-pointer
+   #:%foreign-funcall
+   #:%foreign-funcall-pointer
+   #:%foreign-type-alignment
+   #:%foreign-type-size
+   #:%load-foreign-library
+   #:%close-foreign-library
+   #:native-namestring
+   #:%mem-ref
+   #:%mem-set
+   ;#:make-shareable-byte-vector
+   ;#:with-pointer-to-vector-data
+   #:%foreign-symbol-pointer
+   #:defcfun-helper-forms
+   #:%defcallback
+   #:%callback))
+
+(in-package #:cffi-sys)
+
+;;;# Features
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (mapc (lambda (feature) (pushnew feature *features*))
+        '(;; Backend mis-features.
+          cffi-features:no-long-long
+          cffi-features:flat-namespace
+          ;; OS/CPU features.
+          #+macosx     cffi-features:darwin
+          #+unix       cffi-features:unix
+          #+mswindows  cffi-features:windows
+          #+powerpc    cffi-features:ppc32
+          #+x86        cffi-features:x86
+          #+x86-64     cffi-features:x86-64
+          )))
+
+;;; Symbol case.
+
+(defun canonicalize-symbol-name-case (name)
+  (declare (string name))
+  (if (eq excl:*current-case-mode* :case-sensitive-lower)
+      (string-downcase name)
+      (string-upcase name)))
+
+;;;# Basic Pointer Operations
+
+(deftype foreign-pointer ()
+  'ff:foreign-address)
+
+(defun pointerp (ptr)
+  "Return true if PTR is a foreign pointer."
+  (ff:foreign-address-p ptr))
+
+(defun pointer-eq (ptr1 ptr2)
+  "Return true if PTR1 and PTR2 point to the same address."
+  (eql ptr1 ptr2))
+
+(defun null-pointer ()
+  "Return a null pointer."
+  0)
+
+(defun null-pointer-p (ptr)
+  "Return true if PTR is a null pointer."
+  (zerop ptr))
+
+(defun inc-pointer (ptr offset)
+  "Return a pointer pointing OFFSET bytes past PTR."
+  (+ ptr offset))
+
+(defun make-pointer (address)
+  "Return a pointer pointing to ADDRESS."
+  (check-type address ff:foreign-address)
+  address)
+
+(defun pointer-address (ptr)
+  "Return the address pointed to by PTR."
+  (check-type ptr ff:foreign-address)
+  ptr)
+
+;;;# Allocation
+;;;
+;;; Functions and macros for allocating foreign memory on the stack
+;;; and on the heap.  The main CFFI package defines macros that wrap
+;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
+;;; when the memory has dynamic extent.
+
+(defun %foreign-alloc (size)
+  "Allocate SIZE bytes on the heap and return a pointer."
+  (ff:allocate-fobject :char :c size))
+
+(defun foreign-free (ptr)
+  "Free a PTR allocated by FOREIGN-ALLOC."
+  (ff:free-fobject ptr))
+
+(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
+  "Bind VAR to SIZE bytes of foreign memory during BODY.  The
+pointer in VAR is invalid beyond the dynamic extent of BODY, and
+may be stack-allocated if supported by the implementation.  If
+SIZE-VAR is supplied, it will be bound to SIZE during BODY."
+  (unless size-var
+    (setf size-var (gensym "SIZE")))
+   #+(version>= 8 1)
+   (cond ((and (constantp size) (<= (eval size) ff:*max-stack-fobject-bytes*))
+          ;; stack allocation pattern
+          `(let ((,size-var ,size))
+             (declare (ignorable ,size-var))
+             (ff:with-stack-fobject (,var '(:array :char ,size))
+               (let ((,var (ff:fslot-address ,var)))
+                 ;; (excl::stack-allocated-p var) => T
+                 ,@body))))
+         (t
+          ;; amalloc + free pattern
+          `(let ((,size-var ,size))
+             (declare (ignorable ,size-var))
+             (ff:with-stack-fobject (,var :char :allocation :c :size ,size-var)
+               (unwind-protect
+                    (progn ,@body)
+                 (ff:free-fobject ,var))))))
+   #-(version>= 8 1)
+   `(let ((,size-var ,size))
+      (declare (ignorable ,size-var))
+      (ff:with-stack-fobject (,var :char :c ,size-var)
+        ,@body)))
+
+;;;# Shareable Vectors
+;;;
+;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
+;;; should be defined to perform a copy-in/copy-out if the Lisp
+;;; implementation can't do this.
+
+;(defun make-shareable-byte-vector (size)
+;  "Create a Lisp vector of SIZE bytes can passed to
+;WITH-POINTER-TO-VECTOR-DATA."
+;  (make-array size :element-type '(unsigned-byte 8)))
+;
+;(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+;  "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
+;  `(sb-sys:without-gcing
+;     (let ((,ptr-var (sb-sys:vector-sap ,vector)))
+;       ,@body)))
+
+;;;# Dereferencing
+
+(defun convert-foreign-type (type-keyword &optional (context :normal))
+  "Convert a CFFI type keyword to an Allegro type."
+  (ecase type-keyword
+    (:char             :char)
+    (:unsigned-char    :unsigned-char)
+    (:short            :short)
+    (:unsigned-short   :unsigned-short)
+    (:int              :int)
+    (:unsigned-int     :unsigned-int)
+    (:long             :long)
+    (:unsigned-long    :unsigned-long)
+    (:float            :float)
+    (:double           :double)
+    (:pointer          (ecase context
+                         (:normal '(* :void))
+                         (:funcall :foreign-address)))
+    (:void             :void)))
+
+(defun %mem-ref (ptr type &optional (offset 0))
+  "Dereference an object of TYPE at OFFSET bytes from PTR."
+  (unless (zerop offset)
+    (setf ptr (inc-pointer ptr offset)))
+  (ff:fslot-value-typed (convert-foreign-type type) :c ptr))
+
+;;; Compiler macro to open-code the call to FSLOT-VALUE-TYPED when the
+;;; CFFI type is constant.  Allegro does its own transformation on the
+;;; call that results in efficient code.
+(define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0))
+  (if (constantp type)
+      (let ((ptr-form (if (eql off 0) ptr `(+ ,ptr ,off))))
+        `(ff:fslot-value-typed ',(convert-foreign-type (eval type))
+                               :c ,ptr-form))
+      form))
+
+(defun %mem-set (value ptr type &optional (offset 0))
+  "Set the object of TYPE at OFFSET bytes from PTR."
+  (unless (zerop offset)
+    (setf ptr (inc-pointer ptr offset)))
+  (setf (ff:fslot-value-typed (convert-foreign-type type) :c ptr) value))
+
+;;; Compiler macro to open-code the call to (SETF FSLOT-VALUE-TYPED)
+;;; when the CFFI type is constant.  Allegro does its own
+;;; transformation on the call that results in efficient code.
+(define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0))
+  (if (constantp type)
+      (once-only (val)
+        (let ((ptr-form (if (eql off 0) ptr `(+ ,ptr ,off))))
+          `(setf (ff:fslot-value-typed ',(convert-foreign-type (eval type))
+                                       :c ,ptr-form) ,val)))
+      form))
+
+;;;# Calling Foreign Functions
+
+(defun %foreign-type-size (type-keyword)
+  "Return the size in bytes of a foreign type."
+  (ff:sizeof-fobject (convert-foreign-type type-keyword)))
+
+(defun %foreign-type-alignment (type-keyword)
+  "Returns the alignment in bytes of a foreign type."
+  #+(and powerpc macosx32)
+  (when (eq type-keyword :double)
+    (return-from %foreign-type-alignment 8))
+  ;; No override necessary for the remaining types....
+  (ff::sized-ftype-prim-align
+   (ff::iforeign-type-sftype
+    (ff:get-foreign-type
+     (convert-foreign-type type-keyword)))))
+
+(defun foreign-funcall-type-and-args (args)
+  "Returns a list of types, list of args and return type."
+  (let ((return-type :void))
+    (loop for (type arg) on args by #'cddr
+          if arg collect (convert-foreign-type type :funcall) into types
+          and collect arg into fargs
+          else do (setf return-type (convert-foreign-type type :funcall))
+          finally (return (values types fargs return-type)))))
+
+(defun convert-to-lisp-type (type)
+  (if (equal '(* :void) type)
+      'integer
+      (ecase type
+        (:char 'signed-byte)
+        (:unsigned-char 'integer) ;'unsigned-byte)
+        ((:short
+          :unsigned-short
+          :int
+          :unsigned-int
+          :long
+          :unsigned-long) 'integer)
+        (:float 'single-float)
+        (:double 'double-float)
+        (:foreign-address :foreign-address)
+        (:void 'null))))
+
+(defun foreign-allegro-type (type)
+  (if (eq type :foreign-address)
+      nil
+      type))
+
+(defun allegro-type-pair (type)
+  (list (foreign-allegro-type type)
+        (convert-to-lisp-type type)))
+
+#+ignore
+(defun note-named-foreign-function (symbol name types rettype)
+  "Give Allegro's compiler a hint to perform a direct call."
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (setf (get ',symbol 'system::direct-ff-call)
+           (list '(,name :language :c)
+                 t  ; callback
+                 :c ; convention
+                 ;; return type '(:c-type lisp-type)
+                 ',(allegro-type-pair (convert-foreign-type rettype :funcall))
+                 ;; arg types '({(:c-type lisp-type)}*)
+                 '(,@(loop for type in types
+                           collect (allegro-type-pair
+                                    (convert-foreign-type type :funcall))))
+                 nil ; arg-checking
+                 ff::ep-flag-never-release))))
+
+(defmacro %foreign-funcall (name args &key calling-convention library)
+  (declare (ignore calling-convention library))
+  (multiple-value-bind (types fargs rettype)
+      (foreign-funcall-type-and-args args)
+    `(system::ff-funcall
+      (load-time-value (excl::determine-foreign-address
+                        '(,name :language :c)
+                        ff::ep-flag-never-release
+                        nil ; method-index
+                        ))
+      ;; arg types {'(:c-type lisp-type) argN}*
+      ,@(mapcan (lambda (type arg)
+                  `(',(allegro-type-pair type) ,arg))
+                types fargs)
+      ;; return type '(:c-type lisp-type)
+      ',(allegro-type-pair rettype))))
+
+(defun defcfun-helper-forms (name lisp-name rettype args types options)
+  "Return 2 values for DEFCFUN. A prelude form and a caller form."
+  (declare (ignore options))
+  (let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-name))))
+    (values
+     `(ff:def-foreign-call (,ff-name ,name)
+          ,(mapcar (lambda (ty)
+                     (let ((allegro-type (convert-foreign-type ty)))
+                       (list (gensym) allegro-type
+                             (convert-to-lisp-type allegro-type))))
+                   types)
+        :returning ,(allegro-type-pair
+                     (convert-foreign-type rettype :funcall))
+        ;; Don't use call-direct when there are no arguments.
+        ,@(unless (null args) '(:call-direct t))
+        :arg-checking nil
+        :strings-convert nil)
+     `(,ff-name ,@args))))
+
+;;; See doc/allegro-internals.txt for a clue about entry-vec.
+(defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
+  (declare (ignore calling-convention))
+  (multiple-value-bind (types fargs rettype)
+      (foreign-funcall-type-and-args args)
+    (with-unique-names (entry-vec)
+      `(let ((,entry-vec (excl::make-entry-vec-boa)))
+         (setf (aref ,entry-vec 1) ,ptr) ; set jump address
+         (system::ff-funcall
+          ,entry-vec
+          ;; arg types {'(:c-type lisp-type) argN}*
+          ,@(mapcan (lambda (type arg)
+                      `(',(allegro-type-pair type) ,arg))
+                    types fargs)
+          ;; return type '(:c-type lisp-type)
+          ',(allegro-type-pair rettype))))))
+
+;;;# Callbacks
+
+;;; The *CALLBACKS* hash table contains information about a callback
+;;; for the Allegro FFI.  The key is the name of the CFFI callback,
+;;; and the value is a cons, the car containing the symbol the
+;;; callback was defined on in the CFFI-CALLBACKS package, the cdr
+;;; being an Allegro FFI pointer (a fixnum) that can be passed to C
+;;; functions.
+;;;
+;;; These pointers must be restored when a saved Lisp image is loaded.
+;;; The RESTORE-CALLBACKS function is added to *RESTART-ACTIONS* to
+;;; re-register the callbacks during Lisp startup.
+(defvar *callbacks* (make-hash-table))
+
+;;; Register a callback in the *CALLBACKS* hash table.
+(defun register-callback (cffi-name callback-name)
+  (setf (gethash cffi-name *callbacks*)
+        (cons callback-name (ff:register-foreign-callable
+                             callback-name :reuse t))))
+
+;;; Restore the saved pointers in *CALLBACKS* when loading an image.
+(defun restore-callbacks ()
+  (maphash (lambda (key value)
+             (register-callback key (car value)))
+           *callbacks*))
+
+;;; Arrange for RESTORE-CALLBACKS to run when a saved image containing
+;;; CFFI is restarted.
+(eval-when (:load-toplevel :execute)
+  (pushnew 'restore-callbacks excl:*restart-actions*))
+
+;;; Create a package to contain the symbols for callback functions.
+(defpackage #:cffi-callbacks
+  (:use))
+
+(defun intern-callback (name)
+  (intern (format nil "~A::~A" (package-name (symbol-package name))
+                  (symbol-name name))
+          '#:cffi-callbacks))
+
+(defun convert-cconv (cconv)
+  (ecase cconv
+    (:cdecl :c)
+    (:stdcall :stdcall)))
+
+(defmacro %defcallback (name rettype arg-names arg-types body
+                        &key calling-convention)
+  (declare (ignore rettype))
+  (let ((cb-name (intern-callback name)))
+    `(progn
+       (ff:defun-foreign-callable ,cb-name
+           ,(mapcar (lambda (sym type) (list sym (convert-foreign-type type)))
+                    arg-names arg-types)
+         (declare (:convention ,(convert-cconv calling-convention)))
+         ,body)
+       (register-callback ',name ',cb-name))))
+
+;;; Return the saved Lisp callback pointer from *CALLBACKS* for the
+;;; CFFI callback named NAME.
+(defun %callback (name)
+  (or (cdr (gethash name *callbacks*))
+      (error "Undefined callback: ~S" name)))
+
+;;;# Loading and Closing Foreign Libraries
+
+(defun %load-foreign-library (name path)
+  "Load a foreign library."
+  ;; ACL 8.0 honors the :FOREIGN option and always tries to foreign load
+  ;; the argument. However, previous versions do not and will only
+  ;; foreign load the argument if its type is a member of the
+  ;; EXCL::*LOAD-FOREIGN-TYPES* list. Therefore, we bind that special
+  ;; to a list containing whatever type NAME has.
+  (declare (ignore name))
+  (let ((excl::*load-foreign-types*
+         (list (pathname-type (parse-namestring path)))))
+    (handler-case
+        (progn
+          #+(version>= 7) (load path :foreign t)
+          #-(version>= 7) (load path))
+      (file-error (fe)
+        (error (change-class fe 'simple-error))))
+    path))
+
+(defun %close-foreign-library (name)
+  "Close the foreign library NAME."
+  (ff:unload-foreign-library name))
+
+(defun native-namestring (pathname)
+  (namestring pathname))
+
+;;;# Foreign Globals
+
+(defun convert-external-name (name)
+  "Add an underscore to NAME if necessary for the ABI."
+  #+macosx (concatenate 'string "_" name)
+  #-macosx name)
+
+(defun %foreign-symbol-pointer (name library)
+  "Returns a pointer to a foreign symbol NAME."
+  (declare (ignore library))
+  (prog1 (ff:get-entry-point (convert-external-name name))))
diff --git a/external/cffi.darcs/src/cffi-clisp.lisp b/external/cffi.darcs/src/cffi-clisp.lisp
new file mode 100644
index 0000000..ada94f2
--- /dev/null
+++ b/external/cffi.darcs/src/cffi-clisp.lisp
@@ -0,0 +1,402 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-clisp.lisp --- CFFI-SYS implementation for CLISP.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;;           (C) 2005-2006, Joerg Hoehle  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+  (:use #:common-lisp #:cffi-utils)
+  (:export
+   #:canonicalize-symbol-name-case
+   #:foreign-pointer
+   #:pointerp
+   #:pointer-eq
+   #:null-pointer
+   #:null-pointer-p
+   #:inc-pointer
+   #:make-pointer
+   #:pointer-address
+   #:%foreign-alloc
+   #:foreign-free
+   #:with-foreign-pointer
+   #:%foreign-funcall
+   #:%foreign-funcall-pointer
+   #:%foreign-type-alignment
+   #:%foreign-type-size
+   #:%load-foreign-library
+   #:%close-foreign-library
+   #:native-namestring
+   #:%mem-ref
+   #:%mem-set
+   #:make-shareable-byte-vector
+   #:with-pointer-to-vector-data
+   #:%foreign-symbol-pointer
+   #:%defcallback
+   #:%callback))
+
+(in-package #:cffi-sys)
+
+;;; FIXME: long-long could be supported anyway on 64-bit machines. --luis
+
+;;;# Features
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (mapc (lambda (feature) (pushnew feature *features*))
+        '(;; OS/CPU features.
+          #+:macos  cffi-features:darwin
+          #+:unix   cffi-features:unix
+          #+:win32  cffi-features:windows
+          ))
+  (cond ((string-equal (machine-type) "X86_64")
+         (pushnew 'cffi-features:x86-64 *features*))
+        ((member :pc386 *features*)
+         (pushnew 'cffi-features:x86 *features*))
+        ;; FIXME: probably catches PPC64 as well
+        ((string-equal (machine-type) "POWER MACINTOSH")
+         (pushnew 'cffi-features:ppc32 *features*))))
+
+;;; Symbol case.
+
+(defun canonicalize-symbol-name-case (name)
+  (declare (string name))
+  (string-upcase name))
+
+;;;# Built-In Foreign Types
+
+(defun convert-foreign-type (type)
+  "Convert a CFFI built-in type keyword to a CLisp FFI type."
+  (ecase type
+    (:char 'ffi:char)
+    (:unsigned-char 'ffi:uchar)
+    (:short 'ffi:short)
+    (:unsigned-short 'ffi:ushort)
+    (:int 'ffi:int)
+    (:unsigned-int 'ffi:uint)
+    (:long 'ffi:long)
+    (:unsigned-long 'ffi:ulong)
+    (:long-long 'ffi:sint64)
+    (:unsigned-long-long 'ffi:uint64)
+    (:float 'ffi:single-float)
+    (:double 'ffi:double-float)
+    ;; Clisp's FFI:C-POINTER converts NULL to NIL. For now
+    ;; we have a workaround in the pointer operations...
+    (:pointer 'ffi:c-pointer)
+    (:void nil)))
+
+(defun %foreign-type-size (type)
+  "Return the size in bytes of objects having foreign type TYPE."
+  (nth-value 0 (ffi:sizeof (convert-foreign-type type))))
+
+;; Remind me to buy a beer for whoever made getting the alignment
+;; of foreign types part of the public interface in CLisp. :-)
+(defun %foreign-type-alignment (type)
+  "Return the structure alignment in bytes of foreign TYPE."
+  #+(and cffi-features:darwin cffi-features:ppc32)
+  (case type
+    ((:double :long-long :unsigned-long-long)
+     (return-from %foreign-type-alignment 8)))
+  ;; Override not necessary for the remaining types...
+  (nth-value 1 (ffi:sizeof (convert-foreign-type type))))
+
+;;;# Basic Pointer Operations
+
+(deftype foreign-pointer ()
+  '(or null ffi:foreign-address))
+
+(defun pointerp (ptr)
+  "Return true if PTR is a foreign pointer."
+  (or (null ptr) (typep ptr 'ffi:foreign-address)))
+
+(defun pointer-eq (ptr1 ptr2)
+  "Return true if PTR1 and PTR2 point to the same address."
+  (eql (ffi:foreign-address-unsigned ptr1)
+       (ffi:foreign-address-unsigned ptr2)))
+
+(defun null-pointer ()
+  "Return a null foreign pointer."
+  (ffi:unsigned-foreign-address 0))
+
+(defun null-pointer-p (ptr)
+  "Return true if PTR is a null foreign pointer."
+  (or (null ptr) (zerop (ffi:foreign-address-unsigned ptr))))
+
+(defun inc-pointer (ptr offset)
+  "Return a pointer pointing OFFSET bytes past PTR."
+  (ffi:unsigned-foreign-address
+   (+ offset (if (null ptr) 0 (ffi:foreign-address-unsigned ptr)))))
+
+(defun make-pointer (address)
+  "Return a pointer pointing to ADDRESS."
+  (ffi:unsigned-foreign-address address))
+
+(defun pointer-address (ptr)
+  "Return the address pointed to by PTR."
+  (ffi:foreign-address-unsigned ptr))
+
+;;;# Foreign Memory Allocation
+
+(defun %foreign-alloc (size)
+  "Allocate SIZE bytes of foreign-addressable memory and return a
+pointer to the allocated block.  An implementation-specific error
+is signalled if the memory cannot be allocated."
+  (ffi:foreign-address (ffi:allocate-shallow 'ffi:uint8 :count size)))
+
+(defun foreign-free (ptr)
+  "Free a pointer PTR allocated by FOREIGN-ALLOC.  The results
+are undefined if PTR is used after being freed."
+  (ffi:foreign-free ptr))
+
+(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
+  "Bind VAR to a pointer to SIZE bytes of foreign-addressable
+memory during BODY.  Both PTR and the memory block pointed to
+have dynamic extent and may be stack allocated if supported by
+the implementation.  If SIZE-VAR is supplied, it will be bound to
+SIZE during BODY."
+  (unless size-var
+    (setf size-var (gensym "SIZE")))
+  (let ((obj-var (gensym)))
+    `(let ((,size-var ,size))
+       (ffi:with-foreign-object
+           (,obj-var `(ffi:c-array ffi:uint8 ,,size-var))
+         (let ((,var (ffi:foreign-address ,obj-var)))
+           ,@body)))))
+
+;;;# Memory Access
+
+(defun %mem-ref (ptr type &optional (offset 0))
+  "Dereference a pointer OFFSET bytes from PTR to an object of
+built-in foreign TYPE.  Returns the object as a foreign pointer
+or Lisp number."
+  (ffi:memory-as ptr (convert-foreign-type type) offset))
+
+(define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0))
+  "Compiler macro to open-code when TYPE is constant."
+  (if (constantp type)
+      `(ffi:memory-as ,ptr ',(convert-foreign-type (eval type)) ,offset)
+      form))
+
+(defun %mem-set (value ptr type &optional (offset 0))
+  "Set a pointer OFFSET bytes from PTR to an object of built-in
+foreign TYPE to VALUE."
+  (setf (ffi:memory-as ptr (convert-foreign-type type) offset) value))
+
+(define-compiler-macro %mem-set
+    (&whole form value ptr type &optional (offset 0))
+  (if (constantp type)
+      ;; (setf (ffi:memory-as) value) is exported, but not so nice
+      ;; w.r.t. the left to right evaluation rule
+      `(ffi::write-memory-as
+        ,value ,ptr ',(convert-foreign-type (eval type)) ,offset)
+      form))
+
+;;;# Shareable Vectors
+;;;
+;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
+;;; should be defined to perform a copy-in/copy-out if the Lisp
+;;; implementation can't do this.
+
+(declaim (inline make-shareable-byte-vector))
+(defun make-shareable-byte-vector (size)
+  "Create a Lisp vector of SIZE bytes can passed to
+WITH-POINTER-TO-VECTOR-DATA."
+  (make-array size :element-type '(unsigned-byte 8)))
+
+(deftype shareable-byte-vector ()
+  `(vector (unsigned-byte 8)))
+
+(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+  "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
+  (with-unique-names (vector-var size-var)
+    `(let ((,vector-var ,vector))
+       (check-type ,vector-var shareable-byte-vector)
+       (with-foreign-pointer (,ptr-var (length ,vector-var) ,size-var)
+         ;; copy-in
+         (loop for i below ,size-var do
+               (%mem-set (aref ,vector-var i) ,ptr-var :unsigned-char i))
+         (unwind-protect (progn ,@body)
+           ;; copy-out
+           (loop for i below ,size-var do
+                 (setf (aref ,vector-var i)
+                       (%mem-ref ,ptr-var :unsigned-char i))))))))
+
+;;;# Foreign Function Calling
+
+(defun parse-foreign-funcall-args (args)
+  "Return three values, a list of CLISP FFI types, a list of
+values to pass to the function, and the CLISP FFI return type."
+  (let ((return-type nil))
+    (loop for (type arg) on args by #'cddr
+          if arg collect (list (gensym) (convert-foreign-type type)) into types
+          and collect arg into fargs
+          else do (setf return-type (convert-foreign-type type))
+          finally (return (values types fargs return-type)))))
+
+(defun convert-cconv (calling-convention)
+  (ecase calling-convention
+    (:stdcall :stdc-stdcall)
+    (:cdecl :stdc)))
+
+(defun c-function-type (arg-types rettype calling-convention)
+  "Generate the apropriate CLISP foreign type specification. Also
+takes care of converting the calling convention names."
+  `(ffi:c-function (:arguments ,@arg-types)
+                   (:return-type ,rettype)
+                   (:language ,(convert-cconv calling-convention))))
+
+;;; Quick hack around the fact that the CFFI package is not yet
+;;; defined when this file is loaded.  I suppose we could arrange for
+;;; the CFFI package to be defined a bit earlier, though.
+(defun library-handle-form (name)
+  (flet ((find-cffi-symbol (symbol)
+           (find-symbol (symbol-name symbol) '#:cffi)))
+    `(,(find-cffi-symbol '#:foreign-library-handle)
+       (,(find-cffi-symbol '#:get-foreign-library) ',name))))
+
+(defmacro %foreign-funcall (name args &key library calling-convention)
+  "Invoke a foreign function called NAME, taking pairs of
+foreign-type/value pairs from ARGS.  If a single element is left
+over at the end of ARGS, it specifies the foreign return type of
+the function call."
+  (multiple-value-bind (types fargs rettype)
+      (parse-foreign-funcall-args args)
+    `(funcall
+      (load-time-value
+       (handler-case
+           (ffi::foreign-library-function
+            ,name
+            ,(if (eq library :default)
+                 :default
+                 (library-handle-form library))
+            nil
+            ;; As of version 2.40 (CVS 2006-09-03, to be more precise),
+            ;; FFI::FOREIGN-LIBRARY-FUNCTION takes an additional
+            ;; 'PROPERTIES' argument.
+            #+#.(cl:if (cl:= (cl:length (ext:arglist
+                                         'ffi::foreign-library-function)) 5)
+                       '(and) '(or))
+            nil
+            (ffi:parse-c-type ',(c-function-type
+                                 types rettype calling-convention)))
+         (error (err)
+           (warn "~A" err))))
+      ,@fargs)))
+
+(defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
+  "Similar to %foreign-funcall but takes a pointer instead of a string."
+  (multiple-value-bind (types fargs rettype)
+      (parse-foreign-funcall-args args)
+    `(funcall (ffi:foreign-function
+               ,ptr (load-time-value
+                     (ffi:parse-c-type ',(c-function-type
+                                          types rettype calling-convention))))
+              ,@fargs)))
+
+;;;# Callbacks
+
+;;; *CALLBACKS* contains the callbacks defined by the CFFI DEFCALLBACK
+;;; macro.  The symbol naming the callback is the key, and the value
+;;; is a list containing a Lisp function, the parsed CLISP FFI type of
+;;; the callback, and a saved pointer that should not persist across
+;;; saved images.
+(defvar *callbacks* (make-hash-table))
+
+;;; Return a CLISP FFI function type for a CFFI callback function
+;;; given a return type and list of argument names and types.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun callback-type (rettype arg-names arg-types calling-convention)
+    (ffi:parse-c-type
+     `(ffi:c-function
+       (:arguments ,@(mapcar (lambda (sym type)
+                               (list sym (convert-foreign-type type)))
+                             arg-names arg-types))
+       (:return-type ,(convert-foreign-type rettype))
+       (:language ,(convert-cconv calling-convention))))))
+
+;;; Register and create a callback function.
+(defun register-callback (name function parsed-type)
+  (setf (gethash name *callbacks*)
+        (list function parsed-type
+              (ffi:with-foreign-object (ptr 'ffi:c-pointer)
+                ;; Create callback by converting Lisp function to foreign
+                (setf (ffi:memory-as ptr parsed-type) function)
+                (ffi:foreign-value ptr)))))
+
+;;; Restore all saved callback pointers when restarting the Lisp
+;;; image.  This is pushed onto CUSTOM:*INIT-HOOKS*.
+;;; Needs clisp > 2.35, bugfix 2005-09-29
+(defun restore-callback-pointers ()
+  (maphash
+   (lambda (name list)
+     (register-callback name (first list) (second list)))
+   *callbacks*))
+
+;;; Add RESTORE-CALLBACK-POINTERS to the lists of functions to run
+;;; when an image is restarted.
+(eval-when (:load-toplevel :execute)
+  (pushnew 'restore-callback-pointers custom:*init-hooks*))
+
+;;; Define a callback function NAME to run BODY with arguments
+;;; ARG-NAMES translated according to ARG-TYPES and the return type
+;;; translated according to RETTYPE.  Obtain a pointer that can be
+;;; passed to C code for this callback by calling %CALLBACK.
+(defmacro %defcallback (name rettype arg-names arg-types body
+                        &key calling-convention)
+  `(register-callback ',name (lambda ,arg-names ,body)
+                      ,(callback-type rettype arg-names arg-types
+                                      calling-convention)))
+
+;;; Look up the name of a callback and return a pointer that can be
+;;; passed to a C function.  Signals an error if no callback is
+;;; defined called NAME.
+(defun %callback (name)
+  (multiple-value-bind (list winp) (gethash name *callbacks*)
+    (unless winp
+      (error "Undefined callback: ~S" name))
+    (third list)))
+
+;;;# Loading and Closing Foreign Libraries
+
+(defun %load-foreign-library (name path)
+  "Load a foreign library from PATH."
+  (declare (ignore name))
+  (ffi::foreign-library path))
+
+(defun %close-foreign-library (handle)
+  "Close a foreign library."
+  (ffi:close-foreign-library handle))
+
+(defun native-namestring (pathname)
+  (namestring pathname))
+
+;;;# Foreign Globals
+
+(defun %foreign-symbol-pointer (name library)
+  "Returns a pointer to a foreign symbol NAME."
+  (prog1 (ignore-errors
+           (ffi:foreign-address
+            (ffi::foreign-library-variable
+             name library nil nil)))))
diff --git a/external/cffi.darcs/src/cffi-cmucl.lisp b/external/cffi.darcs/src/cffi-cmucl.lisp
new file mode 100644
index 0000000..64e7d76
--- /dev/null
+++ b/external/cffi.darcs/src/cffi-cmucl.lisp
@@ -0,0 +1,389 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-cmucl.lisp --- CFFI-SYS implementation for CMU CL.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+  (:use #:common-lisp #:alien #:c-call #:cffi-utils)
+  (:export
+   #:canonicalize-symbol-name-case
+   #:foreign-pointer
+   #:pointerp
+   #:pointer-eq
+   #:null-pointer
+   #:null-pointer-p
+   #:inc-pointer
+   #:make-pointer
+   #:pointer-address
+   #:%foreign-alloc
+   #:foreign-free
+   #:with-foreign-pointer
+   #:%foreign-funcall
+   #:%foreign-funcall-pointer
+   #:%foreign-type-alignment
+   #:%foreign-type-size
+   #:%load-foreign-library
+   #:%close-foreign-library
+   #:native-namestring
+   #:%mem-ref
+   #:%mem-set
+   #:make-shareable-byte-vector
+   #:with-pointer-to-vector-data
+   #:%foreign-symbol-pointer
+   #:%defcallback
+   #:%callback))
+
+(in-package #:cffi-sys)
+
+;;;# Features
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (mapc (lambda (feature) (pushnew feature *features*))
+        '(;; OS/CPU features.
+          #+darwin  cffi-features:darwin
+          #+unix    cffi-features:unix
+          #+x86     cffi-features:x86
+          #+(and ppc (not ppc64)) cffi-features:ppc32
+          ;; Misfeatures
+          cffi-features:flat-namespace
+          )))
+
+;;; Symbol case.
+
+(defun canonicalize-symbol-name-case (name)
+  (declare (string name))
+  (string-upcase name))
+
+;;;# Basic Pointer Operations
+
+(deftype foreign-pointer ()
+  'sys:system-area-pointer)
+
+(declaim (inline pointerp))
+(defun pointerp (ptr)
+  "Return true if PTR is a foreign pointer."
+  (sys:system-area-pointer-p ptr))
+
+(declaim (inline pointer-eq))
+(defun pointer-eq (ptr1 ptr2)
+  "Return true if PTR1 and PTR2 point to the same address."
+  (sys:sap= ptr1 ptr2))
+
+(declaim (inline null-pointer))
+(defun null-pointer ()
+  "Construct and return a null pointer."
+  (sys:int-sap 0))
+
+(declaim (inline null-pointer-p))
+(defun null-pointer-p (ptr)
+  "Return true if PTR is a null pointer."
+  (zerop (sys:sap-int ptr)))
+
+(declaim (inline inc-pointer))
+(defun inc-pointer (ptr offset)
+  "Return a pointer pointing OFFSET bytes past PTR."
+  (sys:sap+ ptr offset))
+
+(declaim (inline make-pointer))
+(defun make-pointer (address)
+  "Return a pointer pointing to ADDRESS."
+  (sys:int-sap address))
+
+(declaim (inline pointer-address))
+(defun pointer-address (ptr)
+  "Return the address pointed to by PTR."
+  (sys:sap-int ptr))
+
+(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
+  "Bind VAR to SIZE bytes of foreign memory during BODY.  The
+pointer in VAR is invalid beyond the dynamic extent of BODY, and
+may be stack-allocated if supported by the implementation.  If
+SIZE-VAR is supplied, it will be bound to SIZE during BODY."
+  (unless size-var
+    (setf size-var (gensym "SIZE")))
+  ;; If the size is constant we can stack-allocate.
+  (if (constantp size)
+      (let ((alien-var (gensym "ALIEN")))
+        `(with-alien ((,alien-var (array (unsigned 8) ,(eval size))))
+           (let ((,size-var ,(eval size))
+                 (,var (alien-sap ,alien-var)))
+             (declare (ignorable ,size-var))
+             ,@body)))
+      `(let* ((,size-var ,size)
+              (,var (%foreign-alloc ,size-var)))
+         (unwind-protect
+              (progn ,@body)
+           (foreign-free ,var)))))
+
+;;;# Allocation
+;;;
+;;; Functions and macros for allocating foreign memory on the stack
+;;; and on the heap.  The main CFFI package defines macros that wrap
+;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
+;;; when the memory has dynamic extent.
+
+(defun %foreign-alloc (size)
+  "Allocate SIZE bytes on the heap and return a pointer."
+  (declare (type (unsigned-byte 32) size))
+  (alien-funcall
+   (extern-alien
+    "malloc"
+    (function system-area-pointer unsigned))
+   size))
+
+(defun foreign-free (ptr)
+  "Free a PTR allocated by FOREIGN-ALLOC."
+  (declare (type system-area-pointer ptr))
+  (alien-funcall
+   (extern-alien
+    "free"
+    (function (values) system-area-pointer))
+   ptr))
+
+;;;# Shareable Vectors
+;;;
+;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
+;;; should be defined to perform a copy-in/copy-out if the Lisp
+;;; implementation can't do this.
+
+(defun make-shareable-byte-vector (size)
+  "Create a Lisp vector of SIZE bytes that can passed to
+WITH-POINTER-TO-VECTOR-DATA."
+  (make-array size :element-type '(unsigned-byte 8)))
+
+(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+  "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
+  `(sys:without-gcing
+     (let ((,ptr-var (sys:vector-sap ,vector)))
+       ,@body)))
+
+;;;# Dereferencing
+
+;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
+;;; macros that optimize the case where the type keyword is constant
+;;; at compile-time.
+(defmacro define-mem-accessors (&body pairs)
+  `(progn
+    (defun %mem-ref (ptr type &optional (offset 0))
+      (ecase type
+        ,@(loop for (keyword fn) in pairs
+                collect `(,keyword (,fn ptr offset)))))
+    (defun %mem-set (value ptr type &optional (offset 0))
+      (ecase type
+        ,@(loop for (keyword fn) in pairs
+                collect `(,keyword (setf (,fn ptr offset) value)))))
+    (define-compiler-macro %mem-ref
+        (&whole form ptr type &optional (offset 0))
+      (if (constantp type)
+          (ecase (eval type)
+            ,@(loop for (keyword fn) in pairs
+                    collect `(,keyword `(,',fn ,ptr ,offset))))
+          form))
+    (define-compiler-macro %mem-set
+        (&whole form value ptr type &optional (offset 0))
+      (if (constantp type)
+          (once-only (value)
+            (ecase (eval type)
+              ,@(loop for (keyword fn) in pairs
+                      collect `(,keyword `(setf (,',fn ,ptr ,offset)
+                                                ,value)))))
+          form))))
+
+(define-mem-accessors
+  (:char sys:signed-sap-ref-8)
+  (:unsigned-char sys:sap-ref-8)
+  (:short sys:signed-sap-ref-16)
+  (:unsigned-short sys:sap-ref-16)
+  (:int sys:signed-sap-ref-32)
+  (:unsigned-int sys:sap-ref-32)
+  (:long sys:signed-sap-ref-32)
+  (:unsigned-long sys:sap-ref-32)
+  (:long-long sys:signed-sap-ref-64)
+  (:unsigned-long-long sys:sap-ref-64)
+  (:float sys:sap-ref-single)
+  (:double sys:sap-ref-double)
+  (:pointer sys:sap-ref-sap))
+
+;;;# Calling Foreign Functions
+
+(defun convert-foreign-type (type-keyword)
+  "Convert a CFFI type keyword to an ALIEN type."
+  (ecase type-keyword
+    (:char               'char)
+    (:unsigned-char      'unsigned-char)
+    (:short              'short)
+    (:unsigned-short     'unsigned-short)
+    (:int                'int)
+    (:unsigned-int       'unsigned-int)
+    (:long               'long)
+    (:unsigned-long      'unsigned-long)
+    (:long-long          '(signed 64))
+    (:unsigned-long-long '(unsigned 64))
+    (:float              'single-float)
+    (:double             'double-float)
+    (:pointer            'system-area-pointer)
+    (:void               'void)))
+
+(defun %foreign-type-size (type-keyword)
+  "Return the size in bytes of a foreign type."
+  (/ (alien-internals:alien-type-bits
+      (alien-internals:parse-alien-type
+       (convert-foreign-type type-keyword))) 8))
+
+(defun %foreign-type-alignment (type-keyword)
+  "Return the alignment in bytes of a foreign type."
+  (/ (alien-internals:alien-type-alignment
+      (alien-internals:parse-alien-type
+       (convert-foreign-type type-keyword))) 8))
+
+(defun foreign-funcall-type-and-args (args)
+  "Return an ALIEN function type for ARGS."
+  (let ((return-type nil))
+    (loop for (type arg) on args by #'cddr
+          if arg collect (convert-foreign-type type) into types
+          and collect arg into fargs
+          else do (setf return-type (convert-foreign-type type))
+          finally (return (values types fargs return-type)))))
+
+(defmacro %%foreign-funcall (name types fargs rettype)
+  "Internal guts of %FOREIGN-FUNCALL."
+  `(alien-funcall
+    (extern-alien ,name (function ,rettype ,@types))
+    ,@fargs))
+
+(defmacro %foreign-funcall (name args &key library calling-convention)
+  "Perform a foreign function call, document it more later."
+  (declare (ignore library calling-convention))
+  (multiple-value-bind (types fargs rettype)
+      (foreign-funcall-type-and-args args)
+    `(%%foreign-funcall ,name ,types ,fargs ,rettype)))
+
+(defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
+  "Funcall a pointer to a foreign function."
+  (declare (ignore calling-convention))
+  (multiple-value-bind (types fargs rettype)
+      (foreign-funcall-type-and-args args)
+    (with-unique-names (function)
+      `(with-alien ((,function (* (function ,rettype ,@types)) ,ptr))
+         (alien-funcall ,function ,@fargs)))))
+
+;;;# Callbacks
+
+(defvar *callbacks* (make-hash-table))
+
+;;; Create a package to contain the symbols for callback functions.  We
+;;; want to redefine callbacks with the same symbol so the internal data
+;;; structures are reused.
+(defpackage #:cffi-callbacks
+  (:use))
+
+;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
+;;; callback for NAME.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun intern-callback (name)
+    (intern (format nil "~A::~A" (package-name (symbol-package name))
+                    (symbol-name name))
+            '#:cffi-callbacks)))
+
+(defmacro %defcallback (name rettype arg-names arg-types body
+                        &key calling-convention)
+  (declare (ignore calling-convention))
+  (let ((cb-name (intern-callback name)))
+    `(progn
+       (def-callback ,cb-name
+           (,(convert-foreign-type rettype)
+             ,@(mapcar (lambda (sym type)
+                         (list sym (convert-foreign-type type)))
+                       arg-names arg-types))
+         ,body)
+       (setf (gethash ',name *callbacks*) (callback ,cb-name)))))
+
+(defun %callback (name)
+  (multiple-value-bind (pointer winp)
+      (gethash name *callbacks*)
+    (unless winp
+      (error "Undefined callback: ~S" name))
+    pointer))
+
+;;; CMUCL makes new callback trampolines when it reloads, so we need
+;;; to update CFFI's copies.
+(defun reset-callbacks ()
+  (loop for k being the hash-keys of *callbacks*
+        do (setf (gethash k *callbacks*)
+                 (alien::symbol-trampoline (intern-callback k)))))
+
+;; Needs to be after cmucl's restore-callbacks, so put at the end...
+(unless (member 'reset-callbacks ext:*after-save-initializations*)
+  (setf ext:*after-save-initializations*
+        (append ext:*after-save-initializations* (list 'reset-callbacks))))
+
+;;;# Loading and Closing Foreign Libraries
+
+;;; Work-around for compiling ffi code without loading the
+;;; respective library at compile-time.
+(setf c::top-level-lambda-max 0)
+
+(defun %load-foreign-library (name path)
+  "Load the foreign library NAME."
+  ;; On some platforms SYS::LOAD-OBJECT-FILE signals an error when
+  ;; loading fails, but on others (Linux for instance) it returns
+  ;; two values: NIL and an error string.
+  (declare (ignore name))
+  (multiple-value-bind (ret message)
+      (sys::load-object-file path)
+    (cond
+      ;; Loading failed.
+      ((stringp message) (error "~A" message))
+      ;; The library was already loaded.
+      ((null ret) (cdr (rassoc path sys::*global-table* :test #'string=)))
+      ;; The library has been loaded, but since SYS::LOAD-OBJECT-FILE
+      ;; returns an alist of *all* loaded libraries along with their addresses
+      ;; we return only the handler associated with the library just loaded.
+      (t (cdr (rassoc path ret :test #'string=))))))
+
+;;; XXX: doesn't work on Darwin; does not check for errors. I suppose we'd
+;;; want something like SBCL's dlclose-or-lose in foreign-load.lisp:66
+(defun %close-foreign-library (handler)
+  "Closes a foreign library."
+  (let ((lib (rassoc (ext:unix-namestring handler) sys::*global-table*
+                     :test #'string=)))
+    (sys::dlclose (car lib))
+    (setf (car lib) (sys:int-sap 0))))
+
+(defun native-namestring (pathname)
+  (ext:unix-namestring pathname))
+
+;;;# Foreign Globals
+
+(defun %foreign-symbol-pointer (name library)
+  "Returns a pointer to a foreign symbol NAME."
+  (declare (ignore library))
+  (let ((address (sys:alternate-get-global-address
+                  (vm:extern-alien-name name))))
+    (if (zerop address)
+        nil
+        (sys:int-sap address))))
diff --git a/external/cffi.darcs/src/cffi-corman.lisp b/external/cffi.darcs/src/cffi-corman.lisp
new file mode 100644
index 0000000..bf31b00
--- /dev/null
+++ b/external/cffi.darcs/src/cffi-corman.lisp
@@ -0,0 +1,337 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-corman.lisp --- CFFI-SYS implementation for Corman Lisp.
+;;;
+;;; Copyright (C) 2005-2006, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;; This port is suffering from bitrot as of 2007-03-29.  Corman Lisp
+;;; is too funky with ASDF, crashes easily, makes it very painful to
+;;; do any testing.  -- luis
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+  (:use #:common-lisp #:c-types #:cffi-utils)
+  (:export
+   #:canonicalize-symbol-name-case
+   #:foreign-pointer
+   #:pointerp
+   #:pointer-eq
+   #:null-pointer
+   #:null-pointer-p
+   #:inc-pointer
+   #:make-pointer
+   #:pointer-address
+   #:%foreign-alloc
+   #:foreign-free
+   #:with-foreign-pointer
+   #:%foreign-funcall
+   #:%foreign-type-alignment
+   #:%foreign-type-size
+   #:%load-foreign-library
+   #:native-namestring
+   #:%mem-ref
+   #:%mem-set
+   ;#:make-shareable-byte-vector
+   ;#:with-pointer-to-vector-data
+   #:foreign-symbol-pointer
+   #:defcfun-helper-forms
+   #:%defcallback
+   #:%callback))
+
+(in-package #:cffi-sys)
+
+;;;# Features
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (mapc (lambda (feature) (pushnew feature *features*))
+        '(;; Backend mis-features.
+          cffi-features:no-long-long
+          cffi-features:no-foreign-funcall
+          ;; OS/CPU features.
+          cffi-features:windows
+          cffi-features:x86
+          )))
+
+;;; Symbol case.
+
+(defun canonicalize-symbol-name-case (name)
+  (declare (string name))
+  (string-upcase name))
+
+;;;# Basic Pointer Operations
+
+(deftype foreign-pointer ()
+  'cl::foreign)
+
+(defun pointerp (ptr)
+  "Return true if PTR is a foreign pointer."
+  (cpointerp ptr))
+
+(defun pointer-eq (ptr1 ptr2)
+  "Return true if PTR1 and PTR2 point to the same address."
+  (cpointer= ptr1 ptr2))
+
+(defun null-pointer ()
+  "Return a null pointer."
+  (create-foreign-ptr))
+
+(defun null-pointer-p (ptr)
+  "Return true if PTR is a null pointer."
+  (cpointer-null ptr))
+
+(defun inc-pointer (ptr offset)
+  "Return a pointer pointing OFFSET bytes past PTR."
+  (let ((new-ptr (create-foreign-ptr)))
+    (setf (cpointer-value new-ptr)
+          (+ (cpointer-value ptr) offset))
+    new-ptr))
+
+(defun make-pointer (address)
+  "Return a pointer pointing to ADDRESS."
+  (int-to-foreign-ptr address))
+
+(defun pointer-address (ptr)
+  "Return the address pointed to by PTR."
+  (foreign-ptr-to-int ptr))
+
+;;;# Allocation
+;;;
+;;; Functions and macros for allocating foreign memory on the stack
+;;; and on the heap.  The main CFFI package defines macros that wrap
+;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
+;;; when the memory has dynamic extent.
+
+(defun %foreign-alloc (size)
+  "Allocate SIZE bytes on the heap and return a pointer."
+  (malloc size))
+
+(defun foreign-free (ptr)
+  "Free a PTR allocated by FOREIGN-ALLOC."
+  (free ptr))
+
+(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
+  "Bind VAR to SIZE bytes of foreign memory during BODY.  The
+pointer in VAR is invalid beyond the dynamic extent of BODY, and
+may be stack-allocated if supported by the implementation.  If
+SIZE-VAR is supplied, it will be bound to SIZE during BODY."
+  (unless size-var
+    (setf size-var (gensym "SIZE")))
+  `(let* ((,size-var ,size)
+          (,var (malloc ,size-var)))
+     (unwind-protect
+          (progn ,@body)
+       (free ,var))))
+
+;;;# Shareable Vectors
+;;;
+;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
+;;; should be defined to perform a copy-in/copy-out if the Lisp
+;;; implementation can't do this.
+
+;(defun make-shareable-byte-vector (size)
+;  "Create a Lisp vector of SIZE bytes can passed to
+;WITH-POINTER-TO-VECTOR-DATA."
+;  (make-array size :element-type '(unsigned-byte 8)))
+;
+;(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+;  "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
+;  `(sb-sys:without-gcing
+;     (let ((,ptr-var (sb-sys:vector-sap ,vector)))
+;       ,@body)))
+
+;;;# Dereferencing
+
+;;; According to the docs, Corman's C Function Definition Parser
+;;; converts int to long, so we'll assume that.
+(defun convert-foreign-type (type-keyword)
+  "Convert a CFFI type keyword to a CormanCL type."
+  (ecase type-keyword
+    (:char             :char)
+    (:unsigned-char    :unsigned-char)
+    (:short            :short)
+    (:unsigned-short   :unsigned-short)
+    (:int              :long)
+    (:unsigned-int     :unsigned-long)
+    (:long             :long)
+    (:unsigned-long    :unsigned-long)
+    (:float            :single-float)
+    (:double           :double-float)
+    (:pointer          :handle)
+    (:void             :void)))
+
+(defun %mem-ref (ptr type &optional (offset 0))
+  "Dereference an object of TYPE at OFFSET bytes from PTR."
+  (unless (eql offset 0)
+    (setq ptr (inc-pointer ptr offset)))
+  (ecase type
+    (:char             (cref (:char *) ptr 0))
+    (:unsigned-char    (cref (:unsigned-char *) ptr 0))
+    (:short            (cref (:short *) ptr 0))
+    (:unsigned-short   (cref (:unsigned-short *) ptr 0))
+    (:int              (cref (:long *) ptr 0))
+    (:unsigned-int     (cref (:unsigned-long *) ptr 0))
+    (:long             (cref (:long *) ptr 0))
+    (:unsigned-long    (cref (:unsigned-long *) ptr 0))
+    (:float            (cref (:single-float *) ptr 0))
+    (:double           (cref (:double-float *) ptr 0))
+    (:pointer          (cref (:handle *) ptr 0))))
+
+;(define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0))
+;  (if (constantp type)
+;      `(cref (,(convert-foreign-type type) *) ,ptr ,offset)
+;      form))
+
+(defun %mem-set (value ptr type &optional (offset 0))
+  "Set the object of TYPE at OFFSET bytes from PTR."
+  (unless (eql offset 0)
+    (setq ptr (inc-pointer ptr offset)))
+  (ecase type
+    (:char             (setf (cref (:char *) ptr 0) value))
+    (:unsigned-char    (setf (cref (:unsigned-char *) ptr 0) value))
+    (:short            (setf (cref (:short *) ptr 0) value))
+    (:unsigned-short   (setf (cref (:unsigned-short *) ptr 0) value))
+    (:int              (setf (cref (:long *) ptr 0) value))
+    (:unsigned-int     (setf (cref (:unsigned-long *) ptr 0) value))
+    (:long             (setf (cref (:long *) ptr 0) value))
+    (:unsigned-long    (setf (cref (:unsigned-long *) ptr 0) value))
+    (:float            (setf (cref (:single-float *) ptr 0) value))
+    (:double           (setf (cref (:double-float *) ptr 0) value))
+    (:pointer          (setf (cref (:handle *) ptr 0) value))))
+
+;;;# Calling Foreign Functions
+
+(defun %foreign-type-size (type-keyword)
+  "Return the size in bytes of a foreign type."
+  (sizeof (convert-foreign-type type-keyword)))
+
+;;; Couldn't find anything in sys/ffi.lisp and the C declaration parser
+;;; doesn't seem to care about alignment so we'll assume that it's the
+;;; same as its size.
+(defun %foreign-type-alignment (type-keyword)
+  (sizeof (convert-foreign-type type-keyword)))
+
+(defun find-dll-containing-function (name)
+  "Searches for NAME in the loaded DLLs. If found, returns
+the DLL's name (a string), else returns NIL."
+  (dolist (dll ct::*dlls-loaded*)
+    (when (ignore-errors
+            (ct::get-dll-proc-address name (ct::dll-record-handle dll)))
+      (return (ct::dll-record-name dll)))))
+
+;;; This won't work at all...
+#||
+(defmacro %foreign-funcall (name &rest args)
+  (let ((sym (gensym)))
+    `(let (,sym)
+       (ct::install-dll-function ,(find-dll-containing-function name)
+                                 ,name ,sym)
+       (funcall ,sym ,@(loop for (type arg) on args by #'cddr
+                             if arg collect arg)))))
+||#
+
+;;; It *might* be possible to implement by copying most of the code
+;;; from Corman's DEFUN-DLL.  Alternatively, it could implemented the
+;;; same way as Lispworks' foreign-funcall.  In practice, nobody uses
+;;; Corman with CFFI, apparently. :)
+(defmacro %foreign-funcall (name &rest args)
+  "Call a foreign function NAME passing arguments ARGS."
+  `(format t "~&;; Calling ~A with args ~S.~%" ,name ',args))
+
+(defun defcfun-helper-forms (name lisp-name rettype args types)
+  "Return 2 values for DEFCFUN. A prelude form and a caller form."
+  (let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-name)))
+        ;; XXX This will only work if the dll is already loaded, fix this.
+        (dll (find-dll-containing-function name)))
+    (values
+     `(defun-dll ,ff-name
+          ,(mapcar (lambda (type)
+                     (list (gensym) (convert-foreign-type type)))
+                   types)
+        :return-type ,(convert-foreign-type rettype)
+        :library-name ,dll
+        :entry-name ,name
+        ;; we want also :pascal linkage type to access
+        ;; the win32 api for instance..
+        :linkage-type :c)
+     `(,ff-name ,@args))))
+
+;;;# Callbacks
+
+;;; defun-c-callback vs. defun-direct-c-callback?
+;;; same issue as Allegro, no return type declaration, should we coerce?
+(defmacro %defcallback (name rettype arg-names arg-types body-form)
+  (declare (ignore rettype))
+  (with-unique-names (cb-sym)
+    `(progn
+       (defun-c-callback ,cb-sym
+           ,(mapcar (lambda (sym type) (list sym (convert-foreign-type type)))
+                            arg-names arg-types)
+         ,body-form)
+       (setf (get ',name 'callback-ptr)
+             (get-callback-procinst ',cb-sym)))))
+
+;;; Just continue to use the plist for now even though this really
+;;; should use a *CALLBACKS* hash table and not define the callbacks
+;;; as gensyms.  Someone with access to Corman should update this.
+(defun %callback (name)
+  (get name 'callback-ptr))
+
+;;;# Loading Foreign Libraries
+
+(defun %load-foreign-library (name)
+  "Load the foreign library NAME."
+  (ct::get-dll-record name))
+
+(defun %close-foreign-library (name)
+  "Close the foreign library NAME."
+  (error "Not implemented."))
+
+(defun native-namestring (pathname)
+  (namestring pathname)) ; TODO: confirm
+
+;;;# Foreign Globals
+
+;;; FFI to GetProcAddress from the Win32 API.
+;;; "The GetProcAddress function retrieves the address of an exported
+;;; function or variable from the specified dynamic-link library (DLL)."
+(defun-dll get-proc-address
+    ((module HMODULE)
+     (name LPCSTR))
+  :return-type FARPROC
+  :library-name "Kernel32.dll"
+  :entry-name "GetProcAddress"
+  :linkage-type :pascal)
+
+(defun foreign-symbol-pointer (name)
+  "Returns a pointer to a foreign symbol NAME."
+  (let ((str (lisp-string-to-c-string name)))
+    (unwind-protect
+         (dolist (dll ct::*dlls-loaded*)
+           (let ((ptr (get-proc-address
+                       (int-to-foreign-ptr (ct::dll-record-handle dll))
+                       str)))
+             (when (not (cpointer-null ptr))
+               (return ptr))))
+      (free str))))
diff --git a/external/cffi.darcs/src/cffi-ecl.lisp b/external/cffi.darcs/src/cffi-ecl.lisp
new file mode 100644
index 0000000..abd02ef
--- /dev/null
+++ b/external/cffi.darcs/src/cffi-ecl.lisp
@@ -0,0 +1,306 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-ecl.lisp --- ECL backend for CFFI.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+  (:use #:common-lisp #:cffi-utils)
+  (:export
+   #:canonicalize-symbol-name-case
+   #:foreign-pointer
+   #:pointerp
+   #:pointer-eq
+   #:%foreign-alloc
+   #:foreign-free
+   #:with-foreign-pointer
+   #:null-pointer
+   #:null-pointer-p
+   #:inc-pointer
+   #:make-pointer
+   #:pointer-address
+   #:%mem-ref
+   #:%mem-set
+   #:%foreign-funcall
+   #:%foreign-funcall-pointer
+   #:%foreign-type-alignment
+   #:%foreign-type-size
+   #:%load-foreign-library
+   #:native-namestring
+   #:make-shareable-byte-vector
+   #:with-pointer-to-vector-data
+   #:%defcallback
+   #:%callback
+   #:%foreign-symbol-pointer))
+
+(in-package #:cffi-sys)
+
+;;;# Features
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (mapc (lambda (feature) (pushnew feature *features*))
+        '(;; Backend mis-features.
+          cffi-features:no-long-long
+          cffi-features:flat-namespace
+          ;; OS/CPU features.
+          #+:darwin       cffi-features:darwin
+          #+:darwin       cffi-features:unix
+          #+:unix         cffi-features:unix
+          #+:win32        cffi-features:windows
+          ;; XXX: figure out a way to get a X86 feature
+          ;;#+:athlon       cffi-features:x86
+          #+:powerpc7450  cffi-features:ppc32
+          )))
+
+;;; Symbol case.
+
+(defun canonicalize-symbol-name-case (name)
+  (declare (string name))
+  (string-upcase name))
+
+;;;# Allocation
+
+(defun %foreign-alloc (size)
+  "Allocate SIZE bytes of foreign-addressable memory."
+  (si:allocate-foreign-data :void size))
+
+(defun foreign-free (ptr)
+  "Free a pointer PTR allocated by FOREIGN-ALLOC."
+  (si:free-foreign-data ptr))
+
+(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
+  "Bind VAR to SIZE bytes of foreign memory during BODY.  The
+pointer in VAR is invalid beyond the dynamic extent of BODY, and
+may be stack-allocated if supported by the implementation.  If
+SIZE-VAR is supplied, it will be bound to SIZE during BODY."
+  (unless size-var
+    (setf size-var (gensym "SIZE")))
+  `(let* ((,size-var ,size)
+          (,var (%foreign-alloc ,size-var)))
+     (unwind-protect
+          (progn ,@body)
+       (foreign-free ,var))))
+
+;;;# Misc. Pointer Operations
+
+(deftype foreign-pointer ()
+  'si:foreign-data)
+
+(defun null-pointer ()
+  "Construct and return a null pointer."
+  (si:allocate-foreign-data :void 0))
+
+(defun null-pointer-p (ptr)
+  "Return true if PTR is a null pointer."
+  (si:null-pointer-p ptr))
+
+(defun inc-pointer (ptr offset)
+  "Return a pointer OFFSET bytes past PTR."
+  (ffi:make-pointer (+ (ffi:pointer-address ptr) offset) :void))
+
+(defun pointerp (ptr)
+  "Return true if PTR is a foreign pointer."
+  (typep ptr 'si:foreign-data))
+
+(defun pointer-eq (ptr1 ptr2)
+  "Return true if PTR1 and PTR2 point to the same address."
+  (= (ffi:pointer-address ptr1) (ffi:pointer-address ptr2)))
+
+(defun make-pointer (address)
+  "Return a pointer pointing to ADDRESS."
+  (ffi:make-pointer address :void))
+
+(defun pointer-address (ptr)
+  "Return the address pointed to by PTR."
+  (ffi:pointer-address ptr))
+
+;;;# Dereferencing
+
+(defun %mem-ref (ptr type &optional (offset 0))
+  "Dereference an object of TYPE at OFFSET bytes from PTR."
+  (let* ((type (cffi-type->ecl-type type))
+         (type-size (ffi:size-of-foreign-type type)))
+    (si:foreign-data-ref-elt
+     (si:foreign-data-recast ptr (+ offset type-size) :void) offset type)))
+
+(defun %mem-set (value ptr type &optional (offset 0))
+  "Set an object of TYPE at OFFSET bytes from PTR."
+  (let* ((type (cffi-type->ecl-type type))
+         (type-size (ffi:size-of-foreign-type type)))
+    (si:foreign-data-set-elt
+     (si:foreign-data-recast ptr (+ offset type-size) :void)
+     offset type value)))
+
+;;;# Type Operations
+
+(defconstant +translation-table+
+  '((:char            :byte            "char")
+    (:unsigned-char   :unsigned-byte   "unsigned char")
+    (:short           :short           "short")
+    (:unsigned-short  :unsigned-short  "unsigned short")
+    (:int             :int             "int")
+    (:unsigned-int    :unsigned-int    "unsigned int")
+    (:long            :long            "long")
+    (:unsigned-long   :unsigned-long   "unsigned long")
+    (:float           :float           "float")
+    (:double          :double          "double")
+    (:pointer         :pointer-void    "void*")
+    (:void            :void            "void")))
+
+(defun cffi-type->ecl-type (type-keyword)
+  "Convert a CFFI type keyword to an ECL type keyword."
+  (or (second (find type-keyword +translation-table+ :key #'first))
+      (error "~S is not a valid CFFI type" type-keyword)))
+
+(defun ecl-type->c-type (type-keyword)
+  "Convert a CFFI type keyword to an valid C type keyword."
+  (or (third (find type-keyword +translation-table+ :key #'second))
+      (error "~S is not a valid CFFI type" type-keyword)))
+
+(defun %foreign-type-size (type-keyword)
+  "Return the size in bytes of a foreign type."
+  (nth-value 0 (ffi:size-of-foreign-type
+                (cffi-type->ecl-type type-keyword))))
+
+(defun %foreign-type-alignment (type-keyword)
+  "Return the alignment in bytes of a foreign type."
+  (nth-value 1 (ffi:size-of-foreign-type
+                (cffi-type->ecl-type type-keyword))))
+
+;;;# Calling Foreign Functions
+
+(defconstant +ecl-inline-codes+ "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z")
+
+(defun produce-function-pointer-call (pointer types values return-type)
+  #-dffi
+  (if (stringp pointer)
+;;       `(ffi:c-inline ,values ,types ,return-type
+;;         ,(format nil "~A(~A)" pointer
+;;                  (subseq +ecl-inline-codes+ 0 (max 0 (1- (* (length values) 3)))))
+;;         :one-liner t :side-effects t)
+      (produce-function-pointer-call `(foreign-symbol-pointer ,pointer) types values return-type)
+      `(ffi:c-inline ,(list* pointer values) ,(list* :pointer-void types) ,return-type
+        ,(with-output-to-string (s)
+          (let ((types (mapcar #'ecl-type->c-type types)))
+            ;; On AMD64, the following code only works with the extra argument ",..."
+            ;; If this is not present, functions like sprintf do not work
+            (format s "((~A (*)(~@[~{~A,~}...~]))(#0))(~A)"
+                    (ecl-type->c-type return-type) types
+                    (subseq +ecl-inline-codes+ 3 (max 3 (+ 2 (* (length values) 3)))))))
+        :one-liner t :side-effects t))
+  #+dffi
+  (progn
+    (when (stringp pointer)
+      (setf pointer `(foreign-symbol-pointer ,pointer)))
+    `(si:call-cfun ,pointer ,return-type (list ,@types) (list ,@values))))
+
+
+(defun foreign-funcall-parse-args (args)
+  "Return three values, lists of arg types, values, and result type."
+  (let ((return-type :void))
+    (loop for (type arg) on args by #'cddr
+          if arg collect (cffi-type->ecl-type type) into types
+          and collect arg into values
+          else do (setf return-type (cffi-type->ecl-type type))
+          finally (return (values types values return-type)))))
+
+(defmacro %foreign-funcall (name args &key library calling-convention)
+  "Call a foreign function."
+  (declare (ignore library calling-convention))
+  (multiple-value-bind (types values return-type)
+      (foreign-funcall-parse-args args)
+    (produce-function-pointer-call name types values return-type)))
+
+(defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
+  "Funcall a pointer to a foreign function."
+  (declare (ignore calling-convention))
+  (multiple-value-bind (types values return-type)
+      (foreign-funcall-parse-args args)
+    (produce-function-pointer-call ptr types values return-type)))
+
+;;;# Foreign Libraries
+
+(defun %load-foreign-library (name path)
+  "Load a foreign library."
+  (declare (ignore name))
+  #-dffi (error "LOAD-FOREIGN-LIBRARY requires ECL's DFFI support. Use ~
+                 FFI:LOAD-FOREIGN-LIBRARY with a constant argument instead.")
+  #+dffi (si:load-foreign-module path))
+
+(defun %close-foreign-library (handle)
+  (error "%CLOSE-FOREIGN-LIBRARY unimplemented."))
+
+(defun native-namestring (pathname)
+  (namestring pathname))
+
+;;;# Callbacks
+
+;;; Create a package to contain the symbols for callback functions.
+;;; We want to redefine callbacks with the same symbol so the internal
+;;; data structures are reused.
+(defpackage #:cffi-callbacks
+  (:use))
+
+(defvar *callbacks* (make-hash-table))
+
+;;; Intern a symbol in the CFFI-CALLBACKS package used to name the
+;;; internal callback for NAME.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun intern-callback (name)
+    (intern (format nil "~A::~A" (package-name (symbol-package name))
+                    (symbol-name name))
+            '#:cffi-callbacks)))
+
+(defmacro %defcallback (name rettype arg-names arg-types body
+                        &key calling-convention)
+  (declare (ignore calling-convention))
+  (let ((cb-name (intern-callback name)))
+    `(progn
+       (ffi:defcallback (,cb-name :cdecl)
+           ,(cffi-type->ecl-type rettype)
+           ,(mapcar #'list arg-names
+                    (mapcar #'cffi-type->ecl-type arg-types))
+         ,body)
+       (setf (gethash ',name *callbacks*) ',cb-name))))
+
+(defun %callback (name)
+  (multiple-value-bind (symbol winp)
+      (gethash name *callbacks*)
+    (unless winp
+      (error "Undefined callback: ~S" name))
+    (ffi:callback symbol)))
+
+;;;# Foreign Globals
+
+(defun convert-external-name (name)
+  "Add an underscore to NAME if necessary for the ABI."
+  name)
+
+(defun %foreign-symbol-pointer (name library)
+  "Returns a pointer to a foreign symbol NAME."
+  (declare (ignore library))
+  (si:find-foreign-symbol (convert-external-name name)
+                          :default :pointer-void 0))
diff --git a/external/cffi.darcs/src/cffi-gcl.lisp b/external/cffi.darcs/src/cffi-gcl.lisp
new file mode 100644
index 0000000..fa13809
--- /dev/null
+++ b/external/cffi.darcs/src/cffi-gcl.lisp
@@ -0,0 +1,313 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-gcl.lisp --- CFFI-SYS implementation for GNU Common Lisp.
+;;;
+;;; Copyright (C) 2005-2006, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;; GCL specific notes:
+;;;
+;;; On ELF systems, a library can be loaded with the help of this:
+;;;   http://www.copyleft.de/lisp/gcl-elf-loader.html
+;;;
+;;; Another way is to link the library when creating a new image:
+;;;   (compiler::link nil "new_image" "" "-lfoo")
+;;;
+;;; As GCL's FFI is not dynamic, CFFI declarations will only work
+;;; after compiled and loaded.
+
+;;; *** this port is broken ***
+;;; gcl doesn't compile the rest of CFFI anyway..
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+  (:use #:common-lisp)
+  (:export
+   #:canonicalize-symbol-name-case
+   #:pointerp
+   #:%foreign-alloc
+   #:foreign-free
+   #:with-foreign-ptr
+   #:null-ptr
+   #:null-ptr-p
+   #:inc-ptr
+   #:%mem-ref
+   #:%mem-set
+   #:%foreign-funcall
+   #:%foreign-type-alignment
+   #:%foreign-type-size
+   #:%load-foreign-library
+   ;#:make-shareable-byte-vector
+   ;#:with-pointer-to-vector-data
+   #:foreign-var-ptr
+   #:make-callback))
+
+(in-package #:cffi-sys)
+
+;;;# Mis-*features*
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (pushnew :cffi/no-foreign-funcall *features*))
+
+;;; Symbol case.
+
+(defun canonicalize-symbol-name-case (name)
+  (declare (string name))
+  (string-upcase name))
+
+;;;# Allocation
+;;;
+;;; Functions and macros for allocating foreign memory on the stack
+;;; and on the heap.  The main CFFI package defines macros that wrap
+;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
+;;; usage when the memory has dynamic extent.
+
+(defentry %foreign-alloc (int) (int "malloc"))
+
+;(defun foreign-alloc (size)
+;  "Allocate SIZE bytes on the heap and return a pointer."
+;  (%foreign-alloc size))
+
+(defentry foreign-free (int) (void "free"))
+
+;(defun foreign-free (ptr)
+;  "Free a PTR allocated by FOREIGN-ALLOC."
+;  (%free ptr))
+
+(defmacro with-foreign-ptr ((var size &optional size-var) &body body)
+  "Bind VAR to SIZE bytes of foreign memory during BODY.  The
+pointer in VAR is invalid beyond the dynamic extent of BODY, and
+may be stack-allocated if supported by the implementation.  If
+SIZE-VAR is supplied, it will be bound to SIZE during BODY."
+  (unless size-var
+    (setf size-var (gensym "SIZE")))
+  `(let* ((,size-var ,size)
+          (,var (foreign-alloc ,size-var)))
+     (unwind-protect
+          (progn ,@body)
+       (foreign-free ,var))))
+
+;;;# Misc. Pointer Operations
+
+(defun pointerp (ptr)
+  "Return true if PTR is a foreign pointer."
+  (integerp ptr))
+
+(defun null-ptr ()
+  "Construct and return a null pointer."
+  0)
+
+(defun null-ptr-p (ptr)
+  "Return true if PTR is a null pointer."
+  (= ptr 0))
+
+(defun inc-ptr (ptr offset)
+  "Return a pointer OFFSET bytes past PTR."
+  (+ ptr offset))
+
+;;;# Shareable Vectors
+;;;
+;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
+;;; should be defined to perform a copy-in/copy-out if the Lisp
+;;; implementation can't do this.
+
+;(defun make-shareable-byte-vector (size)
+;  "Create a Lisp vector of SIZE bytes that can passed to
+;WITH-POINTER-TO-VECTOR-DATA."
+;  (make-array size :element-type '(unsigned-byte 8)))
+
+;(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+;  "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
+;  `(ccl:with-pointer-to-ivector (,ptr-var ,vector)
+;     ,@body))
+
+;;;# Dereferencing
+
+(defmacro define-mem-ref/set (type gcl-type &optional c-name)
+  (unless c-name
+    (setq c-name (substitute #\_ #\Space type)))
+  (let ((ref-fn (concatenate 'string "ref_" c-name))
+        (set-fn (concatenate 'string "set_" c-name)))
+    `(progn
+       ;; ref
+       (defcfun ,(format nil "~A ~A(~A *ptr)" type ref-fn type)
+           0 "return *ptr;")
+       (defentry ,(intern (string-upcase (substitute #\- #\_ ref-fn)))
+           (int) (,gcl-type ,ref-fn))
+       ;; set
+       (defcfun ,(format nil "void ~A(~A *ptr, ~A value)" set-fn type type)
+           0 "*ptr = value;")
+       (defentry ,(intern (string-upcase (substitute #\- #\_ set-fn)))
+           (int ,gcl-type) (void ,set-fn)))))
+
+(define-mem-ref/set "char" char)
+(define-mem-ref/set "unsigned char" char)
+(define-mem-ref/set "short" int)
+(define-mem-ref/set "unsigned short" int)
+(define-mem-ref/set "int" int)
+(define-mem-ref/set "unsigned int" int)
+(define-mem-ref/set "long" int)
+(define-mem-ref/set "unsigned long" int)
+(define-mem-ref/set "float" float)
+(define-mem-ref/set "double" double)
+(define-mem-ref/set "void *" int "ptr")
+
+(defun %mem-ref (ptr type &optional (offset 0))
+  "Dereference an object of TYPE at OFFSET bytes from PTR."
+  (unless (zerop offset)
+    (incf ptr offset))
+  (ecase type
+    (:char            (ref-char ptr))
+    (:unsigned-char   (ref-unsigned-char ptr))
+    (:short           (ref-short ptr))
+    (:unsigned-short  (ref-unsigned-short ptr))
+    (:int             (ref-int ptr))
+    (:unsigned-int    (ref-unsigned-int ptr))
+    (:long            (ref-long ptr))
+    (:unsigned-long   (ref-unsigned-long ptr))
+    (:float           (ref-float ptr))
+    (:double          (ref-double ptr))
+    (:pointer         (ref-ptr ptr))))
+
+(defun %mem-set (value ptr type &optional (offset 0))
+  (unless (zerop offset)
+    (incf ptr offset))
+  (ecase type
+    (:char            (set-char ptr value))
+    (:unsigned-char   (set-unsigned-char ptr value))
+    (:short           (set-short ptr value))
+    (:unsigned-short  (set-unsigned-short ptr value))
+    (:int             (set-int ptr value))
+    (:unsigned-int    (set-unsigned-int ptr value))
+    (:long            (set-long ptr value))
+    (:unsigned-long   (set-unsigned-long ptr value))
+    (:float           (set-float ptr value))
+    (:double          (set-double ptr value))
+    (:pointer         (set-ptr ptr value)))
+  value)
+
+;;;# Calling Foreign Functions
+
+;; TODO: figure out if these type conversions make any sense...
+(defun convert-foreign-type (type-keyword)
+  "Convert a CFFI type keyword to a GCL type."
+  (ecase type-keyword
+    (:char            'char)
+    (:unsigned-char   'char)
+    (:short           'int)
+    (:unsigned-short  'int)
+    (:int             'int)
+    (:unsigned-int    'int)
+    (:long            'int)
+    (:unsigned-long   'int)
+    (:float           'float)
+    (:double          'double)
+    (:pointer         'int)
+    (:void            'void)))
+
+(defparameter +cffi-types+
+  '(:char :unsigned-char :short :unsigned-short :int :unsigned-int
+    :long :unsigned-long :float :double :pointer))
+
+(defcfun "int size_of(int type)" 0
+  "switch (type) {
+     case 0:  return sizeof(char);
+     case 1:  return sizeof(unsigned char);
+     case 2:  return sizeof(short);
+     case 3:  return sizeof(unsigned short);
+     case 4:  return sizeof(int);
+     case 5:  return sizeof(unsigned int);
+     case 6:  return sizeof(long);
+     case 7:  return sizeof(unsigned long);
+     case 8:  return sizeof(float);
+     case 9:  return sizeof(double);
+     case 10: return sizeof(void *);
+     default: return -1;
+   }")
+
+(defentry size-of (int) (int "size_of"))
+
+;; TODO: all this is doable inside the defcfun; figure that out..
+(defun %foreign-type-size (type-keyword)
+  "Return the size in bytes of a foreign type."
+  (size-of (position type-keyword +cffi-types+)))
+
+(defcfun "int align_of(int type)" 0
+  "switch (type) {
+     case 0:  return __alignof__(char);
+     case 1:  return __alignof__(unsigned char);
+     case 2:  return __alignof__(short);
+     case 3:  return __alignof__(unsigned short);
+     case 4:  return __alignof__(int);
+     case 5:  return __alignof__(unsigned int);
+     case 6:  return __alignof__(long);
+     case 7:  return __alignof__(unsigned long);
+     case 8:  return __alignof__(float);
+     case 9:  return __alignof__(double);
+     case 10: return __alignof__(void *);
+     default: return -1;
+   }")
+
+(defentry align-of (int) (int "align_of"))
+
+;; TODO: like %foreign-type-size
+(defun %foreign-type-alignment (type-keyword)
+  "Return the alignment in bytes of a foreign type."
+  (align-of (position type-keyword +cffi-types+)))
+
+#+ignore
+(defun convert-external-name (name)
+  "Add an underscore to NAME if necessary for the ABI."
+  #+darwinppc-target (concatenate 'string "_" name)
+  #-darwinppc-target name)
+
+(defmacro %foreign-funcall (function-name &rest args)
+  "Perform a foreign function all, document it more later."
+  `(format t "~&;; Calling ~A with args ~S.~%" ,name ',args))
+
+(defun defcfun-helper-forms (name rettype args types)
+  "Return 2 values for DEFCFUN. A prelude form and a caller form."
+  (let ((ff-name (intern (format nil "%foreign-function/TildeA:~A" name))))
+    (values
+     `(defentry ,ff-name ,(mapcar #'convert-foreign-type types)
+        (,(convert-foreign-type rettype) ,name))
+     `(,ff-name ,@args))))
+
+;;;# Callbacks
+
+;;; XXX unimplemented
+(defmacro make-callback (name rettype arg-names arg-types body-form)
+  0)
+
+;;;# Loading Foreign Libraries
+
+(defun %load-foreign-library (name)
+  "_Won't_ load the foreign library NAME."
+  (declare (ignore name)))
+
+;;;# Foreign Globals
+
+;;; XXX unimplemented
+(defmacro foreign-var-ptr (name)
+  "Return a pointer pointing to the foreign symbol NAME."
+  0)
diff --git a/external/cffi.darcs/src/cffi-lispworks.lisp b/external/cffi.darcs/src/cffi-lispworks.lisp
new file mode 100644
index 0000000..0b0102c
--- /dev/null
+++ b/external/cffi.darcs/src/cffi-lispworks.lisp
@@ -0,0 +1,406 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-lispworks.lisp --- Lispworks CFFI-SYS implementation.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+  (:use #:cl #:cffi-utils)
+  (:export
+   #:canonicalize-symbol-name-case
+   #:foreign-pointer
+   #:pointerp
+   #:pointer-eq
+   #:null-pointer
+   #:null-pointer-p
+   #:inc-pointer
+   #:make-pointer
+   #:pointer-address
+   #:%foreign-alloc
+   #:foreign-free
+   #:with-foreign-pointer
+   #:%foreign-funcall
+   #:%foreign-funcall-pointer
+   #:%foreign-type-alignment
+   #:%foreign-type-size
+   #:%load-foreign-library
+   #:%close-foreign-library
+   #:native-namestring
+   #:%mem-ref
+   #:%mem-set
+   #:make-shareable-byte-vector
+   #:with-pointer-to-vector-data
+   #:%foreign-symbol-pointer
+   #:defcfun-helper-forms
+   #:%defcallback
+   #:%callback))
+
+(in-package #:cffi-sys)
+
+;;;# Features
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (mapc (lambda (feature) (pushnew feature *features*))
+        '(;; Backend mis-features.
+          cffi-features:no-long-long
+          ;; OS/CPU features.
+          #+darwin  cffi-features:darwin
+          #+unix    cffi-features:unix
+          #+win32   cffi-features:windows
+          #+harp::pc386   cffi-features:x86
+          #+harp::powerpc cffi-features:ppc32
+          )))
+
+;;; Symbol case.
+
+(defun canonicalize-symbol-name-case (name)
+  (declare (string name))
+  (string-upcase name))
+
+;;;# Basic Pointer Operations
+
+(deftype foreign-pointer ()
+  'fli::pointer)
+
+(defun pointerp (ptr)
+  "Return true if PTR is a foreign pointer."
+  (fli:pointerp ptr))
+
+(defun pointer-eq (ptr1 ptr2)
+  "Return true if PTR1 and PTR2 point to the same address."
+  (fli:pointer-eq ptr1 ptr2))
+
+;; We use FLI:MAKE-POINTER here instead of FLI:*NULL-POINTER* since old
+;; versions of Lispworks don't seem to have it.
+(defun null-pointer ()
+  "Return a null foreign pointer."
+  (fli:make-pointer :address 0 :type :void))
+
+(defun null-pointer-p (ptr)
+  "Return true if PTR is a null pointer."
+  (fli:null-pointer-p ptr))
+
+;; FLI:INCF-POINTER won't work on FLI pointers to :void so we
+;; increment "manually."
+(defun inc-pointer (ptr offset)
+  "Return a pointer OFFSET bytes past PTR."
+  (fli:make-pointer :type :void :address (+ (fli:pointer-address ptr) offset)))
+
+(defun make-pointer (address)
+  "Return a pointer pointing to ADDRESS."
+  (fli:make-pointer :type :void :address address))
+
+(defun pointer-address (ptr)
+  "Return the address pointed to by PTR."
+  (fli:pointer-address ptr))
+
+;;;# Allocation
+
+(defun %foreign-alloc (size)
+  "Allocate SIZE bytes of memory and return a pointer."
+  (fli:allocate-foreign-object :type :byte :nelems size))
+
+(defun foreign-free (ptr)
+  "Free a pointer PTR allocated by FOREIGN-ALLOC."
+  (fli:free-foreign-object ptr))
+
+(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
+  "Bind VAR to SIZE bytes of foreign memory during BODY.  Both the
+pointer in VAR and the memory it points to have dynamic extent and may
+be stack allocated if supported by the implementation."
+  (unless size-var
+    (setf size-var (gensym "SIZE")))
+  `(fli:with-dynamic-foreign-objects ()
+     (let* ((,size-var ,size)
+            (,var (fli:alloca :type :byte :nelems ,size-var)))
+       ,@body)))
+
+;;;# Shareable Vectors
+
+(defun make-shareable-byte-vector (size)
+  "Create a shareable byte vector."
+  (sys:in-static-area
+    (make-array size :element-type '(unsigned-byte 8))))
+
+(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+  "Bind PTR-VAR to a pointer at the data in VECTOR."
+  `(fli:with-dynamic-lisp-array-pointer (,ptr-var ,vector)
+     ,@body))
+
+;;;# Dereferencing
+
+(defun convert-foreign-type (cffi-type)
+  "Convert a CFFI type keyword to an FLI type."
+  (ecase cffi-type
+    (:char            :byte)
+    (:unsigned-char   '(:unsigned :byte))
+    (:short           :short)
+    (:unsigned-short  '(:unsigned :short))
+    (:int             :int)
+    (:unsigned-int    '(:unsigned :int))
+    (:long            :long)
+    (:unsigned-long   '(:unsigned :long))
+    (:float           :float)
+    (:double          :double)
+    (:pointer         :pointer)
+    (:void            :void)))
+
+;;; Convert a CFFI type keyword to a symbol suitable for passing to
+;;; FLI:FOREIGN-TYPED-AREF.
+#+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
+(defun convert-foreign-typed-aref-type (cffi-type)
+  (ecase cffi-type
+    ((:char :short :int :long)
+     `(signed-byte ,(* 8 (%foreign-type-size cffi-type))))
+    ((:unsigned-char :unsigned-short :unsigned-int :unsigned-long)
+     `(unsigned-byte ,(* 8 (%foreign-type-size cffi-type))))
+    (:float 'single-float)
+    (:double 'double-float)))
+
+(defun %mem-ref (ptr type &optional (offset 0))
+  "Dereference an object of type TYPE OFFSET bytes from PTR."
+  (unless (zerop offset)
+    (setf ptr (inc-pointer ptr offset)))
+  (fli:dereference ptr :type (convert-foreign-type type)))
+
+;;; In LispWorks versions where FLI:FOREIGN-TYPED-AREF is fbound, use
+;;; it instead of FLI:DEREFERENCE in the optimizer for %MEM-REF.
+#+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
+(define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0))
+  (if (constantp type)
+      (let ((type (eval type)))
+        (if (eql type :pointer)
+            (let ((fli-type (convert-foreign-type type))
+                  (ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off))))
+              `(fli:dereference ,ptr-form :type ',fli-type))
+            (let ((lisp-type (convert-foreign-typed-aref-type type)))
+              `(locally
+                   (declare (optimize (speed 3) (safety 0)))
+                 (fli:foreign-typed-aref ',lisp-type ,ptr (the fixnum ,off))))))
+      form))
+
+;;; Open-code the call to FLI:DEREFERENCE when TYPE is constant at
+;;; macroexpansion time, when FLI:FOREIGN-TYPED-AREF is not available.
+#-#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
+(define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0))
+  (if (constantp type)
+      (let ((ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off)))
+            (type (convert-foreign-type (eval type))))
+        `(fli:dereference ,ptr-form :type ',type))
+      form))
+
+(defun %mem-set (value ptr type &optional (offset 0))
+  "Set the object of TYPE at OFFSET bytes from PTR."
+  (unless (zerop offset)
+    (setf ptr (inc-pointer ptr offset)))
+  (setf (fli:dereference ptr :type (convert-foreign-type type)) value))
+
+;;; In LispWorks versions where FLI:FOREIGN-TYPED-AREF is fbound, use
+;;; it instead of FLI:DEREFERENCE in the optimizer for %MEM-SET.
+#+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
+(define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0))
+  (if (constantp type)
+      (once-only (val)
+        (let ((type (eval type)))
+          (if (eql type :pointer)
+              (let ((fli-type (convert-foreign-type type))
+                    (ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off))))
+                `(setf (fli:dereference ,ptr-form :type ',fli-type) ,val))
+              (let ((lisp-type (convert-foreign-typed-aref-type type)))
+                `(locally
+                     (declare (optimize (speed 3) (safety 0)))
+                   (setf (fli:foreign-typed-aref ',lisp-type ,ptr
+                                                 (the fixnum ,off))
+                         ,val))))))
+      form))
+
+;;; Open-code the call to (SETF FLI:DEREFERENCE) when TYPE is constant
+;;; at macroexpansion time.
+#-#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
+(define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0))
+  (if (constantp type)
+      (once-only (val)
+        (let ((ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off)))
+              (type (convert-foreign-type (eval type))))
+          `(setf (fli:dereference ,ptr-form :type ',type) ,val)))
+      form))
+
+;;;# Foreign Type Operations
+
+(defun %foreign-type-size (type)
+  "Return the size in bytes of a foreign type."
+  (fli:size-of (convert-foreign-type type)))
+
+(defun %foreign-type-alignment (type)
+  "Return the structure alignment in bytes of foreign type."
+  #+(and darwin harp::powerpc)
+  (when (eq type :double)
+    (return-from %foreign-type-alignment 8))
+  ;; Override not necessary for the remaining types...
+  (fli:align-of (convert-foreign-type type)))
+
+;;;# Calling Foreign Functions
+
+(defvar *foreign-funcallable-cache* (make-hash-table :test 'equal)
+  "Caches foreign funcallables created by %FOREIGN-FUNCALL or
+%FOREIGN-FUNCALL-POINTER.  We only need to have one per each
+signature.")
+
+(defun foreign-funcall-type-and-args (args)
+  "Returns a list of types, list of args and return type."
+  (let ((return-type :void))
+    (loop for (type arg) on args by #'cddr
+          if arg collect (convert-foreign-type type) into types
+          and collect arg into fargs
+          else do (setf return-type (convert-foreign-type type))
+          finally (return (values types fargs return-type)))))
+
+(defun create-foreign-funcallable (types rettype cconv)
+  "Creates a foreign funcallable for the signature TYPES -> RETTYPE."
+  (format t "~&Creating foreign funcallable for signature ~S -> ~S~%"
+          types rettype)
+  ;; yes, ugly, this most likely wants to be a top-level form...
+  (let ((internal-name (gensym)))
+    (funcall
+     (compile nil
+              `(lambda ()
+                 (fli:define-foreign-funcallable ,internal-name
+                     ,(loop for type in types
+                            collect (list (gensym) type))
+                   :result-type ,rettype
+                   :language :ansi-c
+                   ;; avoid warning about cdecl not being supported on mac
+                   #-mac ,@(list :calling-convention cconv)))))
+    internal-name))
+
+(defun get-foreign-funcallable (types rettype cconv)
+  "Returns a foreign funcallable for the signature TYPES -> RETTYPE -
+either from the cache or newly created."
+  (let ((signature (cons rettype types)))
+    (or (gethash signature *foreign-funcallable-cache*)
+        ;; (SETF GETHASH) is supposed to be thread-safe
+        (setf (gethash signature *foreign-funcallable-cache*)
+              (create-foreign-funcallable types rettype cconv)))))
+
+(defmacro %%foreign-funcall (foreign-function args cconv)
+  "Does the actual work for %FOREIGN-FUNCALL-POINTER and %FOREIGN-FUNCALL.
+Checks if a foreign funcallable which fits ARGS already exists and creates
+and caches it if necessary.  Finally calls it."
+  (multiple-value-bind (types fargs rettype)
+      (foreign-funcall-type-and-args args)
+    `(funcall (load-time-value
+               (get-foreign-funcallable ',types ',rettype ',cconv))
+              ,foreign-function ,@fargs)))
+
+(defmacro %foreign-funcall (name args &key library calling-convention)
+  "Calls a foreign function named NAME passing arguments ARGS."
+  `(%%foreign-funcall
+    (fli:make-pointer :symbol-name ,name
+                      :module ',(if (eq library :default) nil library))
+    ,args ,calling-convention))
+
+(defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
+  "Calls a foreign function pointed at by PTR passing arguments ARGS."
+  `(%%foreign-funcall ,ptr ,args ,calling-convention))
+
+(defun defcfun-helper-forms (name lisp-name rettype args types options)
+  "Return 2 values for DEFCFUN. A prelude form and a caller form."
+  (let ((ff-name (intern (format nil "%cffi-foreign-function/~A"  lisp-name))))
+    (values
+     `(fli:define-foreign-function (,ff-name ,name :source)
+          ,(mapcar (lambda (ty) (list (gensym) (convert-foreign-type ty)))
+                   types)
+        :result-type ,(convert-foreign-type rettype)
+        :language :ansi-c
+        :module ',(let ((lib (getf options :library)))
+                    (if (eq lib :default) nil lib))
+        ;; avoid warning about cdecl not being supported on mac platforms
+        #-mac ,@(list :calling-convention (getf options :calling-convention)))
+     `(,ff-name ,@args))))
+
+;;;# Callbacks
+
+(defvar *callbacks* (make-hash-table))
+
+;;; Create a package to contain the symbols for callback functions.  We
+;;; want to redefine callbacks with the same symbol so the internal data
+;;; structures are reused.
+(defpackage #:cffi-callbacks
+  (:use))
+
+;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
+;;; callback for NAME.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun intern-callback (name)
+    (intern (format nil "~A::~A" (package-name (symbol-package name))
+                    (symbol-name name))
+            '#:cffi-callbacks)))
+
+(defmacro %defcallback (name rettype arg-names arg-types body
+                        &key calling-convention)
+  (let ((cb-name (intern-callback name)))
+    `(progn
+       (fli:define-foreign-callable
+           (,cb-name :encode :lisp
+                     :result-type ,(convert-foreign-type rettype)
+                     :calling-convention ,calling-convention
+                     :language :ansi-c
+                     :no-check nil)
+           ,(mapcar (lambda (sym type)
+                      (list sym (convert-foreign-type type)))
+                    arg-names arg-types)
+         ,body)
+       (setf (gethash ',name *callbacks*) ',cb-name))))
+
+(defun %callback (name)
+  (multiple-value-bind (symbol winp)
+      (gethash name *callbacks*)
+    (unless winp
+      (error "Undefined callback: ~S" name))
+    (fli:make-pointer :symbol-name symbol :module :callbacks)))
+
+;;;# Loading Foreign Libraries
+
+(defun %load-foreign-library (name path)
+  "Load the foreign library NAME."
+  (fli:register-module (or name path) :connection-style :immediate
+                       :real-name path))
+
+(defun %close-foreign-library (name)
+  "Close the foreign library NAME."
+  (fli:disconnect-module name :remove t))
+
+(defun native-namestring (pathname)
+  (namestring pathname))
+
+;;;# Foreign Globals
+
+(defun %foreign-symbol-pointer (name library)
+  "Returns a pointer to a foreign symbol NAME."
+  (values
+   (ignore-errors
+     (fli:make-pointer :symbol-name name :type :void
+                       :module (if (eq library :default) nil library)))))
diff --git a/external/cffi.darcs/src/cffi-openmcl.lisp b/external/cffi.darcs/src/cffi-openmcl.lisp
new file mode 100644
index 0000000..1671004
--- /dev/null
+++ b/external/cffi.darcs/src/cffi-openmcl.lisp
@@ -0,0 +1,315 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-openmcl.lisp --- CFFI-SYS implementation for OpenMCL.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+  (:use #:common-lisp #:ccl #:cffi-utils)
+  (:export
+   #:canonicalize-symbol-name-case
+   #:foreign-pointer
+   #:pointerp  ; ccl:pointerp
+   #:pointer-eq
+   #:%foreign-alloc
+   #:foreign-free
+   #:with-foreign-pointer
+   #:null-pointer
+   #:null-pointer-p
+   #:inc-pointer
+   #:make-pointer
+   #:pointer-address
+   #:%mem-ref
+   #:%mem-set
+   #:%foreign-funcall
+   #:%foreign-funcall-pointer
+   #:%foreign-type-alignment
+   #:%foreign-type-size
+   #:%load-foreign-library
+   #:%close-foreign-library
+   #:native-namestring
+   #:make-shareable-byte-vector
+   #:with-pointer-to-vector-data
+   #:%foreign-symbol-pointer
+   #:%defcallback
+   #:%callback))
+
+(in-package #:cffi-sys)
+
+;;;# Features
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (mapc (lambda (feature) (pushnew feature *features*))
+        '(;; OS/CPU features.
+          #+darwin-target cffi-features:darwin
+          #+unix          cffi-features:unix
+          #+ppc32-target  cffi-features:ppc32
+          #+x8664-target  cffi-features:x86-64
+          ;; Misfeatures.
+          cffi-features:flat-namespace
+          )))
+
+;;; Symbol case.
+
+(defun canonicalize-symbol-name-case (name)
+  (declare (string name))
+  (string-upcase name))
+
+;;;# Allocation
+;;;
+;;; Functions and macros for allocating foreign memory on the stack
+;;; and on the heap.  The main CFFI package defines macros that wrap
+;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
+;;; usage when the memory has dynamic extent.
+
+(defun %foreign-alloc (size)
+  "Allocate SIZE bytes on the heap and return a pointer."
+  (ccl::malloc size))
+
+(defun foreign-free (ptr)
+  "Free a PTR allocated by FOREIGN-ALLOC."
+  ;; TODO: Should we make this a dead macptr?
+  (ccl::free ptr))
+
+(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
+  "Bind VAR to SIZE bytes of foreign memory during BODY.  The
+pointer in VAR is invalid beyond the dynamic extent of BODY, and
+may be stack-allocated if supported by the implementation.  If
+SIZE-VAR is supplied, it will be bound to SIZE during BODY."
+  (unless size-var
+    (setf size-var (gensym "SIZE")))
+  `(let ((,size-var ,size))
+     (%stack-block ((,var ,size-var))
+       ,@body)))
+
+;;;# Misc. Pointer Operations
+
+(deftype foreign-pointer ()
+  'ccl:macptr)
+
+(defun null-pointer ()
+  "Construct and return a null pointer."
+  (ccl:%null-ptr))
+
+(defun null-pointer-p (ptr)
+  "Return true if PTR is a null pointer."
+  (ccl:%null-ptr-p ptr))
+
+(defun inc-pointer (ptr offset)
+  "Return a pointer OFFSET bytes past PTR."
+  (ccl:%inc-ptr ptr offset))
+
+(defun pointer-eq (ptr1 ptr2)
+  "Return true if PTR1 and PTR2 point to the same address."
+  (ccl:%ptr-eql ptr1 ptr2))
+
+(defun make-pointer (address)
+  "Return a pointer pointing to ADDRESS."
+  (ccl:%int-to-ptr address))
+
+(defun pointer-address (ptr)
+  "Return the address pointed to by PTR."
+  (ccl:%ptr-to-int ptr))
+
+;;;# Shareable Vectors
+;;;
+;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
+;;; should be defined to perform a copy-in/copy-out if the Lisp
+;;; implementation can't do this.
+
+(defun make-shareable-byte-vector (size)
+  "Create a Lisp vector of SIZE bytes that can passed to
+WITH-POINTER-TO-VECTOR-DATA."
+  (make-array size :element-type '(unsigned-byte 8)))
+
+(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+  "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
+  `(ccl:with-pointer-to-ivector (,ptr-var ,vector)
+     ,@body))
+
+;;;# Dereferencing
+
+;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
+;;; macros that optimize the case where the type keyword is constant
+;;; at compile-time.
+(defmacro define-mem-accessors (&body pairs)
+  `(progn
+    (defun %mem-ref (ptr type &optional (offset 0))
+      (ecase type
+        ,@(loop for (keyword fn) in pairs
+                collect `(,keyword (,fn ptr offset)))))
+    (defun %mem-set (value ptr type &optional (offset 0))
+      (ecase type
+        ,@(loop for (keyword fn) in pairs
+                collect `(,keyword (setf (,fn ptr offset) value)))))
+    (define-compiler-macro %mem-ref
+        (&whole form ptr type &optional (offset 0))
+      (if (constantp type)
+          (ecase (eval type)
+            ,@(loop for (keyword fn) in pairs
+                    collect `(,keyword `(,',fn ,ptr ,offset))))
+          form))
+    (define-compiler-macro %mem-set
+        (&whole form value ptr type &optional (offset 0))
+      (if (constantp type)
+          (once-only (value)
+            (ecase (eval type)
+              ,@(loop for (keyword fn) in pairs
+                      collect `(,keyword `(setf (,',fn ,ptr ,offset)
+                                                ,value)))))
+          form))))
+
+(define-mem-accessors
+  (:char %get-signed-byte)
+  (:unsigned-char %get-unsigned-byte)
+  (:short %get-signed-word)
+  (:unsigned-short %get-unsigned-word)
+  (:int %get-signed-long)
+  (:unsigned-int %get-unsigned-long)
+  #+32-bit-target (:long %get-signed-long)
+  #+64-bit-target (:long ccl::%%get-signed-longlong)
+  #+32-bit-target (:unsigned-long %get-unsigned-long)
+  #+64-bit-target (:unsigned-long ccl::%%get-unsigned-longlong)
+  (:long-long ccl::%get-signed-long-long)
+  (:unsigned-long-long ccl::%get-unsigned-long-long)
+  (:float %get-single-float)
+  (:double %get-double-float)
+  (:pointer %get-ptr))
+
+;;;# Calling Foreign Functions
+
+(defun convert-foreign-type (type-keyword)
+  "Convert a CFFI type keyword to an OpenMCL type."
+  (ecase type-keyword
+    (:char                :signed-byte)
+    (:unsigned-char       :unsigned-byte)
+    (:short               :signed-short)
+    (:unsigned-short      :unsigned-short)
+    (:int                 :signed-int)
+    (:unsigned-int        :unsigned-int)
+    (:long                :signed-long)
+    (:unsigned-long       :unsigned-long)
+    (:long-long           :signed-doubleword)
+    (:unsigned-long-long  :unsigned-doubleword)
+    (:float               :single-float)
+    (:double              :double-float)
+    (:pointer             :address)
+    (:void                :void)))
+
+(defun %foreign-type-size (type-keyword)
+  "Return the size in bytes of a foreign type."
+  (/ (ccl::foreign-type-bits
+      (ccl::parse-foreign-type
+       (convert-foreign-type type-keyword))) 8))
+
+;; There be dragons here.  See the following thread for details:
+;; http://clozure.com/pipermail/openmcl-devel/2005-June/002777.html
+(defun %foreign-type-alignment (type-keyword)
+  "Return the alignment in bytes of a foreign type."
+  (/ (ccl::foreign-type-alignment
+      (ccl::parse-foreign-type
+       (convert-foreign-type type-keyword))) 8))
+
+(defun convert-foreign-funcall-types (args)
+  "Convert foreign types for a call to FOREIGN-FUNCALL."
+  (loop for (type arg) on args by #'cddr
+        collect (convert-foreign-type type)
+        if arg collect arg))
+
+(defun convert-external-name (name)
+  "Add an underscore to NAME if necessary for the ABI."
+  #+darwinppc-target (concatenate 'string "_" name)
+  #-darwinppc-target name)
+
+(defmacro %foreign-funcall (function-name args &key library calling-convention)
+  "Perform a foreign function call, document it more later."
+  (declare (ignore library calling-convention))
+  `(external-call
+    ,(convert-external-name function-name)
+    ,@(convert-foreign-funcall-types args)))
+
+(defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
+  (declare (ignore calling-convention))
+  `(ff-call ,ptr ,@(convert-foreign-funcall-types args)))
+
+;;;# Callbacks
+
+;;; The *CALLBACKS* hash table maps CFFI callback names to OpenMCL "macptr"
+;;; entry points.  It is safe to store the pointers directly because
+;;; OpenMCL will update the address of these pointers when a saved image
+;;; is loaded (see CCL::RESTORE-PASCAL-FUNCTIONS).
+(defvar *callbacks* (make-hash-table))
+
+;;; Create a package to contain the symbols for callback functions.  We
+;;; want to redefine callbacks with the same symbol so the internal data
+;;; structures are reused.
+(defpackage #:cffi-callbacks
+  (:use))
+
+;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
+;;; callback for NAME.
+(defun intern-callback (name)
+  (intern (format nil "~A::~A" (package-name (symbol-package name))
+                  (symbol-name name))
+          '#:cffi-callbacks))
+
+(defmacro %defcallback (name rettype arg-names arg-types body
+                        &key calling-convention)
+  (declare (ignore calling-convention))
+  (let ((cb-name (intern-callback name)))
+    `(progn
+       (defcallback ,cb-name
+           (,@(mapcan (lambda (sym type)
+                        (list (convert-foreign-type type) sym))
+                      arg-names arg-types)
+            ,(convert-foreign-type rettype))
+         ,body)
+       (setf (gethash ',name *callbacks*) (symbol-value ',cb-name)))))
+
+(defun %callback (name)
+  (or (gethash name *callbacks*)
+      (error "Undefined callback: ~S" name)))
+
+;;;# Loading Foreign Libraries
+
+(defun %load-foreign-library (name path)
+  "Load the foreign library NAME."
+  (declare (ignore name))
+  (open-shared-library path))
+
+(defun %close-foreign-library (name)
+  "Close the foreign library NAME."
+  (close-shared-library name)) ; :completely t ?
+
+(defun native-namestring (pathname)
+  (ccl::native-translated-namestring pathname))
+
+;;;# Foreign Globals
+
+(defun %foreign-symbol-pointer (name library)
+  "Returns a pointer to a foreign symbol NAME."
+  (declare (ignore library))
+  (foreign-symbol-address (convert-external-name name)))
diff --git a/external/cffi.darcs/src/cffi-sbcl.lisp b/external/cffi.darcs/src/cffi-sbcl.lisp
new file mode 100644
index 0000000..7c93200
--- /dev/null
+++ b/external/cffi.darcs/src/cffi-sbcl.lisp
@@ -0,0 +1,354 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-sbcl.lisp --- CFFI-SYS implementation for SBCL.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+  (:use #:common-lisp #:sb-alien #:cffi-utils)
+  (:export
+   #:canonicalize-symbol-name-case
+   #:foreign-pointer
+   #:pointerp
+   #:pointer-eq
+   #:null-pointer
+   #:null-pointer-p
+   #:inc-pointer
+   #:make-pointer
+   #:pointer-address
+   #:%foreign-alloc
+   #:foreign-free
+   #:with-foreign-pointer
+   #:%foreign-funcall
+   #:%foreign-funcall-pointer
+   #:%foreign-type-alignment
+   #:%foreign-type-size
+   #:%load-foreign-library
+   #:%close-foreign-library
+   #:native-namestring
+   #:%mem-ref
+   #:%mem-set
+   #:make-shareable-byte-vector
+   #:with-pointer-to-vector-data
+   #:%foreign-symbol-pointer
+   #:%defcallback
+   #:%callback))
+
+(in-package #:cffi-sys)
+
+;;;# Features
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (mapc (lambda (feature) (pushnew feature *features*))
+        '(;; OS/CPU features.
+          #+darwin  cffi-features:darwin
+          #+(and unix (not win32)) cffi-features:unix
+          #+win32   cffi-features:windows
+          #+x86     cffi-features:x86
+          #+x86-64  cffi-features:x86-64
+          #+(and ppc (not ppc64)) cffi-features:ppc32
+          ;; Misfeatures
+          cffi-features:flat-namespace
+          )))
+
+;;; Symbol case.
+
+(declaim (inline canonicalize-symbol-name-case))
+(defun canonicalize-symbol-name-case (name)
+  (declare (string name))
+  (string-upcase name))
+
+;;;# Basic Pointer Operations
+
+(deftype foreign-pointer ()
+  'sb-sys:system-area-pointer)
+
+(declaim (inline pointerp))
+(defun pointerp (ptr)
+  "Return true if PTR is a foreign pointer."
+  (sb-sys:system-area-pointer-p ptr))
+
+(declaim (inline pointer-eq))
+(defun pointer-eq (ptr1 ptr2)
+  "Return true if PTR1 and PTR2 point to the same address."
+  (declare (type system-area-pointer ptr1 ptr2))
+  (sb-sys:sap= ptr1 ptr2))
+
+(declaim (inline null-pointer))
+(defun null-pointer ()
+  "Construct and return a null pointer."
+  (sb-sys:int-sap 0))
+
+(declaim (inline null-pointer-p))
+(defun null-pointer-p (ptr)
+  "Return true if PTR is a null pointer."
+  (declare (type system-area-pointer ptr))
+  (zerop (sb-sys:sap-int ptr)))
+
+(declaim (inline inc-pointer))
+(defun inc-pointer (ptr offset)
+  "Return a pointer pointing OFFSET bytes past PTR."
+  (declare (type system-area-pointer ptr)
+           (type integer offset))
+  (sb-sys:sap+ ptr offset))
+
+(declaim (inline make-pointer))
+(defun make-pointer (address)
+  "Return a pointer pointing to ADDRESS."
+  ;; (declare (type (unsigned-byte 32) address))
+  (sb-sys:int-sap address))
+
+(declaim (inline pointer-address))
+(defun pointer-address (ptr)
+  "Return the address pointed to by PTR."
+  (declare (type system-area-pointer ptr))
+  (sb-sys:sap-int ptr))
+
+;;;# Allocation
+;;;
+;;; Functions and macros for allocating foreign memory on the stack
+;;; and on the heap.  The main CFFI package defines macros that wrap
+;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
+;;; when the memory has dynamic extent.
+
+(declaim (inline %foreign-alloc))
+(defun %foreign-alloc (size)
+  "Allocate SIZE bytes on the heap and return a pointer."
+  ;; (declare (type (unsigned-byte 32) size))
+  (alien-sap (make-alien (unsigned 8) size)))
+
+(declaim (inline foreign-free))
+(defun foreign-free (ptr)
+  "Free a PTR allocated by FOREIGN-ALLOC."
+  (declare (type system-area-pointer ptr))
+  (free-alien (sap-alien ptr (* (unsigned 8)))))
+
+(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
+  "Bind VAR to SIZE bytes of foreign memory during BODY.  The
+pointer in VAR is invalid beyond the dynamic extent of BODY, and
+may be stack-allocated if supported by the implementation.  If
+SIZE-VAR is supplied, it will be bound to SIZE during BODY."
+  (unless size-var
+    (setf size-var (gensym "SIZE")))
+  ;; If the size is constant we can stack-allocate.
+  (if (constantp size)
+      (let ((alien-var (gensym "ALIEN")))
+        `(with-alien ((,alien-var (array (unsigned 8) ,(eval size))))
+           (let ((,size-var ,(eval size))
+                 (,var (alien-sap ,alien-var)))
+             (declare (ignorable ,size-var))
+             ,@body)))
+      `(let* ((,size-var ,size)
+              (,var (%foreign-alloc ,size-var)))
+         (unwind-protect
+              (progn ,@body)
+           (foreign-free ,var)))))
+
+;;;# Shareable Vectors
+;;;
+;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
+;;; should be defined to perform a copy-in/copy-out if the Lisp
+;;; implementation can't do this.
+
+(declaim (inline make-shareable-byte-vector))
+(defun make-shareable-byte-vector (size)
+  "Create a Lisp vector of SIZE bytes can passed to
+WITH-POINTER-TO-VECTOR-DATA."
+  ; (declare (type sb-int:index size))
+  (make-array size :element-type '(unsigned-byte 8)))
+
+(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+  "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
+  (let ((vector-var (gensym "VECTOR")))
+    `(let ((,vector-var ,vector))
+       (declare (type (sb-kernel:simple-unboxed-array (*)) ,vector-var))
+       (sb-sys:with-pinned-objects (,vector-var)
+         (let ((,ptr-var (sb-sys:vector-sap ,vector-var)))
+           ,@body)))))
+
+;;;# Dereferencing
+
+;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
+;;; macros that optimize the case where the type keyword is constant
+;;; at compile-time.
+(defmacro define-mem-accessors (&body pairs)
+  `(progn
+     (defun %mem-ref (ptr type &optional (offset 0))
+       (ecase type
+         ,@(loop for (keyword fn) in pairs
+                 collect `(,keyword (,fn ptr offset)))))
+     (defun %mem-set (value ptr type &optional (offset 0))
+       (ecase type
+         ,@(loop for (keyword fn) in pairs
+                 collect `(,keyword (setf (,fn ptr offset) value)))))
+     (define-compiler-macro %mem-ref
+         (&whole form ptr type &optional (offset 0))
+       (if (constantp type)
+           (ecase (eval type)
+             ,@(loop for (keyword fn) in pairs
+                     collect `(,keyword `(,',fn ,ptr ,offset))))
+           form))
+     (define-compiler-macro %mem-set
+         (&whole form value ptr type &optional (offset 0))
+       (if (constantp type)
+           (once-only (value)
+             (ecase (eval type)
+               ,@(loop for (keyword fn) in pairs
+                       collect `(,keyword `(setf (,',fn ,ptr ,offset)
+                                                 ,value)))))
+           form))))
+
+(define-mem-accessors
+  (:char sb-sys:signed-sap-ref-8)
+  (:unsigned-char sb-sys:sap-ref-8)
+  (:short sb-sys:signed-sap-ref-16)
+  (:unsigned-short sb-sys:sap-ref-16)
+  (:int sb-sys:signed-sap-ref-32)
+  (:unsigned-int sb-sys:sap-ref-32)
+  (:long sb-sys:signed-sap-ref-word)
+  (:unsigned-long sb-sys:sap-ref-word)
+  (:long-long sb-sys:signed-sap-ref-64)
+  (:unsigned-long-long sb-sys:sap-ref-64)
+  (:float sb-sys:sap-ref-single)
+  (:double sb-sys:sap-ref-double)
+  (:pointer sb-sys:sap-ref-sap))
+
+;;;# Calling Foreign Functions
+
+(defun convert-foreign-type (type-keyword)
+  "Convert a CFFI type keyword to an SB-ALIEN type."
+  (ecase type-keyword
+    (:char               'char)
+    (:unsigned-char      'unsigned-char)
+    (:short              'short)
+    (:unsigned-short     'unsigned-short)
+    (:int                'int)
+    (:unsigned-int       'unsigned-int)
+    (:long               'long)
+    (:unsigned-long      'unsigned-long)
+    (:long-long          'long-long)
+    (:unsigned-long-long 'unsigned-long-long)
+    (:float              'single-float)
+    (:double             'double-float)
+    (:pointer            'system-area-pointer)
+    (:void               'void)))
+
+(defun %foreign-type-size (type-keyword)
+  "Return the size in bytes of a foreign type."
+  (/ (sb-alien-internals:alien-type-bits
+      (sb-alien-internals:parse-alien-type
+       (convert-foreign-type type-keyword) nil)) 8))
+
+(defun %foreign-type-alignment (type-keyword)
+  "Return the alignment in bytes of a foreign type."
+  #+(and darwin ppc (not ppc64))
+  (case type-keyword
+    ((:double :long-long :unsigned-long-long)
+     (return-from %foreign-type-alignment 8)))
+  ;; No override necessary for other types...
+  (/ (sb-alien-internals:alien-type-alignment
+      (sb-alien-internals:parse-alien-type
+       (convert-foreign-type type-keyword) nil)) 8))
+
+(defun foreign-funcall-type-and-args (args)
+  "Return an SB-ALIEN function type for ARGS."
+  (let ((return-type 'void))
+    (loop for (type arg) on args by #'cddr
+          if arg collect (convert-foreign-type type) into types
+          and collect arg into fargs
+          else do (setf return-type (convert-foreign-type type))
+          finally (return (values types fargs return-type)))))
+
+(defmacro %%foreign-funcall (name types fargs rettype)
+  "Internal guts of %FOREIGN-FUNCALL."
+  `(alien-funcall
+    (extern-alien ,name (function ,rettype ,@types))
+    ,@fargs))
+
+(defmacro %foreign-funcall (name args &key library calling-convention)
+  "Perform a foreign function call, document it more later."
+  (declare (ignore library calling-convention))
+  (multiple-value-bind (types fargs rettype)
+      (foreign-funcall-type-and-args args)
+    `(%%foreign-funcall ,name ,types ,fargs ,rettype)))
+
+(defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
+  "Funcall a pointer to a foreign function."
+  (declare (ignore calling-convention))
+  (multiple-value-bind (types fargs rettype)
+      (foreign-funcall-type-and-args args)
+    (with-unique-names (function)
+      `(with-alien ((,function (* (function ,rettype ,@types)) ,ptr))
+         (alien-funcall ,function ,@fargs)))))
+
+;;;# Callbacks
+
+;;; The *CALLBACKS* hash table contains a direct mapping of CFFI
+;;; callback names to SYSTEM-AREA-POINTERs obtained by ALIEN-LAMBDA.
+;;; SBCL will maintain the addresses of the callbacks across saved
+;;; images, so it is safe to store the pointers directly.
+(defvar *callbacks* (make-hash-table))
+
+(defmacro %defcallback (name rettype arg-names arg-types body
+                        &key calling-convention)
+  (declare (ignore calling-convention))
+  `(setf (gethash ',name *callbacks*)
+         (alien-sap
+          (sb-alien::alien-lambda ,(convert-foreign-type rettype)
+              ,(mapcar (lambda (sym type)
+                         (list sym (convert-foreign-type type)))
+                       arg-names arg-types)
+            ,body))))
+
+(defun %callback (name)
+  (or (gethash name *callbacks*)
+      (error "Undefined callback: ~S" name)))
+
+;;;# Loading and Closing Foreign Libraries
+
+(declaim (inline %load-foreign-library))
+(defun %load-foreign-library (name path)
+  "Load a foreign library."
+  (declare (ignore name))
+  (load-shared-object path))
+
+(defun %close-foreign-library (handle)
+  "Closes a foreign library."
+  (sb-alien::dlclose-or-lose
+   (find (sb-ext:native-namestring handle) sb-alien::*shared-objects*
+         :key #'sb-alien::shared-object-file
+         :test #'string=)))
+
+(defun native-namestring (pathname)
+  (sb-ext:native-namestring pathname))
+
+;;;# Foreign Globals
+
+(defun %foreign-symbol-pointer (name library)
+  "Returns a pointer to a foreign symbol NAME."
+  (declare (ignore library))
+  (let-when (address (sb-sys:find-foreign-symbol-address name))
+    (sb-sys:int-sap address)))
diff --git a/external/cffi.darcs/src/cffi-scl.lisp b/external/cffi.darcs/src/cffi-scl.lisp
new file mode 100644
index 0000000..327634e
--- /dev/null
+++ b/external/cffi.darcs/src/cffi-scl.lisp
@@ -0,0 +1,333 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cffi-scl.lisp --- CFFI-SYS implementation for the Scieneer Common Lisp.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;; Copyright (C) 2006-2007, Scieneer Pty Ltd.
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# Administrivia
+
+(defpackage #:cffi-sys
+  (:use #:common-lisp #:alien #:c-call #:cffi-utils)
+  (:export
+   #:canonicalize-symbol-name-case
+   #:foreign-pointer
+   #:pointerp
+   #:pointer-eq
+   #:null-pointer
+   #:null-pointer-p
+   #:inc-pointer
+   #:make-pointer
+   #:pointer-address
+   #:%foreign-alloc
+   #:foreign-free
+   #:with-foreign-pointer
+   #:%foreign-funcall
+   #:%foreign-funcall-pointer
+   #:%foreign-type-alignment
+   #:%foreign-type-size
+   #:%load-foreign-library
+   #:%close-foreign-library
+   #:native-namestring
+   #:%mem-ref
+   #:%mem-set
+   #:make-shareable-byte-vector
+   #:with-pointer-to-vector-data
+   #:%foreign-symbol-pointer
+   #:%defcallback
+   #:%callback))
+
+(in-package #:cffi-sys)
+
+;;;# Features
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (mapc (lambda (feature) (pushnew feature *features*))
+        '(;; OS/CPU features.
+          #+unix    cffi-features:unix
+          #+x86     cffi-features:x86
+          #+amd64   cffi-features:x86-64
+          #+(and ppc (not ppc64)) cffi-features:ppc32
+          #+sparc   cffi-features:sparc
+          #+sparc64 cffi-features:sparc64
+          #+hppa    cffi-features:hppa
+          #+hppa64  cffi-features:hppa64
+          ;; Misfeatures
+          cffi-features:flat-namespace
+          )))
+
+;;; Symbol case.
+
+(defun canonicalize-symbol-name-case (name)
+  (declare (string name))
+  (if (eq ext:*case-mode* :upper)
+      (string-upcase name)
+      (string-downcase name)))
+
+;;;# Basic Pointer Operations
+
+(deftype foreign-pointer ()
+  'sys:system-area-pointer)
+
+(declaim (inline pointerp))
+(defun pointerp (ptr)
+  "Return true if 'ptr is a foreign pointer."
+  (sys:system-area-pointer-p ptr))
+
+(declaim (inline pointer-eq))
+(defun pointer-eq (ptr1 ptr2)
+  "Return true if 'ptr1 and 'ptr2 point to the same address."
+  (sys:sap= ptr1 ptr2))
+
+(declaim (inline null-pointer))
+(defun null-pointer ()
+  "Construct and return a null pointer."
+  (sys:int-sap 0))
+
+(declaim (inline null-pointer-p))
+(defun null-pointer-p (ptr)
+  "Return true if 'ptr is a null pointer."
+  (zerop (sys:sap-int ptr)))
+
+(declaim (inline inc-pointer))
+(defun inc-pointer (ptr offset)
+  "Return a pointer pointing 'offset bytes past 'ptr."
+  (sys:sap+ ptr offset))
+
+(declaim (inline make-pointer))
+(defun make-pointer (address)
+  "Return a pointer pointing to 'address."
+  (sys:int-sap address))
+
+(declaim (inline pointer-address))
+(defun pointer-address (ptr)
+  "Return the address pointed to by 'ptr."
+  (sys:sap-int ptr))
+
+(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
+  "Bind 'var to 'size bytes of foreign memory during 'body.  The
+  pointer in 'var is invalid beyond the dynamic extent of 'body, and
+  may be stack-allocated if supported by the implementation.  If
+  'size-var is supplied, it will be bound to 'size during 'body."
+  (unless size-var
+    (setf size-var (gensym (symbol-name '#:size))))
+  ;; If the size is constant we can stack-allocate.
+  (cond ((constantp size)
+         (let ((alien-var (gensym (symbol-name '#:alien))))
+           `(with-alien ((,alien-var (array (unsigned 8) ,(eval size))))
+             (let ((,size-var ,size)
+                   (,var (alien-sap ,alien-var)))
+               (declare (ignorable ,size-var))
+               ,@body))))
+        (t
+         `(let ((,size-var ,size))
+            (alien:with-bytes (,var ,size-var)
+              ,@body)))))
+
+;;;# Allocation
+;;;
+;;; Functions and macros for allocating foreign memory on the stack and on the
+;;; heap.  The main CFFI package defines macros that wrap 'foreign-alloc and
+;;; 'foreign-free in 'unwind-protect for the common usage when the memory has
+;;; dynamic extent.
+
+(defun %foreign-alloc (size)
+  "Allocate 'size bytes on the heap and return a pointer."
+  (declare (type (unsigned-byte #-64bit 32 #+64bit 64) size))
+  (alien-funcall (extern-alien "malloc"
+                               (function system-area-pointer unsigned))
+                 size))
+
+(defun foreign-free (ptr)
+  "Free a 'ptr allocated by 'foreign-alloc."
+  (declare (type system-area-pointer ptr))
+  (alien-funcall (extern-alien "free"
+                               (function (values) system-area-pointer))
+                 ptr))
+
+;;;# Shareable Vectors
+
+(defun make-shareable-byte-vector (size)
+  "Create a Lisp vector of 'size bytes that can passed to
+  'with-pointer-to-vector-data."
+  (make-array size :element-type '(unsigned-byte 8)))
+
+(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+  "Bind 'ptr-var to a foreign pointer to the data in 'vector."
+  (let ((vector-var (gensym (symbol-name '#:vector))))
+    `(let ((,vector-var ,vector))
+       (ext:with-pinned-object (,vector-var)
+         (let ((,ptr-var (sys:vector-sap ,vector-var)))
+           ,@body)))))
+
+;;;# Dereferencing
+
+;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
+;;; macros that optimize the case where the type keyword is constant
+;;; at compile-time.
+(defmacro define-mem-accessors (&body pairs)
+  `(progn
+    (defun %mem-ref (ptr type &optional (offset 0))
+      (ecase type
+        ,@(loop for (keyword fn) in pairs
+                collect `(,keyword (,fn ptr offset)))))
+    (defun %mem-set (value ptr type &optional (offset 0))
+      (ecase type
+        ,@(loop for (keyword fn) in pairs
+                collect `(,keyword (setf (,fn ptr offset) value)))))
+    (define-compiler-macro %mem-ref
+        (&whole form ptr type &optional (offset 0))
+      (if (constantp type)
+          (ecase (eval type)
+            ,@(loop for (keyword fn) in pairs
+                    collect `(,keyword `(,',fn ,ptr ,offset))))
+          form))
+    (define-compiler-macro %mem-set
+        (&whole form value ptr type &optional (offset 0))
+      (if (constantp type)
+          (once-only (value)
+            (ecase (eval type)
+              ,@(loop for (keyword fn) in pairs
+                      collect `(,keyword `(setf (,',fn ,ptr ,offset)
+                                                ,value)))))
+          form))))
+
+(define-mem-accessors
+  (:char sys:signed-sap-ref-8)
+  (:unsigned-char sys:sap-ref-8)
+  (:short sys:signed-sap-ref-16)
+  (:unsigned-short sys:sap-ref-16)
+  (:int sys:signed-sap-ref-32)
+  (:unsigned-int sys:sap-ref-32)
+  (:long #-64bit sys:signed-sap-ref-32 #+64bit sys:signed-sap-ref-64)
+  (:unsigned-long #-64bit sys:sap-ref-32 #+64bit sys:sap-ref-64)
+  (:long-long sys:signed-sap-ref-64)
+  (:unsigned-long-long sys:sap-ref-64)
+  (:float sys:sap-ref-single)
+  (:double sys:sap-ref-double)
+  #+long-float (:long-double sys:sap-ref-long)
+  (:pointer sys:sap-ref-sap))
+
+;;;# Calling Foreign Functions
+
+(defun convert-foreign-type (type-keyword)
+  "Convert a CFFI type keyword to an ALIEN type."
+  (ecase type-keyword
+    (:char               'char)
+    (:unsigned-char      'unsigned-char)
+    (:short              'short)
+    (:unsigned-short     'unsigned-short)
+    (:int                'int)
+    (:unsigned-int       'unsigned-int)
+    (:long               'long)
+    (:unsigned-long      'unsigned-long)
+    (:long-long          '(signed 64))
+    (:unsigned-long-long '(unsigned 64))
+    (:float              'single-float)
+    (:double             'double-float)
+    #+long-float
+    (:long-double        'long-float)
+    (:pointer            'system-area-pointer)
+    (:void               'void)))
+
+(defun %foreign-type-size (type-keyword)
+  "Return the size in bytes of a foreign type."
+  (values (truncate (alien-internals:alien-type-bits
+                     (alien-internals:parse-alien-type
+                      (convert-foreign-type type-keyword)))
+                    8)))
+
+(defun %foreign-type-alignment (type-keyword)
+  "Return the alignment in bytes of a foreign type."
+  (values (truncate (alien-internals:alien-type-alignment
+                     (alien-internals:parse-alien-type
+                      (convert-foreign-type type-keyword)))
+                    8)))
+
+(defun foreign-funcall-type-and-args (args)
+  "Return an 'alien function type for 'args."
+  (let ((return-type nil))
+    (loop for (type arg) on args by #'cddr
+          if arg collect (convert-foreign-type type) into types
+          and collect arg into fargs
+          else do (setf return-type (convert-foreign-type type))
+          finally (return (values types fargs return-type)))))
+
+(defmacro %%foreign-funcall (name types fargs rettype)
+  "Internal guts of '%foreign-funcall."
+  `(alien-funcall (extern-alien ,name (function ,rettype ,@types))
+                  ,@fargs))
+
+(defmacro %foreign-funcall (name args &key library calling-convention)
+  "Perform a foreign function call, document it more later."
+  (declare (ignore library calling-convention))
+  (multiple-value-bind (types fargs rettype)
+      (foreign-funcall-type-and-args args)
+    `(%%foreign-funcall ,name ,types ,fargs ,rettype)))
+
+(defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
+  "Funcall a pointer to a foreign function."
+  (declare (ignore calling-convention))
+  (multiple-value-bind (types fargs rettype)
+      (foreign-funcall-type-and-args args)
+    (with-unique-names (function)
+      `(with-alien ((,function (* (function ,rettype ,@types)) ,ptr))
+         (alien-funcall ,function ,@fargs)))))
+
+;;; Callbacks
+
+(defmacro %defcallback (name rettype arg-names arg-types body
+                        &key calling-convention)
+   `(alien:defcallback ,name
+       (,(convert-foreign-type rettype)
+         ,@(mapcar (lambda (sym type)
+                     (list sym (convert-foreign-type type)))
+                   arg-names arg-types))
+     ,body))
+
+(declaim (inline %callback))
+(defun %callback (name)
+  (alien:callback-sap name))
+
+;;;# Loading and Closing Foreign Libraries
+
+(defun %load-foreign-library (name path)
+  "Load the foreign library 'name."
+  (declare (ignore name))
+  (ext:load-dynamic-object path))
+
+(defun %close-foreign-library (name)
+  "Closes the foreign library 'name."
+  (ext:close-dynamic-object name))
+
+(defun native-namestring (pathname)
+  (ext:unix-namestring pathname))
+
+;;;# Foreign Globals
+
+(defun %foreign-symbol-pointer (name library)
+  "Returns a pointer to a foreign symbol 'name."
+  (declare (ignore library))
+  (let ((sap (sys:foreign-symbol-address name)))
+    (if (zerop (sys:sap-int sap)) nil sap)))
diff --git a/external/cffi.darcs/src/early-types.lisp b/external/cffi.darcs/src/early-types.lisp
new file mode 100644
index 0000000..852e0b2
--- /dev/null
+++ b/external/cffi.darcs/src/early-types.lisp
@@ -0,0 +1,519 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; early-types.lisp --- Low-level foreign type operations.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;; Copyright (C) 2005-2007, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;;# Early Type Definitions
+;;;
+;;; This module contains basic operations on foreign types.  These
+;;; definitions are in a separate file because they may be used in
+;;; compiler macros defined later on.
+
+(in-package #:cffi)
+
+;;;# Foreign Types
+;;;
+;;; Type specifications are of the form (type {args}*). The type
+;;; parser can specify how its arguments should look like through a
+;;; lambda list.
+;;;
+;;; "type" is a shortcut for "(type)", ie, no args were specified.
+;;;
+;;; Examples of such types: boolean, (boolean), (boolean :int) If the
+;;; boolean type parser specifies the lambda list: &optional
+;;; (base-type :int), then all of the above three type specs would be
+;;; parsed to an identical type.
+;;;
+;;; Type parsers, defined with DEFINE-PARSE-METHOD should return a
+;;; subtype of the foreign-type class.
+
+(defvar *type-parsers* (make-hash-table)
+  "Hash table of defined type parsers.")
+
+(defun find-type-parser (symbol)
+  "Return the type parser for SYMBOL."
+  (or (gethash symbol *type-parsers*)
+      (error "Unknown CFFI type: ~S." symbol)))
+
+(defun (setf find-type-parser) (func symbol)
+  "Set the type parser for SYMBOL."
+  (setf (gethash symbol *type-parsers*) func))
+
+;;; Using a generic function would have been nicer but generates lots
+;;; of style warnings in SBCL.  (Silly reason, yes.)
+(defmacro define-parse-method (name lambda-list &body body)
+  "Define a type parser on NAME and lists whose CAR is NAME."
+  (discard-docstring body)
+  (warn-if-kw-or-belongs-to-cl name)
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (setf (find-type-parser ',name)
+           (lambda ,lambda-list ,@body))
+     ',name))
+
+;;; Utility function for the simple case where the type takes no
+;;; arguments.
+(defun notice-foreign-type (name type)
+  (setf (find-type-parser name) (lambda () type))
+  name)
+
+;;;# Generic Functions on Types
+
+(defgeneric canonicalize (foreign-type)
+  (:documentation
+   "Return the built-in foreign type for FOREIGN-TYPE.
+Signals an error if FOREIGN-TYPE is undefined."))
+
+(defgeneric aggregatep (foreign-type)
+  (:documentation
+   "Return true if FOREIGN-TYPE is an aggregate type."))
+
+(defgeneric foreign-type-alignment (foreign-type)
+  (:documentation
+   "Return the structure alignment in bytes of a foreign type."))
+
+(defgeneric foreign-type-size (foreign-type)
+  (:documentation
+   "Return the size in bytes of a foreign type."))
+
+(defgeneric unparse-type (foreign-type)
+  (:documentation
+   "Unparse FOREIGN-TYPE to a type specification (symbol or list)."))
+
+;;;# Foreign Types
+
+(defclass foreign-type ()
+  ()
+  (:documentation "Base class for all foreign types."))
+
+(defmethod make-load-form ((type foreign-type) &optional env)
+  "Return the form used to dump types to a FASL file."
+  (declare (ignore env))
+  `(parse-type ',(unparse-type type)))
+
+(defmethod foreign-type-size (type)
+  "Return the size in bytes of a foreign type."
+  (foreign-type-size (parse-type type)))
+
+(defclass named-foreign-type (foreign-type)
+  ((name
+    ;; Name of this foreign type, a symbol.
+    :initform (error "Must specify a NAME.")
+    :initarg :name
+    :accessor name)))
+
+(defmethod print-object ((type named-foreign-type) stream)
+  "Print a FOREIGN-TYPEDEF instance to STREAM unreadably."
+  (print-unreadable-object (type stream :type t :identity nil)
+    (format stream "~S" (name type))))
+
+;;; Return the type's name which can be passed to PARSE-TYPE.  If
+;;; that's not the case for some subclass of NAMED-FOREIGN-TYPE then
+;;; it should specialize UNPARSE-TYPE.
+(defmethod unparse-type ((type named-foreign-type))
+  (name type))
+
+;;;# Built-In Foreign Types
+
+(defclass foreign-built-in-type (foreign-type)
+  ((type-keyword
+    ;; Keyword in CFFI-SYS representing this type.
+    :initform (error "A type keyword is required.")
+    :initarg :type-keyword
+    :accessor type-keyword))
+  (:documentation "A built-in foreign type."))
+
+(defmethod canonicalize ((type foreign-built-in-type))
+  "Return the built-in type keyword for TYPE."
+  (type-keyword type))
+
+(defmethod aggregatep ((type foreign-built-in-type))
+  "Returns false, built-in types are never aggregate types."
+  nil)
+
+(defmethod foreign-type-alignment ((type foreign-built-in-type))
+  "Return the alignment of a built-in type."
+  (%foreign-type-alignment (type-keyword type)))
+
+(defmethod foreign-type-size ((type foreign-built-in-type))
+  "Return the size of a built-in type."
+  (%foreign-type-size (type-keyword type)))
+
+(defmethod unparse-type ((type foreign-built-in-type))
+  "Returns the symbolic representation of a built-in type."
+  (type-keyword type))
+
+(defmethod print-object ((type foreign-built-in-type) stream)
+  "Print a FOREIGN-TYPE instance to STREAM unreadably."
+  (print-unreadable-object (type stream :type t :identity nil)
+    (format stream "~S" (type-keyword type))))
+
+(defmacro define-built-in-foreign-type (keyword)
+  "Defines a built-in foreign-type."
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (notice-foreign-type
+      ,keyword (make-instance 'foreign-built-in-type :type-keyword ,keyword))))
+
+;;;# Foreign Pointer Types
+
+(defclass foreign-pointer-type (foreign-built-in-type)
+  ((pointer-type
+    ;; Type of object pointed at by this pointer, or nil for an
+    ;; untyped (void) pointer.
+    :initform nil
+    :initarg :pointer-type
+    :accessor pointer-type))
+  (:default-initargs :type-keyword :pointer))
+
+;;; Define the type parser for the :POINTER type.  If no type argument
+;;; is provided, a void pointer will be created.
+(let ((void-pointer (make-instance 'foreign-pointer-type)))
+  (define-parse-method :pointer (&optional type)
+    (if type
+        (make-instance 'foreign-pointer-type :pointer-type (parse-type type))
+        ;; A bit of premature optimization here.
+        void-pointer)))
+
+;;; Unparse a foreign pointer type when dumping to a fasl.
+(defmethod unparse-type ((type foreign-pointer-type))
+  (if (pointer-type type)
+      `(:pointer ,(unparse-type (pointer-type type)))
+      :pointer))
+
+;;; Print a foreign pointer type unreadably in unparsed form.
+(defmethod print-object ((type foreign-pointer-type) stream)
+  (print-unreadable-object (type stream :type t :identity nil)
+    (format stream "~S" (unparse-type type))))
+
+;;;# Structure Type
+
+(defclass foreign-struct-type (named-foreign-type)
+  ((slots
+    ;; Hash table of slots in this structure, keyed by name.
+    :initform (make-hash-table)
+    :initarg :slots
+    :accessor slots)
+   (size
+    ;; Cached size in bytes of this structure.
+    :initarg :size
+    :accessor size)
+   (alignment
+    ;; This struct's alignment requirements
+    :initarg :alignment
+    :accessor alignment))
+  (:documentation "Hash table of plists containing slot information."))
+
+(defmethod canonicalize ((type foreign-struct-type))
+  "Returns :POINTER, since structures can not be passed by value."
+  :pointer)
+
+(defmethod aggregatep ((type foreign-struct-type))
+  "Returns true, structure types are aggregate."
+  t)
+
+(defmethod foreign-type-size ((type foreign-struct-type))
+  "Return the size in bytes of a foreign structure type."
+  (size type))
+
+(defmethod foreign-type-alignment ((type foreign-struct-type))
+  "Return the alignment requirements for this struct."
+  (alignment type))
+
+;;;# Foreign Typedefs
+
+(defclass foreign-type-alias (foreign-type)
+  ((actual-type
+    ;; The FOREIGN-TYPE instance this type is an alias for.
+    :initarg :actual-type
+    :accessor actual-type
+    :initform (error "Must specify an ACTUAL-TYPE.")))
+  (:documentation "A type that aliases another type."))
+
+(defmethod canonicalize ((type foreign-type-alias))
+  "Return the built-in type keyword for TYPE."
+  (canonicalize (actual-type type)))
+
+(defmethod aggregatep ((type foreign-type-alias))
+  "Return true if TYPE's actual type is aggregate."
+  (aggregatep (actual-type type)))
+
+(defmethod foreign-type-alignment ((type foreign-type-alias))
+  "Return the alignment of a foreign typedef."
+  (foreign-type-alignment (actual-type type)))
+
+(defmethod foreign-type-size ((type foreign-type-alias))
+  "Return the size in bytes of a foreign typedef."
+  (foreign-type-size (actual-type type)))
+
+(defclass foreign-typedef (foreign-type-alias named-foreign-type)
+  ())
+
+(defun follow-typedefs (type)
+  (if (eq (type-of type) 'foreign-typedef)
+      (follow-typedefs (actual-type type))
+      type))
+
+;;;# Type Translators
+;;;
+;;; Type translation is done with generic functions at runtime for
+;;; subclasses of ENHANCED-FOREIGN-TYPE/
+;;;
+;;; The main interface for defining type translations is through the
+;;; generic functions TRANSLATE-{TO,FROM}-FOREIGN and
+;;; FREE-TRANSLATED-OBJECT.
+
+(defclass enhanced-foreign-type (foreign-type-alias)
+  ((unparsed-type :accessor unparsed-type)))
+
+;;; If actual-type isn't parsed already, let's parse it.  This way we
+;;; don't have to export PARSE-TYPE and users don't have to worry
+;;; about this in DEFINE-FOREIGN-TYPE or DEFINE-PARSE-METHOD.
+(defmethod initialize-instance :after ((type enhanced-foreign-type) &key)
+  (unless (typep (actual-type type) 'foreign-type)
+    (setf (actual-type type) (parse-type (actual-type type)))))
+
+(defmethod unparse-type ((type enhanced-foreign-type))
+  (unparsed-type type))
+
+;;; Checks NAMEs, not object identity.
+(defun check-for-typedef-cycles (type)
+  (let ((seen (make-hash-table :test 'eq)))
+    (labels ((%check (cur-type)
+               (when (typep cur-type 'foreign-typedef)
+                 (when (gethash (name cur-type) seen)
+                   (error "Detected cycle in type ~S." type))
+                 (setf (gethash (name cur-type) seen) t)
+                 (%check (actual-type cur-type)))))
+      (%check type))))
+
+;;; Only now we define PARSE-TYPE because it needs to do some extra
+;;; work for ENHANCED-FOREIGN-TYPES.
+(defun parse-type (type)
+  (let* ((spec (ensure-list type))
+         (ptype (apply (find-type-parser (car spec)) (cdr spec))))
+    (check-for-typedef-cycles ptype)
+    (when (typep ptype 'enhanced-foreign-type)
+      (setf (unparsed-type ptype) type))
+    ptype))
+
+(defun canonicalize-foreign-type (type)
+  "Convert TYPE to a built-in type by following aliases.
+Signals an error if the type cannot be resolved."
+  (canonicalize (parse-type type)))
+
+;;; Translate VALUE to a foreign object of the type represented by
+;;; TYPE, which will be a subclass of ENHANCED-FOREIGN-TYPE.  Returns
+;;; the foreign value and an optional second value which will be
+;;; passed to FREE-TRANSLATED-OBJECT as the PARAM argument.
+(defgeneric translate-to-foreign (value type)
+  (:method (value type)
+    (declare (ignore type))
+    value))
+
+;;; Translate the foreign object VALUE from the type repsented by
+;;; TYPE, which will be a subclass of ENHANCED-FOREIGN-TYPE.  Returns
+;;; the converted Lisp value.
+(defgeneric translate-from-foreign (value type)
+  (:method (value type)
+    (declare (ignore type))
+    value))
+
+;;; Free an object allocated by TRANSLATE-TO-FOREIGN.  VALUE is a
+;;; foreign object of the type represented by TYPE, which will be a
+;;; ENHANCED-FOREIGN-TYPE subclass.  PARAM, if present, contains the
+;;; second value returned by TRANSLATE-TO-FOREIGN, and is used to
+;;; communicate between the two functions.
+(defgeneric free-translated-object (value type param)
+  (:method (value type param)
+    (declare (ignore value type param))))
+
+;;;## Macroexpansion Time Translation
+;;;
+;;; The following EXPAND-* generic functions are similar to their
+;;; TRANSLATE-* counterparts but are usually called at macroexpansion
+;;; time. They offer a way to optimize the runtime translators.
+
+;;; This special variable is bound by the various :around methods
+;;; below to the respective form generated by the above %EXPAND-*
+;;; functions.  This way, an expander can "bail out" by calling the
+;;; next method.  All 6 of the below-defined GFs have a default method
+;;; that simply answers the rtf bound by the default :around method.
+(defvar *runtime-translator-form*)
+
+;;; EXPAND-FROM-FOREIGN
+
+(defgeneric expand-from-foreign (value type)
+  (:method (value type)
+    (declare (ignore type))
+    value))
+
+(defmethod expand-from-foreign :around (value (type enhanced-foreign-type))
+  (let ((*runtime-translator-form* `(translate-from-foreign ,value ,type)))
+    (call-next-method)))
+
+(defmethod expand-from-foreign (value (type enhanced-foreign-type))
+  (declare (ignore value))
+  *runtime-translator-form*)
+
+;;; EXPAND-TO-FOREIGN
+
+;; The second return value is used to tell EXPAND-TO-FOREIGN-DYN that
+;; an unspecialized method was called.
+(defgeneric expand-to-foreign (value type)
+  (:method (value type)
+    (declare (ignore type))
+    (values value t)))
+
+(defmethod expand-to-foreign :around (value (type enhanced-foreign-type))
+  (let ((*runtime-translator-form*
+         `(values (translate-to-foreign ,value ,type))))
+    (call-next-method)))
+
+(defmethod expand-to-foreign (value (type enhanced-foreign-type))
+  (declare (ignore value))
+  (values *runtime-translator-form* t))
+
+;;; EXPAND-TO-FOREIGN-DYN
+
+(defgeneric expand-to-foreign-dyn (value var body type)
+  (:method (value var body type)
+    (declare (ignore type))
+    `(let ((,var ,value)) ,@body)))
+
+(defmethod expand-to-foreign-dyn :around
+    (value var body (type enhanced-foreign-type))
+  (let ((*runtime-translator-form*
+         (with-unique-names (param)
+           `(multiple-value-bind (,var ,param)
+                (translate-to-foreign ,value ,type)
+              (unwind-protect
+                   (progn ,@body)
+                (free-translated-object ,var ,type ,param))))))
+    (call-next-method)))
+
+;;; If this method is called it means the user hasn't defined a
+;;; to-foreign-dyn expansion, so we use the to-foreign expansion.
+;;;
+;;; However, we do so *only* if there's a specialized
+;;; EXPAND-TO-FOREIGN for TYPE because otherwise we want to use the
+;;; above *RUNTIME-TRANSLATOR-FORM* which includes a call to
+;;; FREE-TRANSLATED-OBJECT.  (Or else there would occur no translation
+;;; at all.)
+(defmethod expand-to-foreign-dyn (value var body (type enhanced-foreign-type))
+  (multiple-value-bind (expansion default-etp-p)
+      (expand-to-foreign value type)
+    (if default-etp-p
+        *runtime-translator-form*
+        `(let ((,var ,expansion))
+           ,@body))))
+
+;;; User interface for converting values from/to foreign using the
+;;; type translators.  The compiler macros use the expanders when
+;;; possible.
+
+(defun convert-to-foreign (value type)
+  (translate-to-foreign value (parse-type type)))
+
+(define-compiler-macro convert-to-foreign (value type)
+  (if (constantp type)
+      (expand-to-foreign value (parse-type (eval type)))
+      `(translate-to-foreign ,value (parse-type ,type))))
+
+(defun convert-from-foreign (value type)
+  (translate-from-foreign value (parse-type type)))
+
+(define-compiler-macro convert-from-foreign (value type)
+  (if (constantp type)
+      (expand-from-foreign value (parse-type (eval type)))
+      `(translate-from-foreign ,value (parse-type ,type))))
+
+(defun free-converted-object (value type param)
+  (free-translated-object value (parse-type type) param))
+
+;;;# Enhanced typedefs
+
+(defclass enhanced-typedef (foreign-typedef)
+  ())
+
+(defmethod translate-to-foreign (value (type enhanced-typedef))
+  (translate-to-foreign value (actual-type type)))
+
+(defmethod translate-from-foreign (value (type enhanced-typedef))
+  (translate-from-foreign value (actual-type type)))
+
+(defmethod free-translated-object (value (type enhanced-typedef) param)
+  (free-translated-object value (actual-type type) param))
+
+(defmethod expand-from-foreign (value (type enhanced-typedef))
+  (expand-from-foreign value (actual-type type)))
+
+(defmethod expand-to-foreign (value (type enhanced-typedef))
+  (expand-to-foreign value (actual-type type)))
+
+(defmethod expand-to-foreign-dyn (value var body (type enhanced-typedef))
+  (expand-to-foreign-dyn value var body (actual-type type)))
+
+;;;# User-defined Types and Translations.
+
+(defmacro define-foreign-type (name supers slots &rest options)
+  (multiple-value-bind (new-options simple-parser actual-type initargs)
+      (let ((keywords '(:simple-parser :actual-type :default-initargs)))
+        (apply #'values
+               (remove-if (lambda (opt) (member (car opt) keywords)) options)
+               (mapcar (lambda (kw) (cdr (assoc kw options))) keywords)))
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
+       (defclass ,name ,(or supers '(enhanced-foreign-type))
+         ,slots
+         (:default-initargs ,@(when actual-type `(:actual-type ',actual-type))
+             ,@initargs)
+         ,@new-options)
+       ,(when simple-parser
+          `(define-parse-method ,(car simple-parser) (&rest args)
+             (apply #'make-instance ',name args)))
+       ',name)))
+
+(defmacro defctype (name base-type &optional documentation)
+  "Utility macro for simple C-like typedefs."
+  (declare (ignore documentation))
+  (warn-if-kw-or-belongs-to-cl name)
+  (let* ((btype (parse-type base-type))
+         (dtype (if (typep btype 'enhanced-foreign-type)
+                    'enhanced-typedef
+                    'foreign-typedef)))
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
+       (notice-foreign-type
+        ',name (make-instance ',dtype :name ',name :actual-type ,btype)))))
+
+;;; For Verrazano.  We memoize the type this way to help detect cycles.
+(defmacro defctype* (name base-type)
+  "Like DEFCTYPE but defers instantiation until parse-time."
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (let (memoized-type)
+       (define-parse-method ,name ()
+         (unless memoized-type
+           (setf memoized-type (make-instance 'foreign-typedef :name ',name
+                                              :actual-type nil)
+                 (actual-type memoized-type) (parse-type ',base-type)))
+         memoized-type))))
diff --git a/external/cffi.darcs/src/enum.lisp b/external/cffi.darcs/src/enum.lisp
new file mode 100644
index 0000000..dedc473
--- /dev/null
+++ b/external/cffi.darcs/src/enum.lisp
@@ -0,0 +1,216 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; enum.lisp --- Defining foreign constants as Lisp keywords.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi)
+
+;;;# Foreign Constants as Lisp Keywords
+;;;
+;;; This module defines the DEFCENUM macro, which provides an
+;;; interface for defining a type and associating a set of integer
+;;; constants with keyword symbols for that type.
+;;;
+;;; The keywords are automatically translated to the appropriate
+;;; constant for the type by a type translator when passed as
+;;; arguments or a return value to a foreign function.
+
+(defclass foreign-enum (foreign-typedef enhanced-foreign-type)
+  ((keyword-values
+    :initform (make-hash-table :test 'eq)
+    :reader keyword-values)
+   (value-keywords
+    :initform (make-hash-table)
+    :reader value-keywords))
+  (:documentation "Describes a foreign enumerated type."))
+
+(defun make-foreign-enum (type-name base-type values)
+  "Makes a new instance of the foreign-enum class."
+  (let ((type (make-instance 'foreign-enum :name type-name
+                             :actual-type (parse-type base-type)))
+        (default-value 0))
+    (dolist (pair values)
+      (destructuring-bind (keyword &optional (value default-value))
+          (ensure-list pair)
+        (check-type keyword keyword)
+        (check-type value integer)
+        (if (gethash keyword (keyword-values type))
+            (error "A foreign enum cannot contain duplicate keywords: ~S."
+                   keyword)
+            (setf (gethash keyword (keyword-values type)) value))
+        ;; This is completely arbitrary behaviour: we keep the last we
+        ;; value->keyword mapping. I suppose the opposite would be
+        ;; just as good (keeping the first). Returning a list with all
+        ;; the keywords might be a solution too? Suggestions
+        ;; welcome. --luis
+        (setf (gethash value (value-keywords type)) keyword)
+        (setq default-value (1+ value))))
+    type))
+
+(defmacro defcenum (name-and-options &body enum-list)
+  "Define an foreign enumerated type."
+  (discard-docstring enum-list)
+  (destructuring-bind (name &optional (base-type :int))
+      (ensure-list name-and-options)
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
+       (notice-foreign-type
+        ',name (make-foreign-enum ',name ',base-type ',enum-list)))))
+
+(defun hash-keys-to-list (ht)
+  (loop for k being the hash-keys in ht collect k))
+
+(defun foreign-enum-keyword-list (enum-type)
+  "Return a list of KEYWORDS defined in ENUM-TYPE."
+  (hash-keys-to-list (keyword-values (parse-type enum-type))))
+
+;;; These [four] functions could be good canditates for compiler macros
+;;; when the value or keyword is constant.  I am not going to bother
+;;; until someone has a serious performance need to do so though. --jamesjb
+(defun %foreign-enum-value (type keyword &key errorp)
+  (check-type keyword keyword)
+  (or (gethash keyword (keyword-values type))
+      (when errorp
+        (error "~S is not defined as a keyword for enum type ~S."
+               keyword type))))
+
+(defun foreign-enum-value (type keyword &key (errorp t))
+  "Convert a KEYWORD into an integer according to the enum TYPE."
+  (let ((type-obj (parse-type type)))
+    (if (not (typep type-obj 'foreign-enum))
+      (error "~S is not a foreign enum type." type)
+      (%foreign-enum-value type-obj keyword :errorp errorp))))
+
+(defun %foreign-enum-keyword (type value &key errorp)
+  (check-type value integer)
+  (or (gethash value (value-keywords type))
+      (when errorp
+        (error "~S is not defined as a value for enum type ~S."
+               value type))))
+
+(defun foreign-enum-keyword (type value &key (errorp t))
+  "Convert an integer VALUE into a keyword according to the enum TYPE."
+  (let ((type-obj (parse-type type)))
+    (if (not (typep type-obj 'foreign-enum))
+        (error "~S is not a foreign enum type." type)
+        (%foreign-enum-keyword type-obj value :errorp errorp))))
+
+(defmethod translate-to-foreign (value (type foreign-enum))
+  (if (keywordp value)
+      (%foreign-enum-value type value :errorp t)
+      value))
+
+(defmethod translate-from-foreign (value (type foreign-enum))
+  (%foreign-enum-keyword type value :errorp t))
+
+;;;# Foreign Bitfields as Lisp keywords
+;;;
+;;; DEFBITFIELD is an abstraction similar to the one provided by DEFCENUM.
+;;; With some changes to DEFCENUM, this could certainly be implemented on
+;;; top of it.
+
+(defclass foreign-bitfield (foreign-typedef enhanced-foreign-type)
+  ((symbol-values
+    :initform (make-hash-table :test 'eq)
+    :reader symbol-values)
+   (value-symbols
+    :initform (make-hash-table)
+    :reader value-symbols))
+  (:documentation "Describes a foreign bitfield type."))
+
+(defun make-foreign-bitfield (type-name base-type values)
+  "Makes a new instance of the foreign-bitfield class."
+  (let ((type (make-instance 'foreign-bitfield :name type-name
+                             :actual-type (parse-type base-type)))
+        (bit-floor 1))
+    (dolist (pair values)
+      ;; bit-floor rule: find the greatest single-bit int used so far,
+      ;; and store its left-shift
+      (destructuring-bind (symbol &optional
+                           (value (prog1 bit-floor
+                                    (setf bit-floor (ash bit-floor 1)))
+                                  value-p))
+          (ensure-list pair)
+        (check-type symbol symbol)
+        (when value-p
+          (check-type value integer)
+          (when (and (>= value bit-floor) (single-bit-p value))
+            (setf bit-floor (ash value 1))))
+        (if (gethash symbol (symbol-values type))
+            (error "A foreign bitfield cannot contain duplicate symbols: ~S."
+                   symbol)
+            (setf (gethash symbol (symbol-values type)) value))
+        (push symbol (gethash value (value-symbols type)))))
+    type))
+
+(defmacro defbitfield (name-and-options &body masks)
+  "Define an foreign enumerated type."
+  (discard-docstring masks)
+  (destructuring-bind (name &optional (base-type :int))
+      (ensure-list name-and-options)
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
+       (notice-foreign-type
+        ',name (make-foreign-bitfield ',name ',base-type ',masks)))))
+
+(defun foreign-bitfield-symbol-list (bitfield-type)
+  "Return a list of SYMBOLS defined in BITFIELD-TYPE."
+  (hash-keys-to-list (symbol-values (parse-type bitfield-type))))
+
+(defun %foreign-bitfield-value (type symbols)
+  (reduce #'logior symbols
+          :key (lambda (symbol)
+                 (check-type symbol symbol)
+                 (or (gethash symbol (symbol-values type))
+                     (error "~S is not a valid symbol for bitfield type ~S."
+                            symbol type)))))
+
+(defun foreign-bitfield-value (type symbols)
+  "Convert a list of symbols into an integer according to the TYPE bitfield."
+  (let ((type-obj (parse-type type)))
+    (if (not (typep type-obj 'foreign-bitfield))
+      (error "~S is not a foreign bitfield type." type)
+      (%foreign-bitfield-value type-obj symbols))))
+
+(defun %foreign-bitfield-symbols (type value)
+  (check-type value integer)
+  (loop for mask being the hash-keys in (value-symbols type)
+            using (hash-value symbols)
+        when (= (logand value mask) mask)
+        append symbols))
+
+(defun foreign-bitfield-symbols (type value)
+  "Convert an integer VALUE into a list of matching symbols according to
+the bitfield TYPE."
+  (let ((type-obj (parse-type type)))
+    (if (not (typep type-obj 'foreign-bitfield))
+        (error "~S is not a foreign bitfield type." type)
+        (%foreign-bitfield-symbols type-obj value))))
+
+(defmethod translate-to-foreign (value (type foreign-bitfield))
+  (if (integerp value)
+      value
+      (%foreign-bitfield-value type (ensure-list value))))
+
+(defmethod translate-from-foreign (value (type foreign-bitfield))
+  (%foreign-bitfield-symbols type value))
diff --git a/external/cffi.darcs/src/features.lisp b/external/cffi.darcs/src/features.lisp
new file mode 100644
index 0000000..cb62a65
--- /dev/null
+++ b/external/cffi.darcs/src/features.lisp
@@ -0,0 +1,89 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; features.lisp --- CFFI-specific features.
+;;;
+;;; Copyright (C) 2006-2007, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cl-user)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (pushnew :cffi *features*))
+
+;;; CFFI-SYS backends take care of pushing the appropriate features to
+;;; *features*.  See each cffi-*.lisp file.
+
+(defpackage #:cffi-features
+  (:use #:cl)
+  (:export
+   #:cffi-feature-p
+
+   ;; Features related to the CFFI-SYS backend.  Why no-*?  This
+   ;; reflects the hope that these symbols will go away completely
+   ;; meaning that at some point all lisps will support long-longs,
+   ;; the foreign-funcall primitive, etc...
+   #:no-long-long
+   #:no-foreign-funcall
+   #:no-stdcall
+   #:flat-namespace
+
+   ;; Only SCL supports long-double...
+   ;;#:no-long-double
+
+   ;; Features related to the operating system.
+   ;; More should be added.
+   #:darwin
+   #:unix
+   #:windows
+
+   ;; Features related to the processor.
+   ;; More should be added.
+   #:ppc32
+   #:x86
+   #:x86-64
+   #:sparc
+   #:sparc64
+   #:hppa
+   #:hppa64
+   ))
+
+(in-package #:cffi-features)
+
+(defun cffi-feature-p (feature-expression)
+  "Matches a FEATURE-EXPRESSION against those symbols in *FEATURES*
+that belong to the CFFI-FEATURES package."
+  (when (eql feature-expression t)
+    (return-from cffi-feature-p t))
+  (let ((features-package (find-package '#:cffi-features)))
+    (flet ((cffi-feature-eq (name feature-symbol)
+             (and (eq (symbol-package feature-symbol) features-package)
+                  (string= name (symbol-name feature-symbol)))))
+      (etypecase feature-expression
+        (symbol
+         (not (null (member (symbol-name feature-expression) *features*
+                            :test #'cffi-feature-eq))))
+        (cons
+         (ecase (first feature-expression)
+           (:and (every #'cffi-feature-p (rest feature-expression)))
+           (:or  (some #'cffi-feature-p (rest feature-expression)))
+           (:not (not (cffi-feature-p (cadr feature-expression))))))))))
diff --git a/external/cffi.darcs/src/foreign-vars.lisp b/external/cffi.darcs/src/foreign-vars.lisp
new file mode 100644
index 0000000..bd1fdba
--- /dev/null
+++ b/external/cffi.darcs/src/foreign-vars.lisp
@@ -0,0 +1,88 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; foreign-vars.lisp --- High-level interface to foreign globals.
+;;;
+;;; Copyright (C) 2005-2007, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi)
+
+;;;# Accessing Foreign Globals
+
+;;; Called by FOREIGN-OPTIONS in functions.lisp.
+(defun parse-defcvar-options (options)
+  (destructuring-bind (&key (library :default) read-only) options
+    (list :library library :read-only read-only)))
+
+(defun get-var-pointer (symbol)
+  "Return a pointer to the foreign global variable relative to SYMBOL."
+  (foreign-symbol-pointer (get symbol 'foreign-var-name)
+                          :library (get symbol 'foreign-var-library)))
+
+;;; Note: this will lookup not only variables but also functions.
+(defun foreign-symbol-pointer (name &key (library :default))
+  (%foreign-symbol-pointer
+   name (if (eq library :default)
+            :default
+            (foreign-library-handle
+             (get-foreign-library library)))))
+
+(defun fs-pointer-or-lose (foreign-name library)
+  "Like foreign-symbol-ptr but throws an error instead of
+returning nil when foreign-name is not found."
+  (or (foreign-symbol-pointer foreign-name :library library)
+      (error "Trying to access undefined foreign variable ~S." foreign-name)))
+
+(defmacro defcvar (name-and-options type &optional documentation)
+  "Define a foreign global variable."
+  (declare (ignore documentation))
+  (multiple-value-bind (lisp-name foreign-name options)
+      (parse-name-and-options name-and-options t)
+    (let ((fn (symbolicate '#:%var-accessor- lisp-name))
+          (read-only (getf options :read-only))
+          (library (getf options :library)))
+      ;; We can't really setf an aggregate type.
+      (when (aggregatep (parse-type type))
+        (setq read-only t))
+      `(progn
+         ;; Save foreign-name and library for posterior access by
+         ;; GET-VAR-POINTER.
+         (setf (get ',lisp-name 'foreign-var-name) ,foreign-name)
+         (setf (get ',lisp-name 'foreign-var-library) ',library)
+         ;; Getter
+         (defun ,fn ()
+           (mem-ref (fs-pointer-or-lose ,foreign-name ',library) ',type))
+         ;; Setter
+         (defun (setf ,fn) (value)
+           ,(if read-only '(declare (ignore value)) (values))
+           ,(if read-only
+                `(error ,(format nil "Trying to modify read-only foreign var: ~A."
+                                 lisp-name))
+                `(setf (mem-ref (fs-pointer-or-lose ,foreign-name ',library)
+                                ',type)
+                       value)))
+         ;; While most Lisps already expand DEFINE-SYMBOL-MACRO to an
+         ;; EVAL-WHEN form like this, that is not required by the
+         ;; standard so we do it ourselves.
+         (eval-when (:compile-toplevel :load-toplevel :execute)
+           (define-symbol-macro ,lisp-name (,fn)))))))
diff --git a/external/cffi.darcs/src/functions.lisp b/external/cffi.darcs/src/functions.lisp
new file mode 100644
index 0000000..a8b633e
--- /dev/null
+++ b/external/cffi.darcs/src/functions.lisp
@@ -0,0 +1,307 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; functions.lisp --- High-level interface to foreign functions.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;; Copyright (C) 2005-2007, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi)
+
+;;;# Calling Foreign Functions
+;;;
+;;; FOREIGN-FUNCALL is the main primitive for calling foreign
+;;; functions.  It converts each argument based on the installed
+;;; translators for its type, then passes the resulting list to
+;;; CFFI-SYS:%FOREIGN-FUNCALL.
+;;;
+;;; For implementation-specific reasons, DEFCFUN doesn't use
+;;; FOREIGN-FUNCALL directly and might use something else (passed to
+;;; TRANSLATE-OBJECTS as the CALL-FORM argument) instead of
+;;; CFFI-SYS:%FOREIGN-FUNCALL to call the foreign-function.
+
+(defun translate-objects (syms args types rettype call-form)
+  "Helper function for FOREIGN-FUNCALL and DEFCFUN."
+  (if (null args)
+      (expand-from-foreign call-form (parse-type rettype))
+      (expand-to-foreign-dyn
+       (car args) (car syms)
+       (list (translate-objects (cdr syms) (cdr args)
+                                (cdr types) rettype call-form))
+       (parse-type (car types)))))
+
+(defun parse-args-and-types (args)
+  "Returns 4 values. Types, canonicalized types, args and return type."
+  (let ((return-type :void))
+    (loop for (type arg) on args by #'cddr
+          if arg collect type into types
+             and collect (canonicalize-foreign-type type) into ctypes
+             and collect arg into fargs
+          else do (setf return-type type)
+          finally (return (values types ctypes fargs return-type)))))
+
+;;; While the options passed directly to DEFCFUN/FOREIGN-FUNCALL have
+;;; precedence, we also grab its library's options, if possible.
+(defun parse-function-options (options &key pointer)
+  (destructuring-bind (&key (library :default libraryp) calling-convention
+                            (cconv calling-convention))
+      options
+    (list* :calling-convention
+           (or cconv
+               (when libraryp
+                 (let ((lib-options (foreign-library-options
+                                     (get-foreign-library library))))
+                   (getf lib-options :cconv
+                         (getf lib-options :calling-convention))))
+               :cdecl)
+           ;; Don't pass the library option if we're dealing with
+           ;; FOREIGN-FUNCALL-POINTER.
+           (unless pointer
+             (list :library library)))))
+
+(defun foreign-funcall-form (thing options args pointerp)
+  (multiple-value-bind (types ctypes fargs rettype)
+      (parse-args-and-types args)
+    (let ((syms (make-gensym-list (length fargs))))
+      (translate-objects
+       syms fargs types rettype
+       `(,(if pointerp '%foreign-funcall-pointer '%foreign-funcall)
+         ,thing
+         (,@(mapcan #'list ctypes syms)
+            ,(canonicalize-foreign-type rettype))
+         ,@(parse-function-options options :pointer pointerp))))))
+
+(defmacro foreign-funcall (name-and-options &rest args)
+  "Wrapper around %FOREIGN-FUNCALL that translates its arguments."
+  (let ((name (car (ensure-list name-and-options)))
+        (options (cdr (ensure-list name-and-options))))
+    (foreign-funcall-form name options args nil)))
+
+(defmacro foreign-funcall-pointer (pointer options &rest args)
+  (foreign-funcall-form pointer options args t))
+
+(defun promote-varargs-type (builtin-type)
+  "Default argument promotions."
+  (case builtin-type
+    (:float :double)
+    ((:char :short) :int)
+    ((:unsigned-char :unsigned-short) :unsigned-int)
+    (t builtin-type)))
+
+(defun foreign-funcall-varargs-form (thing options fixed-args varargs pointerp)
+  (multiple-value-bind (fixed-types fixed-ctypes fixed-fargs)
+      (parse-args-and-types fixed-args)
+    (multiple-value-bind (varargs-types varargs-ctypes varargs-fargs rettype)
+        (parse-args-and-types varargs)
+      (let ((fixed-syms (make-gensym-list (length fixed-fargs)))
+            (varargs-syms (make-gensym-list (length varargs-fargs))))
+        (translate-objects
+         (append fixed-syms varargs-syms)
+         (append fixed-fargs varargs-fargs)
+         (append fixed-types varargs-types)
+         rettype
+         `(,(if pointerp '%foreign-funcall-pointer '%foreign-funcall)
+            ,thing
+            ,(append
+              (mapcan #'list
+                      (nconc fixed-ctypes
+                             (mapcar #'promote-varargs-type varargs-ctypes))
+                      (append fixed-syms
+                              (loop for sym in varargs-syms
+                                    and type in varargs-ctypes
+                                    if (eq type :float)
+                                    collect `(float ,sym 1.0d0)
+                                    else collect sym)))
+              (list (canonicalize-foreign-type rettype)))
+            ,@options))))))
+
+;;; For now, the only difference between this macro and
+;;; FOREIGN-FUNCALL is that it does argument promotion for that
+;;; variadic argument. This could be useful to call an hypothetical
+;;; %foreign-funcall-varargs on some hypothetical lisp on an
+;;; hypothetical platform that has different calling conventions for
+;;; varargs functions. :-)
+(defmacro foreign-funcall-varargs (name-and-options fixed-args
+                                   &rest varargs)
+  "Wrapper around %FOREIGN-FUNCALL that translates its arguments
+and does type promotion for the variadic arguments."
+  (let ((name (car (ensure-list name-and-options)))
+        (options (cdr (ensure-list name-and-options))))
+    (foreign-funcall-varargs-form name options fixed-args varargs nil)))
+
+(defmacro foreign-funcall-pointer-varargs (pointer options fixed-args
+                                           &rest varargs)
+  "Wrapper around %FOREIGN-FUNCALL-POINTER that translates its
+arguments and does type promotion for the variadic arguments."
+  (foreign-funcall-varargs-form pointer options fixed-args varargs t))
+
+;;;# Defining Foreign Functions
+;;;
+;;; The DEFCFUN macro provides a declarative interface for defining
+;;; Lisp functions that call foreign functions.
+
+;; If cffi-sys doesn't provide a defcfun-helper-forms,
+;; we define one that uses %foreign-funcall.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (fboundp 'defcfun-helper-forms)
+    (defun defcfun-helper-forms (name lisp-name rettype args types options)
+      (declare (ignore lisp-name))
+      (values
+       '()
+       `(%foreign-funcall ,name ,(append (mapcan #'list types args)
+                                         (list rettype))
+                          ,@options)))))
+
+(defun %defcfun (lisp-name foreign-name return-type args options docstring)
+  (let ((arg-names (mapcar #'car args))
+        (arg-types (mapcar #'cadr args))
+        (syms (make-gensym-list (length args))))
+    (multiple-value-bind (prelude caller)
+        (defcfun-helper-forms
+          foreign-name lisp-name (canonicalize-foreign-type return-type)
+          syms (mapcar #'canonicalize-foreign-type arg-types) options)
+      `(progn
+         ,prelude
+         (defun ,lisp-name ,arg-names
+           ,@(ensure-list docstring)
+           ,(translate-objects
+             syms arg-names arg-types return-type caller))))))
+
+(defun %defcfun-varargs (lisp-name foreign-name return-type args options doc)
+  (with-unique-names (varargs)
+    (let ((arg-names (mapcar #'car args)))
+      `(defmacro ,lisp-name (,@arg-names &rest ,varargs)
+         ,@(ensure-list doc)
+         `(foreign-funcall-varargs
+           ,'(,foreign-name ,@options)
+           ,,`(list ,@(loop for (name type) in args
+                            collect `',type collect name))
+           ,@,varargs
+           ,',return-type)))))
+
+;;; The following four functions take care of parsing DEFCFUN's first
+;;; argument whose syntax can be one of:
+;;;
+;;;     1.  string
+;;;     2.  symbol
+;;;     3.  \( string [symbol] options* )
+;;;     4.  \( symbol [string] options* )
+;;;
+;;; The string argument denotes the foreign function's name. The
+;;; symbol argument is used to name the Lisp function. If one isn't
+;;; present, its name is derived from the other. See the user
+;;; documentation for an explanation of the derivation rules.
+
+(defun lisp-name (spec &optional varp)
+  (etypecase spec
+    (list (if (keywordp (second spec))
+              (lisp-name (first spec) varp)
+              (if (symbolp (first spec))
+                  (first spec)
+                  (lisp-name (second spec) varp))))
+    (string (intern
+             (format nil (if varp "*~A*" "~A")
+                     (canonicalize-symbol-name-case
+                      (substitute #\- #\_ spec)))))
+    (symbol spec)))
+
+(defun foreign-name (spec &optional varp)
+  (etypecase spec
+    (list (if (stringp (second spec))
+              (second spec)
+              (foreign-name (first spec) varp)))
+    (string spec)
+    (symbol (let ((name (substitute #\_ #\-
+                                    (string-downcase (symbol-name spec)))))
+              (if varp
+                  (string-trim '(#\*) name)
+                  name)))))
+
+(defun foreign-options (spec varp)
+  (let ((opts (if (listp spec)
+                  (if (keywordp (second spec))
+                      (cdr spec)
+                      (cddr spec))
+                  nil)))
+    (if varp
+        (funcall 'parse-defcvar-options opts)
+        (parse-function-options opts))))
+
+(defun parse-name-and-options (spec &optional varp)
+  (values (lisp-name spec varp)
+          (foreign-name spec varp)
+          (foreign-options spec varp)))
+
+;;; If we find a &REST token at the end of ARGS, it means this is a
+;;; varargs foreign function therefore we define a lisp macro using
+;;; %DEFCFUN-VARARGS. Otherwise, a lisp function is defined with
+;;; %DEFCFUN.
+(defmacro defcfun (name-and-options return-type &body args)
+  "Defines a Lisp function that calls a foreign function."
+  (let ((docstring (when (stringp (car args)) (pop args))))
+    (multiple-value-bind (lisp-name foreign-name options)
+        (parse-name-and-options name-and-options)
+      (if (eq (car (last args)) '&rest)
+          (%defcfun-varargs lisp-name foreign-name return-type
+                            (butlast args) options docstring)
+          (%defcfun lisp-name foreign-name return-type args options
+                    docstring)))))
+
+;;;# Defining Callbacks
+
+(defun inverse-translate-objects (args types declarations rettype call)
+  `(let (,@(loop for arg in args and type in types
+                 collect (list arg (expand-from-foreign
+                                    arg (parse-type type)))))
+     ,@declarations
+     ,(expand-to-foreign call (parse-type rettype))))
+
+(defun parse-defcallback-options (options)
+  (destructuring-bind (&key (calling-convention :cdecl)
+                            (cconv calling-convention))
+      options
+    (list :calling-convention cconv)))
+
+(defmacro defcallback (name-and-options return-type args &body body)
+  (multiple-value-bind (body docstring declarations)
+      (parse-body body)
+    (declare (ignore docstring))
+    (let ((arg-names (mapcar #'car args))
+          (arg-types (mapcar #'cadr args))
+          (name (car (ensure-list name-and-options)))
+          (options (cdr (ensure-list name-and-options))))
+      `(progn
+         (%defcallback ,name ,(canonicalize-foreign-type return-type)
+             ,arg-names ,(mapcar #'canonicalize-foreign-type arg-types)
+           ,(inverse-translate-objects
+             arg-names arg-types declarations return-type
+             `(block ,name ,@body))
+           ,@(parse-defcallback-options options))
+         ',name))))
+
+(declaim (inline get-callback))
+(defun get-callback (symbol)
+  (%callback symbol))
+
+(defmacro callback (name)
+  `(%callback ',name))
diff --git a/external/cffi.darcs/src/libraries.lisp b/external/cffi.darcs/src/libraries.lisp
new file mode 100644
index 0000000..2749d3c
--- /dev/null
+++ b/external/cffi.darcs/src/libraries.lisp
@@ -0,0 +1,280 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; libraries.lisp --- Finding and loading foreign libraries.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;; Copyright (C) 2006-2007, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi)
+
+;;;# Finding Foreign Libraries
+;;;
+;;; We offer two ways for the user of a CFFI library to define
+;;; his/her own library directories: *FOREIGN-LIBRARY-DIRECTORIES*
+;;; for regular libraries and *DARWIN-FRAMEWORK-DIRECTORIES* for
+;;; Darwin frameworks.
+;;;
+;;; These two special variables behave similarly to
+;;; ASDF:*CENTRAL-REGISTRY* as its arguments are evaluated before
+;;; being used. We used our MINI-EVAL instead of the full-blown EVAL
+;;; though.
+;;;
+;;; Only after failing to find a library through the normal ways
+;;; (eg: on Linux LD_LIBRARY_PATH, /etc/ld.so.cache, /usr/lib/, /lib)
+;;; do we try to find the library ourselves.
+
+(defvar *foreign-library-directories* '()
+  "List onto which user-defined library paths can be pushed.")
+
+(defvar *darwin-framework-directories*
+  '((merge-pathnames #p"Library/Frameworks/" (user-homedir-pathname))
+    #p"/Library/Frameworks/"
+    #p"/System/Library/Frameworks/")
+  "List of directories where Frameworks are searched for.")
+
+(defun mini-eval (form)
+  "Simple EVAL-like function to evaluate the elements of
+*FOREIGN-LIBRARY-DIRECTORIES* and *DARWIN-FRAMEWORK-DIRECTORIES*."
+  (typecase form
+    (cons (apply (car form) (mapcar #'mini-eval (cdr form))))
+    (symbol (symbol-value form))
+    (t form)))
+
+(defun find-file (path directories)
+  "Searches for PATH in a list of DIRECTORIES and returns the first it finds."
+  (some (lambda (directory) (probe-file (merge-pathnames path directory)))
+        directories))
+
+(defun find-darwin-framework (framework-name)
+  "Searches for FRAMEWORK-NAME in *DARWIN-FRAMEWORK-DIRECTORIES*."
+  (dolist (framework-directory *darwin-framework-directories*)
+    (let ((path (make-pathname
+                 :name framework-name
+                 :directory
+                 (append (pathname-directory (mini-eval framework-directory))
+                         (list (format nil "~A.framework" framework-name))))))
+      (when (probe-file path)
+        (return-from find-darwin-framework path)))))
+
+;;;# Defining Foreign Libraries
+;;;
+;;; Foreign libraries can be defined using the
+;;; DEFINE-FOREIGN-LIBRARY macro. Example usage:
+;;;
+;;; (define-foreign-library opengl
+;;;   (:darwin  (:framework "OpenGL"))
+;;;   (:unix    (:or "libGL.so" "libGL.so.1"
+;;;                  #p"/myhome/mylibGL.so"))
+;;;   (:windows "opengl32.dll")
+;;;   ;; an hypothetical example of a particular platform
+;;;   ((:and :some-system :some-cpu) "libGL-support.lib")
+;;;   ;; if no other clauses apply, this one will and a type will be
+;;;   ;; automagically appended to the name passed to :default
+;;;   (t (:default "libGL")))
+;;;
+;;; This information is stored in the *FOREIGN-LIBRARIES* hashtable
+;;; and when the library is loaded through LOAD-FOREIGN-LIBRARY (or
+;;; USE-FOREIGN-LIBRARY) the first clause matched by CFFI-FEATURE-P is
+;;; processed.
+
+(defvar *foreign-libraries* (make-hash-table :test 'eq)
+  "Hashtable of defined libraries.")
+
+(defun get-foreign-library (lib)
+  "Look up a library by NAME, signalling an error if not found."
+  (if (typep lib 'foreign-library)
+      lib
+      (or (gethash lib *foreign-libraries*)
+          (error "Undefined foreign library: ~S" lib))))
+
+(defun (setf get-foreign-library) (value name)
+  (setf (gethash name *foreign-libraries*) value))
+
+(defclass foreign-library ()
+  ((spec :initarg :spec)
+   (options :initform nil :initarg :options)
+   (handle :initarg :handle :accessor foreign-library-handle)))
+
+(defun %foreign-library-spec (lib)
+  (assoc-if #'cffi-feature-p (slot-value lib 'spec)))
+
+(defun foreign-library-spec (lib)
+  (second (%foreign-library-spec lib)))
+
+(defun foreign-library-options (lib)
+  (append (cddr (%foreign-library-spec lib))
+          (slot-value lib 'options)))
+
+;;; Warn about unkown options.
+(defmethod initialize-instance :after ((lib foreign-library) &key)
+  (loop for (opt nil)
+        on (append (slot-value lib 'options)
+                   (mapcan (lambda (x) (copy-list (cddr x)))
+                           (slot-value lib 'spec)))
+        by #'cddr
+        when (not (member opt '(:cconv :calling-convention)))
+        do (warn "Unkown option: ~A" opt)))
+
+(defmacro define-foreign-library (name-and-options &body pairs)
+  "Defines a foreign library NAME that can be posteriorly used with
+the USE-FOREIGN-LIBRARY macro."
+  (destructuring-bind (name . options)
+      (ensure-list name-and-options)
+    `(progn
+       (setf (get-foreign-library ',name)
+             (make-instance 'foreign-library
+                            :spec ',pairs :options ',options))
+       ',name)))
+
+;;;# LOAD-FOREIGN-LIBRARY-ERROR condition
+;;;
+;;; The various helper functions that load foreign libraries can
+;;; signal this error when something goes wrong. We ignore the host's
+;;; error. We should probably reuse its error message.
+
+(define-condition load-foreign-library-error (simple-error)
+  ())
+
+(defun read-new-value ()
+  (format *query-io* "~&Enter a new value (unevaluated): ")
+  (force-output *query-io*)
+  (read *query-io*))
+
+(defun fl-error (control &rest arguments)
+  (error 'load-foreign-library-error
+         :format-control control
+         :format-arguments arguments))
+
+;;;# Loading Foreign Libraries
+
+(defun load-darwin-framework (name framework-name)
+  "Tries to find and load a darwin framework in one of the directories
+in *DARWIN-FRAMEWORK-DIRECTORIES*. If unable to find FRAMEWORK-NAME,
+it signals a LOAD-FOREIGN-LIBRARY-ERROR."
+  (let ((framework (find-darwin-framework framework-name)))
+    (if framework
+        (load-foreign-library-path name (native-namestring framework))
+        (fl-error "Unable to find framework ~A" framework-name))))
+
+(defun report-simple-error (name error)
+  (fl-error "Unable to load foreign library (~A).~%  ~A"
+            name
+            (format nil "~?" (simple-condition-format-control error)
+                    (simple-condition-format-arguments error))))
+
+;;; FIXME: haven't double checked whether all Lisps signal a
+;;; SIMPLE-ERROR on %load-foreign-library failure.  In any case they
+;;; should be throwing a more specific error.
+(defun load-foreign-library-path (name path)
+  "Tries to load PATH using %LOAD-FOREIGN-LIBRARY which should try and
+find it using the OS's usual methods. If that fails we try to find it
+ourselves."
+  (handler-case
+      (%load-foreign-library name path)
+    (error (error)
+      (bif (file (find-file path *foreign-library-directories*))
+           (handler-case
+               (%load-foreign-library name (native-namestring file))
+             (simple-error (error)
+               (report-simple-error name error)))
+           (report-simple-error name error)))))
+
+(defun try-foreign-library-alternatives (name library-list)
+  "Goes through a list of alternatives and only signals an error when
+none of alternatives were successfully loaded."
+  (dolist (lib library-list)
+    (let-when (handle (ignore-errors (load-foreign-library-helper name lib)))
+      (return-from try-foreign-library-alternatives handle)))
+  ;; Perhaps we should show the error messages we got for each
+  ;; alternative if we can figure out a nice way to do that.
+  (fl-error "Unable to load any of the alternatives:~%   ~S" library-list))
+
+(defparameter *cffi-feature-suffix-map*
+  '((cffi-features:windows . ".dll")
+    (cffi-features:darwin . ".dylib")
+    (cffi-features:unix . ".so"))
+  "Mapping of OS feature keywords to shared library suffixes.")
+
+(defun default-library-suffix ()
+  "Return a string to use as default library suffix based on the
+operating system.  This is used to implement the :DEFAULT option.
+This will need to be extended as we test on more OSes."
+  (or (cdr (assoc-if #'cffi-feature-p *cffi-feature-suffix-map*))
+      (fl-error "Unable to determine the default library suffix on this OS.")))
+
+(defun load-foreign-library-helper (name thing)
+  (etypecase thing
+    (string
+     (load-foreign-library-path name thing))
+    (pathname
+     (load-foreign-library-path name (namestring thing)))
+    (cons
+     (ecase (first thing)
+       (:framework (load-darwin-framework name (second thing)))
+       (:default
+        (unless (stringp (second thing))
+          (fl-error "Argument to :DEFAULT must be a string."))
+        (load-foreign-library-path
+         name (concatenate 'string (second thing) (default-library-suffix))))
+       (:or (try-foreign-library-alternatives name (rest thing)))))))
+
+(defun load-foreign-library (library)
+  "Loads a foreign LIBRARY which can be a symbol denoting a library defined
+through DEFINE-FOREIGN-LIBRARY; a pathname or string in which case we try to
+load it directly first then search for it in *FOREIGN-LIBRARY-DIRECTORIES*;
+or finally list: either (:or lib1 lib2) or (:framework )."
+  (restart-case
+      (typecase library
+        (symbol
+         (let* ((lib (get-foreign-library library))
+                (spec (foreign-library-spec lib)))
+           (when spec
+             (setf (foreign-library-handle lib)
+                   (load-foreign-library-helper library spec))
+             lib)))
+        (t
+         (make-instance 'foreign-library :spec (list (list library))
+                        :handle (load-foreign-library-helper nil library))))
+    ;; Offer these restarts that will retry the call to
+    ;; LOAD-FOREIGN-LIBRARY.
+    (retry ()
+      :report "Try loading the foreign library again."
+      (load-foreign-library library))
+    (use-value (new-library)
+      :report "Use another library instead."
+      :interactive read-new-value
+      (load-foreign-library new-library))))
+
+(defmacro use-foreign-library (name)
+  `(load-foreign-library ',name))
+
+;;;# Closing Foreign Libraries
+
+(defun close-foreign-library (library)
+  "Closes a foreign library."
+  (let ((lib (get-foreign-library library)))
+    (when (foreign-library-handle lib)
+      (%close-foreign-library (foreign-library-handle lib))
+      (setf (foreign-library-handle lib) nil)
+      t)))
diff --git a/external/cffi.darcs/src/package.lisp b/external/cffi.darcs/src/package.lisp
new file mode 100644
index 0000000..3b48d16
--- /dev/null
+++ b/external/cffi.darcs/src/package.lisp
@@ -0,0 +1,123 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; package.lisp --- Package definition for CFFI.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cl-user)
+
+(defpackage #:cffi
+  (:use #:common-lisp #:cffi-sys #:cffi-utils)
+  (:import-from #:cffi-features #:cffi-feature-p)
+  (:export
+   ;; Types.
+   #:foreign-pointer
+
+   ;; Primitive pointer operations.
+   #:foreign-free
+   #:foreign-alloc
+   #:mem-aref
+   #:mem-ref
+   #:pointerp
+   #:pointer-eq
+   #:null-pointer
+   #:null-pointer-p
+   #:inc-pointer
+   #:incf-pointer
+   #:with-foreign-pointer
+   #:make-pointer
+   #:pointer-address
+
+   ;; Shareable vectors.
+   #:make-shareable-byte-vector
+   #:with-pointer-to-vector-data
+
+   ;; Foreign string operations.
+   #:foreign-string-alloc
+   #:foreign-string-free
+   #:foreign-string-to-lisp
+   #:lisp-string-to-foreign
+   #:with-foreign-string
+   #:with-foreign-strings
+   #:with-foreign-pointer-as-string
+
+   ;; Foreign function operations.
+   #:defcfun
+   #:foreign-funcall
+   #:foreign-funcall-pointer
+
+   ;; Foreign library operations.
+   #:*foreign-library-directories*
+   #:*darwin-framework-directories*
+   #:define-foreign-library
+   #:load-foreign-library
+   #:load-foreign-library-error
+   #:use-foreign-library
+   #:close-foreign-library
+
+   ;; Callbacks.
+   #:callback
+   #:get-callback
+   #:defcallback
+
+   ;; Foreign type operations.
+   #:defcstruct
+   #:defcunion
+   #:defctype
+   #:defcenum
+   #:defbitfield
+   #:define-foreign-type
+   #:define-parse-method
+   #:foreign-enum-keyword
+   #:foreign-enum-keyword-list
+   #:foreign-enum-value
+   #:foreign-bitfield-symbol-list
+   #:foreign-bitfield-symbols
+   #:foreign-bitfield-value
+   #:foreign-slot-pointer
+   #:foreign-slot-value
+   #:foreign-slot-offset
+   #:foreign-slot-names
+   #:foreign-type-alignment
+   #:foreign-type-size
+   #:with-foreign-object
+   #:with-foreign-objects
+   #:with-foreign-slots
+   #:convert-to-foreign
+   #:convert-from-foreign
+   #:free-converted-object
+
+   ;; Extensible foreign type operations.
+   #:translate-to-foreign
+   #:translate-from-foreign
+   #:free-translated-object
+   #:expand-to-foreign-dyn
+   #:expand-to-foreign
+   #:expand-from-foreign
+
+   ;; Foreign globals.
+   #:defcvar
+   #:get-var-pointer
+   #:foreign-symbol-pointer
+   ))
diff --git a/external/cffi.darcs/src/strings.lisp b/external/cffi.darcs/src/strings.lisp
new file mode 100644
index 0000000..9148a1e
--- /dev/null
+++ b/external/cffi.darcs/src/strings.lisp
@@ -0,0 +1,138 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; strings.lisp --- Operations on foreign strings.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi)
+
+;;;# Foreign String Conversion
+;;;
+;;; Functions for converting NULL-terminated C-strings to Lisp strings
+;;; and vice versa.  Currently this is blithely ignorant of encoding
+;;; and assumes characters can fit in 8 bits.
+
+(defun lisp-string-to-foreign (string ptr size)
+  "Copy at most SIZE-1 characters from a Lisp STRING to PTR.
+The foreign string will be null-terminated."
+  (decf size)
+  (etypecase string
+    (string
+     (loop with i = 0 for char across string
+           while (< i size)
+           do (%mem-set (char-code char) ptr :unsigned-char (post-incf i))
+           finally (%mem-set 0 ptr :unsigned-char i)))
+    ((array (unsigned-byte 8))
+     (loop with i = 0 for elt across string
+           while (< i size)
+           do (%mem-set elt ptr :unsigned-char (post-incf i))
+           finally (%mem-set 0 ptr :unsigned-char i)))))
+
+(defun foreign-string-to-lisp (ptr &optional (size array-total-size-limit)
+                               (null-terminated-p t))
+  "Copy at most SIZE characters from PTR into a Lisp string.
+If PTR is a null pointer, returns nil."
+  (unless (null-pointer-p ptr)
+    (with-output-to-string (s)
+      (loop for i fixnum from 0 below size
+            for code = (mem-ref ptr :unsigned-char i)
+            until (and null-terminated-p (zerop code))
+            do (write-char (code-char code) s)))))
+
+;;;# Using Foreign Strings
+
+(defun foreign-string-alloc (string)
+  "Allocate a foreign string containing Lisp string STRING.
+The string must be freed with FOREIGN-STRING-FREE."
+  (check-type string (or string (array (unsigned-byte 8))))
+  (let* ((length (1+ (length string)))
+         (ptr (foreign-alloc :char :count length)))
+    (lisp-string-to-foreign string ptr length)
+    ptr))
+
+(defun foreign-string-free (ptr)
+  "Free a foreign string allocated by FOREIGN-STRING-ALLOC."
+  (foreign-free ptr))
+
+(defmacro with-foreign-string ((var lisp-string) &body body)
+  "Bind VAR to a foreign string containing LISP-STRING in BODY."
+  (with-unique-names (str length)
+    `(let* ((,str ,lisp-string)
+            (,length (progn
+                       (check-type ,str (or string (array (unsigned-byte 8))))
+                       (1+ (length ,str)))))
+       (with-foreign-pointer (,var ,length)
+         (lisp-string-to-foreign ,str ,var ,length)
+         ,@body))))
+
+(defmacro with-foreign-strings (bindings &body body)
+  (if bindings
+      `(with-foreign-string ,(first bindings)
+         (with-foreign-strings ,(rest bindings)
+           ,@body))
+      `(progn ,@body)))
+
+(defmacro with-foreign-pointer-as-string ((var size &optional size-var)
+                                          &body body)
+  "Like WITH-FOREIGN-POINTER except VAR as a Lisp string is used as
+the return value of an implicit PROGN around BODY."
+  `(with-foreign-pointer (,var ,size ,size-var)
+     (progn
+       ,@body
+       (foreign-string-to-lisp ,var))))
+
+;;;# Automatic Conversion of Foreign Strings
+
+(define-foreign-type foreign-string-type ()
+  ()
+  (:actual-type :pointer)
+  (:simple-parser :string))
+
+(defmethod translate-to-foreign ((s string) (type foreign-string-type))
+  (values (foreign-string-alloc s) t))
+
+(defmethod translate-to-foreign (obj (type foreign-string-type))
+  (cond
+    ((pointerp obj)
+     (values obj nil))
+    ((typep obj '(array (unsigned-byte 8)))
+     (values (foreign-string-alloc obj) t))
+    (t (error "~A is not a Lisp string, (array (unsigned-byte 8)) or pointer."
+              obj))))
+
+(defmethod translate-from-foreign (ptr (type foreign-string-type))
+  (foreign-string-to-lisp ptr))
+
+(defmethod free-translated-object (ptr (type foreign-string-type) free-p)
+  (when free-p
+    (foreign-string-free ptr)))
+
+;;; STRING+PTR
+
+(define-foreign-type foreign-string+ptr-type (foreign-string-type)
+  ()
+  (:simple-parser :string+ptr))
+
+(defmethod translate-from-foreign (value (type foreign-string+ptr-type))
+  (list (foreign-string-to-lisp value) value))
diff --git a/external/cffi.darcs/src/types.lisp b/external/cffi.darcs/src/types.lisp
new file mode 100644
index 0000000..36ce4bc
--- /dev/null
+++ b/external/cffi.darcs/src/types.lisp
@@ -0,0 +1,772 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; types.lisp --- User-defined CFFI types.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;; Copyright (C) 2005-2007, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi)
+
+;;;# Built-In Types
+
+(define-built-in-foreign-type :char)
+(define-built-in-foreign-type :unsigned-char)
+(define-built-in-foreign-type :short)
+(define-built-in-foreign-type :unsigned-short)
+(define-built-in-foreign-type :int)
+(define-built-in-foreign-type :unsigned-int)
+(define-built-in-foreign-type :long)
+(define-built-in-foreign-type :unsigned-long)
+(define-built-in-foreign-type :float)
+(define-built-in-foreign-type :double)
+(define-built-in-foreign-type :void)
+
+#-cffi-features:no-long-long
+(progn
+  (define-built-in-foreign-type :long-long)
+  (define-built-in-foreign-type :unsigned-long-long))
+
+;;; When some lisp other than SCL supports :long-double we should
+;;; use #-cffi-features:no-long-double here instead.
+#+(and scl long-float) (define-built-in-foreign-type :long-double)
+
+;;;# Foreign Pointers
+
+(define-modify-macro incf-pointer (&optional (offset 1)) inc-pointer)
+
+(defun mem-ref (ptr type &optional (offset 0))
+  "Return the value of TYPE at OFFSET bytes from PTR. If TYPE is aggregate,
+we don't return its 'value' but a pointer to it, which is PTR itself."
+  (let ((ptype (parse-type type)))
+    (if (aggregatep ptype)
+        (inc-pointer ptr offset)
+        (let ((raw-value (%mem-ref ptr (canonicalize ptype) offset)))
+          (translate-from-foreign raw-value ptype)))))
+
+(define-compiler-macro mem-ref (&whole form ptr type &optional (offset 0))
+  "Compiler macro to open-code MEM-REF when TYPE is constant."
+  (if (constantp type)
+      (let ((parsed-type (parse-type (eval type))))
+        (if (aggregatep parsed-type)
+            `(inc-pointer ,ptr ,offset)
+            (expand-from-foreign
+             `(%mem-ref ,ptr ,(canonicalize parsed-type) ,offset)
+             parsed-type)))
+      form))
+
+(defun mem-set (value ptr type &optional (offset 0))
+  "Set the value of TYPE at OFFSET bytes from PTR to VALUE."
+  (let ((ptype (parse-type type)))
+    (%mem-set (translate-to-foreign value ptype)
+              ptr (canonicalize ptype) offset)))
+
+(define-setf-expander mem-ref (ptr type &optional (offset 0) &environment env)
+  "SETF expander for MEM-REF that doesn't rebind TYPE.
+This is necessary for the compiler macro on MEM-SET to be able
+to open-code (SETF MEM-REF) forms."
+  (multiple-value-bind (dummies vals newval setter getter)
+      (get-setf-expansion ptr env)
+    (declare (ignore setter newval))
+    ;; if either TYPE or OFFSET are constant, we avoid rebinding them
+    ;; so that the compiler macros on MEM-SET and %MEM-SET work.
+    (with-unique-names (store type-tmp offset-tmp)
+      (values
+       (append (unless (constantp type)   (list type-tmp))
+               (unless (constantp offset) (list offset-tmp))
+               dummies)
+       (append (unless (constantp type)   (list type))
+               (unless (constantp offset) (list offset))
+               vals)
+       (list store)
+       `(progn
+          (mem-set ,store ,getter
+                   ,@(if (constantp type)   (list type)   (list type-tmp))
+                   ,@(if (constantp offset) (list offset) (list offset-tmp)))
+          ,store)
+       `(mem-ref ,getter
+                 ,@(if (constantp type)   (list type)   (list type-tmp))
+                 ,@(if (constantp offset) (list offset) (list offset-tmp)))))))
+
+(define-compiler-macro mem-set
+    (&whole form value ptr type &optional (offset 0))
+  "Compiler macro to open-code (SETF MEM-REF) when type is constant."
+  (if (constantp type)
+      (let ((parsed-type (parse-type (eval type))))
+        `(%mem-set ,(expand-to-foreign value parsed-type) ,ptr
+                   ,(canonicalize parsed-type) ,offset))
+      form))
+
+;;;# Dereferencing Foreign Arrays
+
+;;; Maybe this should be named MEM-SVREF? [2007-02-28 LO]
+(defun mem-aref (ptr type &optional (index 0))
+  "Like MEM-REF except for accessing 1d arrays."
+  (mem-ref ptr type (* index (foreign-type-size type))))
+
+(define-compiler-macro mem-aref (&whole form ptr type &optional (index 0))
+  "Compiler macro to open-code MEM-AREF when TYPE (and eventually INDEX)."
+  (if (constantp type)
+      (if (constantp index)
+          `(mem-ref ,ptr ,type
+                    ,(* (eval index) (foreign-type-size (eval type))))
+          `(mem-ref ,ptr ,type (* ,index ,(foreign-type-size (eval type)))))
+      form))
+
+(define-setf-expander mem-aref (ptr type &optional (index 0) &environment env)
+  "SETF expander for MEM-AREF."
+  (multiple-value-bind (dummies vals newval setter getter)
+      (get-setf-expansion ptr env)
+    (declare (ignore setter newval))
+    ;; we avoid rebinding type and index, if possible (and if type is not
+    ;; constant, we don't bother about the index), so that the compiler macros
+    ;; on MEM-SET or %MEM-SET can work.
+    (with-unique-names (store type-tmp index-tmp)
+      (values
+       (append (unless (constantp type)
+                 (list type-tmp))
+               (unless (and (constantp type) (constantp index))
+                 (list index-tmp))
+               dummies)
+       (append (unless (constantp type)
+                 (list type))
+               (unless (and (constantp type) (constantp index))
+                 (list index))
+               vals)
+       (list store)
+       ;; Here we'll try to calculate the offset from the type and index,
+       ;; or if not possible at least get the type size early.
+       `(progn
+          ,(if (constantp type)
+               (if (constantp index)
+                   `(mem-set ,store ,getter ,type
+                             ,(* (eval index) (foreign-type-size (eval type))))
+                   `(mem-set ,store ,getter ,type
+                             (* ,index-tmp ,(foreign-type-size (eval type)))))
+               `(mem-set ,store ,getter ,type-tmp
+                         (* ,index-tmp (foreign-type-size ,type-tmp))))
+          ,store)
+       `(mem-aref ,getter
+                  ,@(if (constantp type)
+                        (list type)
+                        (list type-tmp))
+                  ,@(if (and (constantp type) (constantp index))
+                        (list index)
+                        (list index-tmp)))))))
+
+(define-foreign-type foreign-array-type ()
+  ((dimensions :reader dimensions :initarg :dimensions)
+   (element-type :reader element-type :initarg :element-type))
+  (:actual-type :pointer))
+
+(defmethod print-object ((type foreign-array-type) stream)
+  "Print a FOREIGN-ARRAY-TYPE instance to STREAM unreadably."
+  (print-unreadable-object (type stream :type t :identity nil)
+    (format stream "~S ~S" (element-type type) (dimensions type))))
+
+(define-parse-method :array (element-type &rest dimensions)
+  (make-instance 'foreign-array-type
+                 :element-type element-type
+                 :dimensions dimensions))
+
+(defun array-element-size (array-type)
+  (foreign-type-size (element-type array-type)))
+
+(defun indexes-to-row-major-index (dimensions &rest subscripts)
+  (apply #'+ (maplist (lambda (x y)
+                        (* (car x) (apply #'* (cdr y))))
+                      subscripts
+                      dimensions)))
+
+(defun row-major-index-to-indexes (index dimensions)
+  (loop with idx = index
+        with rank = (length dimensions)
+        with indexes = (make-list rank)
+        for dim-index from (- rank 1) downto 0 do
+        (setf (values idx (nth dim-index indexes))
+              (floor idx (nth dim-index dimensions)))
+        finally (return indexes)))
+
+(defun lisp-array-to-foreign (array pointer array-type)
+  "Copy elements from a Lisp array to POINTER."
+  (let* ((type (follow-typedefs (parse-type array-type)))
+         (el-type (element-type type))
+         (dimensions (dimensions type)))
+    (loop with foreign-type-size = (array-element-size type)
+          with size = (reduce #'* dimensions)
+          for i from 0 below size
+          for offset = (* i foreign-type-size)
+          for element = (apply #'aref array
+                               (row-major-index-to-indexes i dimensions))
+          do (setf (mem-ref pointer el-type offset) element))))
+
+(defun foreign-array-to-lisp (pointer array-type)
+  "Copy elements from ptr into a Lisp array. If POINTER is a null
+pointer, returns NIL."
+  (unless (null-pointer-p pointer)
+    (let* ((type (follow-typedefs (parse-type array-type)))
+           (el-type (element-type type))
+           (dimensions (dimensions type))
+           (array (make-array dimensions)))
+      (loop with foreign-type-size = (array-element-size type)
+            with size = (reduce #'* dimensions)
+            for i from 0 below size
+            for offset = (* i foreign-type-size)
+            for element = (mem-ref pointer el-type offset)
+            do (setf (apply #'aref array
+                            (row-major-index-to-indexes i dimensions))
+                     element))
+      array)))
+
+(defun foreign-array-alloc (array array-type)
+  "Allocate a foreign array containing the elements of lisp array.
+The foreign array must be freed with foreign-array-free."
+  (check-type array array)
+  (let* ((type (follow-typedefs (parse-type array-type)))
+         (ptr (foreign-alloc (element-type type)
+                             :count (reduce #'* (dimensions type)))))
+    (lisp-array-to-foreign array ptr array-type)
+    ptr))
+
+(defun foreign-array-free (ptr)
+  "Free a foreign array allocated by foreign-array-alloc."
+  (foreign-free ptr))
+
+(defmacro with-foreign-array ((var lisp-array array-type) &body body)
+  "Bind var to a foreign array containing lisp-array elements in body."
+  (with-unique-names (type)
+    `(let ((,type (follow-typedefs (parse-type ,array-type))))
+       (with-foreign-pointer (,var (* (reduce #'* (dimensions ,type))
+                                      (array-element-size ,type)))
+         (lisp-array-to-foreign ,lisp-array ,var ,array-type)
+         ,@body))))
+
+(defun foreign-aref (ptr array-type &rest indexes)
+  (let* ((type (follow-typedefs (parse-type array-type)))
+         (offset (* (array-element-size type)
+                    (apply #'indexes-to-row-major-index
+                           (dimensions type) indexes))))
+    (mem-ref ptr (element-type type) offset)))
+
+(defun (setf foreign-aref) (value ptr array-type &rest indexes)
+  (let* ((type (follow-typedefs (parse-type array-type)))
+         (offset (* (array-element-size type)
+                    (apply #'indexes-to-row-major-index
+                           (dimensions type) indexes))))
+    (setf (mem-ref ptr (element-type type) offset) value)))
+
+;;; This type has defined type translators to allocate and free the
+;;; array.  It will also invoke type translators for each of the
+;;; array's element.  **But it doesn't free them yet**
+(define-foreign-type auto-array-type (foreign-array-type)
+  ())
+
+(define-parse-method :auto-array (element-type &rest dimensions)
+  (assert (>= (length dimensions) 1))
+  (make-instance 'auto-array-type
+                 :element-type element-type
+                 :dimensions dimensions))
+
+(defmethod translate-to-foreign (array (type auto-array-type))
+  (foreign-array-alloc array (unparse-type type)))
+
+(defmethod translate-from-foreign (pointer (type auto-array-type))
+  (foreign-array-to-lisp pointer (unparse-type type)))
+
+(defmethod free-translated-object (pointer (type auto-array-type) param)
+  (declare (ignore param))
+  (foreign-array-free pointer))
+
+;;;# Foreign Structures
+
+;;;## Foreign Structure Slots
+
+(defgeneric foreign-struct-slot-pointer (ptr slot)
+  (:documentation
+   "Get the address of SLOT relative to PTR."))
+
+(defgeneric foreign-struct-slot-pointer-form (ptr slot)
+  (:documentation
+   "Return a form to get the address of SLOT in PTR."))
+
+(defgeneric foreign-struct-slot-value (ptr slot)
+  (:documentation
+   "Return the value of SLOT in structure PTR."))
+
+(defgeneric (setf foreign-struct-slot-value) (value ptr slot)
+  (:documentation
+   "Set the value of a SLOT in structure PTR."))
+
+(defgeneric foreign-struct-slot-value-form (ptr slot)
+  (:documentation
+   "Return a form to get the value of SLOT in struct PTR."))
+
+(defgeneric foreign-struct-slot-set-form (value ptr slot)
+  (:documentation
+   "Return a form to set the value of SLOT in struct PTR."))
+
+(defclass foreign-struct-slot ()
+  ((name   :initarg :name   :reader   slot-name)
+   (offset :initarg :offset :accessor slot-offset)
+   (type   :initarg :type   :accessor slot-type))
+  (:documentation "Base class for simple and aggregate slots."))
+
+(defmethod foreign-struct-slot-pointer (ptr (slot foreign-struct-slot))
+  "Return the address of SLOT relative to PTR."
+  (inc-pointer ptr (slot-offset slot)))
+
+(defmethod foreign-struct-slot-pointer-form (ptr (slot foreign-struct-slot))
+  "Return a form to get the address of SLOT relative to PTR."
+  (let ((offset (slot-offset slot)))
+    (if (zerop offset)
+        ptr
+        `(inc-pointer ,ptr ,offset))))
+
+(defun foreign-slot-names (type)
+  "Returns a list of TYPE's slot names in no particular order."
+  (loop for value being the hash-values
+        in (slots (follow-typedefs (parse-type type)))
+        collect (slot-name value)))
+
+;;;### Simple Slots
+
+(defclass simple-struct-slot (foreign-struct-slot)
+  ()
+  (:documentation "Non-aggregate structure slots."))
+
+(defmethod foreign-struct-slot-value (ptr (slot simple-struct-slot))
+  "Return the value of a simple SLOT from a struct at PTR."
+  (mem-ref ptr (slot-type slot) (slot-offset slot)))
+
+(defmethod foreign-struct-slot-value-form (ptr (slot simple-struct-slot))
+  "Return a form to get the value of a slot from PTR."
+  `(mem-ref ,ptr ',(slot-type slot) ,(slot-offset slot)))
+
+(defmethod (setf foreign-struct-slot-value) (value ptr (slot simple-struct-slot))
+  "Set the value of a simple SLOT to VALUE in PTR."
+  (setf (mem-ref ptr (slot-type slot) (slot-offset slot)) value))
+
+(defmethod foreign-struct-slot-set-form (value ptr (slot simple-struct-slot))
+  "Return a form to set the value of a simple structure slot."
+  `(setf (mem-ref ,ptr ',(slot-type slot) ,(slot-offset slot)) ,value))
+
+;;;### Aggregate Slots
+
+(defclass aggregate-struct-slot (foreign-struct-slot)
+  ((count :initarg :count :accessor slot-count))
+  (:documentation "Aggregate structure slots."))
+
+;;; A case could be made for just returning an error here instead of
+;;; this rather DWIM-ish behavior to return the address.  It would
+;;; complicate being able to chain together slot names when accessing
+;;; slot values in nested structures though.
+(defmethod foreign-struct-slot-value (ptr (slot aggregate-struct-slot))
+  "Return a pointer to SLOT relative to PTR."
+  (foreign-struct-slot-pointer ptr slot))
+
+(defmethod foreign-struct-slot-value-form (ptr (slot aggregate-struct-slot))
+  "Return a form to get the value of SLOT relative to PTR."
+  (foreign-struct-slot-pointer-form ptr slot))
+
+;;; This is definitely an error though.  Eventually, we could define a
+;;; new type of type translator that can convert certain aggregate
+;;; types, notably C strings or arrays of integers.  For now, just error.
+(defmethod (setf foreign-struct-slot-value) (value ptr (slot aggregate-struct-slot))
+  "Signal an error; setting aggregate slot values is forbidden."
+  (declare (ignore value ptr))
+  (error "Cannot set value of aggregate slot ~A." slot))
+
+(defmethod foreign-struct-slot-set-form (value ptr (slot aggregate-struct-slot))
+  "Signal an error; setting aggregate slot values is forbidden."
+  (declare (ignore value ptr))
+  (error "Cannot set value of aggregate slot ~A." slot))
+
+;;;## Defining Foreign Structures
+
+(defun make-struct-slot (name offset type count)
+  "Make the appropriate type of structure slot."
+  ;; If TYPE is an aggregate type or COUNT is >1, create an
+  ;; AGGREGATE-STRUCT-SLOT, otherwise a SIMPLE-STRUCT-SLOT.
+  (if (or (> count 1) (aggregatep (parse-type type)))
+      (make-instance 'aggregate-struct-slot :offset offset :type type
+                     :name name :count count)
+      (make-instance 'simple-struct-slot :offset offset :type type
+                     :name name)))
+
+;;; Regarding structure alignment, the following ABIs were checked:
+;;;   - System-V ABI: x86, x86-64, ppc, arm, mips and itanium. (more?)
+;;;   - Mac OS X ABI Function Call Guide: ppc32, ppc64 and x86.
+;;;
+;;; Rules used here:
+;;;
+;;;   1. "An entire structure or union object is aligned on the same
+;;;       boundary as its most strictly aligned member."
+;;;
+;;;   2. "Each member is assigned to the lowest available offset with
+;;;       the appropriate alignment. This may require internal
+;;;       padding, depending on the previous member."
+;;;
+;;;   3. "A structure's size is increased, if necessary, to make it a
+;;;       multiple of the alignment. This may require tail padding,
+;;;       depending on the last member."
+;;;
+;;; Special cases from darwin/ppc32's ABI:
+;;; http://developer.apple.com/documentation/DeveloperTools/Conceptual/LowLevelABI/index.html
+;;;
+;;;   4. "The embedding alignment of the first element in a data
+;;;       structure is equal to the element's natural alignment."
+;;;
+;;;   5. "For subsequent elements that have a natural alignment
+;;;       greater than 4 bytes, the embedding alignment is 4, unless
+;;;       the element is a vector."  (note: this applies for
+;;;       structures too)
+
+;; FIXME: get a better name for this. --luis
+(defun get-alignment (type alignment-type firstp)
+  "Return alignment for TYPE according to ALIGNMENT-TYPE."
+  (declare (ignorable firstp))
+  (ecase alignment-type
+    (:normal #-(and cffi-features:darwin cffi-features:ppc32)
+             (foreign-type-alignment type)
+             #+(and cffi-features:darwin cffi-features:ppc32)
+             (if firstp
+                 (foreign-type-alignment type)
+                 (min 4 (foreign-type-alignment type))))))
+
+(defun adjust-for-alignment (type offset alignment-type firstp)
+  "Return OFFSET aligned properly for TYPE according to ALIGNMENT-TYPE."
+  (let* ((align (get-alignment type alignment-type firstp))
+         (rem (mod offset align)))
+    (if (zerop rem)
+        offset
+        (+ offset (- align rem)))))
+
+(defun notice-foreign-struct-definition (name-and-options slots)
+  "Parse and install a foreign structure definition."
+  (destructuring-bind (name &key size (class 'foreign-struct-type))
+      (ensure-list name-and-options)
+    (let ((struct (make-instance class :name name))
+          (current-offset 0)
+          (max-align 1)
+          (firstp t))
+      ;; determine offsets
+      (dolist (slotdef slots)
+        (destructuring-bind (slotname type &key (count 1) offset) slotdef
+          (when (eq (canonicalize-foreign-type type) :void)
+            (error "void type not allowed in structure definition: ~S" slotdef))
+          (setq current-offset
+                (or offset
+                    (adjust-for-alignment type current-offset :normal firstp)))
+          (let* ((slot (make-struct-slot slotname current-offset type count))
+                 (align (get-alignment (slot-type slot) :normal firstp)))
+            (setf (gethash slotname (slots struct)) slot)
+            (when (> align max-align)
+              (setq max-align align)))
+          (incf current-offset (* count (foreign-type-size type))))
+        (setq firstp nil))
+      ;; calculate padding and alignment
+      (setf (alignment struct) max-align) ; See point 1 above.
+      (let ((tail-padding (- max-align (rem current-offset max-align))))
+        (unless (= tail-padding max-align) ; See point 3 above.
+          (incf current-offset tail-padding)))
+      (setf (size struct) (or size current-offset))
+      (notice-foreign-type name struct))))
+
+(defmacro defcstruct (name-and-options &body fields)
+  "Define the layout of a foreign structure."
+  (discard-docstring fields)
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     ;; n-f-s-d could do with this with mop:ensure-class.
+     ,(let-when (class (getf (cdr (ensure-list name-and-options)) :class))
+        `(defclass ,class (foreign-struct-type) ()))
+     (notice-foreign-struct-definition ',name-and-options ',fields)))
+
+;;;## Accessing Foreign Structure Slots
+
+(defun get-slot-info (type slot-name)
+  "Return the slot info for SLOT-NAME or raise an error."
+  (let* ((struct (follow-typedefs (parse-type type)))
+         (info (gethash slot-name (slots struct))))
+    (unless info
+      (error "Undefined slot ~A in foreign type ~A." slot-name type))
+    info))
+
+(defun foreign-slot-pointer (ptr type slot-name)
+  "Return the address of SLOT-NAME in the structure at PTR."
+  (foreign-struct-slot-pointer ptr (get-slot-info type slot-name)))
+
+(defun foreign-slot-offset (type slot-name)
+  "Return the offset of SLOT in a struct TYPE."
+  (slot-offset (get-slot-info type slot-name)))
+
+(defun foreign-slot-value (ptr type slot-name)
+  "Return the value of SLOT-NAME in the foreign structure at PTR."
+  (foreign-struct-slot-value ptr (get-slot-info type slot-name)))
+
+(define-compiler-macro foreign-slot-value (&whole form ptr type slot-name)
+  "Optimizer for FOREIGN-SLOT-VALUE when TYPE is constant."
+  (if (and (constantp type) (constantp slot-name))
+      (foreign-struct-slot-value-form
+       ptr (get-slot-info (eval type) (eval slot-name)))
+      form))
+
+(define-setf-expander foreign-slot-value (ptr type slot-name &environment env)
+  "SETF expander for FOREIGN-SLOT-VALUE."
+  (multiple-value-bind (dummies vals newval setter getter)
+      (get-setf-expansion ptr env)
+    (declare (ignore setter newval))
+    (if (and (constantp type) (constantp slot-name))
+        ;; if TYPE and SLOT-NAME are constant we avoid rebinding them
+        ;; so that the compiler macro on FOREIGN-SLOT-SET works.
+        (with-unique-names (store)
+          (values
+           dummies
+           vals
+           (list store)
+           `(progn
+              (foreign-slot-set ,store ,getter ,type ,slot-name)
+              ,store)
+           `(foreign-slot-value ,getter ,type ,slot-name)))
+        ;; if not...
+        (with-unique-names (store slot-name-tmp type-tmp)
+          (values
+           (list* type-tmp slot-name-tmp dummies)
+           (list* type slot-name vals)
+           (list store)
+           `(progn
+              (foreign-slot-set ,store ,getter ,type-tmp ,slot-name-tmp)
+              ,store)
+           `(foreign-slot-value ,getter ,type-tmp ,slot-name-tmp))))))
+
+(defun foreign-slot-set (value ptr type slot-name)
+  "Set the value of SLOT-NAME in a foreign structure."
+  (setf (foreign-struct-slot-value ptr (get-slot-info type slot-name)) value))
+
+(define-compiler-macro foreign-slot-set
+    (&whole form value ptr type slot-name)
+  "Optimizer when TYPE and SLOT-NAME are constant."
+  (if (and (constantp type) (constantp slot-name))
+      (foreign-struct-slot-set-form
+       value ptr (get-slot-info (eval type) (eval slot-name)))
+      form))
+
+(defmacro with-foreign-slots ((vars ptr type) &body body)
+  "Create local symbol macros for each var in VARS to reference
+foreign slots in PTR of TYPE.  Similar to WITH-SLOTS."
+  (let ((ptr-var (gensym "PTR")))
+    `(let ((,ptr-var ,ptr))
+       (symbol-macrolet
+           ,(loop for var in vars
+                  collect `(,var (foreign-slot-value ,ptr-var ',type ',var)))
+         ,@body))))
+
+;;;# Foreign Unions
+;;;
+;;; A union is a FOREIGN-STRUCT-TYPE in which all slots have an offset
+;;; of zero.
+
+;;; See also the notes regarding ABI requirements in
+;;; NOTICE-FOREIGN-STRUCT-DEFINITION
+(defun notice-foreign-union-definition (name-and-options slots)
+  "Parse and install a foreign union definition."
+  (destructuring-bind (name &key size)
+      (ensure-list name-and-options)
+    (let ((struct (make-instance 'foreign-struct-type :name name))
+          (max-size 0)
+          (max-align 0))
+      (dolist (slotdef slots)
+        (destructuring-bind (slotname type &key (count 1)) slotdef
+          (when (eq (canonicalize-foreign-type type) :void)
+            (error "void type not allowed in union definition: ~S" slotdef))
+          (let* ((slot (make-struct-slot slotname 0 type count))
+                 (size (* count (foreign-type-size type)))
+                 (align (foreign-type-alignment (slot-type slot))))
+            (setf (gethash slotname (slots struct)) slot)
+            (when (> size max-size)
+              (setf max-size size))
+            (when (> align max-align)
+              (setf max-align align)))))
+      (setf (size struct) (or size max-size))
+      (setf (alignment struct) max-align)
+      (notice-foreign-type name struct))))
+
+(defmacro defcunion (name &body fields)
+  "Define the layout of a foreign union."
+  (discard-docstring fields)
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (notice-foreign-union-definition ',name ',fields)))
+
+;;;# Operations on Types
+
+(defmethod foreign-type-alignment (type)
+  "Return the alignment in bytes of a foreign type."
+  (foreign-type-alignment (parse-type type)))
+
+(defun foreign-alloc (type &key (initial-element nil initial-element-p)
+                      (initial-contents nil initial-contents-p)
+                      (count 1 count-p) null-terminated-p)
+  "Allocate enough memory to hold COUNT objects of type TYPE. If
+INITIAL-ELEMENT is supplied, each element of the newly allocated
+memory is initialized with its value. If INITIAL-CONTENTS is supplied,
+each of its elements will be used to initialize the contents of the
+newly allocated memory."
+  (let (contents-length)
+    ;; Some error checking, etc...
+    (when (and null-terminated-p
+               (not (eq (canonicalize-foreign-type type) :pointer)))
+      (error "Cannot use :NULL-TERMINATED-P with non-pointer types."))
+    (when (and initial-element-p initial-contents-p)
+      (error "Cannot specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
+    (when initial-contents-p
+      (setq contents-length (length initial-contents))
+      (if count-p
+          (assert (>= count contents-length))
+          (setq count contents-length)))
+    ;; Everything looks good.
+    (let ((ptr (%foreign-alloc (* (foreign-type-size type)
+                                  (if null-terminated-p (1+ count) count)))))
+      (when initial-element-p
+        (dotimes (i count)
+          (setf (mem-aref ptr type i) initial-element)))
+      (when initial-contents-p
+        (dotimes (i contents-length)
+          (setf (mem-aref ptr type i) (elt initial-contents i))))
+      (when null-terminated-p
+        (setf (mem-aref ptr :pointer count) (null-pointer)))
+      ptr)))
+
+;;; Stuff we could optimize here:
+;;;   1. (and (constantp type) (constantp count)) => calculate size
+;;;   2. (constantp type) => use the translators' expanders
+#-(and)
+(define-compiler-macro foreign-alloc
+    (&whole form type &key (initial-element nil initial-element-p)
+     (initial-contents nil initial-contents-p) (count 1 count-p))
+  )
+
+(defmacro with-foreign-object ((var type &optional (count 1)) &body body)
+  "Bind VAR to a pointer to COUNT objects of TYPE during BODY.
+The buffer has dynamic extent and may be stack allocated."
+  `(with-foreign-pointer
+       (,var ,(if (constantp type)
+                  ;; with-foreign-pointer may benefit from constant folding:
+                  (if (constantp count)
+                      (* (eval count) (foreign-type-size (eval type)))
+                      `(* ,count ,(foreign-type-size (eval type))))
+                  `(* ,count (foreign-type-size ,type))))
+     ,@body))
+
+(defmacro with-foreign-objects (bindings &body body)
+  (if bindings
+      `(with-foreign-object ,(car bindings)
+         (with-foreign-objects ,(cdr bindings)
+           ,@body))
+      `(progn ,@body)))
+
+;;;## Anonymous Type Translators
+;;;
+;;; (:wrapper :to-c some-function :from-c another-function)
+;;;
+;;; TODO: We will need to add a FREE function to this as well I think.
+;;; --james
+
+(define-foreign-type foreign-type-wrapper ()
+  ((to-c   :initarg :to-c   :reader wrapper-to-c)
+   (from-c :initarg :from-c :reader wrapper-from-c))
+  (:documentation "Wrapper type."))
+
+(define-parse-method :wrapper (base-type &key to-c from-c)
+  (make-instance 'foreign-type-wrapper
+                 :actual-type (parse-type base-type)
+                 :to-c (or to-c 'identity)
+                 :from-c (or from-c 'identity)))
+
+(defmethod translate-to-foreign (value (type foreign-type-wrapper))
+  (translate-to-foreign
+   (funcall (slot-value type 'to-c) value) (actual-type type)))
+
+(defmethod translate-from-foreign (value (type foreign-type-wrapper))
+  (funcall (slot-value type 'from-c)
+           (translate-from-foreign value (actual-type type))))
+
+;;;# Other types
+
+;;; Boolean type. Maps to an :int by default. Only accepts integer types.
+(define-foreign-type foreign-boolean-type ()
+  ())
+
+(define-parse-method :boolean (&optional (base-type :int))
+  (make-instance
+   'foreign-boolean-type :actual-type
+   (ecase (canonicalize-foreign-type base-type)
+     ((:char :unsigned-char :int :unsigned-int :long :unsigned-long
+       #-cffi-features:no-long-long :long-long
+       #-cffi-features:no-long-long :unsigned-long-long) base-type))))
+
+(defmethod translate-to-foreign (value (type foreign-boolean-type))
+  (if value 1 0))
+
+(defmethod translate-from-foreign (value (type foreign-boolean-type))
+  (not (zerop value)))
+
+(defmethod expand-to-foreign (value (type foreign-boolean-type))
+  "Optimization for the :boolean type."
+  (if (constantp value)
+      (if (eval value) 1 0)
+      `(if ,value 1 0)))
+
+(defmethod expand-from-foreign (value (type foreign-boolean-type))
+  "Optimization for the :boolean type."
+  (if (constantp value) ; very unlikely, heh
+      (not (zerop (eval value)))
+      `(not (zerop ,value))))
+
+;;;# Typedefs for built-in types.
+
+(defctype :uchar  :unsigned-char)
+(defctype :ushort :unsigned-short)
+(defctype :uint   :unsigned-int)
+(defctype :ulong  :unsigned-long)
+
+#-cffi-features:no-long-long
+(progn
+  (defctype :llong  :long-long)
+  (defctype :ullong :unsigned-long-long))
+
+;;; We try to define the :[u]int{8,16,32,64} types by looking at
+;;; the sizes of the built-in integer types and defining typedefs.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (macrolet
+      ((match-types (sized-types mtypes)
+         `(progn
+            ,@(loop for (type . size) in sized-types
+                    for m = (car (member size mtypes :key #'foreign-type-size))
+                    when m collect `(defctype ,type ,m)))))
+    ;; signed
+    (match-types ((:int8 . 1) (:int16 . 2) (:int32 . 4) (:int64 . 8))
+                 (:char :short :int :long
+                  #-cffi-features:no-long-long :long-long))
+    ;; unsigned
+    (match-types ((:uint8 . 1) (:uint16 . 2) (:uint32 . 4) (:uint64 . 8))
+                 (:unsigned-char :unsigned-short :unsigned-int :unsigned-long
+                  #-cffi-features:no-long-long :unsigned-long-long))))
diff --git a/external/cffi.darcs/src/utils.lisp b/external/cffi.darcs/src/utils.lisp
new file mode 100644
index 0000000..0f19576
--- /dev/null
+++ b/external/cffi.darcs/src/utils.lisp
@@ -0,0 +1,200 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; utils.lisp --- Various utilities.
+;;;
+;;; Copyright (C) 2005-2006, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cl-user)
+
+(defpackage #:cffi-utils
+  (:use #:common-lisp)
+  (:export #:discard-docstring
+           #:parse-body
+           #:with-unique-names
+           #:once-only
+           #:ensure-list
+           #:make-gensym-list
+           #:symbolicate
+           #:let-when
+           #:bif
+           #:post-incf
+           #:single-bit-p
+           #:warn-if-kw-or-belongs-to-cl))
+
+(in-package #:cffi-utils)
+
+;;;# General Utilities
+
+;;; frodef's, see: http://paste.lisp.org/display/2771#1
+(defmacro post-incf (place &optional (delta 1) &environment env)
+  "Increment PLACE by DELTA and return its previous value."
+  (multiple-value-bind (dummies vals new setter getter)
+      (get-setf-expansion place env)
+    `(let* (,@(mapcar #'list dummies vals) (,(car new) ,getter))
+       (prog1 ,(car new)
+         (setq ,(car new) (+ ,(car new) ,delta))
+         ,setter))))
+
+(defun ensure-list (x)
+  "Make into list if atom."
+  (if (listp x) x (list x)))
+
+(defmacro discard-docstring (body-var &optional force)
+  "Discards the first element of the list in body-var if it's a
+string and the only element (or if FORCE is T)."
+  `(when (and (stringp (car ,body-var)) (or ,force (cdr ,body-var)))
+     (pop ,body-var)))
+
+;;; Parse a body of code, removing an optional documentation string
+;;; and declaration forms.  Returns the actual body, docstring, and
+;;; declarations as three multiple values.
+(defun parse-body (body)
+  (let ((docstring nil)
+        (declarations nil))
+    (when (and (stringp (car body)) (cdr body))
+      (setf docstring (pop body)))
+    (loop while (and (consp (car body)) (eql (caar body) 'cl:declare))
+          do (push (pop body) declarations))
+    (values body docstring (nreverse declarations))))
+
+;;; LET-IF (renamed to BIF) and LET-WHEN taken from KMRCL
+(defmacro let-when ((var test-form) &body body)
+  `(let ((,var ,test-form))
+      (when ,var ,@body)))
+
+(defmacro bif ((var test-form) if-true &optional if-false)
+  `(let ((,var ,test-form))
+      (if ,var ,if-true ,if-false)))
+
+;;; ONCE-ONLY macro taken from PAIP
+(defun starts-with (list x)
+  "Is x a list whose first element is x?"
+  (and (consp list) (eql (first list) x)))
+
+(defun side-effect-free? (exp)
+  "Is exp a constant, variable, or function,
+  or of the form (THE type x) where x is side-effect-free?"
+  (or (atom exp) (constantp exp)
+      (starts-with exp 'function)
+      (and (starts-with exp 'the)
+           (side-effect-free? (third exp)))))
+
+(defmacro once-only (variables &rest body)
+  "Returns the code built by BODY.  If any of VARIABLES
+  might have side effects, they are evaluated once and stored
+  in temporary variables that are then passed to BODY."
+  (assert (every #'symbolp variables))
+  (let ((temps nil))
+    (dotimes (i (length variables)) (push (gensym "ONCE") temps))
+    `(if (every #'side-effect-free? (list .,variables))
+         (progn .,body)
+         (list 'let
+               ,`(list ,@(mapcar #'(lambda (tmp var)
+                                     `(list ',tmp ,var))
+                                 temps variables))
+               (let ,(mapcar #'(lambda (var tmp) `(,var ',tmp))
+                             variables temps)
+                 .,body)))))
+
+;;;; The following utils were taken from SBCL's
+;;;; src/code/*-extensions.lisp
+
+;;; Automate an idiom often found in macros:
+;;;   (LET ((FOO (GENSYM "FOO"))
+;;;         (MAX-INDEX (GENSYM "MAX-INDEX-")))
+;;;     ...)
+;;;
+;;; "Good notation eliminates thought." -- Eric Siggia
+;;;
+;;; Incidentally, this is essentially the same operator which
+;;; _On Lisp_ calls WITH-GENSYMS.
+(defmacro with-unique-names (symbols &body body)
+  `(let ,(mapcar (lambda (symbol)
+                   (let* ((symbol-name (symbol-name symbol))
+                          (stem (if (every #'alpha-char-p symbol-name)
+                                    symbol-name
+                                    (concatenate 'string symbol-name "-"))))
+                     `(,symbol (gensym ,stem))))
+                 symbols)
+     ,@body))
+
+(defun make-gensym-list (n)
+  "Return a list of N gensyms."
+  (loop repeat n collect (gensym)))
+
+(defun symbolicate (&rest things)
+  "Concatenate together the names of some strings and symbols,
+producing a symbol in the current package."
+  (let* ((length (reduce #'+ things
+                         :key (lambda (x) (length (string x)))))
+         (name (make-array length :element-type 'character)))
+    (let ((index 0))
+      (dolist (thing things (values (intern name)))
+        (let* ((x (string thing))
+               (len (length x)))
+          (replace name x :start1 index)
+          (incf index len))))))
+
+(defun single-bit-p (integer)
+  "Answer whether INTEGER, which must be an integer, is a single
+set twos-complement bit."
+  (if (<= integer 0)
+    nil                       ;infinite set bits for negatives
+    (loop until (logbitp 0 integer)
+         do (setf integer (ash integer -1))
+         finally (return (zerop (ash integer -1))))))
+
+;;; This function is here because it needs to be defined early.
+;;;
+;;; This function is used by DEFINE-PARSE-METHOD and DEFCTYPE to warn
+;;; users when they're defining types whose names belongs to the
+;;; KEYWORD or CL packages.  CFFI itself gets to use keywords without
+;;; a warning though.
+(defun warn-if-kw-or-belongs-to-cl (name)
+  (let ((package (symbol-package name)))
+    (when (or (eq package (find-package '#:cl))
+              (and (not (eq *package* (find-package '#:cffi)))
+                   (eq package (find-package '#:keyword))))
+      (warn "Defining a foreign type named ~S.  This symbol belongs to the ~A ~
+             package and that may interfere with other code using CFFI."
+            name (package-name package)))))
+
+;(defun deprecation-warning (bad-name &optional good-name)
+;  (warn "using deprecated ~S~@[, should use ~S instead~]"
+;        bad-name
+;        good-name))
+
+;;; Anaphoric macros
+;(defmacro awhen (test &body body)
+;  `(let ((it ,test))
+;     (when it ,@body)))
+
+;(defmacro acond (&rest clauses)
+;  (if (null clauses)
+;      `()
+;      (destructuring-bind ((test &body body) &rest rest) clauses
+;        (once-only (test)
+;          `(if ,test
+;               (let ((it ,test)) (declare (ignorable it)),@body)
+;               (acond ,@rest))))))
diff --git a/external/cffi.darcs/tests/Makefile b/external/cffi.darcs/tests/Makefile
new file mode 100644
index 0000000..8a2490a
--- /dev/null
+++ b/external/cffi.darcs/tests/Makefile
@@ -0,0 +1,85 @@
+# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*-
+#
+# Makefile --- Make targets for various tasks.
+#
+# Copyright (C) 2005, James Bielman  
+#
+# Permission is hereby granted, free of charge, to any person
+# obtaining a copy of this software and associated documentation
+# files (the "Software"), to deal in the Software without
+# restriction, including without limitation the rights to use, copy,
+# modify, merge, publish, distribute, sublicense, and/or sell copies
+# of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be
+# included in all copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+# NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+# DEALINGS IN THE SOFTWARE.
+#
+
+OSTYPE = $(shell uname)
+
+CC             := gcc
+CFLAGS         := -Wall -std=c99 -pedantic
+SHLIB_CFLAGS   := -shared
+SHLIB_EXT      := .so
+
+ifneq ($(if $(findstring $(OSTYPE),Linux FreeBSD),OK), OK)
+ifeq ($(OSTYPE), Darwin)
+SHLIB_CFLAGS   := -bundle
+else
+ifeq ($(OSTYPE), SunOS)
+CFLAGS         := -c -Wall -std=c99 -pedantic
+else
+# Let's assume this is win32
+SHLIB_EXT      := .dll
+endif
+endif
+endif
+
+ARCH = $(shell uname -m)
+
+ifneq ($(ARCH), x86_64)
+CFLAGS += -lm
+endif
+
+ifeq ($(ARCH), x86_64)
+CFLAGS += -fPIC
+endif
+
+# Are all G5s ppc970s?
+ifeq ($(ARCH), ppc970)
+CFLAGS += -m64
+endif
+
+SHLIBS = libtest$(SHLIB_EXT) libtest2$(SHLIB_EXT)
+
+#ifeq ($(ARCH), x86_64)
+#SHLIBS += libtest32$(SHLIB_EXT)
+#endif
+
+shlibs: $(SHLIBS)
+
+libtest$(SHLIB_EXT): libtest.c
+	$(CC) -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $<
+
+libtest2$(SHLIB_EXT): libtest2.c
+	$(CC) -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $<
+
+#ifeq ($(ARCH), x86_64)
+#libtest32$(SHLIB_EXT): libtest.c
+#	$(CC) -m32 -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $<
+#endif
+
+clean:
+	rm -f *.so *.dylib *.dll *.bundle
+
+# vim: ft=make ts=3 noet
diff --git a/external/cffi.darcs/tests/bindings.lisp b/external/cffi.darcs/tests/bindings.lisp
new file mode 100644
index 0000000..6eac146
--- /dev/null
+++ b/external/cffi.darcs/tests/bindings.lisp
@@ -0,0 +1,96 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; libtest.lisp --- Setup CFFI bindings for libtest.
+;;;
+;;; Copyright (C) 2005-2007, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+(define-foreign-library libtest
+  (:unix (:or "libtest.so" "libtest32.so"))
+  (:windows "libtest.dll")
+  (t (:default "libtest")))
+
+(define-foreign-library libtest2
+  (:darwin "libtest2.so")
+  (t (:default "libtest2")))
+
+(define-foreign-library libc
+  (:windows "msvcrt.dll"))
+
+;;; Return the directory containing the source when compiling or
+;;; loading this file.  We don't use *LOAD-TRUENAME* because the fasl
+;;; file may be in a different directory than the source with certain
+;;; ASDF extensions loaded.
+(defun load-directory ()
+  (let ((here #.(or *compile-file-truename* *load-truename*)))
+    (make-pathname :name nil :type nil :version nil
+                   :defaults here)))
+
+(defun load-test-libraries ()
+  (let ((*foreign-library-directories* (list (load-directory))))
+    (load-foreign-library 'libtest)
+    (load-foreign-library 'libtest2)
+    (load-foreign-library 'libc)))
+
+#-(:and :ecl (:not :dffi))
+(load-test-libraries)
+
+#+(:and :ecl (:not :dffi))
+(ffi:load-foreign-library
+ #.(make-pathname :name "libtest" :type "so"
+                  :defaults (or *compile-file-truename* *load-truename*)))
+
+;;; check libtest version
+(defparameter *required-dll-version* "20060907")
+
+(defcvar "dll_version" :string)
+
+(unless (string= *dll-version* *required-dll-version*)
+  (error "version check failed: expected ~s but libtest reports ~s"
+         *required-dll-version*
+         *dll-version*))
+
+;;; The maximum and minimum values for single and double precision C
+;;; floating point values, which may be quite different from the
+;;; corresponding Lisp versions.
+(defcvar "float_max" :float)
+(defcvar "float_min" :float)
+(defcvar "double_max" :double)
+(defcvar "double_min" :double)
+
+;;; This is not the best place for this code...
+(defparameter *repeat* 1)
+
+(defun run-cffi-tests (&key (compiled nil))
+  (let ((regression-test::*compile-tests* compiled)
+        (*package* (find-package '#:cffi-tests)))
+    (format t "~2&How many times shall we run the tests (~Acompiled)? [~D]: "
+            (if compiled "" "un") *repeat*)
+    (force-output *standard-output*)
+    (let* ((ntimes (or (ignore-errors (parse-integer (read-line))) *repeat*))
+           (ret-values (loop repeat ntimes collect (do-tests))))
+      (format t "~&;;; Finished running tests (~Acompiled) ~D times."
+              (if compiled "" "un") ntimes)
+      (every #'identity ret-values))))
diff --git a/external/cffi.darcs/tests/callbacks.lisp b/external/cffi.darcs/tests/callbacks.lisp
new file mode 100644
index 0000000..04c0dc8
--- /dev/null
+++ b/external/cffi.darcs/tests/callbacks.lisp
@@ -0,0 +1,511 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; callbacks.lisp --- Tests on callbacks.
+;;;
+;;; Copyright (C) 2005-2006, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+(defcfun "expect_char_sum"           :int (f :pointer))
+(defcfun "expect_unsigned_char_sum"  :int (f :pointer))
+(defcfun "expect_short_sum"          :int (f :pointer))
+(defcfun "expect_unsigned_short_sum" :int (f :pointer))
+(defcfun "expect_int_sum"            :int (f :pointer))
+(defcfun "expect_unsigned_int_sum"   :int (f :pointer))
+(defcfun "expect_long_sum"           :int (f :pointer))
+(defcfun "expect_unsigned_long_sum"  :int (f :pointer))
+(defcfun "expect_float_sum"          :int (f :pointer))
+(defcfun "expect_double_sum"         :int (f :pointer))
+(defcfun "expect_pointer_sum"        :int (f :pointer))
+(defcfun "expect_strcat"             :int (f :pointer))
+
+#-cffi-features:no-long-long
+(progn
+  (defcfun "expect_long_long_sum"          :int (f :pointer))
+  (defcfun "expect_unsigned_long_long_sum" :int (f :pointer)))
+
+#+(and scl long-float)
+(defcfun "expect_long_double_sum"    :int (f :pointer))
+
+(defcallback sum-char :char ((a :char) (b :char))
+  "Test if the named block is present and the docstring too."
+  ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
+  (return-from sum-char (+ a b)))
+
+(defcallback sum-unsigned-char :unsigned-char
+    ((a :unsigned-char) (b :unsigned-char))
+  ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
+  (+ a b))
+
+(defcallback sum-short :short ((a :short) (b :short))
+  ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
+  (+ a b))
+
+(defcallback sum-unsigned-short :unsigned-short
+    ((a :unsigned-short) (b :unsigned-short))
+  ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
+  (+ a b))
+
+(defcallback sum-int :int ((a :int) (b :int))
+  (+ a b))
+
+(defcallback sum-unsigned-int :unsigned-int
+    ((a :unsigned-int) (b :unsigned-int))
+  (+ a b))
+
+(defcallback sum-long :long ((a :long) (b :long))
+  (+ a b))
+
+(defcallback sum-unsigned-long :unsigned-long
+    ((a :unsigned-long) (b :unsigned-long))
+  (+ a b))
+
+#-cffi-features:no-long-long
+(progn
+  (defcallback sum-long-long :long-long
+      ((a :long-long) (b :long-long))
+    (+ a b))
+
+  (defcallback sum-unsigned-long-long :unsigned-long-long
+      ((a :unsigned-long-long) (b :unsigned-long-long))
+    (+ a b)))
+
+(defcallback sum-float :float ((a :float) (b :float))
+  ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
+  (+ a b))
+
+(defcallback sum-double :double ((a :double) (b :double))
+  ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
+  (+ a b))
+
+#+(and scl long-float)
+(defcallback sum-long-double :long-double ((a :long-double) (b :long-double))
+  ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
+  (+ a b))
+
+(defcallback sum-pointer :pointer ((ptr :pointer) (offset :int))
+  (inc-pointer ptr offset))
+
+(defcallback lisp-strcat :string ((a :string) (b :string))
+  (concatenate 'string a b))
+
+(deftest callbacks.char
+    (expect-char-sum (get-callback 'sum-char))
+  1)
+
+(deftest callbacks.unsigned-char
+    (expect-unsigned-char-sum (get-callback 'sum-unsigned-char))
+  1)
+
+(deftest callbacks.short
+    (expect-short-sum (callback sum-short))
+  1)
+
+(deftest callbacks.unsigned-short
+    (expect-unsigned-short-sum (callback sum-unsigned-short))
+  1)
+
+(deftest callbacks.int
+    (expect-int-sum (callback sum-int))
+  1)
+
+(deftest callbacks.unsigned-int
+    (expect-unsigned-int-sum (callback sum-unsigned-int))
+  1)
+
+(deftest callbacks.long
+    (expect-long-sum (callback sum-long))
+  1)
+
+(deftest callbacks.unsigned-long
+    (expect-unsigned-long-sum (callback sum-unsigned-long))
+  1)
+
+#-cffi-features:no-long-long
+(progn
+  #+openmcl (push 'callbacks.long-long rt::*expected-failures*)
+
+  (deftest callbacks.long-long
+      (expect-long-long-sum (callback sum-long-long))
+    1)
+
+  (deftest callbacks.unsigned-long-long
+      (expect-unsigned-long-long-sum (callback sum-unsigned-long-long))
+    1))
+
+(deftest callbacks.float
+    (expect-float-sum (callback sum-float))
+  1)
+
+(deftest callbacks.double
+    (expect-double-sum (callback sum-double))
+  1)
+
+#+(and scl long-float)
+(deftest callbacks.long-double
+    (expect-long-double-sum (callback sum-long-double))
+  1)
+
+(deftest callbacks.pointer
+    (expect-pointer-sum (callback sum-pointer))
+  1)
+
+(deftest callbacks.string
+    (expect-strcat (callback lisp-strcat))
+  1)
+
+#-cffi-features:no-foreign-funcall
+(defcallback return-a-string-not-nil :string ()
+  "abc")
+
+#-cffi-features:no-foreign-funcall
+(deftest callbacks.string-not-docstring
+    (foreign-funcall-pointer (callback return-a-string-not-nil) () :string)
+  "abc")
+
+;;; This one tests mem-aref too.
+(defcfun "qsort" :void
+  (base :pointer)
+  (nmemb :int)
+  (size :int)
+  (fun-compar :pointer))
+
+(defcallback < :int ((a :pointer) (b :pointer))
+  (let ((x (mem-ref a :int))
+        (y (mem-ref b :int)))
+    (cond ((> x y) 1)
+          ((< x y) -1)
+          (t 0))))
+
+(deftest callbacks.qsort
+    (with-foreign-object (array :int 10)
+      ;; Initialize array.
+      (loop for i from 0 and n in '(7 2 10 4 3 5 1 6 9 8)
+            do (setf (mem-aref array :int i) n))
+      ;; Sort it.
+      (qsort array 10 (foreign-type-size :int) (callback <))
+      ;; Return it as a list.
+      (loop for i from 0 below 10
+            collect (mem-aref array :int i)))
+  (1 2 3 4 5 6 7 8 9 10))
+
+;;; void callback
+(defparameter *int* -1)
+
+(defcfun "pass_int_ref" :void (f :pointer))
+
+;;; CMUCL chokes on this one for some reason.
+#-(and cffi-features:darwin cmu)
+(defcallback read-int-from-pointer :void ((a :pointer))
+  (setq *int* (mem-ref a :int)))
+
+#+(and cffi-features:darwin cmu)
+(pushnew 'callbacks.void rt::*expected-failures*)
+
+(deftest callbacks.void
+    (progn
+      (pass-int-ref (callback read-int-from-pointer))
+      *int*)
+  1984)
+
+;;; test funcalling of a callback and also declarations inside
+;;; callbacks.
+
+#-cffi-features:no-foreign-funcall
+(progn
+  (defcallback sum-2 :int ((a :int) (b :int) (c :int))
+    (declare (ignore c))
+    (+ a b))
+
+  (deftest callbacks.funcall.1
+      (foreign-funcall-pointer (callback sum-2) () :int 2 :int 3 :int 1 :int)
+    5)
+
+  (defctype foo-float :float)
+
+  (defcallback sum-2f foo-float
+      ((a foo-float) (b foo-float) (c foo-float) (d foo-float) (e foo-float))
+    "This one ignores the middle 3 arguments."
+    (declare (ignore b c))
+    (declare (ignore d))
+    (+ a e))
+
+  (deftest callbacks.funcall.2
+      (foreign-funcall-pointer (callback sum-2f) () foo-float 1.0 foo-float 2.0
+                               foo-float 3.0 foo-float 4.0 foo-float 5.0
+                               foo-float)
+    6.0))
+
+;;; (cb-test :no-long-long t)
+
+(defcfun "call_sum_127_no_ll" :long (cb :pointer))
+
+;;; CMUCL and ECL choke on this one.
+#-(:or :ecl :cmu #.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:or) '(:and)))
+(defcallback sum-127-no-ll :long
+    ((a1 :unsigned-long) (a2 :pointer) (a3 :long) (a4 :double)
+     (a5 :unsigned-long) (a6 :float) (a7 :float) (a8 :int) (a9 :unsigned-int)
+     (a10 :double) (a11 :double) (a12 :double) (a13 :pointer)
+     (a14 :unsigned-short) (a15 :unsigned-short) (a16 :pointer) (a17 :long)
+     (a18 :long) (a19 :int) (a20 :short) (a21 :unsigned-short)
+     (a22 :unsigned-short) (a23 :char) (a24 :long) (a25 :pointer) (a26 :pointer)
+     (a27 :char) (a28 :unsigned-char) (a29 :unsigned-long) (a30 :short)
+     (a31 :int) (a32 :int) (a33 :unsigned-char) (a34 :short) (a35 :long)
+     (a36 :long) (a37 :pointer) (a38 :unsigned-short) (a39 :char) (a40 :double)
+     (a41 :unsigned-short) (a42 :pointer) (a43 :short) (a44 :unsigned-long)
+     (a45 :unsigned-short) (a46 :float) (a47 :unsigned-char) (a48 :short)
+     (a49 :float) (a50 :short) (a51 :char) (a52 :unsigned-long)
+     (a53 :unsigned-long) (a54 :char) (a55 :float) (a56 :long) (a57 :pointer)
+     (a58 :short) (a59 :float) (a60 :unsigned-int) (a61 :float)
+     (a62 :unsigned-int) (a63 :double) (a64 :unsigned-int) (a65 :unsigned-char)
+     (a66 :int) (a67 :long) (a68 :char) (a69 :short) (a70 :double) (a71 :int)
+     (a72 :pointer) (a73 :char) (a74 :unsigned-short) (a75 :pointer)
+     (a76 :unsigned-short) (a77 :pointer) (a78 :unsigned-long) (a79 :double)
+     (a80 :pointer) (a81 :long) (a82 :float) (a83 :unsigned-short)
+     (a84 :unsigned-short) (a85 :pointer) (a86 :float) (a87 :int)
+     (a88 :unsigned-int) (a89 :double) (a90 :float) (a91 :long) (a92 :pointer)
+     (a93 :unsigned-short) (a94 :float) (a95 :unsigned-char) (a96 :unsigned-char)
+     (a97 :float) (a98 :unsigned-int) (a99 :float) (a100 :unsigned-short)
+     (a101 :double) (a102 :unsigned-short) (a103 :unsigned-long)
+     (a104 :unsigned-int) (a105 :unsigned-long) (a106 :pointer)
+     (a107 :unsigned-char) (a108 :char) (a109 :char) (a110 :unsigned-short)
+     (a111 :unsigned-long) (a112 :float) (a113 :short) (a114 :pointer)
+     (a115 :long) (a116 :unsigned-short) (a117 :short) (a118 :double)
+     (a119 :short) (a120 :int) (a121 :char) (a122 :unsigned-long) (a123 :long)
+     (a124 :int) (a125 :pointer) (a126 :double) (a127 :unsigned-char))
+  (let ((args (list a1 (pointer-address a2) a3 (floor a4) a5 (floor a6)
+                    (floor a7) a8 a9 (floor a10) (floor a11) (floor a12)
+                    (pointer-address a13) a14 a15 (pointer-address a16) a17 a18
+                    a19 a20 a21 a22 a23 a24 (pointer-address a25)
+                    (pointer-address a26) a27 a28 a29 a30 a31 a32 a33 a34 a35
+                    a36 (pointer-address a37) a38 a39 (floor a40) a41
+                    (pointer-address a42) a43 a44 a45 (floor a46) a47 a48
+                    (floor a49) a50 a51 a52 a53 a54 (floor a55) a56
+                    (pointer-address a57) a58 (floor a59) a60 (floor a61) a62
+                    (floor a63) a64 a65 a66 a67 a68 a69 (floor a70) a71
+                    (pointer-address a72) a73 a74 (pointer-address a75) a76
+                    (pointer-address a77) a78 (floor a79) (pointer-address a80)
+                    a81 (floor a82) a83 a84 (pointer-address a85) (floor a86)
+                    a87 a88 (floor a89) (floor a90) a91 (pointer-address a92)
+                    a93 (floor a94) a95 a96 (floor a97) a98 (floor a99) a100
+                    (floor a101) a102 a103 a104 a105 (pointer-address a106) a107
+                    a108 a109 a110 a111 (floor a112) a113 (pointer-address a114)
+                    a115 a116 a117 (floor a118) a119 a120 a121 a122 a123 a124
+                    (pointer-address a125) (floor a126) a127)))
+    #-(and)
+    (loop for i from 1 and arg in args do
+          (format t "a~A: ~A~%" i arg))
+    (reduce #'+ args)))
+
+#+(or openmcl cmu ecl (and cffi-features:darwin (or allegro lispworks)))
+(push 'callbacks.bff.1 regression-test::*expected-failures*)
+
+#+#.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:and) '(:or))
+(deftest callbacks.bff.1
+    (call-sum-127-no-ll (callback sum-127-no-ll))
+  2008547941)
+
+;;; (cb-test)
+
+#-(:or cffi-features:no-long-long
+       #.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:or) '(:and)))
+(progn
+  (defcfun "call_sum_127" :long-long (cb :pointer))
+
+  ;;; CMUCL and ECL choke on this one.
+  #-(or cmu ecl)
+  (defcallback sum-127 :long-long
+      ((a1 :short) (a2 :char) (a3 :pointer) (a4 :float) (a5 :long) (a6 :double)
+       (a7 :unsigned-long-long) (a8 :unsigned-short) (a9 :unsigned-char)
+       (a10 :char) (a11 :char) (a12 :unsigned-short) (a13 :unsigned-long-long)
+       (a14 :unsigned-short) (a15 :long-long) (a16 :unsigned-short)
+       (a17 :unsigned-long-long) (a18 :unsigned-char) (a19 :unsigned-char)
+       (a20 :unsigned-long-long) (a21 :long-long) (a22 :char) (a23 :float)
+       (a24 :unsigned-int) (a25 :float) (a26 :float) (a27 :unsigned-int)
+       (a28 :float) (a29 :char) (a30 :unsigned-char) (a31 :long) (a32 :long-long)
+       (a33 :unsigned-char) (a34 :double) (a35 :long) (a36 :double)
+       (a37 :unsigned-int) (a38 :unsigned-short) (a39 :long-long)
+       (a40 :unsigned-int) (a41 :int) (a42 :unsigned-long-long) (a43 :long)
+       (a44 :short) (a45 :unsigned-int) (a46 :unsigned-int)
+       (a47 :unsigned-long-long) (a48 :unsigned-int) (a49 :long) (a50 :pointer)
+       (a51 :unsigned-char) (a52 :char) (a53 :long-long) (a54 :unsigned-short)
+       (a55 :unsigned-int) (a56 :float) (a57 :unsigned-char) (a58 :unsigned-long)
+       (a59 :long-long) (a60 :float) (a61 :long) (a62 :float) (a63 :int)
+       (a64 :float) (a65 :unsigned-short) (a66 :unsigned-long-long) (a67 :short)
+       (a68 :unsigned-long) (a69 :long) (a70 :char) (a71 :unsigned-short)
+       (a72 :long-long) (a73 :short) (a74 :double) (a75 :pointer)
+       (a76 :unsigned-int) (a77 :char) (a78 :unsigned-int) (a79 :pointer)
+       (a80 :pointer) (a81 :unsigned-char) (a82 :pointer) (a83 :unsigned-short)
+       (a84 :unsigned-char) (a85 :long) (a86 :pointer) (a87 :char) (a88 :long)
+       (a89 :unsigned-short) (a90 :unsigned-char) (a91 :double)
+       (a92 :unsigned-long-long) (a93 :unsigned-short) (a94 :unsigned-short)
+       (a95 :unsigned-int) (a96 :long) (a97 :char) (a98 :long) (a99 :char)
+       (a100 :short) (a101 :unsigned-short) (a102 :unsigned-long)
+       (a103 :unsigned-long) (a104 :short) (a105 :long-long) (a106 :long-long)
+       (a107 :long-long) (a108 :double) (a109 :unsigned-short)
+       (a110 :unsigned-char) (a111 :short) (a112 :unsigned-char) (a113 :long)
+       (a114 :long-long) (a115 :unsigned-long-long) (a116 :unsigned-int)
+       (a117 :unsigned-long) (a118 :unsigned-char) (a119 :long-long)
+       (a120 :unsigned-char) (a121 :unsigned-long-long) (a122 :double)
+       (a123 :unsigned-char) (a124 :long-long) (a125 :unsigned-char)
+       (a126 :char) (a127 :long-long))
+    (+ a1 a2 (pointer-address a3) (values (floor a4)) a5 (values (floor a6))
+       a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22
+       (values (floor a23)) a24 (values (floor a25)) (values (floor a26))
+       a27 (values (floor a28)) a29 a30 a31 a32 a33 (values (floor a34))
+       a35 (values (floor a36)) a37 a38 a39 a40 a41 a42 a43 a44 a45 a46 a47
+       a48 a49 (pointer-address a50) a51 a52 a53 a54 a55 (values (floor a56))
+       a57 a58 a59 (values (floor a60)) a61 (values (floor a62)) a63
+       (values (floor a64)) a65 a66 a67 a68 a69 a70 a71 a72 a73
+       (values (floor a74)) (pointer-address a75) a76 a77 a78
+       (pointer-address a79) (pointer-address a80) a81 (pointer-address a82)
+       a83 a84 a85 (pointer-address a86) a87 a88 a89 a90 (values (floor a91))
+       a92 a93 a94 a95 a96 a97 a98 a99 a100 a101 a102 a103 a104 a105 a106 a107
+       (values (floor a108)) a109 a110 a111 a112 a113 a114 a115 a116 a117 a118
+       a119 a120 a121 (values (floor a122)) a123 a124 a125 a126 a127))
+
+  #+(or openmcl cmu ecl)
+  (push 'callbacks.bff.2 rt::*expected-failures*)
+
+  (deftest callbacks.bff.2
+      (call-sum-127 (callback sum-127))
+    8166570665645582011))
+
+;;; regression test: (callback non-existant-callback) should throw an error
+(deftest callbacks.non-existant
+    (not (null (nth-value 1 (ignore-errors (callback doesnt-exist)))))
+  t)
+
+;;; Handling many arguments of type double. Many lisps (used to) fail
+;;; this one on darwin/ppc. This test might be bogus due to floating
+;;; point arithmetic rounding errors.
+;;;
+;;; CMUCL chokes on this one.
+#-(and cffi-features:darwin cmu)
+(defcallback double26 :double
+    ((a1 :double) (a2 :double) (a3 :double) (a4 :double) (a5 :double)
+     (a6 :double) (a7 :double) (a8 :double) (a9 :double) (a10 :double)
+     (a11 :double) (a12 :double) (a13 :double) (a14 :double) (a15 :double)
+     (a16 :double) (a17 :double) (a18 :double) (a19 :double) (a20 :double)
+     (a21 :double) (a22 :double) (a23 :double) (a24 :double) (a25 :double)
+     (a26 :double))
+  (let ((args (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15
+                    a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26)))
+    #-(and)
+    (loop for i from 1 and arg in args do
+          (format t "a~A: ~A~%" i arg))
+    (reduce #'+ args)))
+
+(defcfun "call_double26" :double (f :pointer))
+
+#+(and cffi-features:darwin (or allegro cmu))
+(pushnew 'callbacks.double26 rt::*expected-failures*)
+
+(deftest callbacks.double26
+    (call-double26 (callback double26))
+  81.64d0)
+
+#+(and cffi-features:darwin cmu)
+(pushnew 'callbacks.double26.funcall rt::*expected-failures*)
+
+#-cffi-features:no-foreign-funcall
+(deftest callbacks.double26.funcall
+    (foreign-funcall-pointer
+     (callback double26) () :double 3.14d0 :double 3.14d0
+     :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
+     :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
+     :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
+     :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
+     :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
+     :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
+     :double)
+  81.64d0)
+
+;;; Same as above, for floats.
+#-(and cffi-features:darwin cmu)
+(defcallback float26 :float
+    ((a1 :float) (a2 :float) (a3 :float) (a4 :float) (a5 :float)
+     (a6 :float) (a7 :float) (a8 :float) (a9 :float) (a10 :float)
+     (a11 :float) (a12 :float) (a13 :float) (a14 :float) (a15 :float)
+     (a16 :float) (a17 :float) (a18 :float) (a19 :float) (a20 :float)
+     (a21 :float) (a22 :float) (a23 :float) (a24 :float) (a25 :float)
+     (a26 :float))
+  (let ((args (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15
+                    a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26)))
+    #-(and)
+    (loop for i from 1 and arg in args do
+          (format t "a~A: ~A~%" i arg))
+    (reduce #'+ args)))
+
+(defcfun "call_float26" :float (f :pointer))
+
+#+(and cffi-features:darwin (or lispworks openmcl cmu))
+(pushnew 'callbacks.float26 regression-test::*expected-failures*)
+
+(deftest callbacks.float26
+    (call-float26 (callback float26))
+  130.0)
+
+#+(and cffi-features:darwin (or lispworks openmcl cmu))
+(pushnew 'callbacks.float26.funcall regression-test::*expected-failures*)
+
+#-cffi-features:no-foreign-funcall
+(deftest callbacks.float26.funcall
+    (foreign-funcall-pointer
+     (callback float26) () :float 5.0 :float 5.0
+     :float 5.0 :float 5.0 :float 5.0 :float 5.0
+     :float 5.0 :float 5.0 :float 5.0 :float 5.0
+     :float 5.0 :float 5.0 :float 5.0 :float 5.0
+     :float 5.0 :float 5.0 :float 5.0 :float 5.0
+     :float 5.0 :float 5.0 :float 5.0 :float 5.0
+     :float 5.0 :float 5.0 :float 5.0 :float 5.0
+     :float)
+  130.0)
+
+;;; Defining a callback as a non-toplevel form. Not portable. Doesn't
+;;; work for CMUCL or Allegro.
+#-(and)
+(let ((n 42))
+  (defcallback non-toplevel-cb :int ()
+    n))
+
+#-(and)
+(deftest callbacks.non-toplevel
+    (foreign-funcall (callback non-toplevel-cb) :int)
+  42)
+
+;;;# Stdcall
+
+#+(and cffi-features:x86 (not cffi-features:no-stdcall))
+(progn
+  (defcallback (stdcall-cb :cconv :stdcall) :int
+      ((a :int) (b :int) (c :int))
+    (+ a b c))
+
+  (defcfun "call_stdcall_fun" :int
+    (f :pointer))
+
+  (deftest callbacks.stdcall.1
+      (call-stdcall-fun (callback stdcall-cb))
+    42))
diff --git a/external/cffi.darcs/tests/compile.bat b/external/cffi.darcs/tests/compile.bat
new file mode 100644
index 0000000..1f89eea
--- /dev/null
+++ b/external/cffi.darcs/tests/compile.bat
@@ -0,0 +1,9 @@
+rem
+rem script for compiling the test lib with the free MSVC++ toolkit.
+rem
+
+cl /LD /DWIN32=1 /Tc libtest.c
+del libtest.obj libtest.exp
+
+cl /LD /DWIN32=1 /Tc libtest2.c
+del libtest2.obj libtest2.exp
diff --git a/external/cffi.darcs/tests/defcfun.lisp b/external/cffi.darcs/tests/defcfun.lisp
new file mode 100644
index 0000000..d698b21
--- /dev/null
+++ b/external/cffi.darcs/tests/defcfun.lisp
@@ -0,0 +1,401 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; defcfun.lisp --- Tests function definition and calling.
+;;;
+;;; Copyright (C) 2005-2007, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+;;;# Calling with built-in c types
+;;;
+;;; Tests calling standard C library functions both passing
+;;; and returning each built-in type. (adapted from funcall.lisp)
+
+(defcfun "toupper" :char
+  "toupper docstring"
+  (char :char))
+
+(deftest defcfun.char
+    (toupper (char-code #\a))
+  #.(char-code #\A))
+
+(deftest defcfun.docstring
+    (documentation 'toupper 'function)
+  "toupper docstring")
+
+
+(defcfun ("abs" c-abs) :int
+  (n :int))
+
+(deftest defcfun.int
+    (c-abs -100)
+  100)
+
+
+(defcfun "labs" :long
+  (n :long))
+
+(deftest defcfun.long
+    (labs -131072)
+  131072)
+
+
+#-cffi-features:no-long-long
+(progn
+  (defcfun "my_llabs" :long-long
+    (n :long-long))
+
+  (deftest defcfun.long-long
+      (my-llabs -9223372036854775807)
+    9223372036854775807))
+
+
+(defcfun "my_sqrtf" :float
+  (n :float))
+
+(deftest defcfun.float
+    (my-sqrtf 16.0)
+  4.0)
+
+
+(defcfun ("sqrt" c-sqrt) :double
+  (n :double))
+
+(deftest defcfun.double
+    (c-sqrt 36.0d0)
+  6.0d0)
+
+
+#+(and scl long-float)
+(defcfun ("sqrtl" c-sqrtl) :long-double
+  (n :long-double))
+
+#+(and scl long-float)
+(deftest defcfun.long-double
+    (c-sqrtl 36.0l0)
+  6.0l0)
+
+
+(defcfun "strlen" :int
+  (n :string))
+
+(deftest defcfun.string.1
+    (strlen "Hello")
+  5)
+
+
+(defcfun "strcpy" (:pointer :char)
+  (dest (:pointer :char))
+  (src :string))
+
+(defcfun "strcat" (:pointer :char)
+  (dest (:pointer :char))
+  (src :string))
+
+(deftest defcfun.string.2
+    (with-foreign-pointer-as-string (s 100)
+      (setf (mem-ref s :char) 0)
+      (strcpy s "Hello")
+      (strcat s ", world!"))
+  "Hello, world!")
+
+(defcfun "strerror" :string
+  (n :int))
+
+(deftest defcfun.string.3
+    (typep (strerror 1) 'string)
+  t)
+
+
+;;; Regression test. Allegro would warn on direct calls to
+;;; functions with no arguments.
+;;;
+;;; Also, let's check if void functions will return NIL.
+;;;
+;;; Check if a docstring without arguments doesn't cause problems.
+
+(defcfun "noargs" :int
+  "docstring")
+
+(deftest defcfun.noargs
+    (noargs)
+  42)
+
+(defcfun "noop" :void)
+
+(deftest defcfun.noop
+    (noop)
+  #|no values|#)
+
+;;;# Calling varargs functions
+
+(defcfun "sprintf" :int
+  "sprintf docstring"
+  (str (:pointer :char))
+  (control :string)
+  &rest)
+
+(deftest defcfun.varargs.docstrings
+    (documentation 'sprintf 'function)
+  "sprintf docstring")
+
+(deftest defcfun.varargs.char
+    (with-foreign-pointer-as-string (s 100)
+      (sprintf s "%c" :char 65))
+  "A")
+
+(deftest defcfun.varargs.short
+    (with-foreign-pointer-as-string (s 100)
+      (sprintf s "%d" :short 42))
+  "42")
+
+(deftest defcfun.varargs.int
+    (with-foreign-pointer-as-string (s 100)
+      (sprintf s "%d" :int 1000))
+  "1000")
+
+(deftest defcfun.varargs.long
+    (with-foreign-pointer-as-string (s 100)
+      (sprintf s "%ld" :long 131072))
+  "131072")
+
+(deftest defcfun.varargs.float
+    (with-foreign-pointer-as-string (s 100)
+      (sprintf s "%.2f" :float (float pi)))
+  "3.14")
+
+(deftest defcfun.varargs.double
+    (with-foreign-pointer-as-string (s 100)
+      (sprintf s "%.2f" :double (float pi 1.0d0)))
+  "3.14")
+
+#+(and scl long-float)
+(deftest defcfun.varargs.long-double
+    (with-foreign-pointer-as-string (s 100)
+      (setf (mem-ref s :char) 0)
+      (sprintf s "%.2Lf" :long-double pi))
+  "3.14")
+
+(deftest defcfun.varargs.string
+    (with-foreign-pointer-as-string (s 100)
+      (sprintf s "%s, %s!" :string "Hello" :string "world"))
+  "Hello, world!")
+
+;;; (let ((rettype (find-type :long))
+;;;       (arg-types (n-random-types-no-ll 127)))
+;;;   (c-function rettype arg-types)
+;;;   (gen-function-test rettype arg-types))
+
+#+(:and (:not :ecl) #.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:and) '(:or)))
+(progn
+  (defcfun "sum_127_no_ll" :long
+    (a1 :long) (a2 :unsigned-long) (a3 :short) (a4 :unsigned-short) (a5 :float)
+    (a6 :double) (a7 :unsigned-long) (a8 :float) (a9 :unsigned-char)
+    (a10 :unsigned-short) (a11 :short) (a12 :unsigned-long) (a13 :double)
+    (a14 :long) (a15 :unsigned-int) (a16 :pointer) (a17 :unsigned-int)
+    (a18 :unsigned-short) (a19 :long) (a20 :float) (a21 :pointer) (a22 :float)
+    (a23 :int) (a24 :int) (a25 :unsigned-short) (a26 :long) (a27 :long)
+    (a28 :double) (a29 :unsigned-char) (a30 :unsigned-int) (a31 :unsigned-int)
+    (a32 :int) (a33 :unsigned-short) (a34 :unsigned-int) (a35 :pointer)
+    (a36 :double) (a37 :double) (a38 :long) (a39 :short) (a40 :unsigned-short)
+    (a41 :long) (a42 :char) (a43 :long) (a44 :unsigned-short) (a45 :pointer)
+    (a46 :int) (a47 :unsigned-int) (a48 :double) (a49 :unsigned-char)
+    (a50 :unsigned-char) (a51 :float) (a52 :int) (a53 :unsigned-short)
+    (a54 :double) (a55 :short) (a56 :unsigned-char) (a57 :unsigned-long)
+    (a58 :float) (a59 :float) (a60 :float) (a61 :pointer) (a62 :pointer)
+    (a63 :unsigned-int) (a64 :unsigned-long) (a65 :char) (a66 :short)
+    (a67 :unsigned-short) (a68 :unsigned-long) (a69 :pointer) (a70 :float)
+    (a71 :double) (a72 :long) (a73 :unsigned-long) (a74 :short)
+    (a75 :unsigned-int) (a76 :unsigned-short) (a77 :int) (a78 :unsigned-short)
+    (a79 :char) (a80 :double) (a81 :short) (a82 :unsigned-char) (a83 :float)
+    (a84 :char) (a85 :int) (a86 :double) (a87 :unsigned-char) (a88 :int)
+    (a89 :unsigned-long) (a90 :double) (a91 :short) (a92 :short)
+    (a93 :unsigned-int) (a94 :unsigned-char) (a95 :float) (a96 :long)
+    (a97 :float) (a98 :long) (a99 :long) (a100 :int) (a101 :int)
+    (a102 :unsigned-int) (a103 :char) (a104 :char) (a105 :unsigned-short)
+    (a106 :unsigned-int) (a107 :unsigned-short) (a108 :unsigned-short)
+    (a109 :int) (a110 :long) (a111 :char) (a112 :double) (a113 :unsigned-int)
+    (a114 :char) (a115 :short) (a116 :unsigned-long) (a117 :unsigned-int)
+    (a118 :short) (a119 :unsigned-char) (a120 :float) (a121 :pointer)
+    (a122 :double) (a123 :int) (a124 :long) (a125 :char) (a126 :unsigned-short)
+    (a127 :float))
+
+  (deftest defcfun.bff.1
+      (sum-127-no-ll
+       1442906394 520035521 -4715 50335 -13557.0 -30892.0d0 24061483 -23737.0
+       22 2348 4986 104895680 8073.0d0 -571698147 102484400
+       (make-pointer 507907275) 12733353 7824 -1275845284 13602.0
+       (make-pointer 286958390) -8042.0 -773681663 -1289932452 31199 -154985357
+       -170994216 16845.0d0 177 218969221 2794350893 6068863 26327 127699339
+       (make-pointer 184352771) 18512.0d0 -12345.0d0 -179853040 -19981 37268
+       -792845398 116 -1084653028 50494 (make-pointer 2105239646) -1710519651
+       1557813312 2839.0d0 90 180 30580.0 -532698978 8623 9537.0d0 -10882 54
+       184357206 14929.0 -8190.0 -25615.0 (make-pointer 235310526)
+       (make-pointer 220476977) 7476055 1576685 -117 -11781 31479 23282640
+       (make-pointer 8627281) -17834.0 10391.0d0 -1904504370 114393659 -17062
+       637873619 16078 -891210259 8107 0 760.0d0 -21268 104 14133.0 10
+       588598141 310.0d0 20 1351785456 16159552 -10121.0d0 -25866 24821
+       68232851 60 -24132.0 -1660411658 13387.0 -786516668 -499825680
+       -1128144619 111849719 2746091587 -2 95 14488 326328135 64781 18204
+       150716680 -703859275 103 16809.0d0 852235610 -43 21088 242356110
+       324325428 -22380 23 24814.0 (make-pointer 40362014) -14322.0d0
+       -1864262539 523684371 -21 49995 -29175.0)
+    796447501))
+
+;;; (let ((rettype (find-type :long-long))
+;;;       (arg-types (n-random-types 127)))
+;;;   (c-function rettype arg-types)
+;;;   (gen-function-test rettype arg-types))
+
+#-(:or :ecl cffi-features:no-long-long
+       #.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:or) '(:and)))
+(progn
+  (defcfun "sum_127" :long-long
+    (a1 :pointer) (a2 :pointer) (a3 :float) (a4 :unsigned-long) (a5 :pointer)
+    (a6 :long-long) (a7 :double) (a8 :double) (a9 :unsigned-short) (a10 :int)
+    (a11 :long-long) (a12 :long) (a13 :short) (a14 :unsigned-int) (a15 :long)
+    (a16 :unsigned-char) (a17 :int) (a18 :double) (a19 :short) (a20 :short)
+    (a21 :long-long) (a22 :unsigned-int) (a23 :unsigned-short) (a24 :short)
+    (a25 :pointer) (a26 :short) (a27 :unsigned-short) (a28 :unsigned-short)
+    (a29 :int) (a30 :long-long) (a31 :pointer) (a32 :int) (a33 :unsigned-long)
+    (a34 :unsigned-long) (a35 :pointer) (a36 :unsigned-long-long) (a37 :float)
+    (a38 :int) (a39 :short) (a40 :pointer) (a41 :unsigned-long-long)
+    (a42 :long-long) (a43 :unsigned-long) (a44 :unsigned-long)
+    (a45 :unsigned-long-long) (a46 :unsigned-long) (a47 :char) (a48 :double)
+    (a49 :long) (a50 :unsigned-int) (a51 :int) (a52 :short) (a53 :pointer)
+    (a54 :long) (a55 :unsigned-long-long) (a56 :int) (a57 :unsigned-short)
+    (a58 :unsigned-long-long) (a59 :float) (a60 :pointer) (a61 :float)
+    (a62 :unsigned-short) (a63 :unsigned-long) (a64 :float) (a65 :unsigned-int)
+    (a66 :unsigned-long-long) (a67 :pointer) (a68 :double)
+    (a69 :unsigned-long-long) (a70 :double) (a71 :double) (a72 :long-long)
+    (a73 :pointer) (a74 :unsigned-short) (a75 :long) (a76 :pointer) (a77 :short)
+    (a78 :double) (a79 :long) (a80 :unsigned-char) (a81 :pointer)
+    (a82 :unsigned-char) (a83 :long) (a84 :double) (a85 :pointer) (a86 :int)
+    (a87 :double) (a88 :unsigned-char) (a89 :double) (a90 :short) (a91 :long)
+    (a92 :int) (a93 :long) (a94 :double) (a95 :unsigned-short)
+    (a96 :unsigned-int) (a97 :int) (a98 :char) (a99 :long-long) (a100 :double)
+    (a101 :float) (a102 :unsigned-long) (a103 :short) (a104 :pointer)
+    (a105 :float) (a106 :long-long) (a107 :int) (a108 :long-long)
+    (a109 :long-long) (a110 :double) (a111 :unsigned-long-long) (a112 :double)
+    (a113 :unsigned-long) (a114 :char) (a115 :char) (a116 :unsigned-long)
+    (a117 :short) (a118 :unsigned-char) (a119 :unsigned-char) (a120 :int)
+    (a121 :int) (a122 :float) (a123 :unsigned-char) (a124 :unsigned-char)
+    (a125 :double) (a126 :unsigned-long-long) (a127 :char))
+
+  (deftest defcfun.bff.2
+      (sum-127
+       (make-pointer 2746181372) (make-pointer 177623060) -32334.0 3158055028
+       (make-pointer 242315091) 4288001754991016425 -21047.0d0 287.0d0 18722
+       243379286 -8677366518541007140 581399424 -13872 4240394881 1353358999
+       226 969197676 -26207.0d0 6484 11150 1241680089902988480 106068320 61865
+       2253 (make-pointer 866809333) -31613 35616 11715 1393601698
+       8940888681199591845 (make-pointer 1524606024) 805638893 3315410736
+       3432596795 (make-pointer 1490355706) 696175657106383698 -25438.0
+       1294381547 26724 (make-pointer 3196569545) 2506913373410783697
+       -4405955718732597856 4075932032 3224670123 2183829215657835866
+       1318320964 -22 -3786.0d0 -2017024146 1579225515 -626617701 -1456
+       (make-pointer 3561444187) 395687791 1968033632506257320 -1847773261
+       48853 142937735275669133 -17974.0 (make-pointer 2791749948) -14140.0
+       2707 3691328585 3306.0 1132012981 303633191773289330
+       (make-pointer 981183954) 9114.0d0 8664374572369470 -19013.0d0
+       -10288.0d0 -3679345119891954339 (make-pointer 3538786709) 23761
+       -154264605 (make-pointer 2694396308) 7023 997.0d0 1009561368 241
+       (make-pointer 2612292671) 48 1431872408 -32675.0d0
+       (make-pointer 1587599336) 958916472 -9857.0d0 111 -14370.0d0 -7308
+       -967514912 488790941 2146978095 -24111.0d0 13711 86681861 717987770
+       111 1013402998690933877 17234.0d0 -8772.0 3959216275 -8711
+       (make-pointer 3142780851) 9480.0 -3820453146461186120 1616574376
+       -3336232268263990050 -1906114671562979758 -27925.0d0 9695970875869913114
+       27033.0d0 1096518219 -12 104 3392025403 -27911 60 89 509297051
+       -533066551 29158.0 110 54 -9802.0d0 593950442165910888 -79)
+    7758614658402721936))
+
+;;; regression test: defining an undefined foreign function should only
+;;; throw some sort of warning, not signal an error.
+
+#+(or cmu (and sbcl (or (not linkage-table) win32)))
+(pushnew 'defcfun.undefined rt::*expected-failures*)
+
+(deftest defcfun.undefined
+    (progn
+      (eval '(defcfun ("undefined_foreign_function" undefined-foreign-function) :void))
+      (compile 'undefined-foreign-function)
+      t)
+  t)
+
+;;; Test whether all doubles are passed correctly. On some platforms, eg.
+;;; darwin/ppc, some are passed on registers others on the stack.
+(defcfun "sum_double26" :double
+  (a1 :double) (a2 :double) (a3 :double) (a4 :double) (a5 :double)
+  (a6 :double) (a7 :double) (a8 :double) (a9 :double) (a10 :double)
+  (a11 :double) (a12 :double) (a13 :double) (a14 :double) (a15 :double)
+  (a16 :double) (a17 :double) (a18 :double) (a19 :double) (a20 :double)
+  (a21 :double) (a22 :double) (a23 :double) (a24 :double) (a25 :double)
+  (a26 :double))
+
+(deftest defcfun.double26
+    (sum-double26 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0
+                  3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0
+                  3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0
+                  3.14d0 3.14d0 3.14d0 3.14d0 3.14d0)
+  81.64d0)
+
+;;; Same as above for floats.
+(defcfun "sum_float26" :float
+  (a1 :float) (a2 :float) (a3 :float) (a4 :float) (a5 :float)
+  (a6 :float) (a7 :float) (a8 :float) (a9 :float) (a10 :float)
+  (a11 :float) (a12 :float) (a13 :float) (a14 :float) (a15 :float)
+  (a16 :float) (a17 :float) (a18 :float) (a19 :float) (a20 :float)
+  (a21 :float) (a22 :float) (a23 :float) (a24 :float) (a25 :float)
+  (a26 :float))
+
+(deftest defcfun.float26
+    (sum-float26 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0
+                 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0)
+  130.0)
+
+;;;# Namespaces
+
+#-cffi-features:flat-namespace
+(progn
+  (defcfun ("ns_function" ns-fun1 :library libtest) :boolean)
+  (defcfun ("ns_function" ns-fun2 :library libtest2) :boolean)
+
+  (deftest defcfun.namespace.1
+      (values (ns-fun1) (ns-fun2))
+    t nil))
+
+;;;# stdcall
+
+#+(and cffi-features:x86 (not cffi-features:no-stdcall))
+(progn
+  (defcfun ("stdcall_fun@12" stdcall-fun :cconv :stdcall) :int
+    (a :int)
+    (b :int)
+    (c :int))
+
+  (deftest defcfun.stdcall.1
+      (loop repeat 100 do (stdcall-fun 1 2 3)
+            finally (return (stdcall-fun 1 2 3)))
+    6))
diff --git a/external/cffi.darcs/tests/enum.lisp b/external/cffi.darcs/tests/enum.lisp
new file mode 100644
index 0000000..ec6cc86
--- /dev/null
+++ b/external/cffi.darcs/tests/enum.lisp
@@ -0,0 +1,115 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; enum.lisp --- Tests on C enums.
+;;;
+;;; Copyright (C) 2005-2006, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+(defcenum numeros
+  (:one 1)
+  :two
+  :three
+  :four
+  (:forty-one 41)
+  :forty-two)
+
+(defcfun "check_enums" :int
+  (one numeros)
+  (two numeros)
+  (three numeros)
+  (four numeros)
+  (forty-one numeros)
+  (forty-two numeros))
+
+(deftest enum.1
+    (check-enums :one :two :three 4 :forty-one :forty-two)
+  1)
+
+(defcenum another-boolean :false :true)
+(defcfun "return_enum" another-boolean (x :int))
+
+(deftest enum.2
+    (and (eq :false (return-enum 0))
+         (eq :true (return-enum 1)))
+  t)
+
+(defctype yet-another-boolean another-boolean)
+(defcfun ("return_enum" return-enum2) yet-another-boolean
+  (x yet-another-boolean))
+
+(deftest enum.3
+    (and (eq :false (return-enum2 :false))
+         (eq :true (return-enum2 :true)))
+  t)
+
+;;;# Bitfield tests
+
+;;; Regression test: defbitfield was misbehaving when the first value
+;;; was provided.
+(deftest bitfield.1
+    (eval '(defbitfield bf1
+             (:foo 0)))
+  bf1)
+
+(defbitfield bf2
+  one
+  two
+  four
+  eight
+  sixteen
+  thirty-two
+  sixty-four)
+
+(deftest bitfield.2
+    (mapcar (lambda (symbol)
+              (foreign-bitfield-value 'bf2 (list symbol)))
+            '(one two four eight sixteen thirty-two sixty-four))
+  (1 2 4 8 16 32 64))
+
+(defbitfield bf3
+  (three 3)
+  one
+  (seven 7)
+  two
+  (eight 8)
+  sixteen)
+
+;;; Non-single-bit numbers must not influence the progression of
+;;; implicit values.  Single bits larger than any before *must*
+;;; influence said progression.
+(deftest bitfield.3
+    (mapcar (lambda (symbol)
+              (foreign-bitfield-value 'bf3 (list symbol)))
+            '(one two sixteen))
+  (1 2 16))
+
+(defbitfield bf4
+  (zero 0)
+  one)
+
+;;; Yet another edge case with the 0...
+(deftest bitfield.4
+    (foreign-bitfield-value 'bf4 '(one))
+  1)
diff --git a/external/cffi.darcs/tests/foreign-globals.lisp b/external/cffi.darcs/tests/foreign-globals.lisp
new file mode 100644
index 0000000..bff6471
--- /dev/null
+++ b/external/cffi.darcs/tests/foreign-globals.lisp
@@ -0,0 +1,284 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; foreign-globals.lisp --- Tests on foreign globals.
+;;;
+;;; Copyright (C) 2005-2007, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+(defcvar ("var_char" *char-var*) :char)
+(defcvar "var_unsigned_char"     :unsigned-char)
+(defcvar "var_short"             :short)
+(defcvar "var_unsigned_short"    :unsigned-short)
+(defcvar "var_int"               :int)
+(defcvar "var_unsigned_int"      :unsigned-int)
+(defcvar "var_long"              :long)
+(defcvar "var_unsigned_long"     :unsigned-long)
+(defcvar "var_float"             :float)
+(defcvar "var_double"            :double)
+(defcvar "var_pointer"           :pointer)
+(defcvar "var_string"            :string)
+
+#-cffi-features:no-long-long
+(progn
+  (defcvar "var_long_long"          :long-long)
+  (defcvar "var_unsigned_long_long" :unsigned-long-long))
+
+(deftest foreign-globals.ref.char
+    *char-var*
+  -127)
+
+(deftest foreign-globals.ref.unsigned-char
+    *var-unsigned-char*
+  255)
+
+(deftest foreign-globals.ref.short
+    *var-short*
+  -32767)
+
+(deftest foreign-globals.ref.unsigned-short
+    *var-unsigned-short*
+  65535)
+
+(deftest foreign-globals.ref.int
+    *var-int*
+  -32767)
+
+(deftest foreign-globals.ref.unsigned-int
+    *var-unsigned-int*
+  65535)
+
+(deftest foreign-globals.ref.long
+    *var-long*
+  -2147483647)
+
+(deftest foreign-globals.ref.unsigned-long
+    *var-unsigned-long*
+  4294967295)
+
+(deftest foreign-globals.ref.float
+    *var-float*
+  42.0)
+
+(deftest foreign-globals.ref.double
+    *var-double*
+  42.0d0)
+
+(deftest foreign-globals.ref.pointer
+    (null-pointer-p *var-pointer*)
+  t)
+
+(deftest foreign-globals.ref.string
+    *var-string*
+  "Hello, foreign world!")
+
+#-cffi-features:no-long-long
+(progn
+  #+openmcl (push 'foreign-globals.set.long-long rt::*expected-failures*)
+
+  (deftest foreign-globals.ref.long-long
+      *var-long-long*
+    -9223372036854775807)
+
+  (deftest foreign-globals.ref.unsigned-long-long
+      *var-unsigned-long-long*
+    18446744073709551615))
+
+;; The *.set.* tests restore the old values so that the *.ref.*
+;; don't fail when re-run.
+(defmacro with-old-value-restored ((place) &body body)
+  (let ((old (gensym)))
+    `(let ((,old ,place))
+       (prog1
+           (progn ,@body)
+         (setq ,place ,old)))))
+
+(deftest foreign-globals.set.int
+    (with-old-value-restored (*var-int*)
+      (setq *var-int* 42)
+      *var-int*)
+  42)
+
+(deftest foreign-globals.set.string
+    (with-old-value-restored (*var-string*)
+      (setq *var-string* "Ehxosxangxo")
+      (prog1
+          *var-string*
+        ;; free the string we just allocated
+        (foreign-free (mem-ref (get-var-pointer '*var-string*) :pointer))))
+  "Ehxosxangxo")
+
+#-cffi-features:no-long-long
+(deftest foreign-globals.set.long-long
+    (with-old-value-restored (*var-long-long*)
+      (setq *var-long-long* -9223000000000005808)
+      *var-long-long*)
+  -9223000000000005808)
+
+(deftest foreign-globals.get-var-pointer.1
+    (pointerp (get-var-pointer '*char-var*))
+  t)
+
+(deftest foreign-globals.get-var-pointer.2
+    (mem-ref (get-var-pointer '*char-var*) :char)
+  -127)
+
+;;; Symbol case.
+
+(defcvar "UPPERCASEINT1"     :int)
+(defcvar "UPPER_CASE_INT1"   :int)
+(defcvar "MiXeDCaSeInT1"     :int)
+(defcvar "MiXeD_CaSe_InT1"   :int)
+
+(deftest foreign-globals.ref.uppercaseint1
+    *uppercaseint1*
+  12345)
+
+(deftest foreign-globals.ref.upper-case-int1
+    *upper-case-int1*
+  23456)
+
+(deftest foreign-globals.ref.mixedcaseint1
+    *mixedcaseint1*
+  34567)
+
+(deftest foreign-globals.ref.mixed-case-int1
+    *mixed-case-int1*
+  45678)
+
+(when (string= (symbol-name 'nil) "NIL")
+  (let ((*readtable* (copy-readtable)))
+    (setf (readtable-case *readtable*) :invert)
+    (eval (read-from-string "(defcvar \"UPPERCASEINT2\"     :int)"))
+    (eval (read-from-string "(defcvar \"UPPER_CASE_INT2\"   :int)"))
+    (eval (read-from-string "(defcvar \"MiXeDCaSeInT2\"     :int)"))
+    (eval (read-from-string "(defcvar \"MiXeD_CaSe_InT2\"   :int)"))
+    (setf (readtable-case *readtable*) :preserve)
+    (eval (read-from-string "(DEFCVAR \"UPPERCASEINT3\"     :INT)"))
+    (eval (read-from-string "(DEFCVAR \"UPPER_CASE_INT3\"   :INT)"))
+    (eval (read-from-string "(DEFCVAR \"MiXeDCaSeInT3\"     :INT)"))
+    (eval (read-from-string "(DEFCVAR \"MiXeD_CaSe_InT3\"   :INT)"))))
+
+
+;;; EVAL gets rid of SBCL's unreachable code warnings.
+(when (string= (symbol-name (eval nil)) "nil")
+  (let ((*readtable* (copy-readtable)))
+    (setf (readtable-case *readtable*) :invert)
+    (eval (read-from-string "(DEFCVAR \"UPPERCASEINT2\"     :INT)"))
+    (eval (read-from-string "(DEFCVAR \"UPPER_CASE_INT2\"   :INT)"))
+    (eval (read-from-string "(DEFCVAR \"MiXeDCaSeInT2\"     :INT)"))
+    (eval (read-from-string "(DEFCVAR \"MiXeD_CaSe_InT2\"   :INT)"))
+    (setf (readtable-case *readtable*) :downcase)
+    (eval (read-from-string "(defcvar \"UPPERCASEINT3\"     :int)"))
+    (eval (read-from-string "(defcvar \"UPPER_CASE_INT3\"   :int)"))
+    (eval (read-from-string "(defcvar \"MiXeDCaSeInT3\"     :int)"))
+    (eval (read-from-string "(defcvar \"MiXeD_CaSe_InT3\"   :int)"))))
+
+(deftest foreign-globals.ref.uppercaseint2
+    *uppercaseint2*
+  12345)
+
+(deftest foreign-globals.ref.upper-case-int2
+    *upper-case-int2*
+  23456)
+
+(deftest foreign-globals.ref.mixedcaseint2
+    *mixedcaseint2*
+  34567)
+
+(deftest foreign-globals.ref.mixed-case-int2
+    *mixed-case-int2*
+  45678)
+
+(deftest foreign-globals.ref.uppercaseint3
+    *uppercaseint3*
+  12345)
+
+(deftest foreign-globals.ref.upper-case-int3
+    *upper-case-int3*
+  23456)
+
+(deftest foreign-globals.ref.mixedcaseint3
+    *mixedcaseint3*
+  34567)
+
+(deftest foreign-globals.ref.mixed-case-int3
+    *mixed-case-int3*
+  45678)
+
+;;; regression test:
+;;; gracefully accept symbols in defcvar
+
+(defcvar *var-char* :char)
+(defcvar var-char :char)
+
+(deftest foreign-globals.symbol-name
+    (values *var-char* var-char)
+  -127 -127)
+
+;;;# Namespace
+
+#-cffi-features:flat-namespace
+(progn
+  (deftest foreign-globals.namespace.1
+      (values
+       (mem-ref (foreign-symbol-pointer "var_char" :library 'libtest) :char)
+       (foreign-symbol-pointer "var_char" :library 'libtest2))
+    -127 nil)
+
+  (deftest foreign-globals.namespace.2
+      (values
+       (mem-ref (foreign-symbol-pointer "ns_var" :library 'libtest) :boolean)
+       (mem-ref (foreign-symbol-pointer "ns_var" :library 'libtest2) :boolean))
+    t nil)
+
+  ;; For its "default" module, Lispworks seems to cache lookups from
+  ;; the newest module tried.  If a lookup happens to have failed
+  ;; subsequent lookups will fail even the symbol exists in other
+  ;; modules.  So this test fails.
+  #+lispworks
+  (pushnew 'foreign-globals.namespace.3 regression-test::*expected-failures*)
+
+  (deftest foreign-globals.namespace.3
+      (values
+       (foreign-symbol-pointer "var_char" :library 'libtest2)
+       (mem-ref (foreign-symbol-pointer "var_char") :char))
+    nil -127)
+
+  (defcvar ("ns_var" *ns-var1* :library libtest) :boolean)
+  (defcvar ("ns_var" *ns-var2* :library libtest2) :boolean)
+
+  (deftest foreign-globals.namespace.4
+      (values *ns-var1* *ns-var2*)
+    t nil))
+
+;;;# Read-only
+
+(defcvar ("var_char" *var-char-ro* :read-only t) :char
+  "Testing the docstring too.")
+
+(deftest foreign-globals.read-only.1
+    (values *var-char-ro*
+            (ignore-errors (setf *var-char-ro* 12)))
+  -127 nil)
diff --git a/external/cffi.darcs/tests/funcall.lisp b/external/cffi.darcs/tests/funcall.lisp
new file mode 100644
index 0000000..2e0ef46
--- /dev/null
+++ b/external/cffi.darcs/tests/funcall.lisp
@@ -0,0 +1,193 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; funcall.lisp --- Tests function calling.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;; Copyright (C) 2005-2007, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+;;;# Calling with Built-In C Types
+;;;
+;;; Tests calling standard C library functions both passing and
+;;; returning each built-in type.
+
+;;; Don't run these tests if the implementation does not support
+;;; foreign-funcall.
+#-cffi-features:no-foreign-funcall
+(progn
+
+(deftest funcall.char
+    (foreign-funcall "toupper" :char (char-code #\a) :char)
+  #.(char-code #\A))
+
+(deftest funcall.int.1
+    (foreign-funcall "abs" :int -100 :int)
+  100)
+
+(defun funcall-abs (n)
+  (foreign-funcall "abs" :int n :int))
+
+;;; regression test: lispworks's %foreign-funcall based on creating
+;;; and caching foreign-funcallables at macro-expansion time.
+(deftest funcall.int.2
+    (funcall-abs -42)
+  42)
+
+(deftest funcall.long
+    (foreign-funcall "labs" :long -131072 :long)
+  131072)
+
+#-cffi-features:no-long-long
+(deftest funcall.long-long
+    (foreign-funcall "my_llabs" :long-long -9223372036854775807 :long-long)
+  9223372036854775807)
+
+(deftest funcall.float
+    (foreign-funcall "my_sqrtf" :float 16.0 :float)
+  4.0)
+
+(deftest funcall.double
+    (foreign-funcall "sqrt" :double 36.0d0 :double)
+  6.0d0)
+
+#+(and scl long-float)
+(deftest funcall.long-double
+    (foreign-funcall "sqrtl" :long-double 36.0l0 :long-double)
+  6.0l0)
+
+(deftest funcall.string.1
+    (foreign-funcall "strlen" :string "Hello" :int)
+  5)
+
+(deftest funcall.string.2
+    (with-foreign-pointer-as-string (s 100)
+      (setf (mem-ref s :char) 0)
+      (foreign-funcall "strcpy" :pointer s :string "Hello" :pointer)
+      (foreign-funcall "strcat" :pointer s :string ", world!" :pointer))
+  "Hello, world!")
+
+(deftest funcall.string.3
+    (with-foreign-pointer (ptr 100)
+      (lisp-string-to-foreign "Hello, " ptr 8)
+      (foreign-funcall "strcat" :pointer ptr :string "world!" :string))
+  "Hello, world!")
+
+;;;# Calling Varargs Functions
+
+;; The CHAR argument must be passed as :INT because chars are promoted
+;; to ints when passed as variable arguments.
+(deftest funcall.varargs.char
+    (with-foreign-pointer-as-string (s 100)
+      (setf (mem-ref s :char) 0)
+      (foreign-funcall "sprintf" :pointer s :string "%c" :int 65 :int))
+  "A")
+
+(deftest funcall.varargs.int
+    (with-foreign-pointer-as-string (s 100)
+      (setf (mem-ref s :char) 0)
+      (foreign-funcall "sprintf" :pointer s :string "%d" :int 1000 :int))
+  "1000")
+
+(deftest funcall.varargs.long
+    (with-foreign-pointer-as-string (s 100)
+      (setf (mem-ref s :char) 0)
+      (foreign-funcall "sprintf" :pointer s :string "%ld" :long 131072 :int))
+  "131072")
+
+;;; There is no FUNCALL.VARARGS.FLOAT as floats are promoted to double
+;;; when passed as variable arguments.  Currently this fails in SBCL
+;;; and CMU CL on Darwin/ppc.
+(deftest funcall.varargs.double
+    (with-foreign-pointer-as-string (s 100)
+      (setf (mem-ref s :char) 0)
+      (foreign-funcall "sprintf" :pointer s :string "%.2f"
+                       :double (coerce pi 'double-float) :int))
+  "3.14")
+
+#+(and scl long-float)
+(deftest funcall.varargs.long-double
+    (with-foreign-pointer-as-string (s 100)
+      (setf (mem-ref s :char) 0)
+      (foreign-funcall "sprintf" :pointer s :string "%.2Lf"
+                       :long-double pi :int))
+  "3.14")
+
+(deftest funcall.varargs.string
+    (with-foreign-pointer-as-string (s 100)
+      (setf (mem-ref s :char) 0)
+      (foreign-funcall "sprintf" :pointer s :string "%s, %s!"
+                       :string "Hello" :string "world" :int))
+  "Hello, world!")
+
+;;; See DEFCFUN.DOUBLE26.
+(deftest funcall.double26
+    (foreign-funcall "sum_double26"
+                     :double 3.14d0 :double 3.14d0 :double 3.14d0
+                     :double 3.14d0 :double 3.14d0 :double 3.14d0
+                     :double 3.14d0 :double 3.14d0 :double 3.14d0
+                     :double 3.14d0 :double 3.14d0 :double 3.14d0
+                     :double 3.14d0 :double 3.14d0 :double 3.14d0
+                     :double 3.14d0 :double 3.14d0 :double 3.14d0
+                     :double 3.14d0 :double 3.14d0 :double 3.14d0
+                     :double 3.14d0 :double 3.14d0 :double 3.14d0
+                     :double 3.14d0 :double 3.14d0 :double)
+  81.64d0)
+
+;;; See DEFCFUN.FLOAT26.
+(deftest funcall.float26
+    (foreign-funcall "sum_float26"
+                     :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
+                     :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
+                     :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
+                     :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
+                     :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
+                     :float 5.0 :float)
+  130.0)
+
+;;; Funcalling a pointer.
+(deftest funcall.f-s-p.1
+    (foreign-funcall-pointer (foreign-symbol-pointer "abs") nil :int -42 :int)
+  42)
+
+;;;# Namespaces
+
+#-cffi-features:flat-namespace
+(deftest funcall.namespace.1
+    (values (foreign-funcall ("ns_function" :library libtest) :boolean)
+            (foreign-funcall ("ns_function" :library libtest2) :boolean))
+  t nil)
+
+;;;# stdcall
+
+#+(and cffi-features:x86 (not cffi-features:no-stdcall))
+(deftest funcall.stdcall.1
+    (flet ((fun ()
+             (foreign-funcall ("stdcall_fun@12" :cconv :stdcall)
+                              :int 1 :int 2 :int 3 :int)))
+      (loop repeat 100 do (fun)
+            finally (return (fun))))
+  6)
+
+) ;; #-cffi-features:no-foreign-funcall
diff --git a/external/cffi.darcs/tests/libtest.c b/external/cffi.darcs/tests/libtest.c
new file mode 100644
index 0000000..71095b1
--- /dev/null
+++ b/external/cffi.darcs/tests/libtest.c
@@ -0,0 +1,864 @@
+/* -*- Mode: C; tab-width: 4; indent-tabs-mode: nil -*-
+ *
+ * libtest.c --- auxiliary C lib for testing purposes
+ *
+ * Copyright (C) 2005-2007, Luis Oliveira  
+ *
+ * Permission is hereby granted, free of charge, to any person
+ * obtaining a copy of this software and associated documentation
+ * files (the "Software"), to deal in the Software without
+ * restriction, including without limitation the rights to use, copy,
+ * modify, merge, publish, distribute, sublicense, and/or sell copies
+ * of the Software, and to permit persons to whom the Software is
+ * furnished to do so, subject to the following conditions:
+ *
+ * The above copyright notice and this permission notice shall be
+ * included in all copies or substantial portions of the Software.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ * NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+ * HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+ * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+ * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+ * DEALINGS IN THE SOFTWARE.
+ */
+
+#ifdef WIN32
+#define DLLEXPORT __declspec(dllexport)
+#else
+#define DLLEXPORT
+#endif
+
+#include 
+#include 
+#include 
+#include 
+#include 
+#include 
+
+/* MSVC doesn't have stdint.h and uses a different syntax for stdcall */
+#ifndef _MSC_VER
+#include 
+#define STDCALL __attribute__((stdcall))
+#else
+#define STDCALL __stdcall
+#endif
+
+/*
+ * Some functions that aren't available on WIN32
+ */
+
+DLLEXPORT
+float my_sqrtf(float n)
+{
+    return (float) sqrt((double) n);
+}
+
+DLLEXPORT
+char *my_strdup(const char *str)
+{
+    char *p = malloc(strlen(str) + 1);
+    strcpy(p, str);
+    return p;
+}
+
+DLLEXPORT
+long long my_llabs(long long n)
+{
+    return n < 0 ? -n : n;
+}
+
+/*
+ * Foreign Globals
+ *
+ * (var_int is used in MISC-TYPES.EXPAND.3 as well)
+ */
+
+DLLEXPORT char *         dll_version        = "20060907";
+
+/* TODO: look into signed char vs. unsigned char issue */
+DLLEXPORT char           var_char           = -127;
+DLLEXPORT unsigned char  var_unsigned_char  = 255;
+DLLEXPORT short          var_short          = -32767;
+DLLEXPORT unsigned short var_unsigned_short = 65535;
+DLLEXPORT int            var_int            = -32767;
+DLLEXPORT unsigned int   var_unsigned_int   = 65535;
+DLLEXPORT long           var_long           = -2147483647L;
+DLLEXPORT unsigned long  var_unsigned_long  = 4294967295UL;
+DLLEXPORT float          var_float          = 42.0f;
+DLLEXPORT double         var_double         = 42.0;
+DLLEXPORT void *         var_pointer        = NULL;
+DLLEXPORT char *         var_string         = "Hello, foreign world!";
+
+DLLEXPORT long long          var_long_long          = -9223372036854775807LL;
+DLLEXPORT unsigned long long var_unsigned_long_long = 18446744073709551615ULL;
+
+DLLEXPORT float float_max = FLT_MAX;
+DLLEXPORT float float_min = FLT_MIN;
+DLLEXPORT double double_max = DBL_MAX;
+DLLEXPORT double double_min = DBL_MIN;
+
+/*
+ * Callbacks
+ */
+
+DLLEXPORT
+int expect_char_sum(char (*f)(char, char))
+{
+    return f('a', 3) == 'd';
+}
+
+DLLEXPORT
+int expect_unsigned_char_sum(unsigned char (*f)(unsigned char, unsigned char))
+{
+    return f(UCHAR_MAX-1, 1) == UCHAR_MAX;
+}
+
+DLLEXPORT
+int expect_short_sum(short (*f)(short a, short b))
+{
+    return f(SHRT_MIN+1, -1) == SHRT_MIN;
+}
+
+DLLEXPORT
+int expect_unsigned_short_sum(unsigned short (*f)(unsigned short,
+                                                  unsigned short))
+{
+    return f(USHRT_MAX-1, 1) == USHRT_MAX;
+}
+
+/* used in MISC-TYPES.EXPAND.4 as well */
+DLLEXPORT
+int expect_int_sum(int (*f)(int, int))
+{
+    return f(INT_MIN+1, -1) == INT_MIN;
+}
+
+DLLEXPORT
+int expect_unsigned_int_sum(unsigned int (*f)(unsigned int, unsigned int))
+{
+    return f(UINT_MAX-1, 1) == UINT_MAX;
+}
+
+DLLEXPORT
+int expect_long_sum(long (*f)(long, long))
+{
+    return f(LONG_MIN+1, -1) == LONG_MIN;
+}
+
+DLLEXPORT
+int expect_unsigned_long_sum(unsigned long (*f)(unsigned long, unsigned long))
+{
+    return f(ULONG_MAX-1, 1) == ULONG_MAX;
+}
+
+DLLEXPORT
+int expect_long_long_sum(long long (*f)(long long, long long))
+{
+    return f(LLONG_MIN+1, -1) == LLONG_MIN;
+}
+
+DLLEXPORT
+int expect_unsigned_long_long_sum (unsigned long long
+                                   (*f)(unsigned long long, unsigned long long))
+{
+    return f(ULLONG_MAX-1, 1) == ULLONG_MAX;
+}
+
+DLLEXPORT
+int expect_float_sum(float (*f)(float, float))
+{
+    /*printf("\n>>> FLOAT: %f <<<\n", f(20.0f, 22.0f));*/
+    return f(20.0f, 22.0f) == 42.0f;
+}
+
+DLLEXPORT
+int expect_double_sum(double (*f)(double, double))
+{
+    /*printf("\n>>> DOUBLE: %f<<<\n", f(-20.0, -22.0));*/
+    return f(-20.0, -22.0) == -42.0;
+}
+
+DLLEXPORT
+int expect_long_double_sum(long double (*f)(long double, long double))
+{
+    /*printf("\n>>> DOUBLE: %f<<<\n", f(-20.0, -22.0));*/
+    return f(-20.0, -22.0) == -42.0;
+}
+
+DLLEXPORT
+int expect_pointer_sum(void* (*f)(void*, int))
+{
+    return f(NULL, 0xDEAD) == (void *) 0xDEAD;
+}
+
+DLLEXPORT
+int expect_strcat(char* (*f)(char*, char*))
+{
+    char *ret = f("Hello, ", "C world!");
+    int res = strcmp(ret, "Hello, C world!") == 0;
+    /* commented out as a quick fix on platforms that don't
+       foreign allocate in C malloc space. */
+    /*free(ret);*/ /* is this allowed? */
+    return res;
+}
+
+DLLEXPORT
+void pass_int_ref(void (*f)(int*))
+{
+    int x = 1984;
+    f(&x);
+}
+
+/*
+ * Enums
+ */
+
+typedef enum {
+    ONE = 1,
+    TWO,
+    THREE,
+    FOUR,
+    FORTY_ONE = 41,
+    FORTY_TWO
+} numeros;
+
+DLLEXPORT
+int check_enums(numeros one, numeros two, numeros three, numeros four,
+                numeros forty_one, numeros forty_two)
+{
+    if (one == ONE && two == TWO && three == THREE && four == FOUR &&
+        forty_one == FORTY_ONE && forty_two == FORTY_TWO)
+        return 1;
+
+    return 0;
+}
+
+typedef enum { FALSE, TRUE } another_boolean;
+
+DLLEXPORT
+another_boolean return_enum(int x)
+{
+    if (x == 0)
+        return FALSE;
+    else
+        return TRUE;
+}
+
+/*
+ * Booleans
+ */
+
+DLLEXPORT
+int equalequal(int a, unsigned int b)
+{
+    return ((unsigned int) a) == b;
+}
+
+DLLEXPORT
+char bool_and(unsigned char a, char b)
+{
+    return a && b;
+}
+
+DLLEXPORT
+unsigned long bool_xor(long a, unsigned long b)
+{
+    return (a && !b) || (!a && b);
+}
+
+/*
+ * Test struct alignment issues. These comments assume the x86 gABI.
+ * Hopefully these tests will spot alignment issues in others archs
+ * too.
+ */
+
+/*
+ * STRUCT.ALIGNMENT.1
+ */
+
+struct s_ch {
+    char a_char;
+};
+
+/* This struct's size should be 2 bytes */
+struct s_s_ch {
+    char another_char;
+    struct s_ch a_s_ch;
+};
+
+DLLEXPORT
+struct s_s_ch the_s_s_ch = { 2, { 1 } };
+
+/*
+ * STRUCT.ALIGNMENT.2
+ */
+
+/* This one should be alignment should be the same as short's alignment. */
+struct s_short {
+    char a_char;
+    char another_char;
+    short a_short;
+};
+
+struct s_s_short {
+    char yet_another_char;
+    struct s_short a_s_short; /* so this should be 2-byte aligned */
+};  /* size: 6 bytes */
+
+DLLEXPORT
+struct s_s_short the_s_s_short = { 4, { 1, 2, 3 } };
+
+/*
+ * STRUCT.ALIGNMENT.3
+ */
+
+/* This test will, among other things, check for the existence tail padding. */
+
+struct s_double {
+    char a_char;       /* 1 byte */
+                       /* padding: 3 bytes */
+    double a_double;   /* 8 bytes */
+    char another_char; /* 1 byte */
+                       /* padding: 3 bytes */
+};                     /* total size: 16 bytes */
+
+struct s_s_double {
+    char yet_another_char;      /* 1 byte */
+                                /* 3 bytes padding */
+    struct s_double a_s_double; /* 16 bytes */
+    short a_short;              /* 2 byte */
+                                /* 2 bytes padding */
+};                              /* total size: 24 bytes */
+
+DLLEXPORT
+struct s_s_double the_s_s_double = { 4, { 1, 2.0, 3 }, 5 };
+
+/*
+ * STRUCT.ALIGNMENT.4
+ */
+struct s_s_s_double {
+    short another_short;            /* 2 bytes */
+                                    /* 2 bytes padding */
+    struct s_s_double a_s_s_double; /* 24 bytes */
+    char last_char;                 /* 1 byte */
+                                    /* 3 bytes padding */
+};                                  /* total size: 32 */
+
+DLLEXPORT
+struct s_s_s_double the_s_s_s_double = { 6, { 4, { 1, 2.0, 3 }, 5 }, 7 };
+
+/*
+ * STRUCT.ALIGNMENT.5
+ */
+
+/* MacOSX ABI says: "The embedding alignment of the first element in a data
+   structure is equal to the element's natural alignment." and "For subsequent
+   elements that have a natural alignment greater than 4 bytes, the embedding
+   alignment is 4, unless the element is a vector." */
+
+/* note: these rules will apply to the structure itself. So, unless it is
+   the first element of another structure, its alignment will be 4. */
+
+/* the following offsets and sizes are specific to darwin/ppc32 */
+
+struct s_double2 {
+    double a_double;            /* 8 bytes (alignment 8) */
+    short a_short;              /* 2 bytes */
+                                /* 6 bytes padding */
+};                              /* total size: 16 */
+
+struct s_s_double2 {
+    char a_char;                  /* 1 byte */
+                                  /* 3 bytes padding */
+    struct s_double2 a_s_double2; /* 16 bytes, alignment 4 */
+    short another_short;          /* 2 bytes */
+                                  /* 2 bytes padding */
+};                                /* total size: 24 bytes */
+                                  /* alignment: 4 */
+
+DLLEXPORT
+struct s_s_double2 the_s_s_double2 = { 3, { 1.0, 2 }, 4 };
+
+/*
+ * STRUCT.ALIGNMENT.6
+ */
+
+/* Same as STRUCT.ALIGNMENT.5 but with long long. */
+
+struct s_long_long {
+    long long a_long_long;      /* 8 bytes (alignment 8) */
+    short a_short;              /* 2 bytes */
+                                /* 6 bytes padding */
+};                              /* total size: 16 */
+
+struct s_s_long_long {
+    char a_char;                      /* 1 byte */
+                                      /* 3 bytes padding */
+    struct s_long_long a_s_long_long; /* 16 bytes, alignment 4 */
+    short a_short;                    /* 2 bytes */
+                                      /* 2 bytes padding */
+};                                    /* total size: 24 bytes */
+                                      /* alignment: 4 */
+
+DLLEXPORT
+struct s_s_long_long the_s_s_long_long = { 3, { 1, 2 }, 4 };
+
+/*
+ * STRUCT.ALIGNMENT.7
+ */
+
+/* Another test for Darwin's PPC32 ABI. */
+
+struct s_s_double3 {
+    struct s_double2 a_s_double2; /* 16 bytes, alignment 8*/
+    short another_short;          /* 2 bytes */
+                                  /* 6 bytes padding */
+};                                /* total size: 24 */
+
+struct s_s_s_double3 {
+    struct s_s_double3 a_s_s_double3; /* 24 bytes */
+    char a_char;                      /* 1 byte */
+                                      /* 7 bytes padding */
+};                                    /* total size: 32 */
+
+DLLEXPORT
+struct s_s_s_double3 the_s_s_s_double3 = { { { 1.0, 2 }, 3 }, 4 };
+
+/*
+ * STRUCT.ALIGNMENT.8
+ */
+
+/* Same as STRUCT.ALIGNMENT.[56] but with unsigned long long. */
+
+struct s_unsigned_long_long {
+    unsigned long long an_unsigned_long_long; /* 8 bytes (alignment 8) */
+    short a_short;                            /* 2 bytes */
+                                              /* 6 bytes padding */
+};                                            /* total size: 16 */
+
+struct s_s_unsigned_long_long {
+    char a_char;                                         /* 1 byte */
+                                                         /* 3 bytes padding */
+    struct s_unsigned_long_long a_s_unsigned_long_long;  /* 16 bytes, align 4 */
+    short a_short;                                       /* 2 bytes */
+                                                         /* 2 bytes padding */
+};                                           /* total size: 24 bytes */
+                                             /*  alignment: 4 */
+
+DLLEXPORT
+struct s_s_unsigned_long_long the_s_s_unsigned_long_long = { 3, { 1, 2 }, 4 };
+
+/* STRUCT.ALIGNMENT.x */
+
+/* commented this test out because this is not standard C
+   and MSVC++ (or some versions of it at least) won't compile it. */
+
+/*
+struct empty_struct {};
+
+struct with_empty_struct {
+    struct empty_struct foo;
+    int an_int;
+};
+
+DLLEXPORT
+struct with_empty_struct the_with_empty_struct = { {}, 42 };
+*/
+
+/*
+ * DEFCFUN.NOARGS and DEFCFUN.NOOP
+ */
+
+DLLEXPORT
+int noargs()
+{
+    return 42;
+}
+
+DLLEXPORT
+void noop()
+{
+    return;
+}
+
+/*
+ * DEFCFUN.BFF.1
+ *
+ * (let ((rettype (find-type :long))
+ *       (arg-types (n-random-types-no-ll 127)))
+ *   (c-function rettype arg-types)
+ *   (gen-function-test rettype arg-types))
+ */
+
+DLLEXPORT long sum_127_no_ll
+  (long a1, unsigned long a2, short a3, unsigned short a4, float a5,
+   double a6, unsigned long a7, float a8, unsigned char a9, unsigned
+   short a10, short a11, unsigned long a12, double a13, long a14,
+   unsigned int a15, void* a16, unsigned int a17, unsigned short a18,
+   long a19, float a20, void* a21, float a22, int a23, int a24, unsigned
+   short a25, long a26, long a27, double a28, unsigned char a29, unsigned
+   int a30, unsigned int a31, int a32, unsigned short a33, unsigned int
+   a34, void* a35, double a36, double a37, long a38, short a39, unsigned
+   short a40, long a41, char a42, long a43, unsigned short a44, void*
+   a45, int a46, unsigned int a47, double a48, unsigned char a49,
+   unsigned char a50, float a51, int a52, unsigned short a53, double a54,
+   short a55, unsigned char a56, unsigned long a57, float a58, float a59,
+   float a60, void* a61, void* a62, unsigned int a63, unsigned long a64,
+   char a65, short a66, unsigned short a67, unsigned long a68, void* a69,
+   float a70, double a71, long a72, unsigned long a73, short a74,
+   unsigned int a75, unsigned short a76, int a77, unsigned short a78,
+   char a79, double a80, short a81, unsigned char a82, float a83, char
+   a84, int a85, double a86, unsigned char a87, int a88, unsigned long
+   a89, double a90, short a91, short a92, unsigned int a93, unsigned char
+   a94, float a95, long a96, float a97, long a98, long a99, int a100, int
+   a101, unsigned int a102, char a103, char a104, unsigned short a105,
+   unsigned int a106, unsigned short a107, unsigned short a108, int a109,
+   long a110, char a111, double a112, unsigned int a113, char a114, short
+   a115, unsigned long a116, unsigned int a117, short a118, unsigned char
+   a119, float a120, void* a121, double a122, int a123, long a124, char
+   a125, unsigned short a126, float a127)
+{
+    return (long) a1 + a2 + a3 + a4 + ((long) a5) + ((long) a6) + a7 +
+        ((long) a8) + a9 + a10 + a11 + a12 + ((long) a13) + a14 + a15 +
+        ((unsigned int) a16) + a17 + a18 + a19 + ((long) a20) +
+        ((unsigned int) a21) + ((long) a22) + a23 + a24 + a25 + a26 + a27 +
+        ((long) a28) + a29 + a30 + a31 + a32 + a33 + a34 + ((unsigned int) a35) +
+        ((long) a36) + ((long) a37) + a38 + a39 + a40 + a41 + a42 + a43 + a44 +
+        ((unsigned int) a45) + a46 + a47 + ((long) a48) + a49 + a50 +
+        ((long) a51) + a52 + a53 + ((long) a54) + a55 + a56 + a57 + ((long) a58) +
+        ((long) a59) + ((long) a60) + ((unsigned int) a61) +
+        ((unsigned int) a62) + a63 + a64 + a65 + a66 + a67 + a68 +
+        ((unsigned int) a69) + ((long) a70) + ((long) a71) + a72 + a73 + a74 +
+        a75 + a76 + a77 + a78 + a79 + ((long) a80) + a81 + a82 + ((long) a83) +
+        a84 + a85 + ((long) a86) + a87 + a88 + a89 + ((long) a90) + a91 + a92 +
+        a93 + a94 + ((long) a95) + a96 + ((long) a97) + a98 + a99 + a100 + a101 +
+        a102 + a103 + a104 + a105 + a106 + a107 + a108 + a109 + a110 + a111 +
+        ((long) a112) + a113 + a114 + a115 + a116 + a117 + a118 + a119 +
+        ((long) a120) + ((unsigned int) a121) + ((long) a122) + a123 + a124 +
+        a125 + a126 + ((long) a127);
+}
+
+/*
+ * DEFCFUN.BFF.2
+ *
+ * (let ((rettype (find-type :long-long))
+ *       (arg-types (n-random-types 127)))
+ *   (c-function rettype arg-types)
+ *   (gen-function-test rettype arg-types))
+ */
+
+DLLEXPORT long long sum_127
+  (void* a1, void* a2, float a3, unsigned long a4, void* a5, long long
+  a6, double a7, double a8, unsigned short a9, int a10, long long a11,
+  long a12, short a13, unsigned int a14, long a15, unsigned char a16,
+  int a17, double a18, short a19, short a20, long long a21, unsigned
+  int a22, unsigned short a23, short a24, void* a25, short a26,
+  unsigned short a27, unsigned short a28, int a29, long long a30,
+  void* a31, int a32, unsigned long a33, unsigned long a34, void* a35,
+  unsigned long long a36, float a37, int a38, short a39, void* a40,
+  unsigned long long a41, long long a42, unsigned long a43, unsigned
+  long a44, unsigned long long a45, unsigned long a46, char a47,
+  double a48, long a49, unsigned int a50, int a51, short a52, void*
+  a53, long a54, unsigned long long a55, int a56, unsigned short a57,
+  unsigned long long a58, float a59, void* a60, float a61, unsigned
+  short a62, unsigned long a63, float a64, unsigned int a65, unsigned
+  long long a66, void* a67, double a68, unsigned long long a69, double
+  a70, double a71, long long a72, void* a73, unsigned short a74, long
+  a75, void* a76, short a77, double a78, long a79, unsigned char a80,
+  void* a81, unsigned char a82, long a83, double a84, void* a85, int
+  a86, double a87, unsigned char a88, double a89, short a90, long a91,
+  int a92, long a93, double a94, unsigned short a95, unsigned int a96,
+  int a97, char a98, long long a99, double a100, float a101, unsigned
+  long a102, short a103, void* a104, float a105, long long a106, int
+  a107, long long a108, long long a109, double a110, unsigned long
+  long a111, double a112, unsigned long a113, char a114, char a115,
+  unsigned long a116, short a117, unsigned char a118, unsigned char
+  a119, int a120, int a121, float a122, unsigned char a123, unsigned
+  char a124, double a125, unsigned long long a126, char a127)
+{
+    return (long long) ((unsigned int) a1) + ((unsigned int) a2) + ((long) a3) +
+        a4 + ((unsigned int) a5) + a6 + ((long) a7) + ((long) a8) + a9 + a10 +
+        a11 + a12 + a13 + a14 + a15 + a16 + a17 + ((long) a18) + a19 + a20 +
+        a21 + a22 + a23 + a24 + ((unsigned int) a25) + a26 + a27 + a28 + a29 +
+        a30 + ((unsigned int) a31) + a32 + a33 + a34 + ((unsigned int) a35) +
+        a36 + ((long) a37) + a38 + a39 + ((unsigned int) a40) + a41 + a42 + a43 +
+        a44 + a45 + a46 + a47 + ((long) a48) + a49 + a50 + a51 + a52 +
+        ((unsigned int) a53) + a54 + a55 + a56 + a57 + a58 + ((long) a59) +
+        ((unsigned int) a60) + ((long) a61) + a62 + a63 + ((long) a64) + a65 + a66
+        + ((unsigned int) a67) + ((long) a68) + a69 + ((long) a70) + ((long) a71) +
+        a72 + ((unsigned int) a73) + a74 + a75 + ((unsigned int) a76) + a77 +
+        ((long) a78) + a79 + a80 + ((unsigned int) a81) + a82 + a83 + ((long) a84)
+        + ((unsigned int) a85) + a86 + ((long) a87) + a88 + ((long) a89) + a90 +
+        a91 + a92 + a93 + ((long) a94) + a95 + a96 + a97 + a98 + a99 +
+        ((long) a100) + ((long) a101) + a102 + a103 + ((unsigned int) a104) +
+        ((long) a105) + a106 + a107 + a108 + a109 + ((long) a110) + a111 +
+        ((long) a112) + a113 + a114 + a115 + a116 + a117 + a118 + a119 + a120 +
+        a121 + ((long) a122) + a123 + a124 + ((long) a125) + a126 + a127;
+}
+
+/*
+ * CALLBACKS.BFF.1  (cb-test :no-long-long t)
+ */
+
+DLLEXPORT long call_sum_127_no_ll
+  (long (*func)
+   (unsigned long, void*, long, double, unsigned long, float, float,
+    int, unsigned int, double, double, double, void*, unsigned short,
+    unsigned short, void*, long, long, int, short, unsigned short,
+    unsigned short, char, long, void*, void*, char, unsigned char,
+    unsigned long, short, int, int, unsigned char, short, long, long,
+    void*, unsigned short, char, double, unsigned short, void*, short,
+    unsigned long, unsigned short, float, unsigned char, short, float,
+    short, char, unsigned long, unsigned long, char, float, long, void*,
+    short, float, unsigned int, float, unsigned int, double, unsigned int,
+    unsigned char, int, long, char, short, double, int, void*, char,
+    unsigned short, void*, unsigned short, void*, unsigned long, double,
+    void*, long, float, unsigned short, unsigned short, void*, float, int,
+    unsigned int, double, float, long, void*, unsigned short, float,
+    unsigned char, unsigned char, float, unsigned int, float, unsigned
+    short, double, unsigned short, unsigned long, unsigned int, unsigned
+    long, void*, unsigned char, char, char, unsigned short, unsigned long,
+    float, short, void*, long, unsigned short, short, double, short, int,
+    char, unsigned long, long, int, void*, double, unsigned char))
+{
+    return
+        func(948223085, (void *) 803308438, -465723152, 20385,
+             219679466, -10035, 13915, -1193455756, 1265303699, 27935, -18478,
+             -10508, (void *) 215389089, 55561, 55472, (void *) 146070433,
+             -1040819989, -17851453, -1622662247, -19473, 20837, 30216, 79,
+             986800400, (void *) 390281604, (void *) 1178532858, 19, 117,
+             78337699, -5718, -991300738, 872160910, 184, 926, -1487245383,
+             1633973783, (void *) 33738609, 53985, -116, 31645, 27196, (void *)
+             145569903, -6960, 17252220, 47404, -10491, 88, -30438, -21212,
+             -1982, -16, 1175270, 7949380, -121, 8559, -432968526, (void *)
+             293455312, 11894, -8394, 142421516, -25758, 3422998, 4004,
+             15758212, 198, -1071899743, -1284904617, -11, -17219, -30039,
+             311589092, (void *) 541468577, 123, 63517, (void *) 1252504506,
+             39368, (void *) 10057868, 134781408, -7143, (void *) 72825877,
+             -1190798667, -30862, 63757, 14965, (void *) 802391252, 22008,
+             -517289619, 806091099, 1125, 451, -498145176, (void *) 55960931,
+             15379, 4629, 184, 254, 22532, 465856451, -1669, 49416, -16546,
+             2983, 4337541, 65292495, 39253529, (void *) 669025, 211, 85, -19,
+             24298, 65358, 16776, -29957, (void *) 124311, -163231228, 2610,
+             -7806, 26434, -21913, -753615541, 120, 358697932, -1198889034,
+             -2131350926, (void *) 3749492036, -13413, 17);
+}
+
+/*
+ * CALLBACKS.BFF.2  (cb-test)
+ */
+
+DLLEXPORT long long call_sum_127
+  (long long (*func)
+   (short, char, void*, float, long, double, unsigned long long,
+    unsigned short, unsigned char, char, char, unsigned short, unsigned
+    long long, unsigned short, long long, unsigned short, unsigned long
+    long, unsigned char, unsigned char, unsigned long long, long long,
+    char, float, unsigned int, float, float, unsigned int, float, char,
+    unsigned char, long, long long, unsigned char, double, long,
+    double, unsigned int, unsigned short, long long, unsigned int, int,
+    unsigned long long, long, short, unsigned int, unsigned int,
+    unsigned long long, unsigned int, long, void*, unsigned char, char,
+    long long, unsigned short, unsigned int, float, unsigned char,
+    unsigned long, long long, float, long, float, int, float, unsigned
+    short, unsigned long long, short, unsigned long, long, char,
+    unsigned short, long long, short, double, void*, unsigned int,
+    char, unsigned int, void*, void*, unsigned char, void*, unsigned
+    short, unsigned char, long, void*, char, long, unsigned short,
+    unsigned char, double, unsigned long long, unsigned short, unsigned
+    short, unsigned int, long, char, long, char, short, unsigned short,
+    unsigned long, unsigned long, short, long long, long long, long
+    long, double, unsigned short, unsigned char, short, unsigned char,
+    long, long long, unsigned long long, unsigned int, unsigned long,
+    unsigned char, long long, unsigned char, unsigned long long,
+    double, unsigned char, long long, unsigned char, char, long long))
+{
+    return
+        func(-8573, 14, (void *) 832601021, -32334, -1532040888,
+             -18478, 2793023182591311826, 2740, 230, 103, 97, 13121,
+             5112369026351511084, 7763, -8134147951003417418, 34348,
+             5776613699556468853, 19, 122, 1431603726926527625,
+             439503521880490337, -112, -21557, 1578969190, -22008, -4953,
+             2127745975, -7262, -6, 180, 226352974, -3928775366167459219, 134,
+             -17730, -1175042526, 23868, 3494181009, 57364,
+             3134876875147518682, 104531655, -1286882727, 803577887579693487,
+             1349268803, 24912, 3313099419, 3907347884, 1738833249233805034,
+             2794230885, 1008818752, (void *) 1820044575, 189, 61,
+             -931654560961745071, 57531, 3096859985, 10405, 220, 3631311224,
+             -8531370353478907668, 31258, 678896693, -32150, -1869057813,
+             -19877, 62841, 4161660185772906873, -23869, 4016251006, 610353435,
+             105, 47315, -1051054492535331660, 6846, -15163, (void *)
+             736672359, 2123928476, -122, 3859258652, (void *) 3923394833,
+             (void *) 1265031970, 161, (void *) 1993867800, 55056, 122,
+             1562112760, (void *) 866615125, -79, -1261399547, 31737, 254,
+             -31279, 5462649659172897980, 5202, 7644, 174224940, -337854382,
+             -45, -583502442, -37, -13266, 24520, 2198606699, 2890453969,
+             -8282, -2295716637858246075, -1905178488651598878,
+             -6384652209316714643, 14841, 35443, 132, 15524, 187, 2138878229,
+             -5153032566879951000, 9056545530140684207, 4124632010, 276167701,
+             56, -2307310370663738730, 66, 9113015627153789746, -9618, 167,
+             755753399701306200, 119, -28, -990561962725435433);
+}
+
+/*
+ * CALLBACKS.DOUBLE26
+ */
+
+DLLEXPORT double call_double26
+  (double (*f)(double, double, double, double, double, double, double, double,
+               double, double, double, double, double, double, double, double,
+               double, double, double, double, double, double, double, double,
+               double, double))
+{
+    return f(3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14,
+             3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14,
+             3.14, 3.14, 3.14, 3.14);
+}
+
+/*
+ * DEFCFUN.DOUBLE26 and FUNCALL.DOUBLE26
+ */
+
+DLLEXPORT
+double sum_double26(double a1, double a2, double a3, double a4, double a5,
+                    double a6, double a7, double a8, double a9, double a10,
+                    double a11, double a12, double a13, double a14, double a15,
+                    double a16, double a17, double a18, double a19, double a20,
+                    double a21, double a22, double a23, double a24, double a25,
+                    double a26)
+{
+    return a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 +
+        a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 +
+        a26;
+}
+
+/*
+ * CALLBACKS.FLOAT26
+ */
+
+DLLEXPORT float call_float26
+  (float (*f)(float, float, float, float, float, float, float, float,
+              float, float, float, float, float, float, float, float,
+              float, float, float, float, float, float, float, float,
+              float, float))
+{
+    return f(5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0,
+             5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0,
+             5.0, 5.0, 5.0, 5.0);
+}
+
+/*
+ * DEFCFUN.FLOAT26 and FUNCALL.FLOAT26
+ */
+
+DLLEXPORT
+float sum_float26(float a1, float a2, float a3, float a4, float a5,
+                  float a6, float a7, float a8, float a9, float a10,
+                  float a11, float a12, float a13, float a14, float a15,
+                  float a16, float a17, float a18, float a19, float a20,
+                  float a21, float a22, float a23, float a24, float a25,
+                  float a26)
+{
+    return a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 +
+        a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 +
+        a26;
+}
+
+/*
+ * Symbol case.
+ */
+
+DLLEXPORT int UPPERCASEINT1    = 12345;
+DLLEXPORT int UPPER_CASE_INT1  = 23456;
+DLLEXPORT int MiXeDCaSeInT1    = 34567;
+DLLEXPORT int MiXeD_CaSe_InT1  = 45678;
+
+DLLEXPORT int UPPERCASEINT2    = 12345;
+DLLEXPORT int UPPER_CASE_INT2  = 23456;
+DLLEXPORT int MiXeDCaSeInT2    = 34567;
+DLLEXPORT int MiXeD_CaSe_InT2  = 45678;
+
+DLLEXPORT int UPPERCASEINT3    = 12345;
+DLLEXPORT int UPPER_CASE_INT3  = 23456;
+DLLEXPORT int MiXeDCaSeInT3    = 34567;
+DLLEXPORT int MiXeD_CaSe_InT3  = 45678;
+
+/*
+ * FOREIGN-SYMBOL-POINTER.1
+ */
+
+DLLEXPORT int compare_against_abs(intptr_t p)
+{
+    return p == (intptr_t) abs;
+}
+
+/*
+ * FOREIGN-SYMBOL-POINTER.2
+ */
+
+DLLEXPORT void xpto_fun() {}
+
+DLLEXPORT
+int compare_against_xpto_fun(intptr_t p)
+{
+    return p == (intptr_t) xpto_fun;
+}
+
+/*
+ * [DEFCFUN|FUNCALL].NAMESPACE.1
+ */
+
+DLLEXPORT
+int ns_function()
+{
+    return 1;
+}
+
+/*
+ * FOREIGN-GLOBALS.NAMESPACE.*
+ */
+
+DLLEXPORT int ns_var = 1;
+
+/*
+ * DEFCFUN.STDCALL.1
+ */
+
+DLLEXPORT
+int STDCALL stdcall_fun(int a, int b, int c)
+{
+    return a + b + c;
+}
+
+/*
+ * CALLBACKS.STDCALL.1
+ */
+
+DLLEXPORT
+int call_stdcall_fun(int (STDCALL *f)(int, int, int))
+{
+    int a = 42;
+    f(1, 2, 3);
+    return a;
+}
+
+/* Unlike the one above, this commented test below actually
+ * works. But, alas, it doesn't compile with -std=c99. */
+
+/*
+DLLEXPORT
+int call_stdcall_fun(int __attribute__((stdcall)) (*f)(int, int, int))
+{
+    asm("pushl $42");
+    register int ebx asm("%ebx");
+    f(1, 2, 3);
+    asm("popl %ebx");
+    return ebx;
+}
+*/
+
+/* vim: ts=4 et
+*/
diff --git a/external/cffi.darcs/tests/libtest2.c b/external/cffi.darcs/tests/libtest2.c
new file mode 100644
index 0000000..6e4e2c4
--- /dev/null
+++ b/external/cffi.darcs/tests/libtest2.c
@@ -0,0 +1,50 @@
+/* -*- Mode: C; tab-width: 4; indent-tabs-mode: nil -*-
+ *
+ * libtest2.c --- auxiliary C lib for testing purposes
+ *
+ * Copyright (C) 2007, Luis Oliveira  
+ *
+ * Permission is hereby granted, free of charge, to any person
+ * obtaining a copy of this software and associated documentation
+ * files (the "Software"), to deal in the Software without
+ * restriction, including without limitation the rights to use, copy,
+ * modify, merge, publish, distribute, sublicense, and/or sell copies
+ * of the Software, and to permit persons to whom the Software is
+ * furnished to do so, subject to the following conditions:
+ *
+ * The above copyright notice and this permission notice shall be
+ * included in all copies or substantial portions of the Software.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ * NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+ * HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+ * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+ * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+ * DEALINGS IN THE SOFTWARE.
+ */
+
+#ifdef WIN32
+#define DLLEXPORT __declspec(dllexport)
+#else
+#define DLLEXPORT
+#endif
+
+/*
+ * [DEFCFUN|FOREIGN].NAMESPACE.1
+ */
+
+DLLEXPORT int ns_function()
+{
+    return 0;
+}
+
+/*
+ * FOREIGN-GLOBALS.NAMESPACE.*
+ */
+
+DLLEXPORT int ns_var = 0;
+
+/* vim: ts=4 et
+*/
diff --git a/external/cffi.darcs/tests/memory.lisp b/external/cffi.darcs/tests/memory.lisp
new file mode 100644
index 0000000..72755d2
--- /dev/null
+++ b/external/cffi.darcs/tests/memory.lisp
@@ -0,0 +1,565 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; memory.lisp --- Tests for memory referencing.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+(deftest deref.char
+    (with-foreign-object (p :char)
+      (setf (mem-ref p :char) -127)
+      (mem-ref p :char))
+  -127)
+
+(deftest deref.unsigned-char
+    (with-foreign-object (p :unsigned-char)
+      (setf (mem-ref p :unsigned-char) 255)
+      (mem-ref p :unsigned-char))
+  255)
+
+(deftest deref.short
+    (with-foreign-object (p :short)
+      (setf (mem-ref p :short) -32767)
+      (mem-ref p :short))
+  -32767)
+
+(deftest deref.unsigned-short
+    (with-foreign-object (p :unsigned-short)
+      (setf (mem-ref p :unsigned-short) 65535)
+      (mem-ref p :unsigned-short))
+  65535)
+
+(deftest deref.int
+    (with-foreign-object (p :int)
+      (setf (mem-ref p :int) -131072)
+      (mem-ref p :int))
+  -131072)
+
+(deftest deref.unsigned-int
+    (with-foreign-object (p :unsigned-int)
+      (setf (mem-ref p :unsigned-int) 262144)
+      (mem-ref p :unsigned-int))
+  262144)
+
+(deftest deref.long
+    (with-foreign-object (p :long)
+      (setf (mem-ref p :long) -536870911)
+      (mem-ref p :long))
+  -536870911)
+
+(deftest deref.unsigned-long
+    (with-foreign-object (p :unsigned-long)
+      (setf (mem-ref p :unsigned-long) 536870912)
+      (mem-ref p :unsigned-long))
+  536870912)
+
+#-cffi-features:no-long-long
+(progn
+  #+(and cffi-features:darwin openmcl)
+  (pushnew 'deref.long-long rt::*expected-failures*)
+
+  (deftest deref.long-long
+      (with-foreign-object (p :long-long)
+        (setf (mem-ref p :long-long) -9223372036854775807)
+        (mem-ref p :long-long))
+    -9223372036854775807)
+
+  (deftest deref.unsigned-long-long
+      (with-foreign-object (p :unsigned-long-long)
+        (setf (mem-ref p :unsigned-long-long) 18446744073709551615)
+        (mem-ref p :unsigned-long-long))
+    18446744073709551615))
+
+(deftest deref.float.1
+    (with-foreign-object (p :float)
+      (setf (mem-ref p :float) 0.0)
+      (mem-ref p :float))
+  0.0)
+
+(deftest deref.float.2
+    (with-foreign-object (p :float)
+      (setf (mem-ref p :float) *float-max*)
+      (mem-ref p :float))
+  #.*float-max*)
+
+(deftest deref.float.3
+    (with-foreign-object (p :float)
+      (setf (mem-ref p :float) *float-min*)
+      (mem-ref p :float))
+  #.*float-min*)
+
+(deftest deref.double.1
+    (with-foreign-object (p :double)
+      (setf (mem-ref p :double) 0.0d0)
+      (mem-ref p :double))
+  0.0d0)
+
+(deftest deref.double.2
+    (with-foreign-object (p :double)
+      (setf (mem-ref p :double) *double-max*)
+      (mem-ref p :double))
+  #.*double-max*)
+
+(deftest deref.double.3
+    (with-foreign-object (p :double)
+      (setf (mem-ref p :double) *double-min*)
+      (mem-ref p :double))
+  #.*double-min*)
+
+;;; TODO: use something like *DOUBLE-MIN/MAX* above once we actually
+;;; have an available lisp that supports long double.
+;#-cffi-features:no-long-float
+#+(and scl long-double)
+(progn
+  (deftest deref.long-double.1
+      (with-foreign-object (p :long-double)
+        (setf (mem-ref p :long-double) 0.0l0)
+        (mem-ref p :long-double))
+    0.0l0)
+
+  (deftest deref.long-double.2
+      (with-foreign-object (p :long-double)
+        (setf (mem-ref p :long-double) most-positive-long-float)
+        (mem-ref p :long-double))
+    #.most-positive-long-float)
+
+  (deftest deref.long-double.3
+      (with-foreign-object (p :long-double)
+        (setf (mem-ref p :long-double) least-positive-long-float)
+        (mem-ref p :long-double))
+    #.least-positive-long-float))
+
+;;; make sure the lisp doesn't convert NULL to NIL
+(deftest deref.pointer.null
+    (with-foreign-object (p :pointer)
+      (setf (mem-ref p :pointer) (null-pointer))
+      (null-pointer-p (mem-ref p :pointer)))
+  t)
+
+;;; regression test. lisp-string-to-foreign should handle empty strings
+(deftest lisp-string-to-foreign.empty
+    (with-foreign-pointer (str 2)
+      (setf (mem-ref str :unsigned-char) 42)
+      (lisp-string-to-foreign "" str 1)
+      (mem-ref str :unsigned-char))
+  0)
+
+;; regression test. with-foreign-pointer shouldn't evaluate
+;; the size argument twice.
+(deftest with-foreign-pointer.evalx2
+    (let ((count 0))
+      (with-foreign-pointer (x (incf count) size-var)
+        (values count size-var)))
+  1 1)
+
+(deftest mem-ref.left-to-right
+    (let ((i 0))
+      (with-foreign-object (p :char 3)
+        (setf (mem-ref p :char 0) 66 (mem-ref p :char 1) 92)
+        (setf (mem-ref p :char (incf i)) (incf i))
+        (values (mem-ref p :char 0) (mem-ref p :char 1) i)))
+  66 2 2)
+
+;;; This needs to be in a real function for at least Allegro CL or the
+;;; compiler macro on %MEM-REF is not expanded and the test doesn't
+;;; actually test anything!
+(defun %mem-ref-left-to-right ()
+  (let ((result nil))
+    (with-foreign-object (p :char)
+      (%mem-set 42 p :char)
+      (%mem-ref (progn (push 1 result) p) :char (progn (push 2 result) 0))
+      (nreverse result))))
+
+;;; Test left-to-right evaluation of the arguments to %MEM-REF when
+;;; optimized by the compiler macro.
+(deftest %mem-ref.left-to-right
+    (%mem-ref-left-to-right)
+  (1 2))
+
+;;; This needs to be in a top-level function for at least Allegro CL
+;;; or the compiler macro on %MEM-SET is not expanded and the test
+;;; doesn't actually test anything!
+(defun %mem-set-left-to-right ()
+  (let ((result nil))
+    (with-foreign-object (p :char)
+      (%mem-set (progn (push 1 result) 0)
+                (progn (push 2 result) p)
+                :char
+                (progn (push 3 result) 0))
+      (nreverse result))))
+
+;;; Test left-to-right evaluation of the arguments to %MEM-SET when
+;;; optimized by the compiler macro.
+(deftest %mem-set.left-to-right
+    (%mem-set-left-to-right)
+  (1 2 3))
+
+;; regression test. mem-aref's setf expansion evaluated its type argument twice.
+(deftest mem-aref.eval-type-x2
+    (let ((count 0))
+      (with-foreign-pointer (p 1)
+        (setf (mem-aref p (progn (incf count) :char) 0) 127))
+      count)
+  1)
+
+(deftest mem-aref.left-to-right
+    (let ((count -1))
+      (with-foreign-pointer (p 2)
+        (values
+         (setf (mem-aref p (progn (incf count) :char) (incf count)) (incf count))
+         (setq count -1)
+         (mem-aref (progn (incf count) p) :char (incf count))
+         count)))
+  2 -1 2 1)
+
+;; regression tests. nested mem-ref's and mem-aref's had bogus getters
+(deftest mem-ref.nested
+    (with-foreign-object (p :pointer)
+      (with-foreign-object (i :int)
+        (setf (mem-ref p :pointer) i)
+        (setf (mem-ref i :int) 42)
+        (setf (mem-ref (mem-ref p :pointer) :int) 1984)
+        (mem-ref i :int)))
+  1984)
+
+(deftest mem-aref.nested
+    (with-foreign-object (p :pointer)
+      (with-foreign-object (i :int 2)
+        (setf (mem-aref p :pointer 0) i)
+        (setf (mem-aref i :int 1) 42)
+        (setf (mem-aref (mem-ref p :pointer 0) :int 1) 1984)
+        (mem-aref i :int 1)))
+  1984)
+
+;;; regression tests. dereferencing an aggregate type. dereferencing a
+;;; struct should return a pointer to the struct itself, not return the
+;;; first 4 bytes (or whatever the size of :pointer is) as a pointer.
+;;;
+;;; This important for accessing an array of structs, which is
+;;; what the deref.array-of-aggregates test does.
+(defcstruct some-struct (x :int))
+
+(deftest deref.aggregate
+    (with-foreign-object (s 'some-struct)
+      (pointer-eq s (mem-ref s 'some-struct)))
+  t)
+
+(deftest deref.array-of-aggregates
+    (with-foreign-object (arr 'some-struct 3)
+      (loop for i below 3
+            do (setf (foreign-slot-value (mem-aref arr 'some-struct i)
+                                         'some-struct 'x)
+                     112))
+      (loop for i below 3
+            collect (foreign-slot-value (mem-aref arr 'some-struct i)
+                                        'some-struct 'x)))
+  (112 112 112))
+
+;;; pointer operations
+(deftest pointer.1
+    (pointer-address (make-pointer 42))
+  42)
+
+;;; I suppose this test is not very good. --luis
+(deftest pointer.2
+    (pointer-address (null-pointer))
+  0)
+
+;;; Ensure that a pointer to the highest possible address can be
+;;; created using MAKE-POINTER.  Regression test for CLISP/X86-64.
+(deftest make-pointer.high
+    (let* ((pointer-length (foreign-type-size :pointer))
+           (high-address (1- (expt 2 (* pointer-length 8))))
+           (pointer (make-pointer high-address)))
+      (- high-address (pointer-address pointer)))
+  0)
+
+;;; Ensure that incrementing a pointer by zero bytes returns an
+;;; equivalent pointer.
+(deftest inc-pointer.zero
+    (with-foreign-object (x :int)
+      (pointer-eq x (inc-pointer x 0)))
+  t)
+
+;;; Test the INITIAL-ELEMENT keyword argument to FOREIGN-ALLOC.
+(deftest foreign-alloc.1
+    (let ((ptr (foreign-alloc :int :initial-element 42)))
+      (unwind-protect
+           (mem-ref ptr :int)
+        (foreign-free ptr)))
+  42)
+
+;;; Test the INITIAL-ELEMENT and COUNT arguments to FOREIGN-ALLOC.
+(deftest foreign-alloc.2
+    (let ((ptr (foreign-alloc :int :count 4 :initial-element 100)))
+      (unwind-protect
+           (loop for i from 0 below 4
+                 collect (mem-aref ptr :int i))
+        (foreign-free ptr)))
+  (100 100 100 100))
+
+;;; Test the INITIAL-CONTENTS and COUNT arguments to FOREIGN-ALLOC,
+;;; passing a list of initial values.
+(deftest foreign-alloc.3
+    (let ((ptr (foreign-alloc :int :count 4 :initial-contents '(4 3 2 1))))
+      (unwind-protect
+           (loop for i from 0 below 4
+                 collect (mem-aref ptr :int i))
+        (foreign-free ptr)))
+  (4 3 2 1))
+
+;;; Test INITIAL-CONTENTS and COUNT with FOREIGN-ALLOC passing a
+;;; vector of initial values.
+(deftest foreign-alloc.4
+    (let ((ptr (foreign-alloc :int :count 4 :initial-contents #(10 20 30 40))))
+      (unwind-protect
+           (loop for i from 0 below 4
+                 collect (mem-aref ptr :int i))
+        (foreign-free ptr)))
+  (10 20 30 40))
+
+;;; Ensure calling FOREIGN-ALLOC with both INITIAL-ELEMENT and
+;;; INITIAL-CONTENTS signals an error.
+(deftest foreign-alloc.5
+    (values
+     (ignore-errors
+       (let ((ptr (foreign-alloc :int :initial-element 1 :initial-contents '(1))))
+         (foreign-free ptr))
+       t))
+  nil)
+
+;;; Regression test: FOREIGN-ALLOC shouldn't actually perform translation
+;;; on initial-element/initial-contents since MEM-AREF will do that already.
+(define-foreign-type not-an-int ()
+  ()
+  (:actual-type :int)
+  (:simple-parser not-an-int))
+
+(defmethod translate-to-foreign (value (type not-an-int))
+  (assert (not (integerp value)))
+  0)
+
+(deftest foreign-alloc.6
+    (let ((ptr (foreign-alloc 'not-an-int :initial-element 'foooo)))
+      (foreign-free ptr)
+      t)
+  t)
+
+;;; Ensure calling FOREIGN-ALLOC with NULL-TERMINATED-P and a non-pointer
+;;; type signals an error.
+(deftest foreign-alloc.7
+    (values
+     (ignore-errors
+       (let ((ptr (foreign-alloc :int :null-terminated-p t)))
+         (foreign-free ptr))
+       t))
+  nil)
+
+;;; The opposite of the above test.
+(defctype pointer-alias :pointer)
+
+(deftest foreign-alloc.8
+    (progn
+      (foreign-free (foreign-alloc 'pointer-alias :count 0 :null-terminated-p t))
+      t)
+  t)
+
+;;; Ensure calling FOREIGN-ALLOC with NULL-TERMINATED-P actually places
+;;; a null pointer at the end. Not a very reliable test apparently.
+(deftest foreign-alloc.9
+    (let ((ptr (foreign-alloc :pointer :count 0 :null-terminated-p t)))
+      (unwind-protect
+           (null-pointer-p (mem-ref ptr :pointer))
+        (foreign-free ptr)))
+  t)
+
+;;; Tests for mem-ref with a non-constant type. This is a way to test
+;;; the functional interface (without compiler macros).
+
+(deftest deref.nonconst.char
+    (let ((type :char))
+      (with-foreign-object (p type)
+        (setf (mem-ref p type) -127)
+        (mem-ref p type)))
+  -127)
+
+(deftest deref.nonconst.unsigned-char
+    (let ((type :unsigned-char))
+      (with-foreign-object (p type)
+        (setf (mem-ref p type) 255)
+        (mem-ref p type)))
+  255)
+
+(deftest deref.nonconst.short
+    (let ((type :short))
+      (with-foreign-object (p type)
+        (setf (mem-ref p type) -32767)
+        (mem-ref p type)))
+  -32767)
+
+(deftest deref.nonconst.unsigned-short
+    (let ((type :unsigned-short))
+      (with-foreign-object (p type)
+        (setf (mem-ref p type) 65535)
+        (mem-ref p type)))
+  65535)
+
+(deftest deref.nonconst.int
+    (let ((type :int))
+      (with-foreign-object (p type)
+        (setf (mem-ref p type) -131072)
+        (mem-ref p type)))
+  -131072)
+
+(deftest deref.nonconst.unsigned-int
+    (let ((type :unsigned-int))
+      (with-foreign-object (p type)
+        (setf (mem-ref p type) 262144)
+        (mem-ref p type)))
+  262144)
+
+(deftest deref.nonconst.long
+    (let ((type :long))
+      (with-foreign-object (p type)
+        (setf (mem-ref p type) -536870911)
+        (mem-ref p type)))
+  -536870911)
+
+(deftest deref.nonconst.unsigned-long
+    (let ((type :unsigned-long))
+      (with-foreign-object (p type)
+        (setf (mem-ref p type) 536870912)
+        (mem-ref p type)))
+  536870912)
+
+#-cffi-features:no-long-long
+(progn
+  #+(and cffi-features:darwin openmcl)
+  (pushnew 'deref.nonconst.long-long rt::*expected-failures*)
+
+  (deftest deref.nonconst.long-long
+      (let ((type :long-long))
+        (with-foreign-object (p type)
+          (setf (mem-ref p type) -9223372036854775807)
+          (mem-ref p type)))
+    -9223372036854775807)
+
+  (deftest deref.nonconst.unsigned-long-long
+      (let ((type :unsigned-long-long))
+        (with-foreign-object (p type)
+          (setf (mem-ref p type) 18446744073709551615)
+          (mem-ref p type)))
+    18446744073709551615))
+
+(deftest deref.nonconst.float.1
+    (let ((type :float))
+      (with-foreign-object (p type)
+        (setf (mem-ref p type) 0.0)
+        (mem-ref p type)))
+  0.0)
+
+(deftest deref.nonconst.float.2
+    (let ((type :float))
+      (with-foreign-object (p type)
+        (setf (mem-ref p type) *float-max*)
+        (mem-ref p type)))
+  #.*float-max*)
+
+(deftest deref.nonconst.float.3
+    (let ((type :float))
+      (with-foreign-object (p type)
+        (setf (mem-ref p type) *float-min*)
+        (mem-ref p type)))
+  #.*float-min*)
+
+(deftest deref.nonconst.double.1
+    (let ((type :double))
+      (with-foreign-object (p type)
+        (setf (mem-ref p type) 0.0d0)
+        (mem-ref p type)))
+  0.0d0)
+
+(deftest deref.nonconst.double.2
+    (let ((type :double))
+      (with-foreign-object (p type)
+        (setf (mem-ref p type) *double-max*)
+        (mem-ref p type)))
+  #.*double-max*)
+
+(deftest deref.nonconst.double.3
+    (let ((type :double))
+      (with-foreign-object (p type)
+        (setf (mem-ref p type) *double-min*)
+        (mem-ref p type)))
+  #.*double-min*)
+
+;;; regression tests: lispworks's %mem-ref and %mem-set compiler
+;;; macros were misbehaving.
+
+(defun mem-ref-rt-1 ()
+  (with-foreign-object (a :int 2)
+    (setf (mem-aref a :int 0) 123
+          (mem-aref a :int 1) 456)
+    (values (mem-aref a :int 0) (mem-aref a :int 1))))
+
+(deftest mem-ref.rt.1
+    (mem-ref-rt-1)
+  123 456)
+
+(defun mem-ref-rt-2 ()
+  (with-foreign-object (a :double 2)
+    (setf (mem-aref a :double 0) 123.0d0
+          (mem-aref a :double 1) 456.0d0)
+    (values (mem-aref a :double 0) (mem-aref a :double 1))))
+
+(deftest mem-ref.rt.2
+    (mem-ref-rt-2)
+  123.0d0 456.0d0)
+
+(deftest incf-pointer.1
+    (let ((ptr (null-pointer)))
+      (incf-pointer ptr)
+      (pointer-address ptr))
+  1)
+
+(deftest incf-pointer.2
+    (let ((ptr (null-pointer)))
+      (incf-pointer ptr 42)
+      (pointer-address ptr))
+  42)
+
+(deftest pointerp.1
+    (values
+     (pointerp (null-pointer))
+     (null-pointer-p (null-pointer))
+     (typep (null-pointer) 'foreign-pointer))
+  t t t)
+
+(deftest pointerp.2
+    (let ((p (make-pointer #xFEFF)))
+      (values
+       (pointerp p)
+       (typep p 'foreign-pointer)))
+  t t)
diff --git a/external/cffi.darcs/tests/misc-types.lisp b/external/cffi.darcs/tests/misc-types.lisp
new file mode 100644
index 0000000..b8871ae
--- /dev/null
+++ b/external/cffi.darcs/tests/misc-types.lisp
@@ -0,0 +1,235 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; misc-types.lisp --- Various tests on the type system.
+;;;
+;;; Copyright (C) 2005-2006, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+(defcfun ("my_strdup" strdup) :string+ptr (str :string))
+
+(deftest misc-types.string+ptr
+    (destructuring-bind (string pointer)
+        (strdup "foo")
+      (foreign-free pointer)
+      string)
+  "foo")
+
+(deftest misc-types.string+ptr.ub8
+    (destructuring-bind (string pointer)
+        (strdup (make-array 3 :element-type '(unsigned-byte 8)
+                            :initial-contents (map 'list #'char-code "foo")))
+      (foreign-free pointer)
+      string)
+  "foo")
+
+(deftest misc-types.string.ub8.1
+    (let ((array (make-array 7 :element-type '(unsigned-byte 8)
+                             :initial-contents '(84 117 114 97 110 103 97))))
+      (with-foreign-string (foreign-string array)
+        (foreign-string-to-lisp foreign-string)))
+  "Turanga")
+
+(deftest misc-types.string.ub8.2
+    (let ((str (foreign-string-alloc
+                (make-array 7 :element-type '(unsigned-byte 8)
+                            :initial-contents '(84 117 114 97 110 103 97)))))
+      (prog1 (foreign-string-to-lisp str)
+        (foreign-string-free str)))
+  "Turanga")
+
+(defcfun "equalequal" :boolean
+  (a (:boolean :int))
+  (b (:boolean :unsigned-int)))
+
+(defcfun "bool_and" (:boolean :char)
+  (a (:boolean :unsigned-char))
+  (b (:boolean :char)))
+
+(defcfun "bool_xor" (:boolean :unsigned-long)
+  (a (:boolean :long))
+  (b (:boolean :unsigned-long)))
+
+(deftest misc-types.boolean.1
+    (list (equalequal nil nil)
+          (equalequal t t)
+          (equalequal t 23)
+          (bool-and 'a 'b)
+          (bool-and "foo" nil)
+          (bool-xor t nil)
+          (bool-xor nil nil))
+  (t t t t nil t nil))
+
+
+;;; Regression test: boolean type only worked with canonicalized
+;;; built-in integer types. Should work for any type that canonicalizes
+;;; to a built-in integer type.
+(defctype int-for-bool :int)
+(defcfun ("equalequal" equalequal2) :boolean
+  (a (:boolean int-for-bool))
+  (b (:boolean :uint)))
+
+(deftest misc-types.boolean.2
+    (equalequal2 nil t)
+  nil)
+
+(defctype my-string :string+ptr)
+
+(defun funkify (str)
+  (concatenate 'string "MORE " (string-upcase str)))
+
+(defun 3rd-person (value)
+  (list (concatenate 'string "Strdup says: " (first value))
+        (second value)))
+
+;; (defctype funky-string
+;;     (:wrapper my-string
+;;               :to-c #'funkify
+;;               :from-c (lambda (value)
+;;                         (list
+;;                          (concatenate 'string "Strdup says: "
+;;                                       (first value))
+;;                          (second value))))
+;;   "A useful type.")
+
+(defctype funky-string (:wrapper my-string :to-c funkify :from-c 3rd-person))
+
+(defcfun ("my_strdup" funky-strdup) funky-string
+  (str funky-string))
+
+(deftest misc-types.wrapper
+    (destructuring-bind (string ptr)
+        (funky-strdup "code")
+      (foreign-free ptr)
+      string)
+  "Strdup says: MORE CODE")
+
+(deftest misc-types.sized-ints
+    (mapcar #'foreign-type-size '(:int8 :uint8 :int16 :uint16 :int32 :uint32
+                                  #-cffi-features:no-long-long :int64
+                                  #-cffi-features:no-long-long :uint64))
+  (1 1 2 2 4 4
+   #-cffi-features:no-long-long 8
+   #-cffi-features:no-long-long 8))
+
+(define-foreign-type error-error ()
+  ()
+  (:actual-type :int)
+  (:simple-parser error-error))
+
+(defmethod translate-to-foreign (value (type error-error))
+  (declare (ignore value))
+  (error "translate-to-foreign invoked."))
+
+(defmethod translate-from-foreign (value (type error-error))
+  (declare (ignore value))
+  (error "translate-from-foreign invoked."))
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defmethod expand-to-foreign (value (type error-error))
+    value)
+
+  (defmethod expand-from-foreign (value (type error-error))
+    value))
+
+(defcfun ("abs" expand-abs) error-error
+  (n error-error))
+
+(defcvar ("var_int" *expand-var-int*) error-error)
+
+(defcfun ("expect_int_sum" expand-expect-int-sum) :boolean
+  (cb :pointer))
+
+(defcallback expand-int-sum error-error ((x error-error) (y error-error))
+  (+ x y))
+
+;;; Ensure that macroexpansion-time translators are called where this
+;;; is guaranteed (defcfun, defcvar, foreign-funcall and defcallback)
+(deftest misc-types.expand.1
+    (expand-abs -1)
+  1)
+
+#-cffi-features:no-foreign-funcall
+(deftest misc-types.expand.2
+    (foreign-funcall "abs" error-error -1 error-error)
+  1)
+
+(deftest misc-types.expand.3
+    (let ((old (mem-ref (get-var-pointer '*expand-var-int*) :int)))
+      (unwind-protect
+           (progn
+             (setf *expand-var-int* 42)
+             *expand-var-int*)
+        (setf (mem-ref (get-var-pointer '*expand-var-int*) :int) old)))
+  42)
+
+(deftest misc-types.expand.4
+    (expand-expect-int-sum (callback expand-int-sum))
+  t)
+
+(define-foreign-type translate-tracker ()
+  ()
+  (:actual-type :int)
+  (:simple-parser translate-tracker))
+
+(declaim (special .fto-called.))
+
+(defmethod free-translated-object (value (type translate-tracker) param)
+  (declare (ignore value param))
+  (setf .fto-called. t))
+
+(define-foreign-type expand-tracker ()
+  ()
+  (:actual-type :int)
+  (:simple-parser expand-tracker))
+
+(defmethod free-translated-object (value (type expand-tracker) param)
+  (declare (ignore value param))
+  (setf .fto-called. t))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmethod expand-to-foreign (value (type expand-tracker))
+    (declare (ignore value))
+    (call-next-method)))
+
+(defcfun ("abs" ttracker-abs) :int
+  (n translate-tracker))
+
+(defcfun ("abs" etracker-abs) :int
+  (n expand-tracker))
+
+;; free-translated-object must be called when there is no etf
+(deftest misc-types.expand.5
+    (let ((.fto-called. nil))
+      (ttracker-abs -1)
+      .fto-called.)
+  t)
+
+;; free-translated-object must be called when there is an etf, but
+;; they answer *runtime-translator-form*
+(deftest misc-types.expand.6
+    (let ((.fto-called. nil))
+      (etracker-abs -1)
+      .fto-called.)
+  t)
diff --git a/external/cffi.darcs/tests/misc.lisp b/external/cffi.darcs/tests/misc.lisp
new file mode 100644
index 0000000..636b7fa
--- /dev/null
+++ b/external/cffi.darcs/tests/misc.lisp
@@ -0,0 +1,151 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; misc.lisp --- Miscellaneous tests.
+;;;
+;;; Copyright (C) 2006, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+;;; From CLRFI-1
+(defun featurep (feature-expression)
+  (etypecase feature-expression
+    (symbol (not (null (member feature-expression *features*))))
+    (cons                ; Not LIST, as we've already eliminated NIL.
+     (ecase (first feature-expression)
+       (:and (every #'featurep (rest feature-expression)))
+       (:or  (some #'featurep (rest feature-expression)))
+       (:not (not (featurep (cadr feature-expression))))))))
+
+;;;# Test relations between OS features.
+
+(deftest features.os.1
+    (if (featurep 'cffi-features:windows)
+        (not (or (featurep 'cffi-features:unix)
+                 (featurep 'cffi-features:darwin)))
+        t)
+  t)
+
+(deftest features.os.2
+    (if (featurep 'cffi-features:darwin)
+        (and (not (featurep 'cffi-features:windows))
+             (featurep 'cffi-features:unix))
+        t)
+  t)
+
+(deftest features.os.3
+    (if (featurep 'cffi-features:unix)
+        (not (featurep 'cffi-features:windows))
+        t)
+  t)
+
+;;;# Test mutual exclusiveness of CPU features.
+
+(defparameter *cpu-features*
+  '(cffi-features:x86
+    cffi-features:x86-64
+    cffi-features:ppc32
+    cffi-features:sparc
+    cffi-features:sparc64
+    cffi-features:hppa
+    cffi-features:hppa64
+    ))
+
+(deftest features.cpu.1
+    (loop for feature in *cpu-features*
+          when (featurep feature)
+          sum 1)
+  1)
+
+;;;# foreign-symbol-pointer tests
+
+;;; This might be useful for some libraries that compare function
+;;; pointers. http://thread.gmane.org/gmane.lisp.cffi.devel/694
+(defcfun "compare_against_abs" :boolean (p :pointer))
+
+(deftest foreign-symbol-pointer.1
+    (compare-against-abs (foreign-symbol-pointer "abs"))
+  t)
+
+(defcfun "compare_against_xpto_fun" :boolean (p :pointer))
+
+(deftest foreign-symbol-pointer.2
+    (compare-against-xpto-fun (foreign-symbol-pointer "xpto_fun"))
+  t)
+
+;;;# Library tests
+;;;
+;;; Need to figure out a way to test this.  CLISP, for instance, will
+;;; automatically reopen the foreign-library when we call a foreign
+;;; function so we can't test CLOSE-FOREIGN-LIBRARY this way.
+;;;
+;;; IIRC, GCC has some extensions to have code run when a library is
+;;; loaded and stuff like that.  That could work.
+
+#||
+#-(and :ecl (not :dffi))
+(deftest library.close.2
+    (unwind-protect
+         (progn
+           (close-foreign-library 'libtest)
+           (ignore-errors (my-sqrtf 16.0)))
+      (load-test-libraries))
+  nil)
+
+#-(or (and :ecl (not :dffi))
+      cffi-features:flat-namespace
+      cffi-features:no-foreign-funcall)
+(deftest library.close.2
+    (unwind-protect
+         (values
+          (foreign-funcall ("ns_function" :library libtest) :boolean)
+          (close-foreign-library 'libtest)
+          (foreign-funcall "ns_function" :boolean)
+          (close-foreign-library 'libtest2)
+          (close-foreign-library 'libtest2)
+          (ignore-errors (foreign-funcall "ns_function" :boolean)))
+      (load-test-libraries))
+  t t nil t nil nil)
+||#
+
+(deftest library.error.1
+    (handler-case (load-foreign-library "libdoesnotexistimsure")
+      (load-foreign-library-error () 'error))
+  error)
+
+;;;# Shareable Byte Vector Tests
+
+(deftest shareable-vector.1
+    (let ((vector (cffi-sys::make-shareable-byte-vector 5)))
+      (cffi::with-pointer-to-vector-data (pointer vector)
+        (strcpy pointer "xpto"))
+      vector)
+  #(120 112 116 111 0))
+
+(deftest shareable-vector.2
+    (block nil
+      (let ((vector (cffi-sys::make-shareable-byte-vector 5)))
+        (cffi::with-pointer-to-vector-data (pointer vector)
+          (strcpy pointer "xpto")
+          (return vector))))
+  #(120 112 116 111 0))
diff --git a/external/cffi.darcs/tests/package.lisp b/external/cffi.darcs/tests/package.lisp
new file mode 100644
index 0000000..2cff4f5
--- /dev/null
+++ b/external/cffi.darcs/tests/package.lisp
@@ -0,0 +1,32 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; package.lisp --- CFFI-TESTS package definition.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cl-user)
+
+(defpackage #:cffi-tests
+  (:use #:cl #:cffi #:cffi-sys #:regression-test)
+  (:export #:do-tests))
diff --git a/external/cffi.darcs/tests/random-tester.lisp b/external/cffi.darcs/tests/random-tester.lisp
new file mode 100644
index 0000000..3765660
--- /dev/null
+++ b/external/cffi.darcs/tests/random-tester.lisp
@@ -0,0 +1,246 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; random-tester.lisp --- Random test generator.
+;;;
+;;; Copyright (C) 2006, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;; This code was used to generate the C and Lisp source code for
+;;; the CALLBACKS.BFF.[12] and DEFCFUN.BFF.[12] tests.
+;;;
+;;; The original idea was to test all combinations of argument types
+;;; but obviously as soon as you do the maths that it's not quite
+;;; feasable for more that 4 or 5 arguments.
+;;;
+;;; TODO: actually run random tests, ie compile/load/run the tests
+;;; this code can generate.
+
+(defpackage #:cffi-random-tester
+  (:use #:cl #:cffi #:regression-test))
+(in-package #:cffi-random-tester)
+
+(defstruct (c-type (:conc-name type-))
+  keyword
+  name
+  abbrev
+  min
+  max)
+
+(defparameter +types+
+  (mapcar (lambda (type)
+            (let ((keyword (first type))
+                  (name (second type)))
+              (multiple-value-bind (min max)
+                  ;; assume we can represent an integer in the range
+                  ;; [-2^16 2^16-1] in a float/double without causing
+                  ;; rounding errors (probably a lame assumption)
+                  (let ((type-size (if (or (eq keyword :float)
+                                           (eq keyword :double))
+                                       16
+                                       (* 8 (foreign-type-size keyword)))))
+                    (if (or (eql (char name 0) #\u) (eq keyword :pointer))
+                        (values 0 (1- (expt 2 type-size)))
+                        (values (- (expt 2 (1- type-size)))
+                                (1- (expt 2 (1- type-size))))))
+                (make-c-type :keyword keyword :name name :abbrev (third type)
+                             :min min :max max))))
+          '((:char "char" "c")
+            (:unsigned-char "unsigned char" "uc")
+            (:short "short" "s")
+            (:unsigned-short "unsigned short" "us")
+            (:int "int" "i")
+            (:unsigned-int "unsigned int" "ui")
+            (:long "long" "l")
+            (:unsigned-long "unsigned long" "ul")
+            (:float "float" "f")
+            (:double "double" "d")
+            (:pointer "void*" "p")
+            (:long-long "long long" "ll")
+            (:unsigned-long-long "unsigned long long" "ull"))))
+
+(defun find-type (keyword)
+  (find keyword +types+ :key #'type-keyword))
+
+(defun n-random-types (n)
+  (loop repeat n collect (nth (random (length +types+)) +types+)))
+
+;;; same as above, without the long long types
+(defun n-random-types-no-ll (n)
+  (loop repeat n collect (nth (random (- (length +types+) 2)) +types+)))
+
+(defun random-range (x y)
+  (+ x (random (+ (- y x) 2))))
+
+(defun random-sum (rettype arg-types)
+  "Returns a list of integers that fit in the respective types in the
+ARG-TYPES list and whose sum fits in RETTYPE."
+  (loop with sum = 0
+        for type in arg-types
+        for x = (random-range (max (- (type-min rettype) sum) (type-min type))
+                              (min (- (type-max rettype) sum) (type-max type)))
+        do (incf sum x)
+        collect x))
+
+(defun combinations (n items)
+  (let ((combs '()))
+    (labels ((rec (n accum)
+               (if (= n 0)
+                   (push accum combs)
+                   (loop for item in items
+                         do (rec (1- n) (cons item accum))))))
+      (rec n '())
+      combs)))
+
+(defun function-name (rettype arg-types)
+  (format nil "sum_~A_~{_~A~}"
+          (type-abbrev rettype)
+          (mapcar #'type-abbrev arg-types)))
+
+(defun c-function (rettype arg-types)
+  (let ((args (loop for type in arg-types and i from 1
+                    collect (list (type-name type) (format nil "a~A" i)))))
+    (format t "DLLEXPORT ~A ~A(~{~{~A ~A~}~^, ~})~%~
+               { return ~A(~A) ~{~A~^ + ~}~A; }"
+            (type-name rettype) (function-name rettype arg-types) args
+            (if (eq (type-keyword rettype) :pointer)
+                "(void *)((unsigned int)("
+                "")
+            (type-name rettype)
+            (loop for arg-pair in args collect
+                  (format nil "~A~A~A"
+                          (cond ((string= (first arg-pair) "void*")
+                                 "(unsigned int) ")
+                                ((or (string= (first arg-pair) "double")
+                                     (string= (first arg-pair) "float"))
+                                 "((int) ")
+                                (t ""))
+                          (second arg-pair)
+                          (if (member (first arg-pair)
+                                      '("void*" "double" "float")
+                                      :test #'string=)
+                              ")"
+                              "")))
+            (if (eq (type-keyword rettype) :pointer) "))" ""))))
+
+(defun c-callback (rettype arg-types args)
+  (format t "DLLEXPORT ~A call_~A(~A (*func)(~{~A~^, ~}~^))~%~
+             { return func(~{~A~^, ~}); }"
+          (type-name rettype) (function-name rettype arg-types)
+          (type-name rettype) (mapcar #'type-name arg-types)
+          (loop for type in arg-types and value in args collect
+                (format nil "~A~A"
+                        (if (eq (type-keyword type) :pointer)
+                            "(void *) "
+                            "")
+                        value))))
+
+;;; (output-c-code #p"generated.c" 3 5)
+(defun output-c-code (file min max)
+  (with-open-file (stream file :direction :output :if-exists :error)
+    (let ((*standard-output* stream))
+      (format t "/* automatically generated functions and callbacks */~%~%")
+      (loop for n from min upto max do
+            (format t "/* ~A args */" (1- n))
+            (loop for comb in (combinations n +types+) do
+                  (terpri) (c-function (car comb) (cdr comb))
+                  (terpri) (c-callback (car comb) (cdr comb)))))))
+
+(defmacro with-conversion (type form)
+  (case type
+    (:double `(float ,form 1.0d0))
+    (:float `(float ,form))
+    (:pointer `(make-pointer ,form))
+    (t form)))
+
+(defun integer-conversion (type form)
+  (case type
+    ((:double :float) `(values (floor ,form)))
+    (:pointer `(pointer-address ,form))
+    (t form)))
+
+(defun gen-arg-values (rettype arg-types)
+  (let ((numbers (random-sum rettype arg-types)))
+    (values
+     (reduce #'+ numbers)
+     (loop for type in arg-types and n in numbers
+           collect (case (type-keyword type)
+                     (:double (float n 1.0d0))
+                     (:float (float n))
+                     (:pointer `(make-pointer ,n))
+                     (t n))))))
+
+(defun gen-function-test (rettype arg-types)
+  (let* ((fun-name (function-name rettype arg-types))
+         (fun-sym (cffi::lisp-function-name fun-name)))
+    (multiple-value-bind (sum value-forms)
+        (gen-arg-values rettype arg-types)
+    `(progn
+       (defcfun (,fun-name ,fun-sym) ,(type-keyword rettype)
+         ,@(loop for type in arg-types and i from 1 collect
+                 (list (cffi-utils:symbolicate '#:a (format nil "~A" i))
+                       (type-keyword type))))
+       (deftest ,(cffi-utils:symbolicate '#:defcfun. fun-sym)
+           ,(integer-conversion (type-keyword rettype)
+                                `(,fun-sym ,@value-forms))
+         ,sum)))))
+
+(defun gen-callback-test (rettype arg-types sum)
+  (let* ((fname (function-name rettype arg-types))
+         (cb-sym (cffi::lisp-function-name fname))
+         (fun-name (concatenate 'string "call_" fname))
+         (fun-sym (cffi::lisp-function-name fun-name))
+         (arg-names (loop for i from 1 upto (length arg-types) collect
+                          (cffi-utils:symbolicate '#:a (format nil "~A" i)))))
+    `(progn
+       (defcfun (,fun-name ,fun-sym) ,(type-keyword rettype) (cb :pointer))
+       (defcallback ,cb-sym ,(type-keyword rettype)
+           ,(loop for type in arg-types and name in arg-names
+                  collect (list name (type-keyword type)))
+         ,(integer-conversion
+           (type-keyword rettype)
+           `(+ ,@(mapcar (lambda (tp n)
+                           (integer-conversion (type-keyword tp) n))
+                         arg-types arg-names))))
+       (deftest ,(cffi-utils:symbolicate '#:callbacks. cb-sym)
+           ,(integer-conversion (type-keyword rettype)
+                                `(,fun-sym (callback ,cb-sym)))
+         ,sum))))
+
+(defun cb-test (&key no-long-long)
+  (let* ((rettype (find-type (if no-long-long :long :long-long)))
+         (arg-types (if no-long-long
+                        (n-random-types-no-ll 127)
+                        (n-random-types 127)))
+         (args (random-sum rettype arg-types))
+         (sum (reduce #'+ args)))
+    (c-callback rettype arg-types args)
+    (gen-callback-test rettype arg-types sum)))
+
+;; (defmacro define-function-and-callback-tests (min max)
+;;   `(progn
+;;      ,@(loop for n from min upto max appending
+;;              (loop for comb in (combinations n +types+)
+;;                    collect (gen-function-test (car comb) (cdr comb))
+;;                    collect (gen-callback-test (car comb) (cdr comb))))))
+
+;; (define-function-and-callback-tests 3 5)
\ No newline at end of file
diff --git a/external/cffi.darcs/tests/run-tests.lisp b/external/cffi.darcs/tests/run-tests.lisp
new file mode 100644
index 0000000..14a3835
--- /dev/null
+++ b/external/cffi.darcs/tests/run-tests.lisp
@@ -0,0 +1,45 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; run-tests.lisp --- Simple script to run the unit tests.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(format t "~&;;; -------- Running tests in ~A --------~%"
+        (lisp-implementation-type))
+
+(setf *load-verbose* nil *compile-verbose* nil *compile-print* nil)
+#+cmu (setf ext:*gc-verbose* nil)
+
+#+(and (not asdf) (or sbcl openmcl ecl))
+(require "asdf")
+
+(asdf:operate 'asdf:load-op 'cffi-tests :verbose nil)
+(asdf:operate 'asdf:test-op 'cffi-tests)
+
+(in-package #:cl-user)
+(terpri)
+(force-output)
+
+#-allegro (quit)
+#+allegro (exit)
diff --git a/external/cffi.darcs/tests/struct.lisp b/external/cffi.darcs/tests/struct.lisp
new file mode 100644
index 0000000..1a5a568
--- /dev/null
+++ b/external/cffi.darcs/tests/struct.lisp
@@ -0,0 +1,324 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; struct.lisp --- Foreign structure type tests.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+(defcstruct timeval
+  (tv-secs :long)
+  (tv-usecs :long))
+
+(defparameter *timeval-size* (* 2 (max (foreign-type-size :long)
+                                       (foreign-type-alignment :long))))
+
+;;;# Basic Structure Tests
+
+(deftest struct.1
+    (- (foreign-type-size 'timeval) *timeval-size*)
+  0)
+
+(deftest struct.2
+    (with-foreign-object (tv 'timeval)
+      (setf (foreign-slot-value tv 'timeval 'tv-secs) 0)
+      (setf (foreign-slot-value tv 'timeval 'tv-usecs) 1)
+      (values (foreign-slot-value tv 'timeval 'tv-secs)
+              (foreign-slot-value tv 'timeval 'tv-usecs)))
+  0 1)
+
+(deftest struct.3
+    (with-foreign-object (tv 'timeval)
+      (with-foreign-slots ((tv-secs tv-usecs) tv timeval)
+        (setf tv-secs 100 tv-usecs 200)
+        (values tv-secs tv-usecs)))
+  100 200)
+
+;; regression test: accessing a struct through a typedef
+
+(defctype xpto timeval)
+
+(deftest struct.4
+    (with-foreign-object (tv 'xpto)
+      (setf (foreign-slot-value tv 'xpto 'tv-usecs) 1)
+      (values (foreign-slot-value tv 'xpto 'tv-usecs)
+              (foreign-slot-value tv 'timeval 'tv-usecs)))
+  1 1)
+
+(deftest struct.names
+    (sort (foreign-slot-names 'xpto) #'<
+          :key (lambda (x) (foreign-slot-offset 'xpto x)))
+  (tv-secs tv-usecs))
+
+;; regression test: compiler macro not quoting the type in the
+;; resulting mem-ref form. The compiler macro on foreign-slot-value
+;; is not guaranteed to be expanded though.
+
+(defctype my-int :int)
+(defcstruct s5 (a my-int))
+
+(deftest struct.5
+    (with-foreign-object (s 's5)
+      (setf (foreign-slot-value s 's5 'a) 42)
+      (foreign-slot-value s 's5 'a))
+  42)
+
+;;;# Structs with type translators
+
+(defcstruct struct-string
+  (s :string))
+
+(deftest struct.string.1
+    (with-foreign-object (ptr 'struct-string)
+      (with-foreign-slots ((s) ptr struct-string)
+        (setf s "So long and thanks for all the fish!")
+        s))
+  "So long and thanks for all the fish!")
+
+(deftest struct.string.2
+    (with-foreign-object (ptr 'struct-string)
+      (setf (foreign-slot-value ptr 'struct-string 's) "Cha")
+      (foreign-slot-value ptr 'struct-string 's))
+  "Cha")
+
+;;;# Structure Alignment Tests
+;;;
+;;; See libtest.c and types.lisp for some comments about alignments.
+
+(defcstruct s-ch
+  (a-char :char))
+
+(defcstruct s-s-ch
+  (another-char :char)
+  (a-s-ch s-ch))
+
+(defcvar "the_s_s_ch" s-s-ch)
+
+(deftest struct.alignment.1
+    (list 'a-char (foreign-slot-value
+                   (foreign-slot-value *the-s-s-ch* 's-s-ch 'a-s-ch)
+                   's-ch 'a-char)
+          'another-char (foreign-slot-value *the-s-s-ch* 's-s-ch 'another-char))
+  (a-char 1 another-char 2))
+
+
+(defcstruct s-short
+  (a-char :char)
+  (another-char :char)
+  (a-short :short))
+
+(defcstruct s-s-short
+  (yet-another-char :char)
+  (a-s-short s-short))
+
+(defcvar "the_s_s_short" s-s-short)
+
+(deftest struct.alignment.2
+    (with-foreign-slots ((yet-another-char a-s-short) *the-s-s-short* s-s-short)
+      (with-foreign-slots ((a-char another-char a-short) a-s-short s-short)
+        (list 'a-char           a-char
+              'another-char     another-char
+              'a-short          a-short
+              'yet-another-char yet-another-char)))
+  (a-char 1 another-char 2 a-short 3 yet-another-char 4))
+
+
+(defcstruct s-double
+  (a-char :char)
+  (a-double :double)
+  (another-char :char))
+
+(defcstruct s-s-double
+  (yet-another-char :char)
+  (a-s-double s-double)
+  (a-short :short))
+
+(defcvar "the_s_s_double" s-s-double)
+
+(deftest struct.alignment.3
+    (with-foreign-slots
+        ((yet-another-char a-s-double a-short) *the-s-s-double* s-s-double)
+      (with-foreign-slots ((a-char a-double another-char) a-s-double s-double)
+        (list 'a-char            a-char
+              'a-double          a-double
+              'another-char      another-char
+              'yet-another-char  yet-another-char
+              'a-short           a-short)))
+  (a-char 1 a-double 2.0d0 another-char 3 yet-another-char 4 a-short 5))
+
+
+(defcstruct s-s-s-double
+  (another-short :short)
+  (a-s-s-double s-s-double)
+  (last-char :char))
+
+(defcvar "the_s_s_s_double" s-s-s-double)
+
+(deftest struct.alignment.4
+    (with-foreign-slots
+        ((another-short a-s-s-double last-char) *the-s-s-s-double* s-s-s-double)
+      (with-foreign-slots
+          ((yet-another-char a-s-double a-short) a-s-s-double s-s-double)
+        (with-foreign-slots ((a-char a-double another-char) a-s-double s-double)
+          (list 'a-char            a-char
+                'a-double          a-double
+                'another-char      another-char
+                'yet-another-char  yet-another-char
+                'a-short           a-short
+                'another-short     another-short
+                'last-char         last-char))))
+  (a-char 1 a-double 2.0d0 another-char 3 yet-another-char 4 a-short 5
+   another-short 6 last-char 7))
+
+
+(defcstruct s-double2
+  (a-double :double)
+  (a-short  :short))
+
+(defcstruct s-s-double2
+  (a-char        :char)
+  (a-s-double2   s-double2)
+  (another-short :short))
+
+(defcvar "the_s_s_double2" s-s-double2)
+
+(deftest struct.alignment.5
+    (with-foreign-slots
+        ((a-char a-s-double2 another-short) *the-s-s-double2* s-s-double2)
+      (with-foreign-slots ((a-double a-short) a-s-double2 s-double2)
+        (list 'a-double       a-double
+              'a-short        a-short
+              'a-char         a-char
+              'another-short  another-short)))
+  (a-double 1.0d0 a-short 2 a-char 3 another-short 4))
+
+
+#-cffi-features:no-long-long
+(progn
+  (defcstruct s-long-long
+    (a-long-long :long-long)
+    (a-short     :short))
+
+  (defcstruct s-s-long-long
+    (a-char        :char)
+    (a-s-long-long s-long-long)
+    (another-short :short))
+
+  (defcvar "the_s_s_long_long" s-s-long-long)
+
+  (deftest struct.alignment.6
+      (with-foreign-slots
+          ((a-char a-s-long-long another-short) *the-s-s-long-long* s-s-long-long)
+        (with-foreign-slots ((a-long-long a-short) a-s-long-long s-long-long)
+          (list 'a-long-long    a-long-long
+                'a-short        a-short
+                'a-char         a-char
+                'another-short  another-short)))
+    (a-long-long 1 a-short 2 a-char 3 another-short 4)))
+
+
+(defcstruct s-s-double3
+  (a-s-double2   s-double2)
+  (another-short :short))
+
+(defcstruct s-s-s-double3
+  (a-s-s-double3  s-s-double3)
+  (a-char         :char))
+
+(defcvar "the_s_s_s_double3" s-s-s-double3)
+
+(deftest struct.alignment.7
+    (with-foreign-slots ((a-s-s-double3 a-char) *the-s-s-s-double3* s-s-s-double3)
+      (with-foreign-slots ((a-s-double2 another-short) a-s-s-double3 s-s-double3)
+        (with-foreign-slots ((a-double a-short) a-s-double2 s-double2)
+          (list 'a-double      a-double
+                'a-short       a-short
+                'another-short another-short
+                'a-char        a-char))))
+  (a-double 1.0d0 a-short 2 another-short 3 a-char 4))
+
+
+(defcstruct empty-struct)
+
+(defcstruct with-empty-struct
+  (foo empty-struct)
+  (an-int :int))
+
+;; commented out this test because an empty struct is not valid/standard C
+;; left the struct declarations anyway because they should be handled
+;; gracefuly anyway.
+
+; (defcvar "the_with_empty_struct" with-empty-struct)
+;
+; (deftest struct.alignment.5
+;     (with-foreign-slots ((foo an-int) *the-with-empty-struct* with-empty-struct)
+;       an-int)
+;   42)
+
+
+;; regression test, setf-ing nested foreign-slot-value forms
+;; the setf expander used to return a bogus getter
+
+(defcstruct s1
+  (an-int :int))
+
+(defcstruct s2
+  (an-s1 s1))
+
+(deftest struct.nested-setf
+    (with-foreign-object (an-s2 's2)
+      (setf (foreign-slot-value (foreign-slot-value an-s2 's2 'an-s1)
+                                's1 'an-int)
+            1984)
+      (foreign-slot-value (foreign-slot-value an-s2 's2 'an-s1)
+                          's1 'an-int))
+  1984)
+
+;; regression test, some Lisps were returning 4 instead of 8 for
+;; (foreign-type-alignment :unsigned-long-long) on darwin/ppc32
+
+#-cffi-features:no-long-long
+(progn
+  (defcstruct s-unsigned-long-long
+    (an-unsigned-long-long :unsigned-long-long)
+    (a-short               :short))
+
+  (defcstruct s-s-unsigned-long-long
+    (a-char                 :char)
+    (a-s-unsigned-long-long s-unsigned-long-long)
+    (another-short          :short))
+
+  (defcvar "the_s_s_unsigned_long_long" s-s-unsigned-long-long)
+
+  (deftest struct.alignment.8
+      (with-foreign-slots
+          ((a-char a-s-unsigned-long-long another-short)
+           *the-s-s-unsigned-long-long* s-s-unsigned-long-long)
+        (with-foreign-slots ((an-unsigned-long-long a-short)
+                             a-s-unsigned-long-long s-unsigned-long-long)
+          (list 'an-unsigned-long-long  an-unsigned-long-long
+                'a-short                a-short
+                'a-char                 a-char
+                'another-short          another-short)))
+    (an-unsigned-long-long 1 a-short 2 a-char 3 another-short 4)))
diff --git a/external/cffi.darcs/tests/union.lisp b/external/cffi.darcs/tests/union.lisp
new file mode 100644
index 0000000..bd966d8
--- /dev/null
+++ b/external/cffi.darcs/tests/union.lisp
@@ -0,0 +1,50 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; union.lisp --- Tests on C unions.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+(in-package #:cffi-tests)
+
+(defcunion uint32-bytes
+  (int-value :unsigned-int)
+  (bytes :unsigned-char :count 4))
+
+(defun int-to-bytes (n)
+  "Convert N to a list of bytes using a union."
+  (with-foreign-object (obj 'uint32-bytes)
+    (setf (foreign-slot-value obj 'uint32-bytes 'int-value) n)
+    (loop for i from 0 below 4
+          collect (mem-aref
+                   (foreign-slot-value obj 'uint32-bytes 'bytes)
+                   :unsigned-char i))))
+
+(deftest union.1
+    (let ((bytes (int-to-bytes #x12345678)))
+      (cond ((equal bytes '(#x12 #x34 #x56 #x78))
+             t)
+            ((equal bytes '(#x78 #x56 #x34 #x12))
+             t)
+            (t bytes)))
+  t)
diff --git a/external/cffi.darcs/uffi-compat/uffi-compat.lisp b/external/cffi.darcs/uffi-compat/uffi-compat.lisp
new file mode 100644
index 0000000..5e25f56
--- /dev/null
+++ b/external/cffi.darcs/uffi-compat/uffi-compat.lisp
@@ -0,0 +1,622 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; uffi-compat.lisp --- UFFI compatibility layer for CFFI.
+;;;
+;;; Copyright (C) 2005-2006, James Bielman  
+;;; Copyright (C) 2005-2007, Luis Oliveira  
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+;;;
+
+;;; Code borrowed from UFFI is Copyright (c) Kevin M. Rosenberg.
+
+(defpackage #:cffi-uffi-compat
+  (:nicknames #:uffi) ;; is this a good idea?
+  (: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
+   #:+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              ; not implemented
+
+   ;; function call
+   #:def-function
+
+   ;; libraries
+   #:find-foreign-library
+   #:load-foreign-library
+   #:default-foreign-library-type
+   #:foreign-library-types
+
+   ;; os
+   #:getenv
+   #:run-shell-command
+   ))
+
+(in-package #:cffi-uffi-compat)
+
+#+clisp
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (equal (machine-type) "POWER MACINTOSH")
+    (pushnew :ppc *features*)))
+
+(defun convert-uffi-type (uffi-type)
+  "Convert a UFFI primitive type to a CFFI type."
+  ;; Many CFFI types are the same as UFFI.  This list handles the
+  ;; exceptions only.
+  (case uffi-type
+    (:cstring :pointer)
+    (:pointer-void :pointer)
+    (:pointer-self :pointer)
+    (:char '(uffi-char :char))
+    (:unsigned-char '(uffi-char :unsigned-char))
+    (:byte :char)
+    (:unsigned-byte :unsigned-char)
+    (t
+     (if (listp uffi-type)
+         (case (car uffi-type)
+           ;; this is imho gross but it is what uffi does
+           (quote (convert-uffi-type (second uffi-type)))
+           (* :pointer)
+           (:array `(uffi-array ,(convert-uffi-type (second uffi-type))
+                                ,(third uffi-type)))
+           (:union (second uffi-type))
+           (:struct (convert-uffi-type (second uffi-type)))
+           (:struct-pointer :pointer))
+         uffi-type))))
+
+(cffi:define-foreign-type uffi-array-type ()
+  ;; ELEMENT-TYPE should be /unparsed/, suitable for passing to mem-aref.
+  ((element-type :initform (error "An element-type is required.")
+                 :accessor element-type :initarg :element-type)
+   (nelems :initform (error "nelems is required.")
+           :accessor nelems :initarg :nelems))
+  (:actual-type :pointer)
+  (:documentation "UFFI's :array type."))
+
+(cffi:define-parse-method uffi-array (element-type count)
+  (make-instance 'uffi-array-type :element-type element-type
+                 :nelems (or count 1)))
+
+(defmethod cffi:foreign-type-size ((type uffi-array-type))
+  (* (cffi:foreign-type-size (element-type type)) (nelems type)))
+
+(defmethod cffi::aggregatep ((type uffi-array-type))
+  t)
+
+;; UFFI's :(unsigned-)char
+(cffi:define-foreign-type uffi-char ()
+  ())
+
+(cffi:define-parse-method uffi-char (base-type)
+  (make-instance 'uffi-char :actual-type base-type))
+
+(defmethod cffi:translate-to-foreign ((value character) (type uffi-char))
+  (char-code value))
+
+(defmethod cffi:translate-from-foreign (obj (type uffi-char))
+  (code-char obj))
+
+(defmacro def-type (name type)
+  "Define a Common Lisp type NAME for UFFI type TYPE."
+  (declare (ignore type))
+  `(deftype ,name () t))
+
+(defmacro def-foreign-type (name type)
+  "Define a new foreign type."
+  `(cffi:defctype ,name ,(convert-uffi-type type)))
+
+(defmacro def-constant (name value &key export)
+  "Define a constant and conditionally export it."
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (defconstant ,name ,value)
+     ,@(when export `((export ',name)))
+     ',name))
+
+(defmacro null-char-p (val)
+  "Return true if character is null."
+  `(zerop (char-code ,val)))
+
+(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 `(def-constant ,name ,value) constants)))
+    (setf cmds (append '(progn) `((cffi:defctype ,enum-name :int))
+                       (nreverse constants)))
+    cmds))
+
+(defmacro def-struct (name &body fields)
+  "Define a C structure."
+  `(cffi:defcstruct ,name
+     ,@(loop for (name uffi-type) in fields
+             for cffi-type = (convert-uffi-type uffi-type)
+             collect (list name cffi-type))))
+
+;; TODO: figure out why the compiler macro is kicking in before
+;; the setf expander.
+(defun %foreign-slot-value (obj type field)
+  (cffi:foreign-slot-value obj type field))
+
+(defun (setf %foreign-slot-value) (value obj type field)
+  (setf (cffi:foreign-slot-value obj type field) value))
+
+(defmacro get-slot-value (obj type field)
+  "Access a slot value from a structure."
+  `(%foreign-slot-value ,obj ,type ,field))
+
+;; UFFI uses a different function when accessing a slot whose
+;; type is a pointer. We don't need that in CFFI so we use
+;; foreign-slot-value too.
+(defmacro get-slot-pointer (obj type field)
+  "Access a pointer slot value from a structure."
+  `(cffi:foreign-slot-value ,obj ,type ,field))
+
+(defmacro def-array-pointer (name type)
+  "Define a foreign array type."
+  `(cffi:defctype ,name (uffi-array ,(convert-uffi-type type) 1)))
+
+(defmacro deref-array (array type position)
+  "Dereference an array."
+  `(cffi:mem-aref ,array
+                  ,(if (constantp type)
+                       `',(element-type (cffi::parse-type
+                                         (convert-uffi-type (eval type))))
+                       `(element-type (cffi::parse-type
+                                       (convert-uffi-type ,type))))
+                  ,position))
+
+;; UFFI's documentation on DEF-UNION is a bit scarce, I'm not sure
+;; if DEFCUNION and DEF-UNION are strictly compatible.
+(defmacro def-union (name &body fields)
+  "Define a foreign union type."
+  `(cffi:defcunion ,name
+     ,@(loop for (name uffi-type) in fields
+             for cffi-type = (convert-uffi-type uffi-type)
+             collect (list name cffi-type))))
+
+(defmacro allocate-foreign-object (type &optional (size 1))
+  "Allocate one or more instance of a foreign type."
+  `(cffi:foreign-alloc ,(if (constantp type)
+                            `',(convert-uffi-type (eval type))
+                            `(convert-uffi-type ,type))
+                       :count ,size))
+
+(defmacro free-foreign-object (ptr)
+  "Free a foreign object allocated by ALLOCATE-FOREIGN-OBJECT."
+  `(cffi:foreign-free ,ptr))
+
+(defmacro with-foreign-object ((var type) &body body)
+  "Wrap the allocation of a foreign object around BODY."
+  `(cffi:with-foreign-object (,var (convert-uffi-type ,type))
+     ,@body))
+
+;; Taken from UFFI's src/objects.lisp
+(defmacro with-foreign-objects (bindings &rest body)
+  (if bindings
+      `(with-foreign-object ,(car bindings)
+         (with-foreign-objects ,(cdr bindings)
+           ,@body))
+      `(progn ,@body)))
+
+(defmacro size-of-foreign-type (type)
+  "Return the size in bytes of a foreign type."
+  `(cffi:foreign-type-size (convert-uffi-type ,type)))
+
+(defmacro pointer-address (ptr)
+  "Return the address of a pointer."
+  `(cffi:pointer-address ,ptr))
+
+(defmacro deref-pointer (ptr type)
+  "Dereference a pointer."
+  `(cffi:mem-ref ,ptr (convert-uffi-type ,type)))
+
+(defsetf deref-pointer (ptr type) (value)
+  `(setf (cffi:mem-ref ,ptr (convert-uffi-type ,type)) ,value))
+
+(defmacro ensure-char-character (obj &environment env)
+  "Convert OBJ to a character if it is an integer."
+  (if (constantp obj env)
+      (if (characterp obj) obj (code-char obj))
+      (let ((obj-var (gensym)))
+        `(let ((,obj-var ,obj))
+           (if (characterp ,obj-var)
+               ,obj-var
+               (code-char ,obj-var))))))
+
+(defmacro ensure-char-integer (obj &environment env)
+  "Convert OBJ to an integer if it is a character."
+  (if (constantp obj env)
+      (let ((the-obj (eval obj)))
+        (if (characterp the-obj) (char-code the-obj) the-obj))
+      (let ((obj-var (gensym)))
+        `(let ((,obj-var ,obj))
+           (if (characterp ,obj-var)
+               (char-code ,obj-var)
+               ,obj-var)))))
+
+(defmacro ensure-char-storable (obj)
+  "Ensure OBJ is storable as a character."
+  `(ensure-char-integer ,obj))
+
+(defmacro make-null-pointer (type)
+  "Create a NULL pointer."
+  (declare (ignore type))
+  `(cffi:null-pointer))
+
+(defmacro make-pointer (address type)
+  "Create a pointer to ADDRESS."
+  (declare (ignore type))
+  `(cffi:make-pointer ,address))
+
+(defmacro null-pointer-p (ptr)
+  "Return true if PTR is a null pointer."
+  `(cffi:null-pointer-p ,ptr))
+
+(defparameter +null-cstring-pointer+ (cffi:null-pointer)
+  "A constant NULL string pointer.")
+
+(defmacro char-array-to-pointer (obj)
+  obj)
+
+(defmacro with-cast-pointer ((var ptr type) &body body)
+  "Cast a pointer, does nothing in CFFI."
+  (declare (ignore type))
+  `(let ((,var ,ptr))
+     ,@body))
+
+(defmacro def-foreign-var (name type module)
+  "Define a symbol macro to access a foreign variable."
+  (declare (ignore module))
+  (flet ((lisp-name (name)
+           (intern (cffi-sys:canonicalize-symbol-name-case
+                    (substitute #\- #\_ name)))))
+    `(cffi:defcvar ,(if (listp name)
+                        name
+                        (list name (lisp-name name)))
+         ,(convert-uffi-type type))))
+
+(defmacro def-pointer-var (name value &optional doc)
+  #-openmcl `(defvar ,name ,value ,@(if doc (list doc)))
+  #+openmcl `(ccl::defloadvar ,name ,value ,doc))
+
+(defmacro convert-from-cstring (s)
+  "Convert a cstring to a Lisp string."
+  (let ((ret (gensym)))
+    `(let ((,ret (cffi:foreign-string-to-lisp ,s)))
+       (if (equal ,ret "")
+           nil
+           ,ret))))
+
+(defmacro convert-to-cstring (obj)
+  "Convert a Lisp string to a cstring."
+  (let ((str (gensym)))
+    `(let ((,str ,obj))
+       (if (null ,str)
+           (cffi:null-pointer)
+           (cffi:foreign-string-alloc ,str)))))
+
+(defmacro free-cstring (ptr)
+  "Free a cstring."
+  `(cffi:foreign-string-free ,ptr))
+
+(defmacro with-cstring ((foreign-string lisp-string) &body body)
+  "Binds a newly creating string."
+  (let ((str (gensym)))
+    `(let ((,str ,lisp-string))
+       (if (null ,str)
+           (let ((,foreign-string (cffi:null-pointer)))
+             ,@body)
+           (cffi:with-foreign-string (,foreign-string ,str)
+             ,@body)))))
+
+;; Taken from UFFI's src/strings.lisp
+(defmacro with-cstrings (bindings &rest body)
+  (if bindings
+      `(with-cstring ,(car bindings)
+         (with-cstrings ,(cdr bindings)
+           ,@body))
+      `(progn ,@body)))
+
+(defmacro def-function (name args &key module (returning :void))
+  "Define a foreign function."
+  (declare (ignore module))
+  `(cffi:defcfun ,name ,(convert-uffi-type returning)
+     ,@(loop for (name type) in args
+             collect `(,name ,(convert-uffi-type type)))))
+
+;;; Taken from UFFI's src/libraries.lisp
+
+(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 macos macosx darwin ccl-5.0) "dylib"
+  #-(or win32 cygwin mswindows macos 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 cygwin mswindows) '("dll" "lib" "so")
+  #+(or macos macosx darwin ccl-5.0) '("dylib" "bundle")
+  #-(or win32 cygwin mswindows macos 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 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)))
+
+(defun load-foreign-library (filename &key module supporting-libraries
+                             force-load)
+  #+(or allegro mcl sbcl clisp) (declare (ignore module supporting-libraries))
+  #+(or cmu scl sbcl) (declare (ignore module))
+
+  (when (and filename (or (null (pathname-directory filename))
+                          (probe-file filename)))
+    (if (pathnamep filename) ;; ensure filename is a string to check if
+   (setq filename (namestring filename))) ; already loaded
+
+    (if (and (not force-load)
+        (find filename *loaded-libraries* :test #'string-equal))
+        t ;; return T, but don't reload library
+        (progn
+          ;; FIXME: Hmm, what are these two for?
+          #+cmu
+          (let ((type (pathname-type (parse-namestring filename))))
+            (if (string-equal type "so")
+                (sys::load-object-file filename)
+                (alien:load-foreign filename
+                                    :libraries
+                                    (convert-supporting-libraries-to-string
+                                     supporting-libraries))))
+          #+scl
+          (let ((type (pathname-type (parse-namestring filename))))
+            (if (string-equal type "so")
+                (sys::load-dynamic-object filename)
+                (alien:load-foreign filename
+                                    :libraries
+                                    (convert-supporting-libraries-to-string
+                                     supporting-libraries))))
+
+          #-(or cmu scl)
+          (cffi:load-foreign-library filename)
+          (push filename *loaded-libraries*)
+          t))))
+
+;; Taken from UFFI's src/os.lisp
+(defun getenv (var)
+  "Return the value of the environment variable."
+  #+allegro (sys::getenv (string var))
+  #+clisp (sys::getenv (string var))
+  #+(or cmu scl) (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))
+  #+mcl (ccl::getenv var)
+  #+sbcl (sb-ext:posix-getenv var)
+  #-(or allegro clisp cmu scl gcl lispworks lucid mcl sbcl)
+  (error 'not-implemented :proc (list 'getenv var)))
+
+;; Taken from UFFI's src/os.lisp
+;; 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")
+    ))
+
+;;; Some undocumented UFFI operators...
+
+(defmacro convert-from-foreign-string (obj &key (length most-positive-fixnum)
+                                       (locale :default)
+                                       (null-terminated-p t))
+  (declare (ignore locale))
+  (let ((ret (gensym)))
+    `(let ((,ret (cffi:foreign-string-to-lisp ,obj ,length ,null-terminated-p)))
+       (if (equal ,ret "")
+           nil
+           ,ret))))
+
+;; What's the difference between this and convert-to-cstring?
+(defmacro convert-to-foreign-string (obj)
+  (let ((str (gensym)))
+    `(let ((,str ,obj))
+       (if (null ,str)
+           (cffi:null-pointer)
+           (cffi:foreign-string-alloc ,str)))))
+
+(defmacro allocate-foreign-string (size &key unsigned)
+  (declare (ignore unsigned))
+  `(cffi:foreign-alloc :char :count ,size))
+
+;; Ditto.
+(defmacro with-foreign-string ((foreign-string lisp-string) &body body)
+  (let ((str (gensym)))
+    `(let ((,str ,lisp-string))
+       (if (null ,str)
+           (let ((,foreign-string (cffi:null-pointer)))
+             ,@body)
+           (cffi:with-foreign-string (,foreign-string ,str)
+             ,@body)))))
+
+(defmacro with-foreign-strings (bindings &body body)
+  `(with-foreign-string ,(car bindings)
+    ,@(if (cdr bindings)
+          `((with-foreign-strings ,(cdr bindings) ,@body))
+          body)))
+
+;; This function returns a form? Where is this used in user-code?
+(defun foreign-string-length (foreign-string)
+  (declare (ignore foreign-string))
+  (error "FOREIGN-STRING-LENGTH not implemented."))
+
+;; This should be optimized.
+(defun convert-from-foreign-usb8 (s len)
+  (let ((a (make-array len :element-type '(unsigned-byte 8))))
+    (dotimes (i len a)
+      (setf (aref a i) (cffi:mem-ref s :unsigned-char i)))))
diff --git a/external/cffi.darcs/uffi-compat/uffi.asd b/external/cffi.darcs/uffi-compat/uffi.asd
new file mode 100644
index 0000000..4d31c50
--- /dev/null
+++ b/external/cffi.darcs/uffi-compat/uffi.asd
@@ -0,0 +1,3 @@
+;;;; uffi.asd -*- Mode: Lisp -*-
+
+(defsystem uffi :depends-on (cffi-uffi-compat))
-- 
2.11.4.GIT