cffi-20100219.orig/0002755000175000017500000000000011345222703014053 5ustar pvaneyndpvaneyndcffi-20100219.orig/scripts/0002755000175000017500000000000011345222703015542 5ustar pvaneyndpvaneyndcffi-20100219.orig/scripts/release.sh0000644000175000017500000000661611345222703017525 0ustar pvaneyndpvaneynd#!/bin/bash ### Configuration PROJECT_NAME='cffi' ASDF_FILE="$PROJECT_NAME.asd" HOST="common-lisp.net" RELEASE_DIR="/project/$PROJECT_NAME/public_html/releases" VERSION_FILE="VERSION" VERSION_FILE_DIR="/project/$PROJECT_NAME/public_html" set -e ### Process options FORCE=0 VERSION="" while [ $# -gt 0 ]; do case "$1" in -h|--help) echo "No help, sorry. Read the source." exit 0 ;; -f|--force) FORCE=1 shift ;; -v|--version) VERSION="$2" shift 2 ;; *) echo "Unrecognized argument '$1'" exit 1 ;; esac done ### Check for unrecorded changes if darcs whatsnew; then echo -n "Unrecorded changes. " if [ "$FORCE" -ne 1 ]; then echo "Aborting." echo "Use -f or --force if you want to make a release anyway." exit 1 else echo "Continuing anyway." fi fi ### Determine new version number if [ -z "$VERSION" ]; then CURRENT_VERSION=$(grep :version $ASDF_FILE | cut -d\" -f2) dots=$(echo "$CURRENT_VERSION" | tr -cd '.') count=$(expr length "$dots" + 1) declare -a versions for i in $(seq $count); do new="" for j in $(seq $(expr $i - 1)); do p=$(echo "$CURRENT_VERSION" | cut -d. -f$j) new="$new$p." done part=$(expr 1 + $(echo "$CURRENT_VERSION" | cut -d. -f$i)) new="$new$part" for j in $(seq $(expr $i + 1) $count); do new="$new.0"; done versions[$i]=$new done while true; do echo "Current version is $CURRENT_VERSION. Which will be next one?" for i in $(seq $count); do echo " $i) ${versions[$i]}"; done echo -n "? " read choice if ((choice > 0)) && ((choice <= ${#versions[@]})); then VERSION=${versions[$choice]} break fi done fi ### Do it TARBALL_NAME="${PROJECT_NAME}_${VERSION}" TARBALL="$TARBALL_NAME.tar.gz" SIGNATURE="$TARBALL.asc" echo "Updating $ASDF_FILE with new version: $VERSION" sed -e "s/:version \"$CURRENT_VERSION\"/:version \"$VERSION\"/" \ "$ASDF_FILE" > "$ASDF_FILE.tmp" mv "$ASDF_FILE.tmp" "$ASDF_FILE" darcs record -m "update $ASDF_FILE for version $VERSION" echo "Tagging the tree..." darcs tag "$VERSION" echo "Creating distribution..." darcs dist -d "$TARBALL_NAME" echo "Signing tarball..." gpg -b -a "$TARBALL" echo "Copying tarball to web server..." scp "$TARBALL" "$SIGNATURE" "$HOST:$RELEASE_DIR" echo "Uploaded $TARBALL and $SIGNATURE." echo "Updating ${PROJECT_NAME}_latest links..." ssh $HOST ln -sf "$TARBALL" "$RELEASE_DIR/${PROJECT_NAME}_latest.tar.gz" ssh $HOST ln -sf "$SIGNATURE" "$RELEASE_DIR/${PROJECT_NAME}_latest.tar.gz.asc" if [ "$VERSION_FILE" ]; then echo "Uploading $VERSION_FILE..." echo -n "$VERSION" > "$VERSION_FILE" scp "$VERSION_FILE" "$HOST":"$VERSION_FILE_DIR" rm "$VERSION_FILE" fi while true; do echo -n "Clean local tarball and signature? [y] " read -n 1 response case "$response" in y|'') echo rm "$TARBALL" "$SIGNATURE" break ;; n) break ;; *) echo "Invalid response '$response'. Try again." ;; esac done echo "Building and uploading documentation..." make -C doc upload-docs echo "Pushing changes..." darcs push cffi-20100219.orig/cffi-grovel.asd0000644000175000017500000000316511345222703016752 0ustar pvaneyndpvaneynd;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-grovel.asd --- ASDF system definition for cffi-grovel. ;;; ;;; 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. ;;; (asdf:defsystem cffi-grovel :description "The CFFI Groveller" :author "Dan Knapp " :depends-on (cffi alexandria) :licence "MIT" :components ((:module grovel :serial t :components ((:file "package") (:file "invoke") (:static-file "common.h") (:file "grovel") (:file "asdf"))))) ;; vim: ft=lisp et cffi-20100219.orig/README0000644000175000017500000000166011345222703014734 0ustar pvaneyndpvaneynd 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. Please consult the manual for further details, including installation instructions. cffi-20100219.orig/cffi.asd0000644000175000017500000000500011345222703015444 0ustar pvaneyndpvaneynd;;;; -*- 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 abcl) (error "Sorry, this Lisp is not yet supported. Patches welcome!") (defsystem cffi :description "The Common Foreign Function Interface" :author "James Bielman " :version "0.10.5" :licence "MIT" :depends-on (alexandria trivial-features babel) :components ((:module src :serial t :components (#+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") #+abcl (:file "cffi-abcl") (:file "package") (:file "utils") (:file "libraries") (:file "early-types") (:file "types") (:file "enum") (:file "strings") (:file "functions") (:file "foreign-vars") (:file "features"))))) (defmethod operation-done-p ((o test-op) (c (eql (find-system :cffi)))) nil) (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 cffi-20100219.orig/examples/0002755000175000017500000000000011345222703015671 5ustar pvaneyndpvaneyndcffi-20100219.orig/examples/examples.lisp0000644000175000017500000000522111345222703020376 0ustar pvaneyndpvaneynd;;;; -*- 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 buf-size) 255) (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)) cffi-20100219.orig/examples/gethostname.lisp0000644000175000017500000000410011345222703021071 0ustar pvaneyndpvaneynd;;;; -*- 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 bufsize) 255) (%gethostname buf bufsize))) cffi-20100219.orig/examples/translator-test.lisp0000644000175000017500000000675511345222703021743 0ustar pvaneyndpvaneynd;;;; -*- 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)) (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)) cffi-20100219.orig/examples/gettimeofday.lisp0000644000175000017500000000730211345222703021243 0ustar pvaneyndpvaneynd;;;; -*- 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) (: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)))) cffi-20100219.orig/examples/run-examples.lisp0000644000175000017500000000277711345222703021215 0ustar pvaneyndpvaneynd;;;; -*- 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) cffi-20100219.orig/examples/mapping.lisp0000644000175000017500000000553611345222703020224 0ustar pvaneyndpvaneynd;;;; -*- 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)) cffi-20100219.orig/cffi-uffi-compat.asd0000644000175000017500000000317011345222703017662 0ustar pvaneyndpvaneynd;;;; -*- 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 cffi-20100219.orig/HEADER0000644000175000017500000000234511345222703014730 0ustar pvaneyndpvaneynd;;;; -*- 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. ;;; cffi-20100219.orig/Makefile0000644000175000017500000000452011345222703015512 0ustar pvaneyndpvaneynd# -*- 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 ?= alisp 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 cffi-20100219.orig/doc/0002755000175000017500000000000011345222703014620 5ustar pvaneyndpvaneyndcffi-20100219.orig/doc/gendocs.sh0000644000175000017500000002506711345222703016606 0ustar pvaneyndpvaneynd#!/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. #set -e 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 --no-sysinit --no-userinit --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 --no-userinit --no-sysinit --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." �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������cffi-20100219.orig/doc/gendocs_template�������������������������������������������������������������0000644�0001750�0001750�00000013252�11345222703�020061� 0����������������������������������������������������������������������������������������������������ustar �pvaneynd������������������������pvaneynd���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������<?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%%

cffi-20100219.orig/doc/Makefile0000644000175000017500000000376311345222703016267 0ustar pvaneyndpvaneynd# -*- 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: manual spec 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 cffi-20100219.orig/doc/cffi-sys-spec.texinfo0000644000175000017500000002253411345222703020675 0ustar pvaneyndpvaneynd\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 cffi-20100219.orig/doc/allegro-internals.txt0000644000175000017500000001217511345222703021007 0ustar pvaneyndpvaneyndJuly 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) ...) cffi-20100219.orig/doc/style.css0000644000175000017500000000515711345222703016500 0ustar pvaneyndpvaneyndbody {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; } cffi-20100219.orig/doc/shareable-vectors.txt0000644000175000017500000000300111345222703020762 0ustar pvaneyndpvaneynd # 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)))))) cffi-20100219.orig/doc/mem-vector.txt0000644000175000017500000000514711345222703017444 0ustar pvaneyndpvaneynd # 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. cffi-20100219.orig/doc/colorize-lisp-examples.lisp0000644000175000017500000012601211345222703022120 0ustar pvaneyndpvaneynd;;; 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))
cffi-20100219.orig/doc/cffi-manual.texinfo0000644000175000017500000057555611345222703020425 0ustar  pvaneyndpvaneynd\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

@c Style notes:
@c
@c * The reference section names and "See Also" list are roman, not
@c   @code.  This is to follow the format of CLHS.
@c
@c * How it looks in HTML is the priority.

@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 Typeset comments in roman font for the TeX output.
@iftex
@alias lispcmt = r
@end iftex
@ifnottex
@alias lispcmt = asis
@end ifnottex

@c My copy of makeinfo is not generating any HTML for @result{} for
@c some odd reason. (It certainly used to...)
@ifhtml
@macro result
=>
@end macro
@end ifhtml

@c Similar macro to @result. Its purpose is to work around the fact
@c that ⇒ does not work properly inside @lisp.
@ifhtml
@macro res
@html
⇒
@end html
@end macro
@end ifhtml

@ifnothtml
@alias res = result
@end ifnothtml

@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-2010 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, Introduction, (dir), (dir)
@top cffi
@insertcopying
@end ifnottex

@menu
* Introduction::                What is CFFI?
* Installation::                
* 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::                   
* The Groveller::               
* 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::      Defines how to free a oreign object.
* translate-from-foreign::      Defines a foreign-to-Lisp object translation.
* translate-to-foreign::        Defines a Lisp-to-foreign object translation.
* with-foreign-object::         Allocates a foreign object with dynamic extent.
* with-foreign-objects::        Plural form of @code{with-foreign-object}.
* with-foreign-slots::          Accesses 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

* *default-foreign-encoding*::  Default encoding for the string types.
* 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-strings::        Plural form of @code{with-foreign-string}.
* 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, Installation, Top, Top
@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: Installation

@node Installation, Implementation Support, Introduction, Top
@chapter Installation

@cffi{} can be obtained through one of the following means available
through its @uref{http://common-lisp.net/project/cffi/,,website}:

@itemize
@item
@uref{http://common-lisp.net/project/cffi/releases/?M=D,,official release
tarballs}

@item
@uref{http://common-lisp.net/project/cffi/darcs/cffi,,darcs
repository}

@item
@uref{http://common-lisp.net/project/cffi/tarballs/?M=D,,nightly-generated
snapshots}

@end itemize

In addition, you will need to obtain and install the following
dependencies:

@itemize
@item
@uref{http://common-lisp.net/project/babel/,,Babel}, a charset
encoding/decoding library.

@item
@uref{http://common-lisp.net/project/alexandria/,,Alexandria}, a
collection of portable public-domain utilities.

@item
@uref{http://www.cliki.net/trivial-features,,trivial-features}, a
portability layer that ensures consistent @code{*features*} across
multiple Common Lisp implementations.

@end itemize

Furthermore, if you wish to run the testsuite,
@uref{http://www.cliki.net/rt,,RT} is required.

You may find mechanisms such as
@uref{http://common-lisp.net/project/clbuild/,,clbuild} (recommended)
or @uref{http://www.cliki.net/ASDF-Install,,ASDF-Install} (not as
recommendable) helpful in getting and managing @cffi{} and its
dependencies.


@c ===================================================================
@c CHAPTER: Implementation Support

@node Implementation Support, Tutorial, Installation, Top
@chapter Implementation Support

@cffi{} supports various free and commercial Lisp implementations:
Allegro CL, Corman CL, @sc{clisp}, @acronym{CMUCL}, @acronym{ECL},
LispWorks, Clozure CL, @acronym{SBCL} and the Scieneer CL.

In general, you should work with the latest versions of each
implementation since those will usually be tested against recent
versions of CFFI more often and might include necessary features or
bug fixes. Reasonable patches for compatibility with earlier versions
are welcome nevertheless.

@section Limitations

Some features are not supported in all implementations.
@c TODO: describe these features here.
@c       flat-namespace too

@subheading Allegro CL

@itemize
@item
Does not support the @code{:long-long} type natively.
@item
Unicode support is limited to the Basic Multilingual Plane (16-bit
code points).
@end itemize

@subheading CMUCL

@itemize
@item
No Unicode support. (8-bit code points)
@end itemize

@subheading Corman CL

@itemize
@item
Does not support @code{foreign-funcall}.
@end itemize

@subheading @acronym{ECL}

@itemize
@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.
@item
Does not support the @code{:long-long} type natively.
@item
Unicode support is not enabled by default.
@end itemize

@subheading Lispworks

@itemize
@item
Does not completely support the @code{:long-long} type natively in
32-bit platforms.
@item
Unicode support is limited to the Basic Multilingual Plane (16-bit
code points).
@end itemize

@subheading @acronym{SBCL}

@itemize
@item
Not all platforms support callbacks.

@end itemize


@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, Wrapper generators, Implementation Support, Top
@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, Tutorial-Getting a URL, Tutorial, Tutorial
@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, Tutorial-Loading, Tutorial-Comparison, Tutorial
@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, Tutorial-Initializing, Tutorial-Getting a URL, Tutorial
@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, Tutorial-easy_setopt, Tutorial-Loading, Tutorial
@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{By default, CFFI 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, but we emulate UNIX's behaviour
there.  @ref{defcfun} for more details.}

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, Tutorial-Abstraction, Tutorial-Initializing, Tutorial
@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, Tutorial-Lisp easy_setopt, Tutorial-easy_setopt, Tutorial
@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, Tutorial-Memory, Tutorial-Abstraction, Tutorial
@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, Tutorial-Callbacks, Tutorial-Lisp easy_setopt, Tutorial
@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, Tutorial-Completion, Tutorial-Memory, Tutorial
@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, Tutorial-Types, Tutorial-Callbacks, Tutorial
@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, Tutorial-Conclusion, Tutorial-Completion, Tutorial
@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,  , Tutorial-Types, Tutorial
@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 free-translated-object, or structs.  Let us
know which ones you care about.}


@c ===================================================================
@c CHAPTER: Wrapper generators

@node Wrapper generators, Foreign Types, Tutorial, Top
@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, Pointers, Wrapper generators, Top
@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::     
* 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, Other Types, Foreign Types, Foreign 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.

@code{:long-long} and @code{:unsigned-long-long} are not supported
natively on all implementations. However, they are emulated by
@code{mem-ref} and @code{mem-set}.

When those types are @strong{not} available, the symbol
@code{cffi-sys::no-long-long} is pushed into @code{*features*}.

@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.

@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, Defining Foreign Types, Built-In Types, Foreign 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 accept foreign pointers
and pass them 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
@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, Foreign Type Translators, Other Types, 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, Optimizing Type Translators, Defining Foreign Types, Foreign Types
@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, Foreign Structure Types, Foreign Type Translators, Foreign Types
@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)))
;; @lispcmt{(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)))
;; @lispcmt{(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)))
;; @lispcmt{(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, Allocating Foreign Objects, Optimizing Type Translators, Foreign 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

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.

@ref{defcstruct} for more details.

@node Allocating Foreign Objects, convert-from-foreign, Foreign Structure Types, Foreign Types
@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

@page
@node convert-from-foreign, convert-to-foreign, Allocating Foreign Objects, Foreign Types
@heading convert-from-foreign
@subheading Syntax
@Function{convert-from-foreign foreign-value type @res{} 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{free-converted-object} @*
@seealso{translate-from-foreign}


@c ===================================================================
@c CONVERT-TO-FOREIGN

@page
@node convert-to-foreign, defbitfield, convert-from-foreign, Foreign Types
@heading convert-to-foreign
@subheading Syntax
@Function{convert-to-foreign value type @res{} 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

@page
@node defbitfield, defcstruct, convert-to-foreign, Foreign Types
@heading 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

@page
@node defcstruct, defcunion, defbitfield, Foreign Types
@heading defcstruct
@subheading Syntax
@Macro{defcstruct name-and-options &body doc-and-slots @res{} 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
  "Point 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

@page
@node defcunion, defctype, defcstruct, Foreign Types
@heading defcunion
@subheading Syntax
@Macro{defcunion name &body doc-and-slots @res{} 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

@page
@node defctype, defcenum, defcunion, Foreign Types
@heading 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

@page
@node defcenum, define-foreign-type, defctype, Foreign Types
@heading 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

@page
@node define-foreign-type, define-parse-method, defcenum, Foreign Types
@heading define-foreign-type
@subheading Syntax
@Macro{define-foreign-type class-name supers slots &rest options @res{} 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

@page
@node define-parse-method, foreign-bitfield-symbols, define-foreign-type, Foreign Types
@heading define-parse-method
@subheading Syntax
@Macro{define-parse-method name lambda-list &body body @res{} 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 @heading 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

@page
@node foreign-bitfield-symbols, foreign-bitfield-value, define-parse-method, Foreign Types
@heading foreign-bitfield-symbols
@subheading Syntax
@Function{foreign-bitfield-symbols type value @res{} 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

@page
@node foreign-bitfield-value, foreign-enum-keyword, foreign-bitfield-symbols, Foreign Types
@heading foreign-bitfield-value
@subheading Syntax
@Function{foreign-bitfield-value type symbols @res{} 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

@page
@node foreign-enum-keyword, foreign-enum-value, foreign-bitfield-value, Foreign Types
@heading foreign-enum-keyword
@subheading Syntax
@Function{foreign-enum-keyword type value &key errorp @res{} 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

@page
@node foreign-enum-value, foreign-slot-names, foreign-enum-keyword, Foreign Types
@heading foreign-enum-value
@subheading Syntax
@Function{foreign-enum-value type keyword &key errorp @res{} 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

@page
@node foreign-slot-names, foreign-slot-offset, foreign-enum-value, Foreign Types
@heading foreign-slot-names
@subheading Syntax
@Function{foreign-slot-names type @res{} 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

@page
@node foreign-slot-offset, foreign-slot-pointer, foreign-slot-names, Foreign Types
@heading foreign-slot-offset
@subheading Syntax
@Function{foreign-slot-offset type slot-name @res{} 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

@page
@node foreign-slot-pointer, foreign-slot-value, foreign-slot-offset, Foreign Types
@heading foreign-slot-pointer
@subheading Syntax
@Function{foreign-slot-pointer ptr type slot-name @res{} 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

@page
@node foreign-slot-value, foreign-type-alignment, foreign-slot-pointer, Foreign Types
@heading foreign-slot-value
@subheading Syntax
@Accessor{foreign-slot-value ptr type slot-name @res{} 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

@page
@node foreign-type-alignment, foreign-type-size, foreign-slot-value, Foreign Types
@heading foreign-type-alignment
@subheading Syntax
@c XXX: This is actually a generic function.
@Function{foreign-type-alignment type @res{} 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

@page
@node foreign-type-size, free-converted-object, foreign-type-alignment, Foreign Types
@heading foreign-type-size
@subheading Syntax
@c XXX: this is actually a generic function.
@Function{foreign-type-size type @res{} 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

@page
@node free-converted-object, free-translated-object, foreign-type-size, Foreign Types
@heading 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

@page
@node free-translated-object, translate-from-foreign, free-converted-object, Foreign Types
@heading 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

@page
@node translate-from-foreign, translate-to-foreign, free-translated-object, Foreign Types
@heading translate-from-foreign
@subheading Syntax
@GenericFunction{translate-from-foreign foreign-value type-name @
                                        @res{} 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

@page
@node translate-to-foreign, with-foreign-slots, translate-from-foreign, Foreign Types
@heading translate-to-foreign
@subheading Syntax
@GenericFunction{translate-to-foreign lisp-value type-name @
                                      @res{} 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

@page
@node with-foreign-slots,  , translate-to-foreign, Foreign Types
@heading 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, Strings, Foreign Types, Top
@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-objects::        
* with-foreign-pointer::        
@end menu

@node Basic Pointer Operations, Allocating Foreign Memory, Pointers, Pointers
@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, Accessing Foreign Memory, Basic Pointer Operations, Pointers
@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, foreign-free, Allocating Foreign Memory, Pointers
@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

@page
@node foreign-free, foreign-alloc, Accessing Foreign Memory, Pointers
@heading foreign-free
@subheading Syntax
@Function{foreign-free ptr @res{} 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

@page
@node foreign-alloc, foreign-symbol-pointer, foreign-free, Pointers
@heading foreign-alloc
@subheading Syntax
@Function{foreign-alloc type &key initial-element initial-contents (count 1) @
                        null-terminated-p @res{} 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)

;;; @lispcmt{Allocate a char** pointer that points to newly allocated memory}
;;; @lispcmt{by the :string type translator for the string "foo".}
CFFI> (foreign-alloc :string :initial-element "foo")
@result{} #
@end lisp

@lisp
;;; @lispcmt{Allocate a null-terminated array of strings.}
;;; @lispcmt{(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

@page
@node foreign-symbol-pointer, inc-pointer, foreign-alloc, Pointers
@heading foreign-symbol-pointer
@subheading Syntax
@Function{foreign-symbol-pointer foreign-name &key library @res{} 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

@page
@node inc-pointer, incf-pointer, foreign-symbol-pointer, Pointers
@heading inc-pointer
@subheading Syntax
@Function{inc-pointer pointer offset @res{} 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

@page
@node incf-pointer, make-pointer, inc-pointer, Pointers
@heading incf-pointer
@subheading Syntax
@Macro{incf-pointer place &optional (offset 1) @res{} 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

@page
@node make-pointer, mem-aref, incf-pointer, Pointers
@heading make-pointer
@subheading Syntax
@Function{make-pointer address @res{} 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

@page
@node mem-aref, mem-ref, make-pointer, Pointers
@heading 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

@page
@node mem-ref, null-pointer, mem-aref, Pointers
@heading mem-ref
@subheading Syntax
@Accessor{mem-ref ptr type &optional offset @res{} 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

@page
@node null-pointer, null-pointer-p, mem-ref, Pointers
@heading null-pointer
@subheading Syntax
@Function{null-pointer @res{} 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

@page
@node null-pointer-p, pointerp, null-pointer, Pointers
@heading null-pointer-p
@subheading Syntax
@Function{null-pointer-p ptr @res{} 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

@page
@node pointerp, pointer-address, null-pointer-p, Pointers
@heading pointerp
@subheading Syntax
@Function{pointerp ptr @res{} 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

@page
@node pointer-address, pointer-eq, pointerp, Pointers
@heading pointer-address
@subheading Syntax
@Function{pointer-address ptr @res{} 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

@page
@node pointer-eq, with-foreign-object, pointer-address, Pointers
@heading pointer-eq
@subheading Syntax
@Function{pointer-eq ptr1 ptr2 @res{} 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

@page
@node with-foreign-object, with-foreign-pointer, pointer-eq, Pointers
@heading with-foreign-object, with-foreign-objects
@subheading Syntax
@Macro{with-foreign-object (var type &optional count) &body body}

@anchor{with-foreign-objects}
@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

@page
@node with-foreign-pointer,  , with-foreign-object, Pointers
@heading 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, Variables, Pointers, Top
@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

* *default-foreign-encoding*::  
* 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::
@end menu


@c ===================================================================
@c *DEFAULT-FOREIGN-ENCODING*

@page
@node *default-foreign-encoding*, foreign-string-alloc, Strings, Strings
@heading *default-foreign-encoding*
@subheading Syntax

@Variable{*default-foreign-encoding*}

@subheading Value type

A keyword.

@subheading Initial value

@code{:utf-8}

@subheading Description

This special variable holds the default foreign encoding.

@subheading Examples

@lisp
CFFI> *default-foreign-encoding*
:utf-8
CFFI> (foreign-funcall "strdup" (:string :encoding :utf-16) "foo" :string)
"f"
CFFI> (let ((*default-foreign-encoding* :utf-16))
        (foreign-funcall "strdup" (:string :encoding :utf-16) "foo" :string))
"foo"
@end lisp

@subheading See also

@seealso{Other Types} (@code{:string} type) @*
@seealso{foreign-string-alloc} @*
@seealso{foreign-string-to-lisp} @*
@seealso{lisp-string-to-foreign} @*
@seealso{with-foreign-string} @*
@seealso{with-foreign-pointer-as-string}


@c ===================================================================
@c FOREIGN-STRING-ALLOC

@page
@node foreign-string-alloc, foreign-string-free, *default-foreign-encoding*, Strings
@heading foreign-string-alloc
@subheading Syntax
@Function{foreign-string-alloc string &key encoding null-terminated-p @
                               start end @res{} pointer}

@subheading Arguments and Values

@table @var
@item string
A Lisp string.

@item encoding
Foreign encoding. Defaults to @code{*default-foreign-encoding*}.

@item null-terminated-p
Boolean, defaults to true.

@item start, end
Bounding index designators of @var{string}. 0 and @code{nil}, by
default.

@item pointer
A pointer to the newly allocated foreign string.
@end table

@subheading Description
The @code{foreign-string-alloc} function allocates foreign memory
holding a copy of @var{string} converted using the specified
@var{encoding}. @var{Start} specifies an offset into @var{string} and
@var{end} marks the position following the last element of the foreign
string.

This string must be freed with @code{foreign-string-free}.

If @var{null-terminated-p} is false, the string will not be
null-terminated.

@subheading Examples

@lisp
CFFI> (defparameter *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

@page
@node foreign-string-free, foreign-string-to-lisp, foreign-string-alloc, Strings
@heading 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

@page
@node foreign-string-to-lisp, lisp-string-to-foreign, foreign-string-free, Strings
@heading foreign-string-to-lisp
@subheading Syntax
@Function{foreign-string-to-lisp ptr &optional offset count max-chars @
                                 encoding @res{} string}

@subheading Arguments and Values

@table @var
@item ptr
A pointer.

@item offset
An integer greater than or equal to 0. Defauls to 0.

@item count
Either @code{nil} (the default), or an integer greater than or equal to 0.

@item max-chars
An integer greater than or equal to 0.
@code{(1- array-total-size-limit)}, by default.

@item encoding
Foreign encoding. Defaults to @code{*default-foreign-encoding*}.

@item string
A Lisp string.
@end table

@subheading Description
The @code{foreign-string-to-lisp} function converts at most
@var{count} octets from @var{ptr} into a Lisp string, using the
defined @var{encoding}.

If @var{count} is @code{nil} (the default), characters are copied
until @var{max-chars} is reached or a @code{NULL} character is found.

If @var{ptr} is a null pointer, returns @code{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

@page
@node lisp-string-to-foreign, with-foreign-string, foreign-string-to-lisp, Strings
@heading lisp-string-to-foreign
@subheading Syntax
@Function{lisp-string-to-foreign string buffer bufsize &key start @
                                 end offset encoding @res{} buffer}

@subheading Arguments and Values

@table @var
@item string
A Lisp string.

@item buffer
A foreign pointer.

@item bufsize
An integer.

@item start, end
Bounding index designators of @var{string}. 0 and @code{nil}, by
default.

@item offset
An integer greater than or equal to 0. Defauls to 0.

@item encoding
Foreign encoding. Defaults to @code{*default-foreign-encoding*}.
@end table

@subheading Description
The @code{lisp-string-to-foreign} function copies at most
@var{bufsize}-1 octets from a Lisp @var{string} using the specified
@var{encoding} into @var{buffer}+@var{offset}. The foreign string will
be null-terminated.

@var{Start} specifies an offset into @var{string} and
@var{end} marks the position following the last element of the foreign
string.

@subheading Examples

@lisp
CFFI> (with-foreign-pointer-as-string (str 255)
        (lisp-string-to-foreign "Hello, foreign world!" str 6))
@result{} "Hello"
@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

@page
@node with-foreign-string, with-foreign-pointer-as-string, lisp-string-to-foreign, Strings
@heading with-foreign-string, with-foreign-strings
@subheading Syntax
@Macro{with-foreign-string (var-or-vars string &rest args) &body body}

@anchor{with-foreign-strings}
@Macro{with-foreign-strings (bindings) &body body}

var-or-vars ::= var | (var &optional octet-size-var)
bindings ::= @{(var-or-vars string &rest args)@}*

@subheading Arguments and Values

@table @var
@item var, byte-size-var
A symbol.

@item string
A Lisp string.

@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{string}. @var{Args} is passed
to the underlying @code{foreign-string-alloc} call.

If @var{octet-size-var} is provided, it will be bound the length of
foreign string in octets including the null terminator.

@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

@page
@node with-foreign-pointer-as-string,  , with-foreign-string, Strings
@heading with-foreign-pointer-as-string
@subheading Syntax
@Macro{with-foreign-pointer-as-string (var size &optional size-var @
                                      &rest args) &body body @res{} string}

@subheading Arguments and Values

@table @var
@item var
A symbol.

@item 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} is used as the
returned value of an implicit @code{progn} around @var{body}, after
being converted to a Lisp string using the provided @var{args}.

@subheading Examples

@lisp
CFFI> (with-foreign-pointer-as-string (str 6 str-size :encoding :ascii)
        (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, Functions, Strings, Top
@chapter Variables

@menu
Dictionary

* defcvar::                     
* get-var-pointer::             
@end menu


@c ===================================================================
@c DEFCVAR

@page
@node defcvar, get-var-pointer, Variables, Variables
@heading defcvar
@subheading Syntax
@Macro{defcvar name-and-options type &optional documentation @res{} lisp-name}

@var{name-and-options} ::= name | (name &key read-only (library :default)) @*
@var{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+ :read-only t) :int)
@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
implementation of the C standard library.}

@subheading See Also
@seealso{get-var-pointer}


@c ===================================================================
@c GET-VAR-POINTER

@page
@node get-var-pointer,  , defcvar, Variables
@heading get-var-pointer
@subheading Syntax
@Function{get-var-pointer symbol @res{} 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, Libraries, Variables, Top
@chapter Functions

@menu
@c * Defining Foreign Functions::  
@c * Calling Foreign Functions::   

Dictionary

* defcfun::                     
* foreign-funcall::             
* foreign-funcall-pointer::     
@end menu

@c @node Calling Foreign Functions
@c @section Calling Foreign Functions

@c @node Defining Foreign Functions
@c @section Defining Foreign Functions


@c ===================================================================
@c DEFCFUN

@page
@node defcfun, foreign-funcall, Functions, Functions
@heading defcfun
@subheading Syntax
@Macro{defcfun name-and-options return-type &body [docstring] arguments [&rest] @
               @res{} lisp-name}

@var{name-and-options} ::= name | (name &key library convention) @*
@var{name} ::= @var{lisp-name} [@var{foreign-name}] | @var{foreign-name} [@var{lisp-name}] @*
@var{arguments} ::= @{ (arg-name arg-type) @}* @*

@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 convention
One of @code{:cdecl} (default) or @code{:stdcall}.

@item library
A symbol designating a foreign library.

@item docstring
A documentation string.
@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
  "Calculate the length of a string."
  (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

Function without arguments:

@lisp
(defcfun "rand" :int)

CFFI> (rand)
@result{} 1804289383
@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

@page
@node foreign-funcall, foreign-funcall-pointer, defcfun, Functions
@heading foreign-funcall
@subheading Syntax
@Macro{foreign-funcall name-and-options &rest arguments @res{} return-value}

arguments ::= @{ arg-type arg @}* [return-type]
name-and-options ::= name | ( name &key library convention)

@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 convention
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-sys::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

@page
@node foreign-funcall-pointer,  , foreign-funcall, Functions
@heading foreign-funcall-pointer
@subheading Syntax
@Macro{foreign-funcall-pointer pointer options &rest arguments @res{} return-value}

arguments ::= @{ arg-type arg @}* [return-type]
options ::= ( &key convention )

@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 convention
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-sys::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, Callbacks, Functions, Top
@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, Library definition style, Libraries, Libraries
@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, close-foreign-library, Defining a library, Libraries
@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

@page
@node close-foreign-library, *darwin-framework-directories*, Library definition style, Libraries
@heading close-foreign-library
@subheading Syntax
@Function{close-foreign-library library @res{} 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*

@page
@node *darwin-framework-directories*, define-foreign-library, close-foreign-library, Libraries
@heading *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

@page
@node define-foreign-library, *foreign-library-directories*, *darwin-framework-directories*, Libraries
@heading define-foreign-library

@subheading Syntax

@Macro{define-foreign-library name-and-options @{ load-clause @}* @res{} name}

name-and-options ::= name | (name &key convention)
load-clause ::= (feature library &key convention)

@subheading Arguments and Values

@table @var
@item name
A symbol.

@item feature
A feature expression.

@item library
A library designator.

@item convention
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:

@enumerate 1
@item
If @var{feature} is a symbol 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*

@page
@node *foreign-library-directories*, load-foreign-library, define-foreign-library, Libraries
@heading *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

@page
@node load-foreign-library, load-foreign-library-error, *foreign-library-directories*, Libraries
@heading load-foreign-library
@subheading Syntax
@Function{load-foreign-library library @res{} 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

@page
@node load-foreign-library-error, use-foreign-library, load-foreign-library, Libraries
@heading 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

@page
@node use-foreign-library,  , load-foreign-library-error, Libraries
@heading 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, The Groveller, Libraries, Top
@chapter Callbacks

@menu
Dictionary

* callback::                    
* defcallback::                 
* get-callback::                
@end menu


@c ===================================================================
@c CALLBACK

@page
@node callback, defcallback, Callbacks, Callbacks
@heading callback
@subheading Syntax
@Macro{callback symbol @res{} 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

@page
@node defcallback, get-callback, callback, Callbacks
@heading defcallback
@subheading Syntax
@Macro{defcallback name-and-options return-type arguments &body body @res{} name}

name-and-options ::= name | (name &key convention)
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 convention
One of @code{:cdecl} (default) or @code{:stdcall}.
@end table

@subheading Description
The @code{defcallback} macro defines a Lisp function that can be called
from C. 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

@page
@node get-callback,  , defcallback, Callbacks
@heading get-callback
@subheading Syntax
@Accessor{get-callback symbol @res{} 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: The Groveller

@node The Groveller, Limitations, Callbacks, Top
@chapter The Groveller

@c Manual and software copyright @copyright{} 2005, 2006 Matthew Backes
@c  and Dan Knapp .

@cffi{}-Grovel is a tool which makes it easier to write @cffi{}
declarations for libraries that are implemented in C.  That is, it
grovels through the system headers, getting information about types
and structures, so you don't have to.  This is especially important
for libraries which are implemented in different ways by different
vendors, such as the @sc{unix}/@sc{posix} functions.  The @cffi{}
declarations are usually quite different from platform to platform,
but the information you give to @cffi{}-Grovel is the same.  Hence,
much less work is required!

If you use @acronym{ASDF}, @cffi{}-Grovel is integrated, so that it
will run automatically when your system is building.  This feature was
inspired by SB-Grovel, a similar @acronym{SBCL}-specific project.
@cffi{}-Grovel can also be used without @acronym{ASDF}.

@section Building FFIs with CFFI-Grovel

@cffi{}-Grovel uses a specification file (*.lisp) describing the
features that need groveling.  The C compiler is used to retrieve this
data and write a Lisp file (*.cffi.lisp) which contains the necessary
@cffi{} definitions to access the variables, structures, constants, and
enums mentioned in the specification.

@c This is most similar to the SB-Grovel package, upon which it is
@c based.  Unlike SB-Grovel, we do not currently support defining
@c regular foreign functions in the specification file; those are best
@c defined in normal Lisp code.

@cffi{}-Grovel provides an @acronym{ASDF} component for handling the
necessary calls to the C compiler and resulting file management.

@c See the included CFFI-Unix package for an example of how to
@c integrate a specification file with ASDF-built packages.

@menu
* Groveller Syntax::            How grovel files should look like.
* Groveller ASDF Integration::  ASDF components for grovel files.
* Groveller Implementation Notes:: Implementation notes.
@end menu

@node Groveller Syntax, Groveller ASDF Integration, The Groveller, The Groveller
@section Specification File Syntax

The specification files are read by the normal Lisp reader, so they
have syntax very similar to normal Lisp code.  In particular,
semicolon-comments and reader-macros will work as expected.

There are several forms recognized by @cffi{}-Grovel:

@deffn {Grovel Form} progn &rest forms

Processes a list of forms. Useful for conditionalizing several
forms. For example:
@end deffn

@lisp
#+freebsd
(progn
  (constant (ev-enable "EV_ENABLE"))
  (constant (ev-disable "EV_DISABLE")))
@end lisp

@deffn {Grovel Form} include &rest files

Include the specified files (specified as strings) in the generated C
source code.
@end deffn

@deffn {Grovel Form} in-package symbol

Set the package to be used for the final Lisp output.
@end deffn

@deffn {Grovel Form} ctype lisp-name size-designator

Define a @cffi{} foreign type for the string in @var{size-designator},
e.g. @code{(ctype :pid "pid_t")}.
@end deffn

@deffn {Grovel Form} constant (lisp-name &rest c-names) &key type documentation optional

Search for the constant named by the first @var{c-name} string found
to be known to the C preprocessor and define it as @var{lisp-name}.

The @var{type} keyword argument specifies how to grovel the constant:
either @code{integer} (the default) or @code{double-float}. If
@var{optional} is true, no error will be raised if all the
@var{c-names} are unknown. If @var{lisp-name} is a keyword, the actual
constant will be a symbol of the same name interned in the current
package.
@end deffn

@deffn {Grovel Form} define name &optional value

Defines an additional C preprocessor symbol, which is useful for
altering the behavior of included system headers.
@end deffn

@deffn {Grovel Form} cc-flags &rest flags

Adds @var{cc-flags} to the command line arguments used for the C compiler
invocation.
@end deffn

@deffn {Grovel Form} cstruct lisp-name c-name slots

Define a @cffi{} foreign struct with the slot data specfied.  Slots
are of the form @code{(lisp-name c-name &key type count (signed t))}.
@end deffn

@deffn {Grovel Form} cunion lisp-name c-name slots

Identical to @code{cstruct}, but defines a @cffi{} foreign union.
@end deffn

@deffn {Grovel Form} cstruct-and-class c-name slots

Defines a @cffi{} foreign struct, as with @code{cstruct} and defines a
@acronym{CLOS} class to be used with it.  This is useful for mapping
foreign structures to application-layer code that shouldn't need to
worry about memory allocation issues.
@end deffn

@deffn {Grovel Form} cvar namespec type &key read-only

Defines a foreign variable of the specified type, even if that
variable is potentially a C preprocessor pseudo-variable.  e.g.
@code{(cvar ("errno" errno) errno-values)}, assuming that errno-values
is an enum or equivalent to type @code{:int}.

The @var{namespec} is similar to the one used in @ref{defcvar}.
@end deffn

@deffn {Grovel Form} cenum name-and-opts &rest elements

Defines a true C enum, with elements specified as @code{((lisp-name
&rest c-names) &key optional documentation)}.
@var{name-and-opts} can be either a symbol as name, or a list
@code{(name &key base-type define-constants)}. If @var{define-constants}
is non-null, a Lisp constant will be defined for each enum member.
@end deffn

@deffn {Grovel Form} constantenum name-and-opts &rest elements

Defines an enumeration of pre-processor constants, with elements
specified as @code{((lisp-name &rest c-names) &key optional
documentation)}.
@var{name-and-opts} can be either a symbol as name, or a list
@code{(name &key base-type define-constants)}. If @var{define-constants}
is non-null, a Lisp constant will be defined for each enum member.

This example defines @code{:af-inet} to represent the value held by
@code{AF_INET} or @code{PF_INET}, whichever the pre-processor finds
first.  Similarly for @code{:af-packet}, but no error will be
signalled if the platform supports neither @code{AF_PACKET} nor
@code{PF_PACKET}.
@end deffn

@lisp
(constantenum address-family
  ((:af-inet "AF_INET" "PF_INET")
   :documentation "IPv4 Protocol family")
  ((:af-local "AF_UNIX" "AF_LOCAL" "PF_UNIX" "PF_LOCAL")
   :documentation "File domain sockets")
  ((:af-inet6 "AF_INET6" "PF_INET6")
   :documentation "IPv6 Protocol family")
  ((:af-packet "AF_PACKET" "PF_PACKET")
   :documentation "Raw packet access"
   :optional t))
@end lisp


@c ===================================================================
@c SECTION: Groveller ASDF Integration

@node Groveller ASDF Integration, Groveller Implementation Notes, Groveller Syntax, The Groveller
@section ASDF Integration

An example software project might contain four files; an
@acronym{ASDF} file, a package definition file, an implementation
file, and a @cffi{}-Grovel specification file.

The @acronym{ASDF} file defines the system and its dependencies.
Notice the use of @code{eval-when} to ensure @cffi{}-Grovel is present
and the use of @code{(cffi-grovel:grovel-file name &key cc-flags)}
instead of @code{(:file name)}.

@lisp
;;; @lispcmt{CFFI-Grovel is needed for processing grovel-file components}
(cl:eval-when (:load-toplevel :execute)
  (asdf:operate 'asdf:load-op 'cffi-grovel))

(asdf:defsystem example-software
  :depends-on (cffi)
  :serial t
  :components
  ((:file "package")
   (cffi-grovel:grovel-file "example-grovelling")
   (:file "example")))
@end lisp

The ``package.lisp'' file would contain several @code{defpackage}
forms, to remove circular dependencies and make building the project
easier.  Note that you may or may not want to @code{:use} your
internal package.

@impnote{Mention that it's a not a good idea to :USE when names may
clash with, say, CL symbols.}

@lisp
(defpackage #:example-internal
  (:use)
  (:nicknames #:exampleint))

(defpackage #:example-software
  (:export ...)
  (:use #:cl #:cffi #:exampleint))
@end lisp

The internal package is created by Lisp code output from the C program
written by @cffi{}-Grovel; if your specification file is
exampleint.lisp, the exampleint.cffi.lisp file will contain the
@cffi{} definitions needed by the rest of your project.
@xref{Groveller Syntax}.

@node Groveller Implementation Notes,  , Groveller ASDF Integration, The Groveller
@section Implementation Notes

@impnote{This info might not be up-to-date.}

For @code{foo-internal.lisp}, the resulting @code{foo-internal.c},
@code{foo-internal}, and @code{foo-internal.cffi.lisp} are all
platform-specific, either because of possible reader-macros in
foo-internal.lisp, or because of varying C environments on the host
system.  For this reason, it is not helpful to distribute any of those
files; end users building @cffi{}-Grovel based software will need
@code{cffi}-Grovel anyway.

If you build with multiple architectures in the same directory
(e.g. with NFS/AFS home directories), it is critical to remove these
generated files or the resulting constants will be very incorrect.

@impnote{Maybe we should tag the generated names with something host
or OS-specific?}

@impnote{For now, after some experimentation with @sc{clisp} having no
long-long, it seems appropriate to assert that the generated @code{.c}
files are architecture and operating-system dependent, but
lisp-implementation independent.  This way the same @code{.c} file
(and so the same @code{.grovel-tmp.lisp} file) will be shareable
between the implementations running on a given system.}

@c TODO: document the new wrapper stuff.


@c ===================================================================
@c CHAPTER: Limitations

@node Limitations, Platform-specific features, The Groveller, Top
@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


@node Platform-specific features, Glossary, Limitations, Top
@appendix Platform-specific features

Whenever a backend doesn't support one of @cffi{}'s features, a
specific symbol is pushed onto @code{common-lisp:*features*}.  The
meanings of these symbols follow.

@table @var
@item cffi-sys::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 cffi-sys::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 cffi-sys::no-long-long
The C @code{long long} type is @strong{not} available as a foreign
type.

However, on such platforms @cffi{} provides its own implementation of
the @code{long long} type for all of operations in chapters
@ref{Foreign Types}, @ref{Pointers} and @ref{Variables}. The
functionality described in @ref{Functions} and @ref{Callbacks} will
not be available.

32-bit Lispworks 5.0+ is an exception. In addition to the @cffi{}
implementation described above, Lispworks itself implements the
@code{long long} type for @ref{Functions}. @ref{Callbacks} are still
missing @code{long long} support, though.

@item cffi-sys::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.

@end table


@node Glossary, Comprehensive Index, Platform-specific features, Top
@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,  , Glossary, Top
@unnumbered Index
@printindex cp

@bye
cffi-20100219.orig/COPYRIGHT0000644000175000017500000000207711345222703015352 0ustar  pvaneyndpvaneyndCopyright (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.
cffi-20100219.orig/cffi-tests.asd0000644000175000017500000000557111345222703016621 0ustar  pvaneyndpvaneynd;;;; -*- 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)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (oos 'load-op 'trivial-features))

(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))
  #-windows
  (unless (zerop (run-shell-command
                  "cd ~A; make"
                  (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 "strings")
     (:file "struct")
     (:file "union")
     (:file "enum")
     (:file "misc-types")
     (:file "misc")))))

(defmethod operation-done-p ((o test-op) (c (eql (find-system :cffi-tests))))
  nil)

(defmethod perform ((o test-op) (c (eql (find-system :cffi-tests))))
  (flet ((run-tests (&rest args)
           (apply (intern (string '#:run-cffi-tests) '#:cffi-tests) args)))
    (run-tests :compiled nil)
    (run-tests :compiled t)))

;;; vim: ft=lisp et
cffi-20100219.orig/uffi-compat/0002755000175000017500000000000011345222703016265 5ustar  pvaneyndpvaneyndcffi-20100219.orig/uffi-compat/uffi.asd0000644000175000017500000000012211345222703017700 0ustar  pvaneyndpvaneynd;;;; uffi.asd -*- Mode: Lisp -*-

(defsystem uffi :depends-on (cffi-uffi-compat))
cffi-20100219.orig/uffi-compat/uffi-compat.lisp0000644000175000017500000005150711345222703021376 0ustar  pvaneyndpvaneynd;;;; -*- 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)) (body-proc (gensym)))
    `(flet ((,body-proc (,foreign-string) ,@body))
       (let ((,str ,lisp-string))
         (if (null ,str)
             (,body-proc (cffi:null-pointer))
             (cffi:with-foreign-string (,foreign-string ,str)
               (,body-proc ,foreign-string)))))))

;; 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))
  #+(or mcl ccl) (ccl::getenv var)
  #+sbcl (sb-ext:posix-getenv var)
  #-(or allegro clisp cmu scl gcl lispworks lucid mcl ccl 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 (locale :default)
                                       (null-terminated-p t))
  ;; in effect, (eq NULL-TERMINATED-P (null LENGTH)). Hopefully,
  ;; that's compatible with the intended semantics, which are
  ;; undocumented.  If that's not the case, we can implement
  ;; NULL-TERMINATED-P in CFFI:FOREIGN-STRING-TO-LISP.
  (declare (ignore locale null-terminated-p))
  (let ((ret (gensym)))
    `(let ((,ret (cffi:foreign-string-to-lisp ,obj :count ,length)))
       (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)))))
cffi-20100219.orig/tests/0002755000175000017500000000000011345222703015215 5ustar  pvaneyndpvaneyndcffi-20100219.orig/tests/funcall.lisp0000644000175000017500000001624111345222703017534 0ustar  pvaneyndpvaneynd;;;; -*- 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-sys::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-sys::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-sys::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 x86 windows (not cffi-sys::no-stdcall))
(deftest funcall.stdcall.1
    (flet ((fun ()
             (foreign-funcall ("stdcall_fun@12" :convention :stdcall)
                              :int 1 :int 2 :int 3 :int)))
      (loop repeat 100 do (fun)
            finally (return (fun))))
  6)

;;; RT: NIL arguments are skipped

(defvar *nil-skipped*)

(define-foreign-type check-nil-skip-type ()
  ()
  (:actual-type :pointer)
  (:simple-parser check-nil-skip-type))

(defmethod expand-to-foreign (val (type check-nil-skip-type))
  (setf *nil-skipped* nil)
  (null-pointer))

(deftest funcall.nil-skip
    (let ((*nil-skipped* t))
      (compile nil '(lambda ()
                     (foreign-funcall "abs" check-nil-skip-type nil)))
      *nil-skipped*)
  nil)

;;; RT: CLISP returns NIL instead of a null-pointer

(deftest funcall.pointer-not-nil
    (not (null (foreign-funcall "strchr" :string "" :int 1 :pointer)))
  t)

) ;; #-cffi-sys::no-foreign-funcall
cffi-20100219.orig/tests/libtest2.c0000644000175000017500000000277211345222703017117 0ustar  pvaneyndpvaneynd/* -*- 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
*/
cffi-20100219.orig/tests/compile.bat0000644000175000017500000000032011345222703017326 0ustar  pvaneyndpvaneyndrem
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
cffi-20100219.orig/tests/callbacks.lisp0000644000175000017500000004750711345222703020040 0ustar  pvaneyndpvaneynd;;;; -*- 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-sys::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-sys::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-sys::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-sys::no-foreign-funcall
(defcallback return-a-string-not-nil :string ()
  "abc")

#-cffi-sys::no-foreign-funcall
(deftest callbacks.string-not-docstring
    (foreign-funcall-pointer (callback return-a-string-not-nil) () :string)
  "abc")

(defcallback check-for-nil :boolean ((pointer :pointer))
  (null pointer))

#-cffi-sys::no-foreign-funcall
(deftest callbacks.nil-for-null
    (foreign-funcall-pointer (callback check-for-nil) nil
                             :pointer (null-pointer) :boolean)
  nil)

;;; 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 darwin cmu)
(defcallback read-int-from-pointer :void ((a :pointer))
  (setq *int* (mem-ref a :int)))

#+(and 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-sys::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, ECL and CCL choke on this one.
#-(or ecl cmu clozure
      #.(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 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-sys::no-long-long
      #.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(or) '(and)))
(progn
  (defcfun "call_sum_127" :long-long (cb :pointer))

  ;;; CMUCL, ECL and CCL choke on this one.
  #-(or cmu ecl clozure)
  (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 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 darwin (or allegro cmu))
(pushnew 'callbacks.double26 rt::*expected-failures*)

(deftest callbacks.double26
    (call-double26 (callback double26))
  81.64d0)

#+(and darwin cmu)
(pushnew 'callbacks.double26.funcall rt::*expected-failures*)

#-cffi-sys::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 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 darwin (or lispworks openmcl cmu))
(pushnew 'callbacks.float26 regression-test::*expected-failures*)

(deftest callbacks.float26
    (call-float26 (callback float26))
  130.0)

#+(and darwin (or lispworks openmcl cmu))
(pushnew 'callbacks.float26.funcall regression-test::*expected-failures*)

#-cffi-sys::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 x86 (not cffi-sys::no-stdcall))
(progn
  (defcallback (stdcall-cb :convention :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))

;;; RT: many of the %DEFCALLBACK implementations wouldn't handle
;;;     uninterned symbols.
(deftest callbacks.uninterned
    (values (defcallback #1=#:foo :void ())
            (pointerp (callback #1#)))
  #1# t)
cffi-20100219.orig/tests/strings.lisp0000644000175000017500000001372111345222703017601 0ustar  pvaneyndpvaneynd;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; strings.lisp --- Tests for foreign string conversion.
;;;
;;; Copyright (C) 2005, James Bielman  
;;; 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.
;;;

(in-package #:cffi-tests)

;;;# Foreign String Conversion Tests
;;;
;;; With the implementation of encoding support, there are a lot of
;;; things that can go wrong with foreign string conversions.  This is
;;; a start at defining tests for strings and encoding conversion, but
;;; there needs to be a lot more.

(babel:enable-sharp-backslash-syntax)

;;; *ASCII-TEST-STRING* contains the characters in the ASCII character
;;; set that we will convert to a foreign string and check against
;;; *ASCII-TEST-BYTES*.  We don't bother with control characters.
;;;
;;; FIXME: It would probably be good to move these tables into files
;;; in "tests/", especially if we ever want to get fancier and have
;;; tests for more encodings.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *ascii-test-string*
    (concatenate 'string " !\"#$%&'()*+,-./0123456789:;"
                 "<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]"
                 "^_`abcdefghijklmnopqrstuvwxyz{|}~")))

;;; *ASCII-TEST-BYTES* contains the expected ASCII encoded values
;;; for each character in *ASCII-TEST-STRING*.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *ascii-test-bytes*
    (let ((vector (make-array 95 :element-type '(unsigned-byte 8))))
      (loop for i from 0
            for code from 32 below 127
            do (setf (aref vector i) code)
            finally (return vector)))))

;;; Test basic consistency converting a string to and from Lisp using
;;; the default encoding.
(deftest string.conversion.basic
    (with-foreign-string (s *ascii-test-string*)
      (foreign-string-to-lisp s))
  #.*ascii-test-string* 95)

(deftest string.conversion.basic.2
    (with-foreign-string ((ptr size) "123" :null-terminated-p nil)
      (values (foreign-string-to-lisp ptr :count 3) size))
  "123" 3)

;;; Ensure that conversion of *ASCII-TEST-STRING* to a foreign buffer
;;; and back preserves ASCII encoding.
(deftest string.encoding.ascii
    (with-foreign-string (s *ascii-test-string* :encoding :ascii)
      (let ((vector (make-array 95 :element-type '(unsigned-byte 8))))
        (loop for i from 0 below (length vector)
              do (setf (aref vector i) (mem-ref s :unsigned-char i)))
        vector))
  #.*ascii-test-bytes*)

;;; FIXME: bogus test. We need support for BOM or UTF-16{BE,LE}.
(pushnew 'string.encoding.utf-16.basic rtest::*expected-failures*)

;;; Test UTF-16 conversion of a string back and forth.  Tests proper
;;; null terminator handling for wide character strings and ensures no
;;; byte order marks are added.  (Why no BOM? --luis)
#-babel::8-bit-chars
(deftest string.encoding.utf-16.basic
    (with-foreign-string (s *ascii-test-string* :encoding :utf-16)
      (foreign-string-to-lisp s :encoding :utf-16))
  #-ecl ; ECL (CVS 2008-06-19 17:09) chokes here, no idea why.
  #.*ascii-test-string* 190)

;;; Ensure that writing a long string into a short buffer does not
;;; attempt to write beyond the edge of the buffer, and that the
;;; resulting string is still null terminated.
(deftest string.short-write.1
    (with-foreign-pointer (buf 6)
      (setf (mem-ref buf :unsigned-char 5) 70)
      (lisp-string-to-foreign "ABCDE" buf 5 :encoding :ascii)
      (values (mem-ref buf :unsigned-char 4)
              (mem-ref buf :unsigned-char 5)))
  0 70)

#-babel::8-bit-chars
(deftest string.encoding.utf-8.basic
    (with-foreign-pointer (buf 7 size)
      (let ((string (concatenate 'babel:unicode-string
                                 '(#\u03bb #\u00e3 #\u03bb))))
        (lisp-string-to-foreign string buf size :encoding :utf-8)
        (loop for i from 0 below size
              collect (mem-ref buf :unsigned-char i))))
  (206 187 195 163 206 187 0))

(defparameter *basic-latin-alphabet* "abcdefghijklmnopqrstuvwxyz")

(defparameter *non-latin-compatible-encodings*
  '())

(defun list-latin-compatible-encodings ()
  (remove-if (lambda (x) (member x *non-latin-compatible-encodings*))
             (babel:list-character-encodings)))

;;; FIXME: bogus wrt UTF-16. See STRING.ENCODING.UTF-16.BASIC.
(pushnew 'string.encodings.all.basic rtest::*expected-failures*)

(deftest string.encodings.all.basic
    (let (failed)
      (dolist (encoding (list-latin-compatible-encodings) failed)
        ;; (format t "Testing ~S~%" encoding)
        (with-foreign-string (ptr *basic-latin-alphabet* :encoding encoding)
          (let ((string (foreign-string-to-lisp ptr :encoding encoding)))
            ;; (format t "  got ~S~%" string)
            (unless (string= *basic-latin-alphabet* string)
              (push encoding failed))))))
  nil)

;;; rt: make sure *default-foreign-enconding* binds to a keyword
(deftest string.encodings.default
    (keywordp *default-foreign-encoding*)
  t)
cffi-20100219.orig/tests/GNUmakefile0000644000175000017500000000467511345222703017301 0ustar  pvaneyndpvaneynd# -*- 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)
ARCH   = $(shell uname -m)

CC             := gcc
CFLAGS         := -Wall -std=c99 -pedantic
SHLIB_CFLAGS   := -shared
SHLIB_EXT      := .so

ifneq ($(if $(filter Linux %BSD,$(OSTYPE)),OK), OK)
ifeq ($(OSTYPE), Darwin)
SHLIB_CFLAGS   := -bundle
ifeq ($(shell sysctl -n hw.optional.x86_64), 1)
ARCH           := x86_64
endif
else
ifeq ($(OSTYPE), SunOS)
CFLAGS         := -c -Wall -std=c99 -pedantic
else
# Let's assume this is win32
SHLIB_EXT      := .dll
endif
endif
endif

ifneq ($(ARCH), x86_64)
CFLAGS += -lm
endif

ifeq ($(ARCH), x86_64)
CFLAGS_64 += -fPIC
endif

# Are all G5s ppc970s?
ifeq ($(ARCH), ppc970)
CFLAGS_64 += -m64
endif

SHLIBS = libtest$(SHLIB_EXT) libtest2$(SHLIB_EXT)

ifeq ($(ARCH), x86_64)
SHLIBS += libtest32$(SHLIB_EXT) libtest2_32$(SHLIB_EXT)
endif

shlibs: $(SHLIBS)

libtest$(SHLIB_EXT): libtest.c
	$(CC) -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $(CFLAGS_64) $<

libtest2$(SHLIB_EXT): libtest2.c
	$(CC) -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $(CFLAGS_64) $<

ifeq ($(ARCH), x86_64)
libtest32$(SHLIB_EXT): libtest.c
	$(CC) -m32 -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $<

libtest2_32$(SHLIB_EXT): libtest2.c
	$(CC) -m32 -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $<
endif

clean:
	rm -f *.so *.dylib *.dll *.bundle

# vim: ft=make ts=3 noet
cffi-20100219.orig/tests/Makefile0000644000175000017500000000003011345222703016644 0ustar  pvaneyndpvaneyndshlibs clean:
	gmake $@
cffi-20100219.orig/tests/misc-types.lisp0000644000175000017500000001563011345222703020206 0ustar  pvaneyndpvaneynd;;;; -*- 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")

#-(and)
(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")

#-(and)
(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")

#-(and)
(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 :int64 :uint64))
  (1 1 2 2 4 4 8 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-sys::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)
cffi-20100219.orig/tests/random-tester.lisp0000644000175000017500000002401111345222703020666 0ustar  pvaneyndpvaneynd;;;; -*- 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 #:alexandria #: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 (symbolicate '#:a (format nil "~A" i))
                       (type-keyword type))))
       (deftest ,(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
                          (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 ,(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)
cffi-20100219.orig/tests/bindings.lisp0000644000175000017500000000671711345222703017714 0ustar  pvaneyndpvaneynd;;;; -*- 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 :type :test)
  (:unix (:or "libtest.so" "libtest32.so"))
  (:windows "libtest.dll")
  (t (:default "libtest")))

(define-foreign-library (libtest2 :type :test)
  (:unix (:or "libtest2.so" "libtest2_32.so"))
  (:darwin "libtest2.so")
  (t (:default "libtest2")))

(define-foreign-library libc
  (:windows "msvcrt.dll"))

(define-foreign-library libm
  #+(and lispworks darwin) ; not sure why the full path is necessary
  (:darwin "/usr/lib/libm.dylib")
  (t (:default "libm")))

;;; 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)
    #+(or abcl lispworks) (load-foreign-library 'libm)))

#-(: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)

(defun run-cffi-tests (&key (compiled nil))
  (let ((regression-test::*compile-tests* compiled)
        (*package* (find-package '#:cffi-tests)))
    (format t "~&;;; running tests (~Acompiled)" (if compiled "" "un"))
    (do-tests)))
cffi-20100219.orig/tests/defcfun.lisp0000644000175000017500000003603411345222703017524 0ustar  pvaneyndpvaneynd;;;; -*- 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)

#+(or allegro openmcl ecl) (pushnew 'defcfun.noop rt::*expected-failures*)

(deftest defcfun.noop
    (noop)
  #|no values|#)

;;;# Calling varargs functions

(defcfun "sprintf" :int
  "sprintf docstring"
  (str (:pointer :char))
  (control :string)
  &rest)

;;; CLISP and ABCL discard macro docstrings.
#+(or clisp abcl)
(pushnew 'defcfun.varargs.docstrings rt::*expected-failures*)

(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-sys::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-sys::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 x86 windows (not cffi-sys::no-stdcall))
(progn
  (defcfun ("stdcall_fun@12" stdcall-fun :convention :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))
cffi-20100219.orig/tests/union.lisp0000644000175000017500000000363311345222703017241 0ustar  pvaneyndpvaneynd;;;; -*- 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)
cffi-20100219.orig/tests/misc.lisp0000644000175000017500000000764411345222703017052 0ustar  pvaneyndpvaneynd;;;; -*- 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)

;;;# 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-sys::flat-namespace
      cffi-sys::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)

(define-foreign-library pseudo-library
  (t pseudo-library-spec))

;;; RT: T clause was being handled as :T by FEATUREP.
;;;
;;; We might want to export (and clean up) the API used in this test
;;; when the need arises.
(deftest library.t-clause
    (eq (cffi::foreign-library-spec
         (cffi::get-foreign-library 'pseudo-library))
        'pseudo-library-spec)
  t)

;;;# Shareable Byte Vector Tests

#+ecl
(mapc (lambda (x) (pushnew x rt::*expected-failures*))
      '(shareable-vector.1 shareable-vector.2))

(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))
cffi-20100219.orig/tests/struct.lisp0000644000175000017500000002506411345222703017437 0ustar  pvaneyndpvaneynd;;;; -*- 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))

(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

(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))

;;;# C Struct Wrappers

(define-c-struct-wrapper timeval ())

(define-c-struct-wrapper (timeval2 timeval) ()
  (tv-secs))

(defmacro with-example-timeval (var &body body)
  `(with-foreign-object (,var 'timeval)
     (with-foreign-slots ((tv-secs tv-usecs) ,var timeval)
       (setf tv-secs 42 tv-usecs 1984)
       ,@body)))

(deftest struct-wrapper.1
    (with-example-timeval ptr
      (let ((obj (make-instance 'timeval :pointer ptr)))
        (values (timeval-tv-secs obj)
                (timeval-tv-usecs obj))))
  42 1984)

(deftest struct-wrapper.2
    (with-example-timeval ptr
      (let ((obj (make-instance 'timeval2 :pointer ptr)))
        (timeval2-tv-secs obj)))
  42)
cffi-20100219.orig/tests/package.lisp0000644000175000017500000000257311345222703017506 0ustar  pvaneyndpvaneynd;;;; -*- 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))
cffi-20100219.orig/tests/foreign-globals.lisp0000644000175000017500000002135511345222703021164 0ustar  pvaneyndpvaneynd;;;; -*- 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)
(defcvar "var_long_long"          :long-long)
(defcvar "var_unsigned_long_long" :unsigned-long-long)

;;; The expected failures marked below result from this odd behaviour:
;;;
;;;   (foreign-symbol-pointer "var_char") => NIL
;;;
;;;   (foreign-symbol-pointer "var_char" :library 'libtest)
;;;     => #
;;;
;;; Why is this  happening? --luis
#+lispworks
(mapc (lambda (x) (pushnew x rtest::*expected-failures*))
      '(foreign-globals.ref.char foreign-globals.get-var-pointer.1
        foreign-globals.get-var-pointer.2 foreign-globals.symbol-name
        foreign-globals.read-only.1 ))

(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!")

#+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")

(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-sys::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
  "docstring")

(deftest foreign-globals.read-only.1
    (values *var-char-ro*
            (ignore-errors (setf *var-char-ro* 12)))
  -127 nil)

(deftest defcvar.docstring
    (documentation '*var-char-ro* 'variable)
  "docstring")cffi-20100219.orig/tests/memory.lisp0000644000175000017500000004123411345222703017420 0ustar  pvaneyndpvaneynd;;;; -*- 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)

#+(and 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-sys::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)

(deftest pointer.null
    (nth-value 0 (ignore-errors (null-pointer-p nil)))
  nil)

(deftest foreign-pointer-type.nil
    (typep nil 'foreign-pointer)
  nil)

;;; 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)

;;; RT: FOREIGN-ALLOC with :COUNT 0 on CLISP signalled an error.
(deftest foreign-alloc.6
    (foreign-free (foreign-alloc :char :count 0))
  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)

#+(and 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)
cffi-20100219.orig/tests/run-tests.lisp0000644000175000017500000000327311345222703020055 0ustar  pvaneyndpvaneynd;;;; -*- 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)
cffi-20100219.orig/tests/libtest.c0000644000175000017500000007153611345222703017041 0ustar  pvaneyndpvaneynd/* -*- 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 
#endif

#ifdef WIN32
#ifdef _MSC_VER
#define STDCALL __stdcall
#else
#define STDCALL __attribute__((stdcall))
#endif
#else
#define 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 +
        ((intptr_t) a16) + a17 + a18 + a19 + ((long) a20) +
        ((intptr_t) a21) + ((long) a22) + a23 + a24 + a25 + a26 + a27 +
        ((long) a28) + a29 + a30 + a31 + a32 + a33 + a34 + ((intptr_t) a35) +
        ((long) a36) + ((long) a37) + a38 + a39 + a40 + a41 + a42 + a43 + a44 +
        ((intptr_t) a45) + a46 + a47 + ((long) a48) + a49 + a50 +
        ((long) a51) + a52 + a53 + ((long) a54) + a55 + a56 + a57 + ((long) a58) +
        ((long) a59) + ((long) a60) + ((intptr_t) a61) +
        ((intptr_t) a62) + a63 + a64 + a65 + a66 + a67 + a68 +
        ((intptr_t) 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) + ((intptr_t) 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) ((intptr_t) a1) + ((intptr_t) a2) + ((long) a3) +
        a4 + ((intptr_t) a5) + a6 + ((long) a7) + ((long) a8) + a9 + a10 +
        a11 + a12 + a13 + a14 + a15 + a16 + a17 + ((long) a18) + a19 + a20 +
        a21 + a22 + a23 + a24 + ((intptr_t) a25) + a26 + a27 + a28 + a29 +
        a30 + ((intptr_t) a31) + a32 + a33 + a34 + ((intptr_t) a35) +
        a36 + ((long) a37) + a38 + a39 + ((intptr_t) a40) + a41 + a42 + a43 +
        a44 + a45 + a46 + a47 + ((long) a48) + a49 + a50 + a51 + a52 +
        ((intptr_t) a53) + a54 + a55 + a56 + a57 + a58 + ((long) a59) +
        ((intptr_t) a60) + ((long) a61) + a62 + a63 + ((long) a64) + a65 + a66
        + ((intptr_t) a67) + ((long) a68) + a69 + ((long) a70) + ((long) a71) +
        a72 + ((intptr_t) a73) + a74 + a75 + ((intptr_t) a76) + a77 +
        ((long) a78) + a79 + a80 + ((intptr_t) a81) + a82 + a83 + ((long) a84)
        + ((intptr_t) a85) + a86 + ((long) a87) + a88 + ((long) a89) + a90 +
        a91 + a92 + a93 + ((long) a94) + a95 + a96 + a97 + a98 + a99 +
        ((long) a100) + ((long) a101) + a102 + a103 + ((intptr_t) 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
*/
cffi-20100219.orig/tests/enum.lisp0000644000175000017500000000573111345222703017056 0ustar  pvaneyndpvaneynd;;;; -*- 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)
cffi-20100219.orig/TODO0000644000175000017500000000756511345222703014556 0ustar  pvaneyndpvaneynd-*- 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.
-> Implement the proposed interfaces (see doc/).
-> 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)
-> 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.

### 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.
-> 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

### CFFI-Grovel

-> Look into making the C output more concise.

### Other

-> Type-checking pointer interface.
cffi-20100219.orig/src/0002755000175000017500000000000011345222703014642 5ustar  pvaneyndpvaneyndcffi-20100219.orig/src/early-types.lisp0000644000175000017500000004577111345222703020025 0ustar  pvaneyndpvaneynd;;;; -*- 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))))
    (when (typep ptype 'foreign-typedef)
      (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))

;;; Similar to TRANSLATE-TO-FOREIGN, used exclusively by
;;; (SETF FOREIGN-STRUCT-SLOT-VALUE).
(defgeneric translate-aggregate-to-foreign (ptr value type))

;;; 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.
;;;
;;; FIXME: I don't think this PARAM argument is necessary anymore
;;; because the TYPE object can contain that information. [2008-12-31 LO]
(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))))
cffi-20100219.orig/src/cffi-allegro.lisp0000644000175000017500000003700711345222703020072 0ustar  pvaneyndpvaneynd;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-allegro.lisp --- CFFI-SYS implementation for Allegro CL.
;;;
;;; Copyright (C) 2005-2009, 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)
  (:import-from #:alexandria #:if-let #:with-unique-names #:once-only)
  (: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)

;;;# Mis-features

#-64bit (pushnew 'no-long-long *features*)
(pushnew 'flat-namespace *features*)

;;;# 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)
  (when (and (constantp size) (<= (eval size) ff:*max-stack-fobject-bytes*))
    (return-from with-foreign-pointer
      `(let ((,size-var ,size))
         (declare (ignorable ,size-var))
         (ff:with-static-fobject (,var '(:array :char ,size)
                                       :allocation :foreign-static-gc)
           ;; (excl::stack-allocated-p var) => T
           (let ((,var (ff:fslot-address ,var)))
             ,@body)))))
  `(let* ((,size-var ,size)
          (,var (ff:allocate-fobject :char :c ,size-var)))
     (unwind-protect
          (progn ,@body)
       (ff:free-fobject ,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)
              :allocation :static-reclaimable))

(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
  "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
  ;; An array allocated in static-reclamable is a non-simple array in
  ;; the normal Lisp allocation area, pointing to a simple array in
  ;; the static-reclaimable allocation area. Therefore we have to get
  ;; out the simple-array to find the pointer to the actual contents.
  (with-unique-names (simple-vec)
    `(excl:with-underlying-simple-vector (,vector ,simple-vec)
       (let ((,ptr-var (ff:fslot-address-typed :unsigned-char :lisp
                                               ,simple-vec)))
         ,@body))))

;;;# Dereferencing

(defun convert-foreign-type (type-keyword)
  "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)
    #+64bit (:long-long :nat)
    #+64bit (:unsigned-long-long :unsigned-nat)
    (:float            :float)
    (:double           :double)
    (:pointer          :unsigned-nat)
    (: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 type into types
          and collect arg into fargs
          else do (setf return-type type)
          finally (return (values types fargs return-type)))))

(defun convert-to-lisp-type (type)
  (ecase type
    ((:char :short :int :long)
     `(signed-byte ,(* 8 (ff:sizeof-fobject type))))
    ((:unsigned-char :unsigned-short :unsigned-int :unsigned-long :unsigned-nat)
     `(unsigned-byte ,(* 8 (ff:sizeof-fobject type))))
    (:float 'single-float)
    (:double 'double-float)
    (:void 'null)))

(defun allegro-type-pair (cffi-type)
  ;; the :FOREIGN-ADDRESS pseudo-type accepts both pointers and
  ;; arrays. We need the latter for shareable byte vector support.
  (if (eq cffi-type :pointer)
      (list :foreign-address)
      (let ((ftype (convert-foreign-type cffi-type)))
        (list ftype (convert-to-lisp-type ftype)))))

#+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 rettype)
                 ;; arg types '({(:c-type lisp-type)}*)
                 '(,@(mapcar #'allegro-type-pair types))
                 nil ; arg-checking
                 ff::ep-flag-never-release))))

(defmacro %foreign-funcall (name args &key convention library)
  (declare (ignore 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)
           ,(loop for type in types
                  collect (list* (gensym) (allegro-type-pair type)))
         :returning ,(allegro-type-pair rettype)
         ;; 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 convention)
  (declare (ignore 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"
                  (if-let (package (symbol-package name))
                    (package-name package)
                    "#")
                  (symbol-name name))
          '#:cffi-callbacks))

(defun convert-calling-convention (convention)
  (ecase convention
    (:cdecl :c)
    (:stdcall :stdcall)))

(defmacro %defcallback (name rettype arg-names arg-types body
                        &key 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-calling-convention 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))))
cffi-20100219.orig/src/cffi-ecl.lisp0000644000175000017500000002763311345222703017214 0ustar  pvaneyndpvaneynd;;;; -*- 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 #:alexandria)
  (: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)

;;;# Mis-features

(pushnew 'no-long-long *features*)
(pushnew 'flat-namespace *features*)

;;;# 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))

;;;# 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)))

;;; ECL, built with the Boehm GC never moves allocated data, so this
;;; isn't nearly as hard to do. In fact, we support a bunch of vector
;;; types that other backends don't.
(defun %vector-address (vector)
  "Return the address of VECTOR's data."
  (check-type vector
              (or (vector (unsigned-byte 8))
                  (vector (signed-byte 8))
                  #+uint16-t (vector (unsigned-byte 16))
                  #+uint16-t (vector (signed-byte 16))
                  #+uint32-t (vector (unsigned-byte 32))
                  #+uint32-t (vector (signed-byte 32))
                  #+uint64-t (vector (unsigned-byte 64))
                  #+uint64-t (vector (signed-byte 64))
                  (vector single-float)
                  (vector double-float)
                  (vector bit)
                  (vector base-char)
                  #+unicode (vector character)))
  ;; ecl_array_data is a union, so we don't have to pick the specific
  ;; fields out of it, so long as we know the array has the expected
  ;; type.
  (ffi:c-inline (vector) (object) :unsigned-long
                "(unsigned long) #0->vector.self.b8"
                :side-effects nil
                :one-liner t))

(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
  "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
  `(let ((,ptr-var (make-pointer (%vector-address ,vector))))
     ,@body))

;;;# 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")
    #+x86-64 (:long-long :long "long long")
    #+x86-64 (:unsigned-long-long :unsigned-long "unsigned long 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)
      (produce-function-pointer-call
       `(%foreign-symbol-pointer ,pointer nil) 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 nil)))
    `(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 convention)
  "Call a foreign function."
  (declare (ignore library 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 convention)
  "Funcall a pointer to a foreign function."
  (declare (ignore 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
  (handler-case (si:load-foreign-module path)
    (file-error ()
      (error "file error while trying to load `~A'" 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"
                    (if-let (package (symbol-package name))
                      (package-name package)
                      "#")
                    (symbol-name name))
            '#:cffi-callbacks)))

(defmacro %defcallback (name rettype arg-names arg-types body
                        &key convention)
  (declare (ignore 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 %foreign-symbol-pointer (name library)
  "Returns a pointer to a foreign symbol NAME."
  (declare (ignore library))
  (si:find-foreign-symbol name :default :pointer-void 0))
cffi-20100219.orig/src/strings.lisp0000644000175000017500000003131411345222703017224 0ustar  pvaneyndpvaneynd;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; strings.lisp --- Operations on foreign strings.
;;;
;;; 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)

;;;# Foreign String Conversion
;;;
;;; Functions for converting NULL-terminated C-strings to Lisp strings
;;; and vice versa.  The string functions accept an ENCODING keyword
;;; argument which is used to specify the encoding to use when
;;; converting to/from foreign strings.

(defvar *default-foreign-encoding* :utf-8
  "Default foreign encoding.")

;;; TODO: refactor, sigh.  Also, this should probably be a function.
(defmacro bget (ptr off &optional (bytes 1) (endianness :ne))
  (let ((big-endian (member endianness
                            '(:be #+big-endian :ne #+little-endian :re))))
    (once-only (ptr off)
      (ecase bytes
        (1 `(mem-ref ,ptr :uint8 ,off))
        (2 (if big-endian
               #+big-endian
               `(mem-ref ,ptr :uint16 ,off)
               #-big-endian
               `(dpb (mem-ref ,ptr :uint8 ,off) (byte 8 8)
                     (mem-ref ,ptr :uint8 (1+ ,off)))
               #+little-endian
               `(mem-ref ,ptr :uint16 ,off)
               #-little-endian
               `(dpb (mem-ref ,ptr :uint8 (1+ ,off)) (byte 8 8)
                     (mem-ref ,ptr :uint8 ,off))))
        (4 (if big-endian
               #+big-endian
               `(mem-ref ,ptr :uint32 ,off)
               #-big-endian
               `(dpb (mem-ref ,ptr :uint8 ,off) (byte 8 24)
                     (dpb (mem-ref ,ptr :uint8 (1+ ,off)) (byte 8 16)
                          (dpb (mem-ref ,ptr :uint8 (+ ,off 2)) (byte 8 8)
                               (mem-ref ,ptr :uint8 (+ ,off 3)))))
               #+little-endian
               `(mem-ref ,ptr :uint32 ,off)
               #-little-endian
               `(dpb (mem-ref ,ptr :uint8 (+ ,off 3)) (byte 8 24)
                     (dpb (mem-ref ,ptr :uint8 (+ ,off 2)) (byte 8 16)
                          (dpb (mem-ref ,ptr :uint8 (1+ ,off)) (byte 8 8)
                               (mem-ref ,ptr :uint8 ,off))))))))))

(defmacro bset (val ptr off &optional (bytes 1) (endianness :ne))
  (let ((big-endian (member endianness
                            '(:be #+big-endian :ne #+little-endian :re))))
    (ecase bytes
      (1 `(setf (mem-ref ,ptr :uint8 ,off) ,val))
      (2 (if big-endian
             #+big-endian
             `(setf (mem-ref ,ptr :uint16 ,off) ,val)
             #-big-endian
             `(setf (mem-ref ,ptr :uint8 (1+ ,off)) (ldb (byte 8 0) val)
                    (mem-ref ,ptr :uint8 ,off) (ldb (byte 8 8) val))
             #+little-endian
             `(setf (mem-ref ,ptr :uint16 ,off) ,val)
             #-little-endian
             `(setf (mem-ref ,ptr :uint8 ,off) (ldb (byte 8 0) val)
                    (mem-ref ,ptr :uint8 (1+ ,off)) (ldb (byte 8 8) val))))
      (4 (if big-endian
             #+big-endian
             `(setf (mem-ref ,ptr :uint32 ,off) ,val)
             #-big-endian
             `(setf (mem-ref ,ptr :uint8 (+ 3 ,off)) (ldb (byte 8 0) val)
                    (mem-ref ,ptr :uint8 (+ 2 ,off)) (ldb (byte 8 8) val)
                    (mem-ref ,ptr :uint8 (1+ ,off)) (ldb (byte 8 16) val)
                    (mem-ref ,ptr :uint8 ,off) (ldb (byte 8 24) val))
             #+little-endian
             `(setf (mem-ref ,ptr :uint32 ,off) ,val)
             #-little-endian
             `(setf (mem-ref ,ptr :uint8 ,off) (ldb (byte 8 0) val)
                    (mem-ref ,ptr :uint8 (1+ ,off)) (ldb (byte 8 8) val)
                    (mem-ref ,ptr :uint8 (+ ,off 2)) (ldb (byte 8 16) val)
                    (mem-ref ,ptr :uint8 (+ ,off 3)) (ldb (byte 8 24) val)))))))

;;; TODO: tackle optimization notes.
(defparameter *foreign-string-mappings*
  (instantiate-concrete-mappings
   ;; :optimize ((speed 3) (debug 0) (compilation-speed 0) (safety 0))
   :octet-seq-getter bget
   :octet-seq-setter bset
   :octet-seq-type foreign-pointer
   :code-point-seq-getter babel::string-get
   :code-point-seq-setter babel::string-set
   :code-point-seq-type babel:simple-unicode-string))

(defun null-terminator-len (encoding)
  (length (enc-nul-encoding (get-character-encoding encoding))))

(defun lisp-string-to-foreign (string buffer bufsize &key (start 0) end offset
                               (encoding *default-foreign-encoding*))
  (check-type string string)
  (when offset
    (setq buffer (inc-pointer buffer offset)))
  (with-checked-simple-vector ((string (coerce string 'babel:unicode-string))
                               (start start) (end end))
    (declare (type simple-string string))
    (let ((mapping (lookup-mapping *foreign-string-mappings* encoding))
          (nul-len (null-terminator-len encoding)))
      (assert (plusp bufsize))
      (multiple-value-bind (size end)
          (funcall (octet-counter mapping) string start end (- bufsize nul-len))
        (funcall (encoder mapping) string start end buffer 0)
        (dotimes (i nul-len)
          (setf (mem-ref buffer :char (+ size i)) 0))))
    buffer))

;;; Expands into a loop that calculates the length of the foreign
;;; string at PTR plus OFFSET, using ACCESSOR and looking for a null
;;; terminator of LENGTH bytes.
(defmacro %foreign-string-length (ptr offset type length)
  (once-only (ptr offset)
    `(do ((i 0 (+ i ,length)))
         ((zerop (mem-ref ,ptr ,type (+ ,offset i))) i)
       (declare (fixnum i)))))

;;; Return the length in octets of the null terminated foreign string
;;; at POINTER plus OFFSET octets, assumed to be encoded in ENCODING,
;;; a CFFI encoding.  This should be smart enough to look for 8-bit vs
;;; 16-bit null terminators, as appropriate for the encoding.
(defun foreign-string-length (pointer &key (encoding *default-foreign-encoding*)
                              (offset 0))
  (ecase (null-terminator-len encoding)
    (1 (%foreign-string-length pointer offset :uint8 1))
    (2 (%foreign-string-length pointer offset :uint16 2))
    (4 (%foreign-string-length pointer offset :uint32 4))))

(defun foreign-string-to-lisp (pointer &key (offset 0) count
                               (max-chars (1- array-total-size-limit))
                               (encoding *default-foreign-encoding*))
  "Copy at most COUNT bytes from POINTER plus OFFSET encoded in
ENCODING into a Lisp string and return it.  If POINTER is a null
pointer, NIL is returned."
  (unless (null-pointer-p pointer)
    (let ((count (or count
                     (foreign-string-length
                      pointer :encoding encoding :offset offset)))
          (mapping (lookup-mapping *foreign-string-mappings* encoding)))
      (assert (plusp max-chars))
      (multiple-value-bind (size new-end)
          (funcall (code-point-counter mapping)
                   pointer offset (+ offset count) max-chars)
        (let ((string (make-string size :element-type 'babel:unicode-char)))
          (funcall (decoder mapping) pointer offset new-end string 0)
          (values string (- new-end offset)))))))

;;;# Using Foreign Strings

(defun foreign-string-alloc (string &key (encoding *default-foreign-encoding*)
                             (null-terminated-p t) (start 0) end)
  "Allocate a foreign string containing Lisp string STRING.
The string must be freed with FOREIGN-STRING-FREE."
  (check-type string string)
  (with-checked-simple-vector ((string (coerce string 'babel:unicode-string))
                               (start start) (end end))
    (declare (type simple-string string))
    (let* ((mapping (lookup-mapping *foreign-string-mappings* encoding))
           (count (funcall (octet-counter mapping) string start end 0))
           (length (if null-terminated-p
                       (+ count (null-terminator-len encoding))
                       count))
           (ptr (foreign-alloc :char :count length)))
      (funcall (encoder mapping) string start end ptr 0)
      (when null-terminated-p
        (dotimes (i (null-terminator-len encoding))
          (setf (mem-ref ptr :char (+ count i)) 0)))
      (values ptr length))))

(defun foreign-string-free (ptr)
  "Free a foreign string allocated by FOREIGN-STRING-ALLOC."
  (foreign-free ptr))

(defmacro with-foreign-string ((var-or-vars lisp-string &rest args) &body body)
  "VAR-OR-VARS is not evaluated ans should a list of the form
\(VAR &OPTIONAL BYTE-SIZE-VAR) or just a VAR symbol.  VAR is
bound to a foreign string containing LISP-STRING in BODY.  When
BYTE-SIZE-VAR is specified then bind the C buffer size
\(including the possible null terminator\(s)) to this variable."
  (destructuring-bind (var &optional size-var)
      (ensure-list var-or-vars)
    `(multiple-value-bind (,var ,@(when size-var (list size-var)))
         (foreign-string-alloc ,lisp-string ,@args)
       (unwind-protect
            (progn ,@body)
         (foreign-string-free ,var)))))

(defmacro with-foreign-strings (bindings &body body)
  "See WITH-FOREIGN-STRING's documentation."
  (if bindings
      `(with-foreign-string ,(first bindings)
         (with-foreign-strings ,(rest bindings)
           ,@body))
      `(progn ,@body)))

(defmacro with-foreign-pointer-as-string
    ((var-or-vars size &rest args) &body body)
  "VAR-OR-VARS is not evaluated and should be a list of the form
\(VAR &OPTIONAL SIZE-VAR) or just a VAR symbol.  VAR is bound to
a foreign buffer of size SIZE within BODY.  The return value is
constructed by calling FOREIGN-STRING-TO-LISP on the foreign
buffer along with ARGS." ; fix wording, sigh
  (destructuring-bind (var &optional size-var)
      (ensure-list var-or-vars)
    `(with-foreign-pointer (,var ,size ,size-var)
       (progn
         ,@body
         (values (foreign-string-to-lisp ,var ,@args))))))

;;;# Automatic Conversion of Foreign Strings

(define-foreign-type foreign-string-type ()
  (;; CFFI encoding of this string.
   (encoding :initform nil :initarg :encoding :reader encoding)
   ;; Should we free after translating from foreign?
   (free-from-foreign :initarg :free-from-foreign
                      :reader fst-free-from-foreign-p
                      :initform nil :type boolean)
   ;; Should we free after translating to foreign?
   (free-to-foreign :initarg :free-to-foreign
                    :reader fst-free-to-foreign-p
                    :initform t :type boolean))
  (:actual-type :pointer)
  (:simple-parser :string))

;;; describe me
(defun fst-encoding (type)
  (or (encoding type) *default-foreign-encoding*))

;;; Display the encoding when printing a FOREIGN-STRING-TYPE instance.
(defmethod print-object ((type foreign-string-type) stream)
  (print-unreadable-object (type stream :type t)
    (format stream "~S" (fst-encoding type))))

(defmethod translate-to-foreign ((s string) (type foreign-string-type))
  (values (foreign-string-alloc s :encoding (fst-encoding type))
          (fst-free-to-foreign-p type)))

(defmethod translate-to-foreign (obj (type foreign-string-type))
  (cond
    ((pointerp obj)
     (values obj nil))
    ;; FIXME: we used to support UB8 vectors but not anymore.
    ;; ((typep obj '(array (unsigned-byte 8)))
    ;;  (values (foreign-string-alloc obj) t))
    (t (error "~A is not a Lisp string or pointer." obj))))

(defmethod translate-from-foreign (ptr (type foreign-string-type))
  (unwind-protect
       (values (foreign-string-to-lisp ptr :encoding (fst-encoding type)))
    (when (fst-free-from-foreign-p type)
      (foreign-free 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 (call-next-method) value))
cffi-20100219.orig/src/cffi-lispworks.lisp0000644000175000017500000003705411345222703020504 0ustar  pvaneyndpvaneynd;;;; -*- 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 #:alexandria)
  (: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)

;;;# Misfeatures

#-lispworks-64bit (pushnew 'no-long-long *features*)

;;;# 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."
  (check-type ptr fli::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."
  #+(or lispworks3 lispworks4 lispworks5.0)
  (sys:in-static-area
    (make-array size :element-type '(unsigned-byte 8)))
  #-(or lispworks3 lispworks4 lispworks5.0)
  (make-array size :element-type '(unsigned-byte 8) :allocation :static))

(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))
    ;; On 32-bit platforms, Lispworks 5.0+ supports long-long for
    ;; DEFCFUN and FOREIGN-FUNCALL.
    (:long-long          '(:long :long))
    (:unsigned-long-long '(:unsigned :long :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 #+lispworks-64bit :long-long)
     `(signed-byte ,(* 8 (%foreign-type-size cffi-type))))
    ((:unsigned-char :unsigned-short :unsigned-int :unsigned-long
      #+lispworks-64bit :unsigned-long-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)))

;; Lispworks 5.0 on 64-bit platforms doesn't have [u]int64 support in
;; FOREIGN-TYPED-AREF.  That was implemented in 5.1.
#+(and lispworks-64bit lispworks5.0)
(defun 64-bit-type-p (type)
  (member type '(:long :unsigned-long :long-long :unsigned-long-long)))

;;; 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 (or #+(and lispworks-64bit lispworks5.0) (64-bit-type-p type)
                (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 (or #+(and lispworks-64bit lispworks5.0) (64-bit-type-p type)
                  (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 convention)
  "Creates a foreign funcallable for the signature TYPES -> RETTYPE."
  #+mac (declare (ignore convention))
  (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 convention)))))
    internal-name))

(defun get-foreign-funcallable (types rettype convention)
  "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 convention)))))

(defmacro %%foreign-funcall (foreign-function args convention)
  "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 ',convention))
              ,foreign-function ,@fargs)))

(defmacro %foreign-funcall (name args &key library 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 ,convention))

(defmacro %foreign-funcall-pointer (ptr args &key convention)
  "Calls a foreign function pointed at by PTR passing arguments ARGS."
  `(%%foreign-funcall ,ptr ,args ,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 :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"
                    (if-let (package (symbol-package name))
                      (package-name package)
                      "#")
                    (symbol-name name))
            '#:cffi-callbacks)))

(defmacro %defcallback (name rettype arg-names arg-types body
                        &key convention)
  (let ((cb-name (intern-callback name)))
    `(progn
       (fli:define-foreign-callable
           (,cb-name :encode :lisp
                     :result-type ,(convert-foreign-type rettype)
                     :calling-convention ,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)))))
cffi-20100219.orig/src/cffi-corman.lisp0000644000175000017500000002647711345222703017735 0ustar  pvaneyndpvaneynd;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-corman.lisp --- CFFI-SYS implementation for Corman Lisp.
;;;
;;; Copyright (C) 2005-2008, 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)
  (:import-from #:alexandria #:with-unique-names)
  (: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)

;;;# Misfeatures

(pushnew 'no-long-long *features*)
(pushnew 'no-foreign-funcall *features*)

;;;$ 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))))
cffi-20100219.orig/src/features.lisp0000644000175000017500000000756011345222703017357 0ustar  pvaneyndpvaneynd;;;; -*- 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.
;;;
;;; Not anymore, I think we should use TRIVIAL-FEATURES for the
;;; platform features instead.  Less pain.  CFFI-FEATURES is now
;;; deprecated and this code will stay here for a while for backwards
;;; compatibility purposes, to be removed in a future release.

(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))))))))))

;;; for backwards compatibility
(mapc (lambda (sym) (pushnew sym *features*))
      '(#+darwin darwin
        #+unix unix
        #+windows windows
        #+ppc ppc32
        #+x86 x86
        #+x86-64 x86-64
        #+sparc sparc
        #+sparc64 sparc64
        #+hppa hppa
        #+hppa64 hppa64
        #+cffi-sys::no-long-long no-long-long
        #+cffi-sys::flat-namespace flat-namespace
        #+cffi-sys::no-foreign-funcall no-foreign-funcall
        #+cffi-sys::no-stdcall no-stdcall
        ))
cffi-20100219.orig/src/cffi-openmcl.lisp0000644000175000017500000002440511345222703020100 0ustar  pvaneyndpvaneynd;;;; -*- 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)
  (:import-from #:alexandria #:once-only #:if-let)
  (: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)

;;;# Misfeatures

(pushnew 'flat-namespace *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.

(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."
  #+darwin (concatenate 'string "_" name)
  #-darwin name)

(defmacro %foreign-funcall (function-name args &key library convention)
  "Perform a foreign function call, document it more later."
  (declare (ignore library convention))
  `(external-call
    ,(convert-external-name function-name)
    ,@(convert-foreign-funcall-types args)))

(defmacro %foreign-funcall-pointer (ptr args &key convention)
  (declare (ignore 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"
                  (if-let (package (symbol-package name))
                    (package-name package)
                    "#")
                  (symbol-name name))
          '#:cffi-callbacks))

(defmacro %defcallback (name rettype arg-names arg-types body
                        &key convention)
  (let ((cb-name (intern-callback name)))
    `(progn
       (defcallback ,cb-name
           (,@(when (eq convention :stdcall)
                '(:discard-stack-args))
            ,@(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)))
cffi-20100219.orig/src/cffi-cmucl.lisp0000644000175000017500000003164411345222703017551 0ustar  pvaneyndpvaneynd;;;; -*- 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)
  (:import-from #:alexandria #:once-only #:with-unique-names #:if-let)
  (: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)

;;;# Misfeatures

(pushnew 'flat-namespace *features*)

;;;# 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 convention)
  "Perform a foreign function call, document it more later."
  (declare (ignore library 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 convention)
  "Funcall a pointer to a foreign function."
  (declare (ignore 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"
                    (if-let (package (symbol-package name))
                      (package-name package)
                      name)
                    (symbol-name name))
            '#:cffi-callbacks)))

(defmacro %defcallback (name rettype arg-names arg-types body
                        &key convention)
  (declare (ignore 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 nil))

;;;# 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))))
cffi-20100219.orig/src/cffi-abcl.lisp0000644000175000017500000003515511345222703017350 0ustar  pvaneyndpvaneynd;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-abcl.lisp --- CFFI-SYS implementation for ABCL/JNA.
;;;
;;; Copyright (C) 2009, 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 implementation requires the Java Native Access (JNA) library.
;;; 

;;; This is a preliminary version that will have to be cleaned up,
;;; optimized, etc. Nevertheless, it passes all of the relevant CFFI
;;; tests except MAKE-POINTER.HIGH. Callbacks and Shareable Vectors
;;; are not implemented yet.

;;;# Administrivia

(defpackage #:cffi-sys
  (:use #:cl #:java)
  (:import-from #:alexandria #:hash-table-values #:length=)
  (: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)

(defun private-jfield (class-name field-name instance)
  (let ((field (find field-name
                     (jcall (jmethod "java.lang.Class" "getDeclaredFields")
                            (jclass class-name))
                     :key #'jfield-name
                     :test #'string=)))
    (jcall (jmethod "java.lang.reflect.Field" "setAccessible" "boolean")
           field (make-immediate-object t :boolean))
    (jcall (jmethod "java.lang.reflect.Field" "get" "java.lang.Object")
           field instance)))

;;; XXX: doesn't match jmethod-arguments.
(defun private-jmethod (class-name method-name)
  (let ((method (find method-name
                      (jcall (jmethod "java.lang.Class" "getDeclaredMethods")
                             (jclass class-name))
                      :key #'jmethod-name
                      :test #'string=)))
    (jcall (jmethod "java.lang.reflect.Method" "setAccessible" "boolean")
           method (make-immediate-object t :boolean))
    method))

(defun private-jconstructor (class-name &rest params)
  (let* ((param-classes (mapcar #'jclass params))
         (cons (find-if (lambda (x &aux (cons-params (jconstructor-params x)))
                          (and (length= param-classes cons-params)
                               (loop for param in param-classes
                                     and param-x across cons-params
                                     always (string= (jclass-name param)
                                                     (jclass-name param-x)))))
                        (jcall (jmethod "java.lang.Class"
                                        "getDeclaredConstructors")
                               (jclass class-name)))))
    (jcall (jmethod "java.lang.reflect.Constructor" "setAccessible" "boolean")
           cons (make-immediate-object t :boolean))
    cons))

;;;# Symbol Case

(defun canonicalize-symbol-name-case (name)
  (string-upcase name))

;;;# Pointers

(deftype foreign-pointer ()
  '(satisfies pointerp))

(defun pointerp (ptr)
  "Return true if PTR is a foreign pointer."
  (jclass-superclass-p (jclass "com.sun.jna.Pointer") (jclass-of ptr)))

(defun make-pointer (address)
  "Return a pointer pointing to ADDRESS."
  (jnew (private-jconstructor "com.sun.jna.Pointer" "long") address))

(defun pointer-address (pointer)
  "Return the address pointed to by PTR."
  (private-jfield "com.sun.jna.Pointer" "peer" pointer))

(defun pointer-eq (ptr1 ptr2)
  "Return true if PTR1 and PTR2 point to the same address."
  (= (pointer-address ptr1) (pointer-address ptr2)))

(defun null-pointer ()
  "Construct and return a null pointer."
  (make-pointer 0))

(defun null-pointer-p (ptr)
  "Return true if PTR is a null pointer."
  (zerop (pointer-address ptr)))

(defun inc-pointer (ptr offset)
  "Return a fresh pointer pointing OFFSET bytes past PTR."
  (make-pointer (+ (pointer-address ptr) offset)))

;;;# Allocation

(defun %foreign-alloc (size)
  "Allocate SIZE bytes on the heap and return a pointer."
  (make-pointer
   (jcall (private-jmethod "com.sun.jna.Memory" "malloc")
          nil size)))

(defun foreign-free (ptr)
  "Free a PTR allocated by FOREIGN-ALLOC."
  (jcall (private-jmethod "com.sun.jna.Memory" "free")
         nil (pointer-address ptr)))

;;; TODO: stack allocation.
(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))))

;;;# 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.

;;; TODO.

(defun make-shareable-byte-vector (size)
  "Create a Lisp vector of SIZE bytes can passed to
WITH-POINTER-TO-VECTOR-DATA."
  (error "unimplemented"))

(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
  "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
  (warn "unimplemented"))

;;;# Dereferencing

(defun foreign-type-to-java-class (type)
  (jclass
   (ecase type
     ((:int :unsigned-int) "java.lang.Integer")
     ((:long :unsigned-long) "com.sun.jna.NativeLong")
     ((:long-long :unsigned-long-long) "java.lang.Long")
     (:pointer "com.sun.jna.Pointer")
     (:float "java.lang.Float")
     (:double "java.lang.Double")
     ((:char :unsigned-char) "java.lang.Byte")
     ((:short :unsigned-short) "java.lang.Short"))))

(defun %foreign-type-size (type)
  "Return the size in bytes of a foreign type."
  (jstatic "getNativeSize" "com.sun.jna.Native"
           (foreign-type-to-java-class type)))

;;; FIXME.
(defun %foreign-type-alignment (type)
  "Return the alignment in bytes of a foreign type."
  (%foreign-type-size type))

(defun unsigned-type-p (type)
  (case type
    ((:unsigned-char
      :unsigned-int
      :unsigned-short
      :unsigned-long
      :unsigned-long-long) t)
    (t nil)))

(defun jna-getter (type)
  (ecase type
    ((:char :unsigned-char) "getByte")
    (:double "getDouble")
    (:float "getFloat")
    ((:int :unsigned-int) "getInt")
    ((:long :unsigned-long) "getNativeLong")
    ((:long-long :unsigned-long-long) "getLong")
    (:pointer "getPointer")
    ((:short :unsigned-short) "getShort")))

(defun lispify-value (value type)
  (when (and (eq type :pointer) (null value))
    (return-from lispify-value (null-pointer)))
  (when (or (eq type :long) (eq type :unsigned-long))
    (setq value (jcall (jmethod "com.sun.jna.NativeLong" "longValue") value)))
  (let ((bit-size (* 8 (%foreign-type-size type))))
    (if (and (unsigned-type-p type) (logbitp (1- bit-size) value))
        (lognot (logxor value (1- (expt 2 bit-size))))
        value)))

(defun %mem-ref (ptr type &optional (offset 0))
  (lispify-value
   (jcall (jmethod "com.sun.jna.Pointer" (jna-getter type) "long")
          ptr offset)
   type))

(defun jna-setter (type)
  (ecase type
    ((:char :unsigned-char) "setByte")
    (:double "setDouble")
    (:float "setFloat")
    ((:int :unsigned-int) "setInt")
    ((:long :unsigned-long) "setNativeLong")
    ((:long-long :unsigned-long-long) "setLong")
    (:pointer "setPointer")
    ((:short :unsigned-short) "setShort")))

(defun jna-setter-arg-type (type)
  (ecase type
    ((:char :unsigned-char) "byte")
    (:double "double")
    (:float "float")
    ((:int :unsigned-int) "int")
    ((:long :unsigned-long) "com.sun.jna.NativeLong")
    ((:long-long :unsigned-long-long) "long")
    (:pointer "com.sun.jna.Pointer")
    ((:short :unsigned-short) "short")))

(defun %mem-set (value ptr type &optional (offset 0))
  (let* ((bit-size (* 8 (%foreign-type-size type)))
         (val (if (and (unsigned-type-p type) (logbitp (1- bit-size) value))
                  (lognot (logxor value (1- (expt 2 bit-size))))
                  value)))
    (jcall (jmethod "com.sun.jna.Pointer"
                    (jna-setter type) "long" (jna-setter-arg-type type))
           ptr
           offset
           (if (or (eq type :long) (eq type :unsigned-long))
               (jnew (jconstructor "com.sun.jna.NativeLong" "long") val)
               val)))
  value)

;;;# Calling Foreign Functions

(defun find-foreign-function (name library)
  (flet ((find-it (name library)
           (ignore-errors
             (jcall (jmethod "com.sun.jna.NativeLibrary" "getFunction"
                             "java.lang.String")
                    library name))))
    (if (eq library :default)
        (loop for lib in (hash-table-values *loaded-libraries*)
              for fn = (find-it name lib)
              when fn do (return fn))
        (find-it name (gethash library *loaded-libraries*)))))

(defun make-function-pointer (pointer cconv)
  (jnew (private-jconstructor "com.sun.jna.Function"
                              "com.sun.jna.Pointer" "int")
        pointer
        (jfield "com.sun.jna.Function"
                (ecase cconv
                  (:cdecl "C_CONVENTION")
                  (:stdcall "ALT_CONVENTION")))))

(defun lisp-value-to-java (value foreign-type)
  (if (eq foreign-type :pointer)
      value
      (jnew (ecase foreign-type
              ((:int :unsigned-int) (jconstructor "java.lang.Integer" "int"))
              ((:long-long :unsigned-long-long)
                 (jconstructor "java.lang.Long" "long"))
              ((:long :unsigned-long)
                 (jconstructor "com.sun.jna.NativeLong" "long"))
              ((:short :unsigned-short) (jconstructor "java.lang.Short" "short"))
              ((:char :unsigned-char) (jconstructor "java.lang.Byte" "byte"))
              (:float (jconstructor "java.lang.Float" "float"))
              (:double (jconstructor "java.lang.Double" "double")))
            value)))

(defun %%foreign-funcall (function args arg-types return-type)
  (let ((jargs (jnew-array "java.lang.Object" (length args))))
    (loop for arg in args and type in arg-types and i from 0
          do (setf (jarray-ref jargs i)
                   (lisp-value-to-java arg type)))
    (if (eq return-type :void)
        (progn
          (jcall (jmethod "com.sun.jna.Function" "invoke" "[Ljava.lang.Object;")
                 function jargs)
          (values))
        (lispify-value
         (jcall (jmethod "com.sun.jna.Function" "invoke"
                         "java.lang.Class" "[Ljava.lang.Object;")
                function
                (foreign-type-to-java-class return-type)
                jargs)
         return-type))))

(defun foreign-funcall-type-and-args (args)
  (let ((return-type :void))
    (loop for (type arg) on args by #'cddr
          if arg collect type into types
          and collect arg into fargs
          else do (setf return-type type)
          finally (return (values types fargs return-type)))))

(defmacro %foreign-funcall (name args &key library calling-convention)
  (multiple-value-bind (types fargs rettype)
      (foreign-funcall-type-and-args args)
    `(%%foreign-funcall (find-foreign-function ',name ',library)
                        (list ,@fargs) ',types ',rettype)))

(defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
  (multiple-value-bind (types fargs rettype)
      (foreign-funcall-type-and-args args)
    `(%%foreign-funcall (make-function-pointer ,ptr ',calling-convention)
                        (list ,@fargs) ',types ',rettype)))

;;;# Callbacks

;;; TODO. IIUC, implementing this functionality would require being
;;; able to create new interface definitions at runtime, which is
;;; apparently no supported by ABCL as of June 2009.

(defmacro %defcallback (name rettype arg-names arg-types body
                        &key calling-convention)
  (warn "callback support unimplemented"))

(defun %callback (name)
  (error "callback support unimplemented"))

;;;# Loading and Closign Foreign Libraries

(defparameter *loaded-libraries* (make-hash-table))

(defun %load-foreign-library (name path)
  "Load a foreign library, signals a simple error on failure."
  (handler-case
      (let ((lib (jstatic "getInstance" "com.sun.jna.NativeLibrary" path)))
        (setf (gethash name *loaded-libraries*) lib)
        lib)
    (java-exception (e)
      (error (jcall (jmethod "java.lang.Exception" "getMessage")
                    (java-exception-cause e))))))

;;; FIXME. Should remove libraries from the hash table.
(defun %close-foreign-library (handle)
  "Closes a foreign library."
  #+#:ignore (setf *loaded-libraries* (remove handle *loaded-libraries*))
  (jcall (jmethod "com.sun.jna.NativeLibrary" "dispose") handle))

(defun native-namestring (pathname)
  (namestring pathname))

;;;# Foreign Globals

(defun %foreign-symbol-pointer (name library)
  "Returns a pointer to a foreign symbol NAME."
  (flet ((find-it (name library)
           (let ((p (ignore-errors
                      (jcall (private-jmethod "com.sun.jna.NativeLibrary"
                                              "getSymbolAddress")
                             library name))))
             (unless (null p)
               (make-pointer p)))))
    (if (eq library :default)
        (loop for lib in (hash-table-values *loaded-libraries*)
              for fn = (find-it name lib)
              when fn do (return fn))
        (find-it name library))))
cffi-20100219.orig/src/foreign-vars.lisp0000644000175000017500000000770711345222703020146 0ustar  pvaneyndpvaneynd;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; foreign-vars.lisp --- High-level interface to foreign globals.
;;;
;;; Copyright (C) 2005-2008, 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."
  (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
         (setf (documentation ',lisp-name 'variable) ,documentation)
         ;; 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)))))))
cffi-20100219.orig/src/libraries.lisp0000644000175000017500000003625511345222703017520 0ustar  pvaneyndpvaneynd;;;; -*- 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 FEATUREP is
;;; processed.

(defvar *foreign-libraries* (make-hash-table :test 'eq)
  "Hashtable of defined libraries.")

(defclass foreign-library ()
  ((type :initform :system :initarg :type)
   (spec :initarg :spec)
   (options :initform nil :initarg :options)
   (handle :initform nil :initarg :handle
           :accessor foreign-library-handle)
   (pathname :initform nil)))

(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))

(defun foreign-library-type (lib)
  (slot-value (get-foreign-library lib) 'type))

(defun foreign-library-pathname (lib)
  (slot-value (get-foreign-library lib) 'pathname))

(defun %foreign-library-spec (lib)
  (assoc-if (lambda (feature)
              (or (eq feature t)
                  (featurep feature)))
            (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)))

(defun foreign-library-search-path (lib)
  (loop for (opt val) on (foreign-library-options lib) by #'cddr
        when (eql opt :search-path)
          append (ensure-list val) into search-path
        finally (return (mapcar #'pathname search-path))))

(defun foreign-library-loaded-p (lib)
  (not (null (slot-value (get-foreign-library lib) 'handle))))

(defun list-foreign-libraries (&key (loaded-only t) type)
  "Return a list of defined foreign libraries.
If LOADED-ONLY is non-null only loaded libraries are returned.
TYPE restricts the output to a specific library type: if NIL
all libraries are returned."
  (let ((libs (hash-table-values *foreign-libraries*)))
    (remove-if (lambda (lib)
                 (or (and type
                          (not (eql type (foreign-library-type lib))))
                     (and loaded-only
                          (not (foreign-library-loaded-p lib)))))
               libs)))

;; :CONVENTION, :CALLING-CONVENTION and :CCONV are coalesced,
;; the former taking priority
;; options with NULL values are removed
(defun clean-spec-up (spec)
  (mapcar (lambda (x)
            (list* (first x) (second x)
                   (let* ((opts (cddr x))
                          (cconv (getf opts :cconv))
                          (calling-convention (getf opts :calling-convention))
                          (convention (getf opts :convention))
                          (search-path (getf opts :search-path)))
                     (remf opts :cconv) (remf opts :calling-convention)
                     (when cconv
                       (warn-obsolete-argument :cconv :convention))
                     (when calling-convention
                       (warn-obsolete-argument :calling-convention
                                               :convention))
                     (setf (getf opts :convention)
                           (or convention calling-convention cconv))
                     (setf (getf opts :search-path)
                           (mapcar #'pathname (ensure-list search-path)))
                     (loop for (opt val) on opts by #'cddr
                           when val append (list opt val) into new-opts
                           finally (return new-opts)))))
          spec))

(defmethod initialize-instance :after
    ((lib foreign-library) &key search-path
     (cconv :cdecl cconv-p)
     (calling-convention cconv calling-convention-p)
     (convention calling-convention))
  (with-slots (type options spec) lib
    (check-type type (member :system :test :grovel-wrapper))
    (setf spec (clean-spec-up spec))
    (let ((all-options
           (apply #'append options (mapcar #'cddr spec))))
      (assert (subsetp (loop for (key . nil) on all-options by #'cddr
                             collect key)
                       '(:convention :search-path)))
      (when cconv-p
        (warn-obsolete-argument :cconv :convention))
      (when calling-convention-p
        (warn-obsolete-argument :calling-convention :convention))
      (flet ((set-option (key value)
               (when value (setf (getf options key) value))))
        (set-option :convention convention)
        (set-option :search-path
                    (mapcar #'pathname (ensure-list search-path)))))))

;;; FIXME: re-evaluating DEFINE-FOREIGN-LIBRARY overwrites the current entry
;;;        breaking FOREIGN-LIBRARY-LOADED-P if already loaded
(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))
       ',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 &optional search-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
      (values (%load-foreign-library name path)
              (pathname path))
    (error (error)
      (if-let (file (find-file path (append search-path
                                            *foreign-library-directories*)))
        (handler-case
            (values (%load-foreign-library name (native-namestring file))
                    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)
    (multiple-value-bind (handle pathname)
        (ignore-errors (load-foreign-library-helper name lib))
      (when handle
        (return-from try-foreign-library-alternatives
          (values handle pathname)))))
  ;; 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*
  '((:windows . ".dll")
    (:darwin . ".dylib")
    (:unix . ".so")
    (t . ".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 #'featurep *cffi-feature-suffix-map*))
      (fl-error "Unable to determine the default library suffix on this OS.")))

(defun load-foreign-library-helper (name thing &optional search-path)
  (etypecase thing
    (string
     (load-foreign-library-path name thing search-path))
    (pathname
     (load-foreign-library-path name (namestring thing) search-path))
    (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."))
        (let ((library-path
               (concatenate 'string
                            (second thing)
                            (default-library-suffix))))
          (load-foreign-library-path name library-path search-path)))
       (:or (try-foreign-library-alternatives name (rest thing)))))))

(defun %do-load-foreign-library (library search-path)
  (flet ((%do-load (lib name spec)
           (when (foreign-library-spec lib)
             (multiple-value-bind (handle pathname)
                 (load-foreign-library-helper
                  name spec (foreign-library-search-path lib))
               (setf (slot-value lib 'handle) handle
                     (slot-value lib 'pathname) pathname)))
           lib))
    (typecase library
      (symbol
       (let* ((lib (get-foreign-library library))
              (spec (foreign-library-spec lib)))
         (%do-load lib library spec)))
      (t
       (let* ((lib-name (gensym (string '#:library-)))
              (lib
               (make-instance 'foreign-library :type :system
                              :spec `((t ,library))
                              :search-path search-path)))
         (setf (get-foreign-library lib-name) lib)
         (%do-load lib lib-name library))))))

(defun load-foreign-library (library &key search-path)
  "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
      (%do-load-foreign-library library search-path)
    ;; Offer these restarts that will retry the call to
    ;; %LOAD-FOREIGN-LIBRARY.
    (retry ()
      :report "Try loading the foreign library again."
      (load-foreign-library library :search-path search-path))
    (use-value (new-library)
      :report "Use another library instead."
      :interactive read-new-value
      (load-foreign-library new-library :search-path search-path))))

(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))
         (handle (foreign-library-handle lib)))
    (when handle
      (%close-foreign-library handle)
      (setf (foreign-library-handle lib) nil)
      t)))
cffi-20100219.orig/src/package.lisp0000644000175000017500000000734711345222703017137 0ustar  pvaneyndpvaneynd;;;; -*- 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 #:babel-encodings)
  (:import-from #:alexandria
                #:ensure-list #:featurep #:format-symbol #:if-let
                #:make-gensym-list #:once-only #:parse-body #:symbolicate
                #:when-let #:with-unique-names #:lastcar
                #:hash-table-values #:make-keyword)
  (: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.
   #:*default-foreign-encoding*
   #: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*
   #:foreign-library
   #:foreign-library-pathname
   #:foreign-library-type
   #:foreign-library-loaded-p
   #:list-foreign-libraries
   #: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
   #:define-c-struct-wrapper
   #: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
   ))
cffi-20100219.orig/src/functions.lisp0000644000175000017500000003200311345222703017537 0ustar  pvaneyndpvaneynd;;;; -*- 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* ((len (length args))
         (return-type (if (oddp len) (lastcar args) :void)))
    (loop repeat (floor len 2)
          for (type arg) on args by #'cddr
          collect type into types
          collect (canonicalize-foreign-type type) into ctypes
          collect arg into fargs
          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)
                            (cconv nil cconv-p)
                            (calling-convention cconv calling-convention-p)
                            (convention calling-convention))
      options
    (when cconv-p
      (warn-obsolete-argument :cconv :convention))
    (when calling-convention-p
      (warn-obsolete-argument :calling-convention :convention))
    (list* :convention
           (or convention
               (when libraryp
                 (let ((lib-options (foreign-library-options
                                     (get-foreign-library library))))
                   (getf lib-options :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 (cconv :cdecl cconv-p)
                            (calling-convention cconv calling-convention-p)
                            (convention calling-convention))
      options
    (when cconv-p
      (warn-obsolete-argument :cconv :convention))
    (when calling-convention-p
      (warn-obsolete-argument :calling-convention :convention))
    (list :convention convention)))

(defmacro defcallback (name-and-options return-type args &body body)
  (multiple-value-bind (body declarations)
      (parse-body body :documentation t)
    (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))
cffi-20100219.orig/src/cffi-scl.lisp0000644000175000017500000002553311345222703017227 0ustar  pvaneyndpvaneynd;;;; -*- 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)
  (:import-from #:alexandria #:once-only #:with-unique-names)
  (: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)

;;;# Mis-features

(pushnew 'flat-namespace *features*)

;;;# 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 convention)
  "Perform a foreign function call, document it more later."
  (declare (ignore library 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 convention)
  "Funcall a pointer to a foreign function."
  (declare (ignore 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 convention)
  (declare (ignore 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 nil))

;;;# 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)))
cffi-20100219.orig/src/cffi-clisp.lisp0000644000175000017500000003711511345222703017557 0ustar  pvaneyndpvaneynd;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-clisp.lisp --- CFFI-SYS implementation for CLISP.
;;;
;;; Copyright (C) 2005-2006, James Bielman  
;;; Copyright (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 #:alexandria)
  (: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)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (unless (find-package :ffi)
    (error "CFFI requires CLISP compiled with dynamic FFI support.")))

;;;# 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 darwin ppc)
  (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 ()
  'ffi:foreign-address)

(defun pointerp (ptr)
  "Return true if PTR is a foreign pointer."
  (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."
  (zerop (ffi:foreign-address-unsigned ptr)))

(defun inc-pointer (ptr offset)
  "Return a pointer pointing OFFSET bytes past PTR."
  (ffi:unsigned-foreign-address
   (+ offset (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 (if (zerop size) 1 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

;;; %MEM-REF and its compiler macro work around CLISP's FFI:C-POINTER
;;; type and convert NILs back to null pointers.
(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."
  (let ((value (ffi:memory-as ptr (convert-foreign-type type) offset)))
    (if (eq type :pointer)
        (or value (null-pointer))
        value)))

(define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0))
  "Compiler macro to open-code when TYPE is constant."
  (if (constantp type)
      (let* ((ftype (convert-foreign-type (eval type)))
             (form `(ffi:memory-as ,ptr ',ftype ,offset)))
        (if (eq type :pointer)
            `(or ,form (null-pointer))
            form))
      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-calling-convention (convention)
  (ecase convention
    (:stdcall :stdc-stdcall)
    (:cdecl :stdc)))

(defun c-function-type (arg-types rettype 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-calling-convention 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))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  ;; version 2.40 (CVS 2006-09-03, to be more precise) added a
  ;; PROPERTIES argument to FFI::FOREIGN-LIBRARY-FUNCTION.
  (defun post-2.40-ffi-interface-p ()
    (let ((f-l-f (find-symbol (string '#:foreign-library-function) '#:ffi)))
      (if (and f-l-f (= (length (ext:arglist f-l-f)) 5))
          '(:and)
          '(:or))))
  ;; FFI::FOREIGN-LIBRARY-FUNCTION and FFI::FOREIGN-LIBRARY-VARIABLE
  ;; were deprecated in 2.41 and removed in 2.45.
  (defun post-2.45-ffi-interface-p ()
    (if (find-symbol (string '#:foreign-library-function) '#:ffi)
        '(:or)
        '(:and))))

#+#.(cffi-sys::post-2.45-ffi-interface-p)
(defun %foreign-funcall-aux (name type library)
  `(ffi::find-foreign-function ,name ,type nil ,library nil nil))

#-#.(cffi-sys::post-2.45-ffi-interface-p)
(defun %foreign-funcall-aux (name type library)
  `(ffi::foreign-library-function
    ,name ,library nil
    #+#.(cffi-sys::post-2.40-ffi-interface-p)
    nil
    ,type))

(defmacro %foreign-funcall (name args &key library 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)
    (let* ((fn (%foreign-funcall-aux
                name
                `(ffi:parse-c-type
                  ',(c-function-type types rettype convention))
                (if (eq library :default)
                    :default
                    (library-handle-form library))))
          (form `(funcall
                  (load-time-value
                   (handler-case ,fn
                     (error (err)
                       (warn "~A" err))))
                  ,@fargs)))
      (if (eq rettype 'ffi:c-pointer)
          `(or ,form (null-pointer))
          form))))

(defmacro %foreign-funcall-pointer (ptr args &key 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 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 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-calling-convention 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 convention)
  `(register-callback
    ',name
    (lambda ,arg-names
      ;; Work around CLISP's FFI:C-POINTER type and convert NIL values
      ;; back into a null pointers.
      (let (,@(loop for name in arg-names
                    and type in arg-types
                    when (eq type :pointer)
                    collect `(,name (or ,name (null-pointer)))))
        ,body))
    ,(callback-type rettype arg-names arg-types 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))
  #+#.(cffi-sys::post-2.45-ffi-interface-p)
  (ffi:open-foreign-library path)
  #-#.(cffi-sys::post-2.45-ffi-interface-p)
  (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
            #+#.(cffi-sys::post-2.45-ffi-interface-p)
            (ffi::find-foreign-variable name nil library nil nil)
            #-#.(cffi-sys::post-2.45-ffi-interface-p)
            (ffi::foreign-library-variable name library nil nil)))))
cffi-20100219.orig/src/cffi-sbcl.lisp0000644000175000017500000003106411345222703017365 0ustar  pvaneyndpvaneynd;;;; -*- 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)
  (:import-from #:alexandria
                #:once-only #:with-unique-names #:when-let #:removef)
  (: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)

;;;# Misfeatures

(pushnew 'flat-namespace *features*)

;;;# 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 convention)
  "Perform a foreign function call, document it more later."
  (declare (ignore library 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 convention)
  "Funcall a pointer to a foreign function."
  (declare (ignore 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 convention)
  (declare (ignore 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))

;;; SBCL 1.0.21.15 renamed SB-ALIEN::SHARED-OBJECT-FILE but introduced
;;; SB-ALIEN:UNLOAD-SHARED-OBJECT which we can use instead.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun unload-shared-object-present-p ()
    (multiple-value-bind (foundp kind)
        (find-symbol "UNLOAD-SHARED-OBJECT" "SB-ALIEN")
      (if (and foundp (eq kind :external))
          '(:and)
          '(:or)))))

(defun %close-foreign-library (handle)
  "Closes a foreign library."
  #+#.(cffi-sys::unload-shared-object-present-p)
  (sb-alien:unload-shared-object handle)
  #-#.(cffi-sys::unload-shared-object-present-p)
  (sb-thread:with-mutex (sb-alien::*shared-objects-lock*)
    (let ((obj (find (sb-ext:native-namestring handle)
                     sb-alien::*shared-objects*
                     :key #'sb-alien::shared-object-file
                     :test #'string=)))
      (when obj
        (sb-alien::dlclose-or-lose obj)
        (removef sb-alien::*shared-objects* obj)
        #+(and linkage-table (not win32))
        (sb-alien::update-linkage-table)))))

(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))
  (when-let (address (sb-sys:find-foreign-symbol-address name))
    (sb-sys:int-sap address)))
cffi-20100219.orig/src/utils.lisp0000644000175000017500000000575411345222703016704 0ustar  pvaneyndpvaneynd;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; utils.lisp --- Various utilities.
;;;
;;; Copyright (C) 2005-2008, 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)

(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)))

(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. It's
;;; 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.
(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)))))

(define-condition obsolete-argument-warning (style-warning)
  ((old-arg :initarg :old-arg :reader old-arg)
   (new-arg :initarg :new-arg :reader new-arg))
  (:report (lambda (c s)
             (format s "Keyword ~S is obsolete, please use ~S"
                     (old-arg c) (new-arg c)))))

(defun warn-obsolete-argument (old-arg new-arg)
  (warn 'obsolete-argument-warning
        :old-arg old-arg :new-arg new-arg))
cffi-20100219.orig/src/cffi-gcl.lisp0000644000175000017500000002407111345222703017207 0ustar  pvaneyndpvaneynd;;;; -*- 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 #:alexandria)
  (: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)
cffi-20100219.orig/src/types.lisp0000644000175000017500000011267211345222703016706 0ustar  pvaneyndpvaneynd;;;; -*- 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-sys::no-long-long
(progn
  (define-built-in-foreign-type :long-long)
  (define-built-in-foreign-type :unsigned-long-long))

;;; Define emulated LONG-LONG types.  Needs checking whether we're
;;; using the right sizes on various platforms.
;;;
;;; A possibly better, certainly faster though more intrusive,
;;; alternative is available here:
;;;   
#+cffi-sys::no-long-long
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defclass emulated-llong-type (foreign-type) ())
  (defmethod foreign-type-size ((tp emulated-llong-type)) 8)
  (defmethod foreign-type-alignment ((tp emulated-llong-type))
    ;; better than assuming that the alignment is 8
    (foreign-type-alignment :long))
  (defmethod aggregatep ((tp emulated-llong-type)) nil)

  (define-foreign-type emulated-llong (emulated-llong-type)
    ()
    (:simple-parser :long-long))

  (define-foreign-type emulated-ullong (emulated-llong-type)
    ()
    (:simple-parser :unsigned-long-long))

  (defmethod canonicalize ((tp emulated-llong)) :long-long)
  (defmethod unparse-type ((tp emulated-llong)) :long-long)
  (defmethod canonicalize ((tp emulated-ullong)) :unsigned-long-long)
  (defmethod unparse-type ((tp emulated-ullong)) :unsigned-long-long)

  (defun %emulated-mem-ref-64 (ptr type offset)
    (let ((value #+big-endian
                 (+ (ash (mem-ref ptr :unsigned-long offset) 32)
                    (mem-ref ptr :unsigned-long (+ offset 4)))
                 #+little-endian
                 (+ (mem-ref ptr :unsigned-long offset)
                    (ash (mem-ref ptr :unsigned-long (+ offset 4)) 32))))
      (if (and (eq type :long-long) (logbitp 63 value))
          (lognot (logxor value #xFFFFFFFFFFFFFFFF))
          value)))

  (defun %emulated-mem-set-64 (value ptr type offset)
    (when (and (eq type :long-long) (minusp value))
      (setq value (lognot (logxor value #xFFFFFFFFFFFFFFFF))))
    (%mem-set (ldb (byte 32 0) value) ptr :unsigned-long
              #+big-endian (+ offset 4) #+little-endian offset)
    (%mem-set (ldb (byte 32 32) value) ptr :unsigned-long
              #+big-endian offset #+little-endian (+ offset 4))
    value))

;;; When some lisp other than SCL supports :long-double we should
;;; use #-cffi-sys::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 ((ctype (canonicalize ptype)))
          #+cffi-sys::no-long-long
          (when (or (eq ctype :long-long) (eq ctype :unsigned-long-long))
            (return-from mem-ref
              (translate-from-foreign (%emulated-mem-ref-64 ptr ctype offset)
                                      ptype)))
          ;; normal branch
          (translate-from-foreign (%mem-ref ptr ctype offset) 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)))
             (ctype (canonicalize parsed-type)))
        ;; Bail out when using emulated long long types.
        #+cffi-sys::no-long-long
        (when (member ctype '(:long-long :unsigned-long-long))
          (return-from mem-ref form))
        (if (aggregatep parsed-type)
            `(inc-pointer ,ptr ,offset)
            (expand-from-foreign `(%mem-ref ,ptr ,ctype ,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))
         (ctype (canonicalize ptype)))
    #+cffi-sys::no-long-long
    (when (or (eq ctype :long-long) (eq ctype :unsigned-long-long))
      (return-from mem-set
        (%emulated-mem-set-64 (translate-to-foreign value ptype)
                              ptr ctype offset)))
    (%mem-set (translate-to-foreign value ptype) ptr ctype 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)))
             (ctype (canonicalize parsed-type)))
        ;; Bail out when using emulated long long types.
        #+cffi-sys::no-long-long
        (when (member ctype '(:long-long :unsigned-long-long))
          (return-from mem-set form))
        `(%mem-set ,(expand-to-foreign value parsed-type) ,ptr ,ctype ,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 aggregatep ((type foreign-array-type))
  t)

(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))))

(defun array-element-size (array-type)
  (foreign-type-size (element-type array-type)))

(defmethod foreign-type-size ((type foreign-array-type))
  (* (array-element-size type) (reduce #'* (dimensions type))))

(defmethod foreign-type-alignment ((type foreign-array-type))
  (foreign-type-alignment (element-type type)))

(define-parse-method :array (element-type &rest dimensions)
  (assert (plusp (length dimensions)))
  (make-instance 'foreign-array-type
                 :element-type element-type
                 :dimensions dimensions))

(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)))

;;; Automatic translations for the :ARRAY type. Notice that these
;;; translators will also invoke the appropriate translators for for
;;; each of the array's elements since that's the normal behaviour of
;;; the FOREIGN-ARRAY-* operators, but there's a FIXME: **it doesn't
;;; free them yet**

;;; This used to be in a separate type but let's experiment with just
;;; one type for a while. [2008-12-30 LO]

;;; FIXME: those ugly invocations of UNPARSE-TYPE suggest that these
;;; foreign array operators should take the type and dimention
;;; arguments "unboxed". [2008-12-31 LO]

(defmethod translate-to-foreign (array (type foreign-array-type))
  (foreign-array-alloc array (unparse-type type)))

(defmethod translate-aggregate-to-foreign (ptr value (type foreign-array-type))
  (lisp-array-to-foreign value ptr (unparse-type type)))

(defmethod translate-from-foreign (pointer (type foreign-array-type))
  (foreign-array-to-lisp pointer (unparse-type type)))

(defmethod free-translated-object (pointer (type foreign-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)
   ;; FIXME: the type should probably be parsed?
   (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."))

;;; Since MEM-REF returns a pointer for struct types we are able to
;;; chain together slot names when accessing slot values in nested
;;; structures.
(defmethod foreign-struct-slot-value (ptr (slot aggregate-struct-slot))
  "Return a pointer to SLOT relative to PTR."
  (convert-from-foreign (inc-pointer ptr (slot-offset slot))
                        (slot-type slot)))

(defmethod foreign-struct-slot-value-form (ptr (slot aggregate-struct-slot))
  "Return a form to get the value of SLOT relative to PTR."
  `(convert-from-foreign (inc-pointer ,ptr ,(slot-offset slot))
                         ',(slot-type slot)))

(defmethod translate-aggregate-to-foreign (ptr value (type foreign-struct-type))
  ;;; FIXME: use the block memory interface instead.
  (loop for i below (foreign-type-size type)
        do (%mem-set (%mem-ref value :char i) ptr :char i)))

(defmethod (setf foreign-struct-slot-value)
    (value ptr (slot aggregate-struct-slot))
  "Set the value of an aggregate SLOT to VALUE in PTR."
  (translate-aggregate-to-foreign (inc-pointer ptr (slot-offset slot))
                                  value
                                  (parse-type (slot-type slot))))

(defmethod foreign-struct-slot-set-form (value ptr (slot aggregate-struct-slot))
  "Return a form to get the value of an aggregate SLOT relative to PTR."
  `(setf (foreign-struct-slot-value ,ptr ',(slot-name slot)) ,value))

;;;## 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 darwin ppc)
             (foreign-type-alignment type)
             #+(and darwin ppc)
             (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 options slots)
  "Parse and install a foreign structure definition."
  (destructuring-bind (&key size (class 'foreign-struct-type))
      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))))

(defun generate-struct-accessors (name conc-name slot-names)
  (loop with pointer-arg = (symbolicate '#:pointer-to- name)
        for slot in slot-names
        for accessor = (symbolicate conc-name slot)
        collect `(defun ,accessor (,pointer-arg)
                   (foreign-slot-value ,pointer-arg ',name ',slot))
        collect `(defun (setf ,accessor) (value ,pointer-arg)
                   (foreign-slot-set value ,pointer-arg ',name ',slot))))

(defmacro defcstruct (name-and-options &body fields)
  "Define the layout of a foreign structure."
  (discard-docstring fields)
  (destructuring-bind (name . options)
      (ensure-list name-and-options)
    (let ((conc-name (getf options :conc-name)))
      (remf options :conc-name)
      `(eval-when (:compile-toplevel :load-toplevel :execute)
         ;; m-f-s-t could do with this with mop:ensure-class.
         ,(when-let (class (getf options :class))
            `(defclass ,class (foreign-struct-type) ()))
         (notice-foreign-struct-definition ',name ',options ',fields)
         ,@(when conc-name
             (generate-struct-accessors name conc-name
                                        (mapcar #'car fields)))
         ',name))))

;;;## 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))))

;;; We could add an option to define a struct instead of a class, in
;;; the unlikely event someone needs something like that.
(defmacro define-c-struct-wrapper (class-and-type supers &optional slots)
  "Define a new class with CLOS slots matching those of a foreign
struct type.  An INITIALIZE-INSTANCE method is defined which
takes a :POINTER initarg that is used to store the slots of a
foreign object.  This pointer is only used for initialization and
it is not retained.

CLASS-AND-TYPE is either a list of the form (class-name
struct-type) or a single symbol naming both.  The class will
inherit SUPERS.  If a list of SLOTS is specified, only those
slots will be defined and stored."
  (destructuring-bind (class-name &optional (struct-type class-name))
      (ensure-list class-and-type)
    (let ((slots (or slots (foreign-slot-names struct-type))))
      `(progn
         (defclass ,class-name ,supers
           ,(loop for slot in slots collect
                  `(,slot :reader ,(format-symbol t "~A-~A" class-name slot))))
         ;; This could be done in a parent class by using
         ;; FOREIGN-SLOT-NAMES when instantiating but then the compiler
         ;; macros wouldn't kick in.
         (defmethod initialize-instance :after ((inst ,class-name) &key pointer)
           (with-foreign-slots (,slots pointer ,struct-type)
             ,@(loop for slot in slots collect
                     `(setf (slot-value inst ',slot) ,slot))))
         ',class-name))))

;;;# 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)))

;;; Simple compiler macro that kicks in when TYPE is constant and only
;;; the COUNT argument is passed.  (Note: hard-coding the type's size
;;; into the fasl will likely break CLISP fasl cross-platform
;;; compatibilty.)
(define-compiler-macro foreign-alloc (&whole form type &rest args
                                      &key (count 1 count-p) &allow-other-keys)
  (if (or (and count-p (<= (length args) 2)) (null args))
      (cond
        ((and (constantp type) (constantp count))
         `(%foreign-alloc ,(* (eval count) (foreign-type-size (eval type)))))
        ((constantp type)
         `(%foreign-alloc (* ,count ,(foreign-type-size (eval type)))))
        (t form))
      form))

(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-sys::no-long-long :long-long
       #-cffi-sys::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)
(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-or-type) in sized-types
                    for m = (car (member (if (keywordp size-or-type)
                                             (foreign-type-size size-or-type)
                                             size-or-type)
                                         mtypes :key #'foreign-type-size))
                    when m collect `(defctype ,type ,m)))))
    ;; signed
    (match-types ((:int8 . 1) (:int16 . 2) (:int32 . 4) (:int64 . 8)
                  (:intptr . :pointer))
                 (:char :short :int :long :long-long))
    ;; unsigned
    (match-types ((:uint8 . 1) (:uint16 . 2) (:uint32 . 4) (:uint64 . 8)
                  (:uintptr . :pointer))
                 (:unsigned-char :unsigned-short :unsigned-int :unsigned-long
                  :unsigned-long-long))))
cffi-20100219.orig/src/enum.lisp0000644000175000017500000002147111345222703016502 0ustar  pvaneyndpvaneynd;;;; -*- 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))
cffi-20100219.orig/grovel/0002755000175000017500000000000011345222703015351 5ustar  pvaneyndpvaneyndcffi-20100219.orig/grovel/invoke.lisp0000644000175000017500000001152011345222703017532 0ustar  pvaneyndpvaneynd;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; invoke.lisp --- Half-baked portable run-program.
;;;
;;; Copyright (C) 2005-2006, Dan Knap 
;;; Copyright (C) 2005-2006, Matthew Backes 
;;; Copyright (C) 2007, Stelian Ionescu 
;;; 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.
;;;

(in-package #:cffi-grovel)

;;;# Shell Execution

#-(or abcl allegro clisp cmu ecl lispworks openmcl sbcl scl)
(error "%INVOKE is unimplemented for this Lisp.  Patches welcome.")

;; FIXME: doesn't do shell quoting
#+abcl
(defun %invoke (command arglist)
  (let ((cmdline (reduce (lambda (str1 str2)
                           (concatenate 'string str1 #\Space str2))
                         arglist :initial-value command))
        (stream (make-string-output-stream)))
    (values (ext:run-shell-command cmdline :output stream)
            (get-output-stream-string stream))))

;;; FIXME: As best I can tell CLISP's EXT:RUN-PROGRAM can either
;;; create new streams OR return the exit code, but not both.  Using
;;; existing streams doesn't seem to be an option either.
#+clisp
(defun %invoke (command arglist)
  (let ((ret (ext:run-program command :arguments arglist)))
    (values (etypecase ret
              ((eql nil) 0)
              ((eql   t) 1)
              (integer   ret))
            "")))

;;; FIXME: there's no way to tell from EXT:RUN-PROGRAM whether the
;;; command failed or not.  Using EXT:SYSTEM instead, but we should
;;; quote arguments.
#+ecl
(defun %invoke (command arglist)
  (values (ext:system (format nil "~A~{ ~A~}" command arglist))
          ""))

#+(or openmcl cmu scl sbcl)
(defun %invoke (command arglist)
  (let* ((exit-code)
         (output
          (with-output-to-string (s)
            (let ((process (#+openmcl ccl:run-program
                            #+(or cmu scl) ext:run-program
                            #+sbcl sb-ext:run-program
                            command arglist #-win32 :output #-win32 s
                            :error :output
                            #+sbcl :search #+sbcl t)))
              #+win32
              (write-line "note: SBCL on windows can't redirect output.")
              (setq exit-code
                    #+openmcl (nth-value
                               1 (ccl:external-process-status process))
                    #+sbcl (sb-ext:process-exit-code process)
                    #+(or cmu scl) (ext:process-exit-code process))))))
    (values exit-code output)))

#+allegro
(eval-when (:compile-toplevel :load-toplevel :execute)
  (require '#:osi))

#+allegro
(defun %invoke (command arglist)
  (let ((cmd #-mswindows (concatenate 'vector (list command command) arglist)
             #+mswindows (format nil "~A~{ ~A~}" command arglist)))
    (multiple-value-bind (output error-output exit-code)
        (excl.osi:command-output cmd :whole t)
      (declare (ignore error-output))
      (values exit-code output))))

;;; FIXME: Runs shell, and arguments are unquoted.
#+lispworks
(defun %invoke (command arglist)
  (let ((s (make-string-output-stream)))
    (values (sys:call-system-showing-output
             (format nil "~A~{ ~A~}" command arglist)
             :output-stream s :prefix "" :show-cmd nil)
            (get-output-stream-string s))))

;;; Do we really want to suppress the output by default?
(defun invoke (command &rest args)
  (when (pathnamep command)
    (setf command (cffi-sys:native-namestring command)))
  (format *debug-io* "; ~A~{ ~A~}~%" command args)
  (multiple-value-bind (exit-code output)
      (%invoke command args)
    (unless (zerop exit-code)
      (error "External process exited with code ~S.~@
              Command was: ~S~{ ~S~}~@
              Output was:~%~A"
             exit-code command args output))))
cffi-20100219.orig/grovel/grovel.lisp0000644000175000017500000007550211345222703017547 0ustar  pvaneyndpvaneynd;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; grovel.lisp --- The CFFI Groveller.
;;;
;;; Copyright (C) 2005-2006, Dan Knap 
;;; Copyright (C) 2005-2006, Matthew Backes 
;;; Copyright (C) 2007, Stelian Ionescu 
;;; 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.
;;;

(in-package #:cffi-grovel)

;;;# Utils

(defun trim-whitespace (strings)
  (loop for s in strings
        collect (string-trim '(#\Space #\Tab) s)))

;;;# Error Conditions

;;; This warning is signalled when cffi-grovel can't find some macro.
;;; Signalled by CONSTANT or CONSTANTENUM.
(define-condition missing-definition (warning)
  ((%name :initarg :name :reader name-of))
  (:report (lambda (condition stream)
             (format stream "No definition for ~A"
                     (name-of condition)))))

;;;# Grovelling

(defparameter *cc*
  #+(or cygwin (not windows)) "cc"
  #+(and windows (not cygwin)) "c:/msys/1.0/bin/gcc.exe")

(defparameter *cc-flags* nil)

;;; The header of the intermediate C file.
(defparameter *header*
  "/*
 * This file has been automatically generated by cffi-grovel.
 * Do not edit it by hand.
 */

")

;;; C code generated by cffi-grovel is inserted between the contents
;;; of *PROLOGUE* and *POSTSCRIPT*, inside the main function's body.

(defparameter *prologue*
  "
#include 

int main(int argc, char**argv) {
  FILE *output = argc > 1 ? fopen(argv[1], \"w\") : stdout;
  fprintf(output, \";;;; This file has been automatically generated by \"
                  \"cffi-grovel.\\n;;;; Do not edit it by hand.\\n\\n\");
")

(defparameter *postscript*
  "
  if  (output != stdout)
    fclose(output);
  return 0;
}
")

(defun unescape-for-c (text)
  (with-output-to-string (result)
    (loop for i below (length text)
          for char = (char text i) do
          (cond ((eql char #\") (princ "\\\"" result))
                ((eql char #\newline) (princ "\\n" result))
                (t (princ char result))))))

(defun c-format (out fmt &rest args)
  (let ((text (unescape-for-c (format nil "~?" fmt args))))
    (format out "~&  fprintf(output, \"~A\");~%" text)))

(defun c-printf (out fmt &rest args)
  (flet ((item (item)
           (format out "~A" (unescape-for-c (format nil item)))))
    (format out "~&  fprintf(output, \"")
    (item fmt)
    (format out "\"")
    (loop for arg in args do
          (format out ", ")
          (item arg))
    (format out ");~%")))

;;; TODO: handle packages in a better way. One way is to process each
;;; grovel form as it is read (like we already do for wrapper
;;; forms). This way in can expect *PACKAGE* to have sane values.
;;; This would require that "header forms" come before any other
;;; forms.
(defun c-print-symbol (out symbol &optional no-package)
  (c-format out
            (let ((package (symbol-package symbol)))
              (cond
                ((eq (find-package '#:keyword) package) ":~(~A~)")
                (no-package "~(~A~)")
                ((eq (find-package '#:cl) package) "cl:~(~A~)")
                (t "~(~A~)")))
            symbol))

(defun c-write (out form &key recursive)
  (cond
    ((and (listp form)
          (eq 'quote (car form)))
     (c-format out "'")
     (c-write out (cadr form) :recursive t))
    ((listp form)
     (c-format out "(")
     (loop for subform in form
           for first-p = t then nil
           unless first-p do (c-format out " ")
           do (c-write out subform :recursive t))
     (c-format out ")"))
    ((symbolp form)
     (c-print-symbol out form)))
  (unless recursive
    (c-format out "~%")))

;;; Always NIL for now, add {ENABLE,DISABLE}-AUTO-EXPORT grovel forms
;;; later, if necessary.
(defvar *auto-export* nil)

(defun c-export (out symbol)
  (when (and *auto-export* (not (keywordp symbol)))
    (c-format out "(cl:export '")
    (c-print-symbol out symbol t)
    (c-format out ")~%")))

(defun c-section-header (out section-type section-symbol)
  (format out "~%  /* ~A section for ~S */~%"
          section-type
          section-symbol))

(defun remove-suffix (string suffix)
  (let ((suffix-start (- (length string) (length suffix))))
    (if (and (> suffix-start 0)
             (string= string suffix :start1 suffix-start))
        (subseq string 0 suffix-start)
        string)))

(defun strcat (&rest strings)
  (apply #'concatenate 'string strings))

(defgeneric %process-grovel-form (name out arguments)
  (:method (name out arguments)
    (declare (ignore out arguments))
    (error "Unknown Grovel syntax: ~S" name)))

(defun process-grovel-form (out form)
  (%process-grovel-form (form-kind form) out (cdr form)))

(defun form-kind (form)
  ;; Using INTERN here instead of FIND-SYMBOL will result in less
  ;; cryptic error messages when an undefined grovel/wrapper form is
  ;; found.
  (intern (symbol-name (car form)) '#:cffi-grovel))

(defvar *header-forms* '(c include define flag typedef))

(defun header-form-p (form)
  (member (form-kind form) *header-forms*))

(defun generate-c-file (input-file output-defaults)
  (let ((c-file (make-pathname :type "c" :defaults output-defaults)))
    (with-open-file (out c-file :direction :output :if-exists :supersede)
      (with-open-file (in input-file :direction :input)
        (flet ((read-forms (s)
                 (do ((forms ())
                      (form (read s nil nil) (read s nil nil)))
                     ((null form) (nreverse forms))
                   (labels
                       ((process-form (f)
                          (case (form-kind f)
                            (flag (warn "Groveler clause FLAG is deprecated, use CC-FLAGS instead.")))
                          (case (form-kind f)
                            (in-package
                             (setf *package* (find-package (second f)))
                             (push f forms))
                            (progn
                              ;; flatten progn forms
                              (mapc #'process-form (rest f)))
                            (t (push f forms)))))
                     (process-form form)))))
          (let* ((forms (read-forms in))
                 (header-forms (remove-if-not #'header-form-p forms))
                 (body-forms (remove-if #'header-form-p forms)))
            (write-string *header* out)
            (dolist (form header-forms)
              (process-grovel-form out form))
            (write-string *prologue* out)
            (dolist (form body-forms)
              (process-grovel-form out form))
            (write-string *postscript* out)))))
    c-file))

(defparameter *exe-extension* #-windows nil #+windows "exe")

(defun exe-filename (defaults)
  (let ((path (make-pathname :type *exe-extension*
                             :defaults defaults)))
    ;; It's necessary to prepend "./" to relative paths because some
    ;; implementations of INVOKE use a shell.
    (when (or (not (pathname-directory path))
              (eq :relative (car (pathname-directory path))))
      (setf path (make-pathname
                  :directory (list* :relative "."
                                    (cdr (pathname-directory path)))
                  :defaults path)))
    path))

(defun tmp-lisp-filename (defaults)
  (make-pathname :name (strcat (pathname-name defaults) ".grovel-tmp")
                 :type "lisp" :defaults defaults))

(cffi:defcfun "getenv" :string
  (name :string))

;;; FIXME: is there a better way to detect whether these flags
;;; are necessary?
(defparameter *cpu-word-size-flags*
  (ecase (cffi:foreign-type-size :long)
    (4 (list "-m32"))
    (8 (list "-m64"))))

(defparameter *platform-library-flags*
  (list #+darwin "-bundle" #-darwin "-shared"))

(defun cc-compile-and-link (input-file output-file &key library)
  (let ((arglist
         `(,(or (getenv "CC") *cc*)
           ,@*cpu-word-size-flags*
           ,@*cc-flags*
           ;; add the cffi directory to the include path to make common.h visible
           ,(format nil "-I~A"
                    (directory-namestring
                     (truename
                      (asdf:system-definition-pathname :cffi-grovel))))
           ,@(when library *platform-library-flags*)
           "-fPIC" "-o"
           ,(native-namestring output-file)
           ,(native-namestring input-file))))
    (apply #'invoke arglist)))

;;; *PACKAGE* is rebound so that the IN-PACKAGE form can set it during
;;; *the extent of a given grovel file.
(defun process-grovel-file (input-file &optional (output-defaults input-file))
  (with-standard-io-syntax
    (let* ((c-file (generate-c-file input-file output-defaults))
           (exe-file (exe-filename c-file))
           (lisp-file (tmp-lisp-filename c-file)))
      (cc-compile-and-link c-file exe-file)
      (invoke exe-file (native-namestring lisp-file))
      lisp-file)))

;;; OUT is lexically bound to the output stream within BODY.
(defmacro define-grovel-syntax (name lambda-list &body body)
  (with-unique-names (name-var args)
    `(defmethod %process-grovel-form ((,name-var (eql ',name)) out ,args)
       (declare (ignorable out))
       (destructuring-bind ,lambda-list ,args
         ,@body))))

(define-grovel-syntax c (body)
  (format out "~%~A~%" body))

(define-grovel-syntax include (&rest includes)
  (format out "~{#include <~A>~%~}" includes))

(define-grovel-syntax define (name &optional value)
  (format out "#define ~A~@[ ~A~]~%" name value))

(define-grovel-syntax typedef (base-type new-type)
  (format out "typedef ~A ~A;~%" base-type new-type))

;;; Is this really needed?
(define-grovel-syntax ffi-typedef (new-type base-type)
  (c-format out "(cffi:defctype ~S ~S)~%" new-type base-type))

(define-grovel-syntax flag (&rest flags)
  (appendf *cc-flags* (trim-whitespace flags)))

(define-grovel-syntax cc-flags (&rest flags)
  (appendf *cc-flags* (trim-whitespace flags)))

;;; This form also has some "read time" effects. See GENERATE-C-FILE.
(define-grovel-syntax in-package (name)
  (c-format out "(cl:in-package #:~A)~%~%" name))

(define-grovel-syntax ctype (lisp-name size-designator)
  (c-section-header out "ctype" lisp-name)
  (c-export out lisp-name)
  (c-format out "(cffi:defctype ")
  (c-print-symbol out lisp-name t)
  (c-format out " ")
  (format out "~&  type_name(output, SIGNEDP(~A), ~:[sizeof(~A)~;~D~]);~%"
          size-designator
          (etypecase size-designator
            (string nil)
            (integer t))
          size-designator)
  (c-format out ")~%")
  (unless (keywordp lisp-name)
    (c-export out lisp-name))
  (let ((size-of-constant-name (symbolicate '#:size-of- lisp-name)))
    (c-export out size-of-constant-name)
    (c-format out "(cl:defconstant "
              size-of-constant-name lisp-name)
    (c-print-symbol out size-of-constant-name)
    (c-format out " (cffi:foreign-type-size '")
    (c-print-symbol out lisp-name)
    (c-format out "))~%")))

;;; Syntax differs from anything else in CFFI.  Fix?
(define-grovel-syntax constant ((lisp-name &rest c-names)
                                &key (type 'integer) documentation optional)
  (when (keywordp lisp-name)
    (setf lisp-name (format-symbol "~A" lisp-name)))
  (c-section-header out "constant" lisp-name)
  (dolist (c-name c-names)
    (format out "~&#ifdef ~A~%" c-name)
    (c-export out lisp-name)
    (c-format out "(cl:defconstant ")
    (c-print-symbol out lisp-name t)
    (c-format out " ")
    (ecase type
      (integer
       (format out "~&  if(SIGNED64P(~A))~%" c-name)
       (format out "    fprintf(output, \"%lli\", (int64_t) ~A);" c-name)
       (format out "~&  else~%")
       (format out "    fprintf(output, \"%llu\", (uint64_t) ~A);" c-name))
      (double-float
       (format out "~&  fprintf(output, \"%s\", print_double_for_lisp((double)~A));~%" c-name)))
    (when documentation
      (c-format out " ~S" documentation))
    (c-format out ")~%")
    (format out "~&#else~%"))
  (unless optional
    (c-format out "(cl:warn 'cffi-grovel:missing-definition :name '~A)~%"
              lisp-name))
  (dotimes (i (length c-names))
    (format out "~&#endif~%")))

(define-grovel-syntax cunion (union-lisp-name union-c-name &rest slots)
  (let ((documentation (when (stringp (car slots)) (pop slots))))
    (c-section-header out "cunion" union-lisp-name)
    (c-export out union-lisp-name)
    (dolist (slot slots)
      (let ((slot-lisp-name (car slot)))
        (c-export out slot-lisp-name)))
    (c-format out "(cffi:defcunion (")
    (c-print-symbol out union-lisp-name t)
    (c-printf out " :size %i)" (format nil "sizeof(~A)" union-c-name))
    (when documentation
      (c-format out "~%  ~S" documentation))
    (dolist (slot slots)
      (destructuring-bind (slot-lisp-name slot-c-name &key type count)
          slot
        (declare (ignore slot-c-name))
        (c-format out "~%  (")
        (c-print-symbol out slot-lisp-name t)
        (c-format out " ")
        (c-print-symbol out type)
        (etypecase count
          (integer
           (c-format out " :count ~D" count))
          ((eql :auto)
           ;; nb, works like :count :auto does in cstruct below
           (c-printf out " :count %i"
                     (format nil "sizeof(~A)" union-c-name)))
          (null t))
        (c-format out ")")))
    (c-format out ")~%")))

(defun make-from-pointer-function-name (type-name)
  (symbolicate '#:make- type-name '#:-from-pointer))

;;; DEFINE-C-STRUCT-WRAPPER (in ../src/types.lisp) seems like a much
;;; cleaner way to do this.  Unless I can find any advantage in doing
;;; it this way I'll delete this soon.  --luis
(define-grovel-syntax cstruct-and-class-item (&rest arguments)
  (process-grovel-form out (cons 'cstruct arguments))
  (destructuring-bind (struct-lisp-name struct-c-name &rest slots)
      arguments
    (declare (ignore struct-c-name))
    (let* ((slot-names (mapcar #'car slots))
           (reader-names (mapcar
                          (lambda (slot-name)
                            (intern
                             (strcat (symbol-name struct-lisp-name) "-"
                                     (symbol-name slot-name))))
                          slot-names))
           (initarg-names (mapcar
                           (lambda (slot-name)
                             (intern (symbol-name slot-name) "KEYWORD"))
                           slot-names))
           (slot-decoders (mapcar (lambda (slot)
                                    (destructuring-bind
                                          (lisp-name c-name
                                                     &key type count
                                                     &allow-other-keys)
                                        slot
                                      (declare (ignore lisp-name c-name))
                                      (cond ((and (eq type :char) count)
                                             'cffi:foreign-string-to-lisp)
                                            (t nil))))
                                  slots))
           (defclass-form
            `(defclass ,struct-lisp-name ()
               ,(mapcar (lambda (slot-name initarg-name reader-name)
                          `(,slot-name :initarg ,initarg-name
                                       :reader ,reader-name))
                        slot-names
                        initarg-names
                        reader-names)))
           (make-function-name
            (make-from-pointer-function-name struct-lisp-name))
           (make-defun-form
            ;; this function is then used as a constructor for this class.
            `(defun ,make-function-name (pointer)
               (cffi:with-foreign-slots
                   (,slot-names pointer ,struct-lisp-name)
                 (make-instance ',struct-lisp-name
                                ,@(loop for slot-name in slot-names
                                        for initarg-name in initarg-names
                                        for slot-decoder in slot-decoders
                                        collect initarg-name
                                        if slot-decoder
                                        collect `(,slot-decoder ,slot-name)
                                        else collect slot-name))))))
      (c-export out make-function-name)
      (dolist (reader-name reader-names)
        (c-export out reader-name))
      (c-write out defclass-form)
      (c-write out make-defun-form))))

(define-grovel-syntax cstruct (struct-lisp-name struct-c-name &rest slots)
  (let ((documentation (when (stringp (car slots)) (pop slots))))
    (c-section-header out "cstruct" struct-lisp-name)
    (c-export out struct-lisp-name)
    (dolist (slot slots)
      (let ((slot-lisp-name (car slot)))
        (c-export out slot-lisp-name)))
    (c-format out "(cffi:defcstruct (")
    (c-print-symbol out struct-lisp-name t)
    (c-printf out " :size %i)"
              (format nil "sizeof(~A)" struct-c-name))
    (when documentation
      (c-format out "~%  ~S" documentation))
    (dolist (slot slots)
      (destructuring-bind (slot-lisp-name slot-c-name &key type count)
          slot
        (c-format out "~%  (")
        (c-print-symbol out slot-lisp-name t)
        (c-format out " ")
        (c-print-symbol out type)
        (etypecase count
          (null t)
          (integer
           (c-format out " :count ~D" count))
          ((eql :auto)
           (c-printf out " :count %i"
                     (format nil "sizeof(~A) - offsetof(~A, ~A)"
                             struct-c-name
                             struct-c-name
                             slot-c-name)))
          ((or symbol string)
           (format out "~&#ifdef ~A~%" count)
           (c-printf out " :count %i"
                     (format nil "~A" count))
           (format out "~&#endif~%")))
        (c-printf out " :offset %i)"
                  (format nil "offsetof(~A, ~A)"
                          struct-c-name
                          slot-c-name))))
    (c-format out ")~%")
    (let ((size-of-constant-name
           (symbolicate '#:size-of- struct-lisp-name)))
      (c-export out size-of-constant-name)
      (c-format out "(cl:defconstant "
                size-of-constant-name struct-lisp-name)
      (c-print-symbol out size-of-constant-name)
      (c-format out " (cffi:foreign-type-size '")
      (c-print-symbol out struct-lisp-name)
      (c-format out "))~%"))))

(defmacro define-pseudo-cvar (str name type &key read-only)
  (let ((c-parse (let ((*read-eval* nil)
                       (*readtable* (copy-readtable nil)))
                   (setf (readtable-case *readtable*) :preserve)
                   (read-from-string str))))
    (typecase c-parse
      (symbol `(cffi:defcvar (,(symbol-name c-parse) ,name) ,type
                 :read-only ,read-only))
      (list (unless (and (= (length c-parse) 2)
                         (null (second c-parse))
                         (symbolp (first c-parse))
                         (eql #\* (char (symbol-name (first c-parse)) 0)))
              (error "Unable to parse c-string ~s." str))
            (let ((func-name (symbolicate "%" name '#:-accessor)))
              `(progn
                 (declaim (inline ,func-name))
                 (cffi:defcfun (,(string-trim "*" (symbol-name (first c-parse)))
                                 ,func-name) :pointer)
                 (define-symbol-macro ,name
                     (cffi:mem-ref (,func-name) ',type)))))
      (t (error "Unable to parse c-string ~s." str)))))

(defun foreign-name-to-symbol (s)
  (intern (substitute #\- #\_ (string-upcase s))))

(defun choose-lisp-and-foreign-names (string-or-list)
  (etypecase string-or-list
    (string (values string-or-list (foreign-name-to-symbol string-or-list)))
    (list (destructuring-bind (fname lname &rest args) string-or-list
            (declare (ignore args))
            (assert (and (stringp fname) (symbolp lname)))
            (values fname lname)))))

(define-grovel-syntax cvar (name type &key read-only)
  (multiple-value-bind (c-name lisp-name)
      (choose-lisp-and-foreign-names name)
    (c-section-header out "cvar" lisp-name)
    (c-export out lisp-name)
    (c-printf out "(cffi-grovel::define-pseudo-cvar \"%s\" "
              (format nil "indirect_stringify(~A)" c-name))
    (c-print-symbol out lisp-name t)
    (c-format out " ")
    (c-print-symbol out type)
    (when read-only
      (c-format out " :read-only t"))
    (c-format out ")~%")))

;;; FIXME: where would docs on enum elements go?
(define-grovel-syntax cenum (name &rest enum-list)
  (destructuring-bind (name &key base-type define-constants)
      (ensure-list name)
    (c-section-header out "cenum" name)
    (c-export out name)
    (c-format out "(cffi:defcenum (")
    (c-print-symbol out name t)
    (when base-type
      (c-printf out " ")
      (c-print-symbol out base-type t))
    (c-format out ")")
    (dolist (enum enum-list)
      (destructuring-bind ((lisp-name &rest c-names) &key documentation)
          enum
        (declare (ignore documentation))
        (check-type lisp-name keyword)
        (loop :for c-name :in c-names :do
           (check-type c-name string)
           (c-format out "  (")
           (c-print-symbol out lisp-name)
           (c-format out " ")
           (c-printf out "%i" c-name)
           (c-format out ")~%"))))
    (c-format out ")~%")
    (when define-constants
      (define-constants-from-enum out enum-list))))

(define-grovel-syntax constantenum (name &rest enum-list)
  (destructuring-bind (name &key base-type define-constants)
      (ensure-list name)
    (c-section-header out "constantenum" name)
    (c-export out name)
    (c-format out "(cffi:defcenum (")
    (c-print-symbol out name t)
    (when base-type
      (c-printf out " ")
      (c-print-symbol out base-type t))
    (c-format out ")")
    (dolist (enum enum-list)
      (destructuring-bind ((lisp-name &rest c-names)
                           &key optional documentation) enum
        (declare (ignore documentation))
        (check-type lisp-name keyword)
        (c-format out "~%  (")
        (c-print-symbol out lisp-name)
        (loop for c-name in c-names do
             (check-type c-name string)
             (format out "~&#ifdef ~A~%" c-name)
             (c-format out " ")
             (c-printf out "%i" c-name)
             (format out "~&#else~%"))
        (unless optional
          (c-format out
                    "~%  #.(cl:progn ~
                           (cl:warn 'cffi-grovel:missing-definition :name '~A) ~
                           -1)"
                    lisp-name))
        (dotimes (i (length c-names))
          (format out "~&#endif~%"))
        (c-format out ")")))
    (c-format out ")~%")
    (when define-constants
      (define-constants-from-enum out enum-list))))

(defun define-constants-from-enum (out enum-list)
  (dolist (enum enum-list)
    (destructuring-bind ((lisp-name &rest c-names) &rest options)
        enum
      (%process-grovel-form
       'constant out
       `((,(intern (string lisp-name)) ,(car c-names))
         ,@options)))))


;;;# Wrapper Generation
;;;
;;; Here we generate a C file from a s-exp specification but instead
;;; of compiling and running it, we compile it as a shared library
;;; that can be subsequently loaded with LOAD-FOREIGN-LIBRARY.
;;;
;;; Useful to get at macro functionality, errno, system calls,
;;; functions that handle structures by value, etc...
;;;
;;; Matching CFFI bindings are generated along with said C file.

(defun process-wrapper-form (out form)
  (%process-wrapper-form (form-kind form) out (cdr form)))

;;; The various operators push Lisp forms onto this list which will be
;;; written out by PROCESS-WRAPPER-FILE once everything is processed.
(defvar *lisp-forms*)

(defun generate-c-lib-file (input-file output-defaults)
  (let ((*lisp-forms* nil)
        (c-file (make-pathname :type "c" :defaults output-defaults)))
    (with-open-file (out c-file :direction :output :if-exists :supersede)
      (with-open-file (in input-file :direction :input)
        (write-string *header* out)
        (loop for form = (read in nil nil) while form
              do (process-wrapper-form out form))))
    (values c-file (nreverse *lisp-forms*))))

(defun lib-filename (defaults)
  (make-pathname :type (subseq (cffi::default-library-suffix) 1)
                 :defaults defaults))

(defun generate-bindings-file (lib-file lib-soname lisp-forms output-defaults)
  (let ((lisp-file (tmp-lisp-filename output-defaults)))
    (with-open-file (out lisp-file :direction :output :if-exists :supersede)
      (format out ";;;; This file was automatically generated by cffi-grovel.~%~
                   ;;;; Do not edit by hand.~%")
      (let ((*package* (find-package '#:cl))
            (named-library-name
             (let ((*package* (find-package :keyword))
                   (*read-eval* nil))
               (read-from-string lib-soname))))
        (pprint `(progn
                   (cffi:define-foreign-library
                       (,named-library-name
                        :type :grovel-wrapper
                        :search-path ,(directory-namestring lib-file))
                     (t ,(namestring (lib-filename lib-soname))))
                   (cffi:use-foreign-library ,named-library-name))
                out)
        (fresh-line out))
      (dolist (form lisp-forms)
        (print form out))
      (terpri out))
    lisp-file))

;;; *PACKAGE* is rebound so that the IN-PACKAGE form can set it during
;;; *the extent of a given wrapper file.
(defun process-wrapper-file (input-file output-defaults lib-soname)
  (with-standard-io-syntax
    (let ((lib-file
           (lib-filename (make-pathname :name lib-soname
                                        :defaults output-defaults))))
      (multiple-value-bind (c-file lisp-forms)
          (generate-c-lib-file input-file output-defaults)
        (cc-compile-and-link c-file lib-file :library t)
        ;; FIXME: hardcoded library path.
        (values (generate-bindings-file lib-file lib-soname lisp-forms output-defaults)
                lib-file)))))

(defgeneric %process-wrapper-form (name out arguments)
  (:method (name out arguments)
    (declare (ignore out arguments))
    (error "Unknown Grovel syntax: ~S" name)))

;;; OUT is lexically bound to the output stream within BODY.
(defmacro define-wrapper-syntax (name lambda-list &body body)
  (with-unique-names (name-var args)
    `(defmethod %process-wrapper-form ((,name-var (eql ',name)) out ,args)
       (declare (ignorable out))
       (destructuring-bind ,lambda-list ,args
         ,@body))))

(define-wrapper-syntax progn (&rest forms)
  (dolist (form forms)
    (process-wrapper-form out form)))

(define-wrapper-syntax in-package (name)
  (setq *package* (find-package name))
  (push `(in-package ,name) *lisp-forms*))

(define-wrapper-syntax c (&rest strings)
  (dolist (string strings)
    (write-line string out)))

(define-wrapper-syntax flag (&rest flags)
  (appendf *cc-flags* (trim-whitespace flags)))

(define-wrapper-syntax proclaim (&rest proclamations)
  (push `(proclaim ,@proclamations) *lisp-forms*))

(define-wrapper-syntax declaim (&rest declamations)
  (push `(declaim ,@declamations) *lisp-forms*))

(define-wrapper-syntax define (name &optional value)
  (format out "#define ~A~@[ ~A~]~%" name value))

(define-wrapper-syntax include (&rest includes)
  (format out "~{#include <~A>~%~}" includes))

;;; FIXME: this function is not complete.  Should probably follow
;;; typedefs?  Should definitely understand pointer types.
(defun c-type-name (typespec)
  (let ((spec (ensure-list typespec)))
    (if (stringp (car spec))
        (car spec)
        (case (car spec)
          ((:uchar :unsigned-char) "unsigned char")
          ((:unsigned-short :ushort) "unsigned short")
          ((:unsigned-int :uint) "unsigned int")
          ((:unsigned-long :ulong) "unsigned long")
          ((:long-long :llong) "long long")
          ((:unsigned-long-long :ullong) "unsigned long long")
          (:pointer "void*")
          (:string "char*")
          (t (cffi::foreign-name (car spec)))))))

(defun cffi-type (typespec)
  (if (and (listp typespec) (stringp (car typespec)))
      (second typespec)
      typespec))

(define-wrapper-syntax defwrapper (name-and-options rettype &rest args)
  (multiple-value-bind (lisp-name foreign-name options)
      (cffi::parse-name-and-options name-and-options)
    (let* ((foreign-name-wrap (strcat foreign-name "_cffi_wrap"))
           (fargs (mapcar (lambda (arg)
                            (list (c-type-name (second arg))
                                  (cffi::foreign-name (first arg))))
                          args))
           (fargnames (mapcar #'second fargs)))
      ;; output C code
      (format out "~A ~A" (c-type-name rettype) foreign-name-wrap)
      (format out "(~{~{~A ~A~}~^, ~})~%" fargs)
      (format out "{~%  return ~A(~{~A~^, ~});~%}~%~%" foreign-name fargnames)
      ;; matching bindings
      (push `(cffi:defcfun (,foreign-name-wrap ,lisp-name ,@options)
                 ,(cffi-type rettype)
               ,@(mapcar (lambda (arg)
                           (list (cffi::lisp-name (first arg))
                                 (cffi-type (second arg))))
                         args))
            *lisp-forms*))))

(define-wrapper-syntax defwrapper* (name-and-options rettype args &rest c-lines)
  ;; output C code
  (multiple-value-bind (lisp-name foreign-name options)
      (cffi::parse-name-and-options name-and-options)
    (let ((foreign-name-wrap (strcat foreign-name "_cffi_wrap"))
          (fargs (mapcar (lambda (arg)
                           (list (c-type-name (second arg))
                                 (cffi::foreign-name (first arg))))
                         args)))
      (format out "~A ~A" (c-type-name rettype)
              foreign-name-wrap)
      (format out "(~{~{~A ~A~}~^, ~})~%" fargs)
      (format out "{~%~{  ~A~%~}}~%~%" c-lines)
      ;; matching bindings
      (push `(cffi:defcfun (,foreign-name-wrap ,lisp-name ,@options)
                 ,(cffi-type rettype)
               ,@(mapcar (lambda (arg)
                           (list (cffi::lisp-name (first arg))
                                 (cffi-type (second arg))))
                         args))
            *lisp-forms*))))
cffi-20100219.orig/grovel/package.lisp0000644000175000017500000000273511345222703017642 0ustar  pvaneyndpvaneynd;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; package.lisp --- Groveler DEFPACKAGE.
;;;
;;; 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-grovel
  (:use #:common-lisp #:alexandria)
  (:import-from #:cffi-sys #:native-namestring)
  (:export
   ;; Class name
   #:grovel-file
   #:process-grovel-file
   ;; Error condition
   #:missing-definition)
  (:export
   ;; Class name
   #:wrapper-file
   #:process-wrapper-file))
cffi-20100219.orig/grovel/asdf.lisp0000644000175000017500000000754311345222703017166 0ustar  pvaneyndpvaneynd;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; asdf.lisp --- ASDF components for cffi-grovel.
;;;
;;; Copyright (C) 2005-2006, Dan Knap 
;;; Copyright (C) 2005-2006, Matthew Backes 
;;; Copyright (C) 2007, Stelian Ionescu 
;;; 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.
;;;

(in-package #:cffi-grovel)

(defun ensure-pathname (thing)
  (if (typep thing 'logical-pathname)
      (translate-logical-pathname thing)
      (pathname thing)))

(defclass cc-flags-mixin ()
  ((cc-flags :initform nil :accessor cc-flags-of :initarg :cc-flags)))

(defmethod asdf:perform :around ((op asdf:compile-op) (file cc-flags-mixin))
  (let ((*cc-flags* (append (ensure-list (cc-flags-of file))
                            *cc-flags*)))
    (call-next-method)))

;;;# ASDF component: GROVEL-FILE

(defclass grovel-file (asdf:cl-source-file cc-flags-mixin)
  ()
  (:documentation
   "This ASDF component defines COMPILE-OP and LOAD-SOURCE-OP
operations that take care of calling PROCESS-GROVEL-FILE in order
to generate a Lisp file that is subsequently compiled and/or
loaded."))

(defmethod asdf:perform ((op asdf:compile-op) (c grovel-file))
  (let ((output-file (ensure-pathname (car (asdf:output-files op c)))))
    (compile-file (process-grovel-file (asdf:component-pathname c) output-file)
                  :output-file output-file
                  #+ecl :system-p #+ecl t)))

(defmethod asdf:perform ((op asdf:load-source-op) (c grovel-file))
  (load (process-grovel-file
         (asdf:component-pathname c)
         (ensure-pathname (car (asdf:output-files op c))))))

;;;# ASDF component: WRAPPER-FILE

(defclass wrapper-file (asdf:cl-source-file cc-flags-mixin)
  ((soname :initform nil :initarg :soname :accessor soname-of))
  (:documentation
   "This ASDF component defines COMPILE-OP and LOAD-SOURCE-OP
operations that take care of calling PROCESS-WRAPPER-FILE in
order to generate a foreign library and matching CFFI bindings
that are subsequently compiled and/or loaded."))

(defun %perform-process-wrapper-file (op c)
  (let ((fasl-file (ensure-pathname (car (asdf:output-files op c)))))
    (values (process-wrapper-file (asdf:component-pathname c)
                                  fasl-file
                                  (or (soname-of c)
                                      (asdf:component-name c)))
            fasl-file)))

(defmethod asdf:perform ((op asdf:compile-op) (c wrapper-file))
  (multiple-value-bind (generated-source-file fasl-file)
      (%perform-process-wrapper-file op c)
    (compile-file generated-source-file
                  :output-file fasl-file
                  #+ecl :system-p #+ecl t)))

(defmethod asdf:perform ((op asdf:load-source-op) (c wrapper-file))
  (load (%perform-process-wrapper-file op c)))
cffi-20100219.orig/grovel/common.h0000644000175000017500000000237511345222703017017 0ustar  pvaneyndpvaneynd#include 
#include 
#include 
#include 

#ifndef offsetof
#define offsetof(type, slot) ((int) ((char *) &(((type *) 0)->slot)))
#endif
#define sizeofslot(type, slot) (sizeof(((type *) 0)->slot))
#define stringify(x) #x
#define indirect_stringify(x) stringify(x)

#define SIGNEDP(x) (((x)-1)<0)
#define SIGNED64P(x) ( x <= 0x7FFFFFFFFFFFFFFFLL )

void type_name(FILE *output, int signed_p, int size) {
  if (signed_p) {
    switch (size) {
    case 1: fprintf(output, ":int8"); break;
    case 2: fprintf(output, ":int16"); break;
    case 4: fprintf(output, ":int32"); break;
    case 8: fprintf(output, ":int64"); break;
    default: goto error;
    }
  } else {
    switch(size) {
    case 1: fprintf(output, ":uint8"); break;
    case 2: fprintf(output, ":uint16"); break;
    case 4: fprintf(output, ":uint32"); break;
    case 8: fprintf(output, ":uint64"); break;
    default: goto error;
    }
  }

  return;

error:
  fprintf(output, "(cl:error \"No type of size ~D.\" %i)\n", size);
}

char* print_double_for_lisp(double n)
{
    static char buf[256];
    memset(buf, 0, 256);
    snprintf(buf, 255, "(let ((*read-default-float-format* 'double-float)) (coerce (read-from-string \"%.20E\") 'double-float))", n);
    return buf;
}
cffi-20100219.orig/cffi-examples.asd0000644000175000017500000000302411345222703017264 0ustar  pvaneyndpvaneynd;;;; -*- 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))