cffi_0.16.1/000755 000765 000024 00000000000 12566330641 012715 5ustar00luisstaff000000 000000 cffi_0.16.1/.gitignore000644 000765 000024 00000000353 12562363066 014711 0ustar00luisstaff000000 000000 *~ *.o *.dylib *.dll *.bundle *.so *.fasl *.xfasl .DS_Store doc/*.aux doc/manual/ doc/spec/ doc/*.log doc/*.info doc/*.aux doc/*.cp doc/*.fn doc/*.fns doc/*.ky doc/*.pg doc/*.toc doc/*.tp doc/*.vr doc/*.dvi doc/*.cps doc/*.vrs doc/dir cffi_0.16.1/.travis.yml000644 000765 000024 00000001544 12562363066 015035 0ustar00luisstaff000000 000000 branches: only: - master language: lisp env: matrix: #- LISP=abcl #- LISP=allegro - LISP=sbcl - LISP=sbcl32 - LISP=ccl - LISP=ccl32 #- LISP=clisp #- LISP=clisp32 #- LISP=cmucl #- LISP=ecl matrix: allow_failures: - env: LISP=ccl32 install: - curl -L https://github.com/luismbo/cl-travis/raw/master/install.sh | sh - if [ "${LISP:(-2)}" = "32" ]; then sudo apt-get install libc6-dev-i386 libffi-dev:i386; fi - git clone --depth=1 git://github.com/trivial-features/trivial-features.git ~/lisp/trivial-features - git clone https://gitlab.common-lisp.net/alexandria/alexandria.git ~/lisp/alexandria - git clone --depth=1 git://github.com/cl-babel/babel.git ~/lisp/babel script: - cl -e '(ql:quickload :cffi-tests) (when (cffi-tests:run-all-cffi-tests) (uiop:quit 1))' cffi_0.16.1/cffi-examples.asd000644 000765 000024 00000003024 12562363066 016133 0ustar00luisstaff000000 000000 ;;;; -*- 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)) cffi_0.16.1/cffi-grovel.asd000644 000765 000024 00000003165 12562363066 015621 0ustar00luisstaff000000 000000 ;;;; -*- 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_0.16.1/cffi-libffi.asd000644 000765 000024 00000003665 12562363066 015563 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-libffi.asd --- Foreign Structures By Value ;;; ;;; Copyright (C) 2011 Liam M. Healy ;;; ;;; 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 :asdf) (eval-when (:compile-toplevel :execute) (asdf:oos 'asdf:load-op :cffi-grovel) (asdf:oos 'asdf:load-op :trivial-features)) (defsystem cffi-libffi :description "Foreign structures by value" :author "Liam Healy " :maintainer "Liam Healy " :defsystem-depends-on (#:trivial-features #:cffi-grovel) :components ((:module libffi :serial t :components ((:file "init") (cffi-grovel:grovel-file "libffi" :pathname #+unix "libffi-unix" #+windows "libffi-win32") (:file "built-in-types") (:file "cstruct") (:file "cif") (:file "functions")))) :depends-on (#:cffi #:cffi-grovel #:trivial-features)) cffi_0.16.1/cffi-tests.asd000644 000765 000024 00000005647 12562363066 015474 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-tests.asd --- ASDF system definition for CFFI unit tests. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; Copyright (C) 2005-2011, 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. ;;; (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-grovel cffi-libffi bordeaux-threads #-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 "fsbv") (:file "union") (:file "enum") (:file "misc-types") (:file "misc") (:file "grovel"))))) (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)))) (funcall (intern (string '#:run-all-cffi-tests) :cffi-tests))) ;;; vim: ft=lisp et cffi_0.16.1/cffi-uffi-compat.asd000644 000765 000024 00000003170 12562363066 016531 0ustar00luisstaff000000 000000 ;;;; -*- 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_0.16.1/cffi.asd000644 000765 000024 00000005421 12566330641 014317 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi.asd --- ASDF system definition for CFFI. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; Copyright (C) 2005-2010, 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 :asdf) #-(or openmcl mcl sbcl cmu scl clisp lispworks ecl allegro cormanlisp abcl mkcl) (error "Sorry, this Lisp is not yet supported. Patches welcome!") (defsystem :cffi :version "0.16.1" :description "The Common Foreign Function Interface" :author "James Bielman " :maintainer "Luis Oliveira " :licence "MIT" :depends-on (:uiop :alexandria :trivial-features :babel) :components ((:module "src" :serial t :components (#+openmcl (:file "cffi-openmcl") #+mcl (:file "cffi-mcl") #+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") #+mkcl (:file "cffi-mkcl") (:file "package") (:file "utils") (:file "libraries") (:file "early-types") (:file "types") (:file "enum") (:file "strings") (:file "structures") (: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_0.16.1/COPYRIGHT000644 000765 000024 00000002077 12562363066 014221 0ustar00luisstaff000000 000000 Copyright (C) 2005-2007, James Bielman Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. cffi_0.16.1/doc/000755 000765 000024 00000000000 12562363066 013465 5ustar00luisstaff000000 000000 cffi_0.16.1/examples/000755 000765 000024 00000000000 12562363066 014536 5ustar00luisstaff000000 000000 cffi_0.16.1/grovel/000755 000765 000024 00000000000 12562363066 014216 5ustar00luisstaff000000 000000 cffi_0.16.1/HEADER000644 000765 000024 00000002345 12562363066 013577 0ustar00luisstaff000000 000000 ;;;; -*- 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_0.16.1/libffi/000755 000765 000024 00000000000 12562363066 014153 5ustar00luisstaff000000 000000 cffi_0.16.1/Makefile000644 000765 000024 00000004520 12562363066 014361 0ustar00luisstaff000000 000000 # -*- 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_0.16.1/README.md000644 000765 000024 00000001717 12562363066 014205 0ustar00luisstaff000000 000000 [![Build Status](https://travis-ci.org/cffi/cffi.svg?branch=master)](https://travis-ci.org/cffi/cffi) CFFI, the Common Foreign Function Interface, purports to be a portable foreign function interface for Common Lisp. The CFFI library is composed of a Lisp-implementation-specific backend in the CFFI-SYS package, and a portable frontend in the CFFI package. The CFFI-SYS backend package defines a low-level interface to the native FFI support in the Lisp implementation. It offers operators for allocating and dereferencing foreign memory, calling foreign functions, and loading shared libraries. The CFFI frontend provides a declarative interface for defining foreign functions, structures, typedefs, enumerated types, etc. It is implemented in portable ANSI CL making use of the low-level operators exported by CFFI-SYS. Please consult [the manual][1] for further details, including installation instructions. [1]: http://common-lisp.net/project/cffi/manual/html_node/ cffi_0.16.1/scripts/000755 000765 000024 00000000000 12562363066 014407 5ustar00luisstaff000000 000000 cffi_0.16.1/src/000755 000765 000024 00000000000 12562363066 013507 5ustar00luisstaff000000 000000 cffi_0.16.1/tests/000755 000765 000024 00000000000 12562363066 014062 5ustar00luisstaff000000 000000 cffi_0.16.1/TODO000644 000765 000024 00000007565 12562363066 013425 0ustar00luisstaff000000 000000 -*- 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_0.16.1/uffi-compat/000755 000765 000024 00000000000 12562363066 015132 5ustar00luisstaff000000 000000 cffi_0.16.1/uffi-compat/uffi-compat.lisp000644 000765 000024 00000054152 12562363066 020244 0ustar00luisstaff000000 000000 ;;;; -*- 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 #:string-to-octets #:octets-to-string #:foreign-encoded-octet-count ;; 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) ;; Although UFFI's documentation claims dereferencing :CHAR and ;; :UNSIGNED-CHAR returns characters, it actually returns ;; integers. (:char :char) (:unsigned-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 #+#:ignore (cffi:define-foreign-type uffi-char () ()) #+#:ignore (cffi:define-parse-method uffi-char (base-type) (make-instance 'uffi-char :actual-type base-type)) #+#:ignore (defmethod cffi:translate-to-foreign ((value character) (type uffi-char)) (char-code value)) #+#:ignore (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 `(:struct ,type) field)) (defun (setf %foreign-slot-value) (value obj type field) (setf (cffi:foreign-slot-value obj `(:struct ,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)) #+(or ecl 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 ecl 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) "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." (let ((command (apply #'format nil control-string args)) (output *trace-output*)) #+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))) #+ecl (nth-value 1 (ext:run-program "/bin/sh" (list "-c" command) :input nil :output output :error nil :wait t)) #-(or openmcl ecl 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) (encoding 'cffi:*default-foreign-encoding*) (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 :encoding ,encoding))) (if (equal ,ret "") nil ,ret)))) ;; What's the difference between this and convert-to-cstring? (defmacro convert-to-foreign-string (obj &optional (encoding 'cffi:*default-foreign-encoding*)) (let ((str (gensym))) `(let ((,str ,obj)) (if (null ,str) (cffi:null-pointer) (cffi:foreign-string-alloc ,str :encoding ,encoding))))) (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))))) ;;;; String Encodings (defmacro string-to-octets (str &key encoding null-terminate) `(babel:concatenate-strings-to-octets (or ,encoding cffi:*default-foreign-encoding*) ,str (if ,null-terminate #.(string #\Nul) ""))) (defmacro octets-to-string (octets &key encoding) `(babel:octets-to-string ,octets :encoding (or ,encoding cffi:*default-foreign-encoding*))) (defun foreign-encoded-octet-count (str &key encoding) (babel:string-size-in-octets str :encoding (or encoding cffi:*default-foreign-encoding*))) cffi_0.16.1/uffi-compat/uffi.asd000644 000765 000024 00000000122 12562363066 016547 0ustar00luisstaff000000 000000 ;;;; uffi.asd -*- Mode: Lisp -*- (defsystem uffi :depends-on (cffi-uffi-compat)) cffi_0.16.1/tests/bindings.lisp000644 000765 000024 00000011657 12562363066 016562 0ustar00luisstaff000000 000000 ;;;; -*- 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) (:darwin (:or "libtest.dylib" "libtest32.dylib")) (:unix (:or "libtest.so" "libtest32.so")) (:windows "libtest.dll") (t (:default "libtest"))) (define-foreign-library (libtest2 :type :test) (:darwin (:or "libtest2.dylib" "libtest2_32.dylib")) (:unix (:or "libtest2.so" "libtest2_32.so")) (t (:default "libtest2"))) (define-foreign-library (libfsbv :type :test) (:darwin (:or "libfsbv.dylib" "libfsbv32.dylib")) (:unix (:or "libfsbv.so" "libfsbv_32.so")) (:windows "libfsbv.dll") (t (:default "libfsbv"))) (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"))) (defun call-within-new-thread (fn &rest args) (let (result error (cv (bordeaux-threads:make-condition-variable)) (lock (bordeaux-threads:make-lock))) (bordeaux-threads:with-lock-held (lock) (bordeaux-threads:make-thread (lambda () (multiple-value-setq (result error) (ignore-errors (apply fn args))) (bordeaux-threads:with-lock-held (lock) (bordeaux-threads:condition-notify cv)))) (bordeaux-threads:condition-wait cv lock) (values result error)))) ;;; As of OSX 10.6.6, loading CoreFoundation on something other than ;;; the initial thread results in a crash. (deftest load-core-foundation (progn #+bordeaux-threads (call-within-new-thread 'load-foreign-library '(:framework "CoreFoundation")) t) t) ;;; 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) #+fsbv (load-foreign-library 'libfsbv) (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* "20120107") (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) (set-difference (regression-test:pending-tests) regression-test::*expected-failures*))) (defun run-all-cffi-tests () (append (run-cffi-tests :compiled nil) (run-cffi-tests :compiled t))) (defmacro expecting-error (&body body) `(handler-case (progn ,@body :no-error) (error () :error))) cffi_0.16.1/tests/callbacks.lisp000644 000765 000024 00000047507 12562363066 016707 0ustar00luisstaff000000 000000 ;;;; -*- 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_0.16.1/tests/compile.bat000644 000765 000024 00000000320 12562363066 016175 0ustar00luisstaff000000 000000 rem rem script for compiling the test lib with the free MSVC++ toolkit. rem cl /LD /DWIN32=1 /Tc libtest.c del libtest.obj libtest.exp cl /LD /DWIN32=1 /Tc libtest2.c del libtest2.obj libtest2.exp cffi_0.16.1/tests/defcfun.lisp000644 000765 000024 00000045640 12562363066 016376 0ustar00luisstaff000000 000000 ;;;; -*- 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) (deftest defcfun.parse-name-and-options.1 (multiple-value-bind (lisp-name foreign-name) (let ((*package* (find-package '#:cffi-tests))) (cffi::parse-name-and-options "foo_bar")) (list lisp-name foreign-name)) (foo-bar "foo_bar")) (deftest defcfun.parse-name-and-options.2 (multiple-value-bind (lisp-name foreign-name) (let ((*package* (find-package '#:cffi-tests))) (cffi::parse-name-and-options "foo_bar" t)) (list lisp-name foreign-name)) (*foo-bar* "foo_bar")) (deftest defcfun.parse-name-and-options.3 (multiple-value-bind (lisp-name foreign-name) (cffi::parse-name-and-options 'foo-bar) (list lisp-name foreign-name)) (foo-bar "foo_bar")) (deftest defcfun.parse-name-and-options.4 (multiple-value-bind (lisp-name foreign-name) (cffi::parse-name-and-options '*foo-bar* t) (list lisp-name foreign-name)) (*foo-bar* "foo_bar")) (deftest defcfun.parse-name-and-options.5 (multiple-value-bind (lisp-name foreign-name) (cffi::parse-name-and-options '("foo_bar" foo-baz)) (list lisp-name foreign-name)) (foo-baz "foo_bar")) (deftest defcfun.parse-name-and-options.6 (multiple-value-bind (lisp-name foreign-name) (cffi::parse-name-and-options '("foo_bar" *foo-baz*) t) (list lisp-name foreign-name)) (*foo-baz* "foo_bar")) (deftest defcfun.parse-name-and-options.7 (multiple-value-bind (lisp-name foreign-name) (cffi::parse-name-and-options '(foo-baz "foo_bar")) (list lisp-name foreign-name)) (foo-baz "foo_bar")) (deftest defcfun.parse-name-and-options.8 (multiple-value-bind (lisp-name foreign-name) (cffi::parse-name-and-options '(*foo-baz* "foo_bar") t) (list lisp-name foreign-name)) (*foo-baz* "foo_bar")) ;;;# Name translation (deftest translate-underscore-separated-name.to-symbol (let ((*package* (find-package '#:cffi-tests))) (translate-underscore-separated-name "some_name_with_underscores")) some-name-with-underscores) (deftest translate-underscore-separated-name.to-string (translate-underscore-separated-name 'some-name-with-underscores) "some_name_with_underscores") (deftest translate-camelcase-name.to-symbol (let ((*package* (find-package '#:cffi-tests))) (translate-camelcase-name "someXmlFunction")) some-xml-function) (deftest translate-camelcase-name.to-string (translate-camelcase-name 'some-xml-function) "someXmlFunction") (deftest translate-camelcase-name.to-string-upper (translate-camelcase-name 'some-xml-function :upper-initial-p t) "SomeXmlFunction") (deftest translate-camelcase-name.to-symbol-special (let ((*package* (find-package '#:cffi-tests))) (translate-camelcase-name "someXMLFunction" :special-words '("XML"))) some-xml-function) (deftest translate-camelcase-name.to-string-special (translate-camelcase-name 'some-xml-function :special-words '("XML")) "someXMLFunction") (deftest translate-name-from-foreign.function (let ((*package* (find-package '#:cffi-tests))) (translate-name-from-foreign "some_xml_name" *package*)) some-xml-name) (deftest translate-name-from-foreign.var (let ((*package* (find-package '#:cffi-tests))) (translate-name-from-foreign "some_xml_name" *package* t)) *some-xml-name*) (deftest translate-name-to-foreign.function (translate-name-to-foreign 'some-xml-name *package*) "some_xml_name") (deftest translate-name-to-foreign.var (translate-name-to-foreign '*some-xml-name* *package* t) "some_xml_name") ;;;# 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 "ullong" :unsigned-long-long (n :unsigned-long-long)) #+allegro ; lp#914500 (pushnew 'defcfun.unsigned-long-long rt::*expected-failures*) (deftest defcfun.unsigned-long-long (let ((ullong-max (1- (expt 2 (* 8 (foreign-type-size :unsigned-long-long)))))) (eql ullong-max (ullong ullong-max))) t)) (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)) #+(and sbcl x86) (push 'defcfun.bff.2 rtest::*expected-failures*) (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_0.16.1/tests/enum.lisp000644 000765 000024 00000006516 12562363066 015727 0ustar00luisstaff000000 000000 ;;;; -*- 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) (deftest bitfield.4b (values (foreign-bitfield-symbols 'bf4 0) (foreign-bitfield-symbols 'bf4 1)) (zero) (zero one)) (deftest bitfield.translators (with-foreign-object (bf 'bf4 2) (setf (mem-aref bf 'bf4 0) 0) (setf (mem-aref bf 'bf4 1) 1) (values (mem-aref bf 'bf4 0) (mem-aref bf 'bf4 1))) (zero) (zero one)) cffi_0.16.1/tests/foreign-globals.lisp000644 000765 000024 00000022067 12562363066 020034 0ustar00luisstaff000000 000000 ;;;; -*- 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") ;;;# Other tests ;;; RT: FOREIGN-SYMBOL-POINTER shouldn't signal an error when passed ;;; an undefined variable. (deftest foreign-globals.undefined.1 (foreign-symbol-pointer "surely-undefined?") nil) (deftest foreign-globals.error.1 (handler-case (foreign-symbol-pointer 'not-a-string) (type-error () t)) t) cffi_0.16.1/tests/fsbv.lisp000644 000765 000024 00000005351 12562363066 015717 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; fsbv.lisp --- Tests of foreign structure by value calls. ;;; ;;; Copyright (C) 2011, Liam M. Healy ;;; ;;; 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) ;; Requires struct.lisp (defcfun "sumpair" :int (p (:struct struct-pair))) (defcfun "makepair" (:struct struct-pair)) (defcfun "doublepair" (:struct struct-pair) (p (:struct struct-pair))) (defcfun "prodsumpair" :double (p (:struct struct-pair+double))) (defcfun "doublepairdouble" (:struct struct-pair+double) (p (:struct struct-pair+double))) ;;; Call struct by value (deftest fsbv.1 (sumpair '(1 . 2)) 3) ;;; Call and return struct by value (deftest fsbv.2 (doublepair '(1 . 2)) (2 . 4)) ;;; return struct by value (deftest fsbv.makepair (makepair) (-127 . 42)) ;;; Call recursive structure by value (deftest fsbv.3 (prodsumpair '(pr (a 4 b 5) dbl 2.5d0)) 22.5d0) ;;; Call and return recursive structure by value (deftest fsbv.4 (let ((ans (doublepairdouble '(pr (a 4 b 5) dbl 2.5d0)))) (values (getf (getf ans 'pr) 'a) (getf (getf ans 'pr) 'b) (getf ans 'dbl))) 8 10 5.0d0) ;;; Typedef fsbv test (defcfun ("sumpair" sumpair2) :int (p struct-pair-typedef1)) (deftest fsbv.5 (sumpair2 '(1 . 2)) 3) ;;; Test ulonglong on no-long-long implementations. (defcfun "ullsum" :unsigned-long-long (a :unsigned-long-long) (b :unsigned-long-long)) (deftest fsbv.6 (ullsum #x10DEADBEEF #x2300000000) #x33DEADBEEF) ;;; Combine structures by value with a string argument (defcfun "stringlenpair" (:struct struct-pair) (s :string) (p (:struct struct-pair))) (deftest fsbv.7 (stringlenpair "abc" '(1 . 2)) (3 . 6)) cffi_0.16.1/tests/funcall.lisp000644 000765 000024 00000016747 12562363066 016416 0ustar00luisstaff000000 000000 ;;;; -*- 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) #-cffi-sys::no-long-long (deftest funcall.unsigned-long-long (let ((ullong-max (1- (expt 2 (* 8 (foreign-type-size :unsigned-long-long)))))) (eql ullong-max (foreign-funcall "ullong" :unsigned-long-long ullong-max :unsigned-long-long))) t) (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)) (declare (ignore val)) (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_0.16.1/tests/GNUmakefile000644 000765 000024 00000005323 12562363066 016137 0ustar00luisstaff000000 000000 # -*- 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 := -dynamiclib SHLIB_EXT := .dylib ifeq ($(shell sysctl -n hw.optional.x86_64), 1) ARCH := x86_64 CFLAGS_64 := -m64 endif else ifeq ($(OSTYPE), SunOS) CFLAGS := -m64 -fPIC -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) libfsbv$(SHLIB_EXT) ifeq ($(ARCH), x86_64) SHLIBS += libtest32$(SHLIB_EXT) libtest2_32$(SHLIB_EXT) libfsbv_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) $< libfsbv$(SHLIB_EXT): libfsbv.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) $< libfsbv_32$(SHLIB_EXT): libfsbv.c -$(CC) -m32 -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $< endif clean: rm -f *.so *.dylib *.dll *.bundle # vim: ft=make ts=3 noet cffi_0.16.1/tests/grovel.lisp000644 000765 000024 00000007147 12562363066 016262 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; grovel.lisp --- CFFI-Grovel tests. ;;; ;;; Copyright (C) 2014, 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) (deftest %invoke (cffi-grovel::%invoke "echo" '("test")) 0 "test ") (defun bug-1395242-helper (enum-type base-type constant-name) (check-type enum-type (member constantenum cenum)) (check-type base-type string) (check-type constant-name string) (let ((enum-name (intern (symbol-name (gensym)))) (base-type-name (intern (symbol-name (gensym))))) (uiop:with-temporary-file (:stream grovel-stream :pathname grovel-file) ;; Write the grovel file (with-open-stream (*standard-output* grovel-stream) (write `(ctype ,base-type-name ,base-type)) (write `(,enum-type (,enum-name :base-type ,base-type-name) ((:value ,constant-name))))) ;; Get the value of :inaddr-broadcast (let ((lisp-file (cffi-grovel:process-grovel-file grovel-file))) (unwind-protect (progn (load lisp-file) (cffi:foreign-enum-value enum-name :value)) (uiop/filesystem:delete-file-if-exists lisp-file)))))) (deftest bug-1395242 (labels ((process-expression (expression) (loop for enum-type in '(constantenum cenum) always (destructuring-bind (base-type &rest evaluations) expression (loop for (name expected-value) in evaluations for actual-value = (bug-1395242-helper enum-type base-type name) always (or (= expected-value actual-value) (progn (format *error-output* "Test failed for case: ~A, ~A, ~A (expected ~A, actual ~A)~%" enum-type base-type name expected-value actual-value) nil))))))) (every #'process-expression '(("uint8_t" ("UINT8_MAX" 255) ("INT8_MAX" 127) ("INT8_MIN" 128)) ("int8_t" ("INT8_MIN" -128) ("INT8_MAX" 127) ("UINT8_MAX" -1)) ("uint16_t" ("UINT16_MAX" 65535) ("INT8_MIN" 65408)) ("int16_t" ("INT16_MIN" -32768) ("INT16_MAX" 32767) ("UINT16_MAX" -1)) ("uint32_t" ("UINT32_MAX" 4294967295) ("INT8_MIN" 4294967168)) ("int32_t" ("INT32_MIN" -2147483648) ("INT32_MAX" 2147483647))))) t) cffi_0.16.1/tests/libfsbv.c000644 000765 000024 00000005644 12562363066 015666 0ustar00luisstaff000000 000000 /* -*- Mode: C; tab-width: 4; indent-tabs-mode: nil -*- * * libfsbv.c --- auxiliary C lib for testing foreign structure by value calls * * Copyright (C) 2011 Liam M. Healy * * 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 struct struct_pair { int a; int b; }; struct struct_pair_double { struct struct_pair pr; double dbl; }; int sumpair (struct struct_pair sp); struct struct_pair doublepair (struct struct_pair dp); double prodsumpair (struct struct_pair_double spd); struct struct_pair_double doublepairdouble (struct struct_pair_double pd); DLLEXPORT int sumpair (struct struct_pair sp) { return sp.a + sp.b; } DLLEXPORT struct struct_pair makepair () { struct struct_pair ret; ret.a = -127; ret.b = 42; return ret; } DLLEXPORT struct struct_pair doublepair (struct struct_pair dp) { struct struct_pair ret; ret.a = 2*dp.a; ret.b = 2*dp.b; return ret; } DLLEXPORT double prodsumpair (struct struct_pair_double pd) { return pd.dbl * sumpair(pd.pr); } DLLEXPORT struct struct_pair_double doublepairdouble (struct struct_pair_double pd) { struct struct_pair_double ret; ret.pr = doublepair(pd.pr); ret.dbl = 2*pd.dbl; return ret; } DLLEXPORT unsigned long long ullsum (unsigned long long a, unsigned long long b) { return a + b; } DLLEXPORT struct struct_pair stringlenpair (char *string, struct struct_pair dp) { struct struct_pair ret; int len = strlen(string); ret.a = len*dp.a; ret.b = len*dp.b; return ret; } cffi_0.16.1/tests/libtest.c000644 000765 000024 00000074352 12562363066 015707 0ustar00luisstaff000000 000000 /* -*- 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 #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 void my_strfree(char *str) { free(str); } DLLEXPORT long long my_llabs(long long n) { return n < 0 ? -n : n; } DLLEXPORT unsigned long long ullong(unsigned long long n) { return n == ULLONG_MAX ? n : 42; } /* * Foreign Globals * * (var_int is used in MISC-TYPES.EXPAND.3 as well) */ DLLEXPORT char * dll_version = "20120107"; /* 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); } DLLEXPORT unsigned sizeof_bool(void) { return (unsigned) sizeof(_Bool); } DLLEXPORT unsigned bool_to_unsigned(_Bool b) { return (unsigned) b; } DLLEXPORT _Bool unsigned_to_bool(unsigned u) { return (_Bool) u; } /* * 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 }; */ /* * STRUCT-VALUES.* */ struct pair { int a, b; }; DLLEXPORT int pair_sum(struct pair p) { return p.a + p.b; } DLLEXPORT int pair_pointer_sum(struct pair *p) { return p->a + p->b; } DLLEXPORT struct pair make_pair(int a, int b) { return (struct pair) { a, b }; } DLLEXPORT struct pair *alloc_pair(int a, int b) { struct pair *p = malloc(sizeof(struct pair)); p->a = a; p->b = b; return p; } struct pair_plus_one { struct pair p; int c; }; DLLEXPORT int pair_plus_one_sum(struct pair_plus_one p) { return p.p.a + p.p.b + p.c; } DLLEXPORT int pair_plus_one_pointer_sum(struct pair_plus_one *p) { return p->p.a + p->p.b + p->c; } DLLEXPORT struct pair_plus_one make_pair_plus_one(int a, int b, int c) { return (struct pair_plus_one) { { a, b }, c }; } DLLEXPORT struct pair_plus_one *alloc_pair_plus_one(int a, int b, int c) { struct pair_plus_one *p = malloc(sizeof(struct pair_plus_one)); p->p.a = a; p->p.b = b; p->c = c; return p; } /* * 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_0.16.1/tests/libtest2.c000644 000765 000024 00000002772 12562363066 015766 0ustar00luisstaff000000 000000 /* -*- 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_0.16.1/tests/Makefile000644 000765 000024 00000000030 12562363066 015513 0ustar00luisstaff000000 000000 shlibs clean: gmake $@ cffi_0.16.1/tests/memory.lisp000644 000765 000024 00000045107 12562363066 016272 0ustar00luisstaff000000 000000 ;;;; -*- 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) (defconstant +two+ 2) ;;; regression test. cffi-allegro's with-foreign-pointer wasn't ;;; handling constants properly. (deftest with-foreign-pointer.constant-size (with-foreign-pointer (p +two+ size) size) 2) (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) (cffi:defcstruct mem-aref.bare-struct (a :uint8)) ;;; regression test: although mem-aref was dealing with bare struct ;;; types as though they were pointers, it wasn't calculating the ;;; proper offsets. The offsets for bare structs types should be ;;; calculated as aggregate types. (deftest mem-aref.bare-struct (with-foreign-object (a 'mem-aref.bare-struct 2) (eql (- (pointer-address (cffi:mem-aref a 'mem-aref.bare-struct 1)) (pointer-address (cffi:mem-aref a 'mem-aref.bare-struct 0))) (foreign-type-size '(:struct mem-aref.bare-struct)))) t) ;;; 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) ;;; 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) ;;; RT: FOREIGN-ALLOC with :COUNT 0 on CLISP signalled an error. (deftest foreign-alloc.10 (foreign-free (foreign-alloc :char :count 0)) nil) ;;; 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) (deftest pointerp.3 (pointerp 'not-a-pointer) nil) (deftest pointerp.4 (pointerp 42) nil) (deftest pointerp.5 (pointerp 0) nil) (deftest pointerp.6 (pointerp nil) nil) (deftest mem-ref.setf.1 (with-foreign-object (p :char) (setf (mem-ref p :char) 42)) 42) (define-foreign-type int+1 () () (:actual-type :int) (:simple-parser int+1)) (defmethod translate-to-foreign (value (type int+1)) (1+ value)) (defmethod translate-from-foreign (value (type int+1)) (1+ value)) (deftest mem-ref.setf.2 (with-foreign-object (p 'int+1) (values (setf (mem-ref p 'int+1) 42) (mem-ref p 'int+1))) 42 ; should this be 43? 44) (deftest pointer-eq.non-pointers.1 (expecting-error (pointer-eq 1 2)) :error) (deftest pointer-eq.non-pointers.2 (expecting-error (pointer-eq 'a 'b)) :error) (deftest null-pointer-p.non-pointer.1 (expecting-error (null-pointer-p 'not-a-pointer)) :error) (deftest null-pointer-p.non-pointer.2 (expecting-error (null-pointer-p 0)) :error) (deftest null-pointer-p.non-pointer.3 (expecting-error (null-pointer-p nil)) :error) cffi_0.16.1/tests/misc-types.lisp000644 000765 000024 00000021142 12562363066 017050 0ustar00luisstaff000000 000000 ;;;; -*- 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)) (defcfun ("my_strfree" strfree) :void (str :pointer)) (deftest misc-types.string+ptr (destructuring-bind (string pointer) (strdup "foo") (strfree 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"))) (strfree 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)) (defcfun "sizeof_bool" :unsigned-int) (deftest misc-types.sizeof.bool (eql (sizeof-bool) (foreign-type-size :bool)) t) (defcfun "bool_to_unsigned" :unsigned-int (b :bool)) (defcfun "unsigned_to_bool" :bool (u :unsigned-int)) (deftest misc-types.bool.convert-to-foreign.mem (loop for v in '(nil t) collect (with-foreign-object (b :bool) (setf (mem-ref b :bool) v) (mem-ref b #.(cffi::canonicalize-foreign-type :bool)))) (0 1)) (deftest misc-types.bool.convert-to-foreign.call (mapcar #'bool-to-unsigned '(nil t)) (0 1)) (deftest misc-types.bool.convert-from-foreign.mem (loop for v in '(0 1 42) collect (with-foreign-object (b :bool) (setf (mem-ref b #.(cffi::canonicalize-foreign-type :bool)) v) (mem-ref b :bool))) (nil t t)) (deftest misc-types.bool.convert-from-foreign.call (mapcar #'unsigned-to-bool '(0 1 42)) (nil t t)) ;;; 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") (strfree 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) (define-foreign-type misc-type.expand.7 () () (:actual-type :int) (:simple-parser misc-type.expand.7)) (defmethod translate-to-foreign (value (type misc-type.expand.7)) (values value 'second-value)) ;; Auxiliary function to test CONVERT-TO-FOREIGN's compiler macro. (defun misc-type.expand.7-aux () (convert-to-foreign "foo" 'misc-type.expand.7)) ;; Checking that expand-to-foreign doesn't ignore the second value of ;; translate-to-foreign. (deftest misc-type.expand.7 (misc-type.expand.7-aux) "foo" second-value) ;; Like MISC-TYPE.EXPAND.7 but doesn't depend on compiler macros ;; kicking in. (deftest misc-type.expand.8 (eval (expand-to-foreign "foo" (cffi::parse-type 'misc-type.expand.7))) "foo" second-value) cffi_0.16.1/tests/misc.lisp000644 000765 000024 00000007644 12562363066 015721 0ustar00luisstaff000000 000000 ;;;; -*- 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_0.16.1/tests/package.lisp000644 000765 000024 00000002641 12562363066 016351 0ustar00luisstaff000000 000000 ;;;; -*- 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 #:run-cffi-tests #:run-all-cffi-tests)) cffi_0.16.1/tests/random-tester.lisp000644 000765 000024 00000024011 12562363066 017535 0ustar00luisstaff000000 000000 ;;;; -*- 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_0.16.1/tests/run-tests.lisp000644 000765 000024 00000003300 12562363066 016713 0ustar00luisstaff000000 000000 ;;;; -*- 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 mkcl)) (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_0.16.1/tests/strings.lisp000644 000765 000024 00000014373 12562363066 016454 0ustar00luisstaff000000 000000 ;;;; -*- 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) ;;; ;;; FIXME: an identical test using :UTF-16 wouldn't work because on ;;; little-endian architectures, :UTF-16 defaults to little-endian ;;; when writing and big-endian on reading because the BOM is ;;; suppressed. #-babel::8-bit-chars (progn (deftest string.encoding.utf-16le.basic (with-foreign-string (s *ascii-test-string* :encoding :utf-16le) (foreign-string-to-lisp s :encoding :utf-16le)) #.*ascii-test-string* 190) (deftest string.encoding.utf-16be.basic (with-foreign-string (s *ascii-test-string* :encoding :utf-16be) (foreign-string-to-lisp s :encoding :utf-16be)) #.*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") (deftest string.encodings.all.basic (let (failed) ;;; FIXME: UTF-{32,16} and friends fail due to lack of BOM. See ;;; STRING.ENCODING.UTF-16.BASIC for more details. (dolist (encoding (remove-if (lambda (x) (member x '(:utf-32 :utf-16 :ucs-2))) (babel:list-character-encodings))) ;; (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))))) failed) nil) ;;; rt: make sure *default-foreign-enconding* binds to a keyword (deftest string.encodings.default (keywordp *default-foreign-encoding*) t) cffi_0.16.1/tests/struct.lisp000644 000765 000024 00000047152 12562363066 016310 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; struct.lisp --- Foreign structure type tests. ;;; ;;; Copyright (C) 2005-2006, James Bielman ;;; Copyright (C) 2005-2011, 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) (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 (:struct 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)) (defctype s-ch (:struct s-ch)) (defcstruct s-s-ch (another-char :char) (a-s-ch s-ch)) (defctype s-s-ch (:struct s-s-ch)) (defcvar "the_s_s_ch" s-s-ch) (deftest struct.alignment.1 (list 'a-char (foreign-slot-value (foreign-slot-pointer *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)) (defctype s-short (:struct s-short)) (defcstruct s-s-short (yet-another-char :char) (a-s-short s-short)) (defctype s-s-short (:struct s-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)) (defctype s-double (:struct s-double)) (defcstruct s-s-double (yet-another-char :char) (a-s-double s-double) (a-short :short)) (defctype s-s-double (:struct s-s-double)) (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)) (defctype s-s-s-double (:struct s-s-s-double)) (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)) (defctype s-double2 (:struct s-double2)) (defcstruct s-s-double2 (a-char :char) (a-s-double2 s-double2) (another-short :short)) (defctype s-s-double2 (:struct s-s-double2)) (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)) (defctype s-long-long (:struct s-long-long)) (defcstruct s-s-long-long (a-char :char) (a-s-long-long s-long-long) (another-short :short)) (defctype s-s-long-long (:struct s-s-long-long)) (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)) (defctype s-s-double3 (:struct s-s-double3)) (defcstruct s-s-s-double3 (a-s-s-double3 s-s-double3) (a-char :char)) (defctype s-s-s-double3 (:struct s-s-s-double3)) (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) (defctype empty-struct (:struct 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)) (defctype s1 (:struct s1)) (defcstruct s2 (an-s1 s1)) (defctype s2 (:struct s2)) (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)) (defctype s-unsigned-long-long (:struct s-unsigned-long-long)) (defcstruct s-s-unsigned-long-long (a-char :char) (a-s-unsigned-long-long s-unsigned-long-long) (another-short :short)) (defctype s-s-unsigned-long-long (:struct s-s-unsigned-long-long)) (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 (:struct 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) ;;;# Structures as Values (defcstruct (struct-pair :class pair) (a :int) (b :int)) (defctype struct-pair-typedef1 (:struct struct-pair)) (defctype struct-pair-typedef2 (:pointer (:struct struct-pair))) (deftest struct.unparse.1 (mapcar (alexandria:compose #'cffi::unparse-type #'cffi::parse-type) '(struct-pair (:struct struct-pair) struct-pair-typedef1 struct-pair-typedef2)) (struct-pair (:struct struct-pair) struct-pair-typedef1 struct-pair-typedef2)) (deftest struct.canonicalize.1 (mapcar #'cffi::canonicalize-foreign-type '(struct-pair (:struct struct-pair) struct-pair-typedef1 struct-pair-typedef2)) (:pointer (:struct struct-pair) (:struct struct-pair) :pointer)) (deftest struct.canonicalize.2 (mapcar #'cffi::canonicalize-foreign-type '(struct-pair (:struct struct-pair) struct-pair-typedef1 struct-pair-typedef2)) (:pointer (:struct struct-pair) (:struct struct-pair) :pointer)) (defmethod translate-from-foreign (pointer (type pair)) (with-foreign-slots ((a b) pointer (:struct struct-pair)) (cons a b))) (defmethod translate-into-foreign-memory (object (type pair) pointer) (with-foreign-slots ((a b) pointer (:struct struct-pair)) (setf a (car object) b (cdr object)))) (defmethod translate-to-foreign (object (type pair)) (let ((p (foreign-alloc '(:struct struct-pair)))) (translate-into-foreign-memory object type p) (values p t))) (defmethod free-translated-object (pointer (type pair) freep) (when freep (foreign-free pointer))) (deftest struct-values.translation.1 (multiple-value-bind (p freep) (convert-to-foreign '(1 . 2) 'struct-pair) (assert freep) (unwind-protect (convert-from-foreign p 'struct-pair) (free-converted-object p 'struct-pair freep))) (1 . 2)) (defcfun "pair_pointer_sum" :int (p (:pointer (:struct struct-pair)))) #+#:pointer-translation-not-yet-implemented (deftest struct-values.translation.2 (pair-pointer-sum '(1 . 2)) 3) ;;; should the return type be something along the lines of ;;; (:pointer (:struct pair) :free t)? ;;; LMH: error on ":free t" option? (defcfun "alloc_pair" (:pointer (:struct struct-pair)) (a :int) (b :int)) ;; bogus: doesn't free() pointer. #+#:pointer-translation-not-yet-implemented (deftest struct-values.translation.3 (alloc-pair 1 2) (1 . 2)) (deftest struct-values.translation.mem-ref.1 (with-foreign-object (p '(:struct struct-pair)) (setf (mem-ref p '(:struct struct-pair)) '(1 . 2)) (with-foreign-slots ((a b) p (:struct struct-pair)) (values (mem-ref p '(:struct struct-pair)) a b))) (1 . 2) 1 2) (deftest struct-values.translation.mem-aref.1 (with-foreign-object (p '(:struct struct-pair) 2) (setf (mem-aref p '(:struct struct-pair) 0) '(1 . 2) (mem-aref p '(:struct struct-pair) 1) '(3 . 4)) (values (mem-aref p '(:struct struct-pair) 0) (mem-aref p '(:struct struct-pair) 1))) (1 . 2) (3 . 4)) (defcstruct (struct-pair-default-translate :class pair-default) (a :int) (b :int)) (deftest struct-values-default.translation.mem-ref.1 (with-foreign-object (p '(:struct struct-pair-default-translate)) (setf (mem-ref p '(:struct struct-pair-default-translate)) '(a 1 b 2)) (with-foreign-slots ((a b) p (:struct struct-pair-default-translate)) (let ((plist (mem-ref p '(:struct struct-pair-default-translate)))) (values (getf plist 'a) (getf plist 'b) a b)))) 1 2 1 2) (defcstruct (struct-pair+double :class pair+double) (pr (:struct struct-pair-default-translate)) (dbl :double)) (deftest struct-values-default.translation.mem-ref.2 (with-foreign-object (p '(:struct struct-pair+double)) (setf (mem-ref p '(:struct struct-pair+double)) '(pr (a 4 b 5) dbl 2.5d0)) (with-foreign-slots ((pr dbl) p (:struct struct-pair+double)) (let ((plist (mem-ref p '(:struct struct-pair+double)))) (values (getf (getf plist 'pr) 'a) (getf (getf plist 'pr) 'b) (getf plist 'dbl))))) 4 5 2.5d0) (defcstruct (struct-pair+1 :class pair+1) (p (:pointer (:struct struct-pair))) (c :int)) (defctype struct-pair+1 (:struct struct-pair+1)) (defmethod translate-from-foreign (pointer (type pair+1)) (with-foreign-slots ((p c) pointer struct-pair+1) (cons p c))) (defmethod translate-into-foreign-memory (object (type pair+1) pointer) (with-foreign-slots ((c) pointer struct-pair+1) (convert-into-foreign-memory (car object) 'struct-pair (foreign-slot-pointer pointer 'struct-pair+1 'p)) (setf c (cdr object)))) (defmethod translate-to-foreign (object (type pair+1)) (let ((p (foreign-alloc 'struct-pair+1))) (translate-into-foreign-memory object type p) (values p t))) (defmethod free-translated-object (pointer (type pair+1) freep) (when freep (foreign-free pointer))) #+#:pointer-translation-not-yet-implemented (deftest struct-values.translation.ppo.1 (multiple-value-bind (p freep) (convert-to-foreign '((1 . 2) . 3) 'struct-pair+1) (assert freep) (unwind-protect (convert-from-foreign p 'struct-pair+1) (free-converted-object p 'struct-pair+1 freep))) ((1 . 2) . 3)) #+#:unimplemented (defcfun "pair_plus_one_sum" :int (p (:struct pair+1))) (defcfun "pair_plus_one_pointer_sum" :int (p (:pointer (:struct struct-pair+1)))) #+#:pointer-translation-not-yet-implemented (deftest struct-values.translation.ppo.2 (pair-plus-one-pointer-sum '((1 . 2) . 3)) 6) #+#:unimplemented (defcfun "make_pair_plus_one" (:struct pair+1) (a :int) (b :int) (c :int)) (defcfun "alloc_pair_plus_one" struct-pair+1 (a :int) (b :int) (c :int)) ;; bogus: doesn't free() pointer. #+#:pointer-translation-not-yet-implemented (deftest struct-values.translation.ppo.3 (alloc-pair-plus-one 1 2 3) ((1 . 2) . 3)) #+#:unimplemented (defcfun "pair_sum" :int (p (:struct pair))) #+#:unimplemented (defcfun "make_pair" (:struct pair) (a :int) (b :int)) #|| ; TODO: load cffi-libffi for these tests to work. (deftest struct-values.fn.1 (with-foreign-object (p '(:struct pair)) (with-foreign-slots ((a b) p (:struct pair)) (setf a -1 b 2) (pair-sum p))) 1) (deftest struct-values.fn.2 (pair-sum '(3 . 5)) 8) (deftest struct-values.fn.3 (with-foreign-object (p '(:struct pair)) (make-pair 7 11 :result-pointer p) (with-foreign-slots ((a b) p (:struct pair)) (cons a b))) (7 . 11)) (deftest struct-values.fn.4 (make-pair 13 17) (13 . 17)) ||# (defcstruct single-byte-struct (a :uint8)) (deftest bare-struct-types.1 (eql (foreign-type-size 'single-byte-struct) (foreign-type-size '(:struct single-byte-struct))) t) (defctype single-byte-struct-alias (:struct single-byte-struct)) (deftest bare-struct-types.2 (eql (foreign-type-size 'single-byte-struct-alias) (foreign-type-size '(:struct single-byte-struct))) t) ;;; Old-style access to inner structure fields. (defcstruct inner-struct (x :int)) (defcstruct old-style-outer (inner inner-struct)) (defcstruct new-style-outer (inner (:struct inner-struct))) (deftest old-style-struct-access (with-foreign-object (s '(:struct old-style-outer)) (let ((inner-ptr (foreign-slot-pointer s 'old-style-outer 'inner))) (setf (foreign-slot-value inner-ptr 'inner-struct 'x) 42)) (assert (pointerp (foreign-slot-value s 'old-style-outer 'inner))) (foreign-slot-value (foreign-slot-value s 'old-style-outer 'inner) 'inner-struct 'x)) 42) (deftest new-style-struct-access (with-foreign-object (s '(:struct new-style-outer)) (let ((inner-ptr (foreign-slot-pointer s 'new-style-outer 'inner))) (setf (foreign-slot-value inner-ptr 'inner-struct 'x) 42)) (foreign-slot-value s 'new-style-outer 'inner)) (x 42)) cffi_0.16.1/tests/union.lisp000644 000765 000024 00000003712 12562363066 016106 0ustar00luisstaff000000 000000 ;;;; -*- 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)) (defctype uint32-bytes (:union uint32-bytes)) (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_0.16.1/src/cffi-abcl.lisp000644 000765 000024 00000062672 12562363066 016223 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-abcl.lisp --- CFFI-SYS implementation for ABCL/JNA. ;;; ;;; Copyright (C) 2009, Luis Oliveira ;;; Copyright (C) 2012, Mark Evenson ;;; ;;; 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. ;;; ;;; ;;; JNA may be automatically loaded into the current JVM process from ;;; abcl-1.1.0-dev via the contrib mechanism. (eval-when (:compile-toplevel :load-toplevel :execute) (require :abcl-contrib) (require :jna) (require :jss)) ;;; 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. Shareable Vectors are not ;;; implemented yet. ;;;# Administrivia (defpackage #:cffi-sys (:use #:cl #:java) (:import-from #:alexandria #:hash-table-values #:length= #:format-symbol) (: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 #:with-pointer-to-vector-data #:make-shareable-byte-vector)) (in-package #:cffi-sys) ;;;# Loading and Closing Foreign Libraries (defparameter *loaded-libraries* (make-hash-table)) (defun %load-foreign-library (name path) "Load a foreign library, signals a simple error on failure." (flet ((load-and-register (name path) (let ((lib (jstatic "getInstance" "com.sun.jna.NativeLibrary" path))) (setf (gethash name *loaded-libraries*) lib) lib)) (foreign-library-type-p (type) (find type '("so" "dll" "dylib") :test #'string=)) (java-error (e) (error (jcall (jmethod "java.lang.Exception" "getMessage") (java-exception-cause e))))) (handler-case (load-and-register name path) (java-exception (e) ;; From JNA http://jna.java.net/javadoc/com/sun/jna/NativeLibrary.html ;; ``[The name] can be short form (e.g. "c"), an explicit ;; version (e.g. "libc.so.6"), or the full path to the library ;; (e.g. "/lib/libc.so.6")'' ;; ;; Try to deal with the occurance "libXXX" and "libXXX.so" as ;; "libXXX.so.6" and "XXX" should have succesfully loaded. (let ((p (pathname path))) (if (and (not (pathname-directory p)) (= (search "lib" (pathname-name p)) 0)) (let ((short-name (if (foreign-library-type-p (pathname-type p)) (subseq (pathname-name p) 3) (pathname-name p)))) (handler-case (load-and-register name short-name) (java-exception (e) (java-error e)))) (java-error 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-raw (jmethod "com.sun.jna.NativeLibrary" "dispose") handle)) ;;; ;;; FIXME! We should probably define a private-jfield-accessor that does the hard work once! (let ((get-declared-fields-jmethod (jmethod "java.lang.Class" "getDeclaredFields"))) (defun private-jfield (class-name field-name instance) (let ((field (find field-name (jcall get-declared-fields-jmethod (jclass class-name)) :key #'jfield-name :test #'string=))) (jcall (jmethod "java.lang.reflect.Field" "setAccessible" "boolean") field +true+) (jcall (jmethod "java.lang.reflect.Field" "get" "java.lang.Object") field instance)))) ;;; XXX: doesn't match jmethod-arguments. (let ((get-declared-methods-jmethod (jmethod "java.lang.Class" "getDeclaredMethods"))) (defun private-jmethod (class-name method-name) (let ((method (find method-name (jcall get-declared-methods-jmethod (jclass class-name)) :key #'jmethod-name :test #'string=))) (jcall (jmethod "java.lang.reflect.Method" "setAccessible" "boolean") method +true+) method))) (let ((get-declared-constructors-jmethod (jmethod "java.lang.Class" "getDeclaredConstructors")) (set-accessible-jmethod (jmethod "java.lang.reflect.Constructor" "setAccessible" "boolean"))) (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 get-declared-constructors-jmethod (jclass class-name))))) (jcall set-accessible-jmethod cons +true+) 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." (let ((jclass (jclass-of ptr))) (when jclass (jclass-superclass-p (jclass "com.sun.jna.Pointer") jclass)))) (let ((jconstructor (private-jconstructor "com.sun.jna.Pointer" "long"))) (defun make-pointer (address) "Return a pointer pointing to ADDRESS." (jnew jconstructor address))) (defun make-private-jfield-accessor (class-name field-name) (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 +true+) (let ((get-jmethod (jmethod "java.lang.reflect.Field" "get" "java.lang.Object"))) (lambda (instance) (jcall get-jmethod field instance))))) (let ((accessor (make-private-jfield-accessor "com.sun.jna.Pointer" "peer"))) (defun %pointer-address (pointer) (funcall accessor pointer))) (defun pointer-address (pointer) "Return the address pointed to by PTR." (let ((peer (%pointer-address pointer))) (if (< peer 0) (+ #.(ash 1 64) peer) peer))) (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 (let ((malloc-jmethod (private-jmethod "com.sun.jna.Memory" "malloc"))) (defun %foreign-alloc (size) "Allocate SIZE bytes on the heap and return a pointer." (make-pointer (jcall-raw malloc-jmethod nil size)))) (let ((free-jmethod (private-jmethod "com.sun.jna.Memory" "free"))) (defun foreign-free (ptr) "Free a PTR allocated by FOREIGN-ALLOC." (jcall-raw free-jmethod nil (%pointer-address ptr)) nil)) ;;; 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. (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 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 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))) (let ((method (jmethod "com.sun.jna.Pointer" (jna-setter :char) "long" (jna-setter-arg-type :char)))) (defun copy-to-foreign-vector (vector foreign-pointer) (loop for i below (length vector) do (jcall-raw method foreign-pointer i (aref vector i))))) ;; hand-roll the jna-getter method instead of calling %mem-ref every time through (let ((method (jmethod "com.sun.jna.Pointer" (jna-getter :char) "long"))) (defun copy-from-foreign-vector (vector foreign-pointer) (loop for i below (length vector) do (setf (aref vector i) (java:jobject-lisp-value (jcall-raw method foreign-pointer i)))))) (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-sym (gensym "VECTOR"))) `(let ((,vector-sym ,vector)) (with-foreign-pointer (,ptr-var (length ,vector-sym)) (copy-to-foreign-vector ,vector-sym ,ptr-var) (unwind-protect (progn ,@body) (copy-from-foreign-vector ,vector-sym ,ptr-var)))))) ;;;# 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") ;; void * is 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 lispify-value (value type) (when (and (eq type :pointer) (or (null (java:jobject-lisp-value value)) (eq +null+ (java:jobject-lisp-value value)))) (return-from lispify-value (null-pointer))) (when (or (eq type :long) (eq type :unsigned-long)) (setq value (jcall-raw (jmethod "com.sun.jna.NativeLong" "longValue") (java:jobject-lisp-value value)))) (let ((bit-size (* 8 (%foreign-type-size type)))) (let ((lisp-value (java:jobject-lisp-value value))) (if (and (unsigned-type-p type) (logbitp (1- bit-size) lisp-value)) (lognot (logxor lisp-value (1- (expt 2 bit-size)))) lisp-value)))) (defun %mem-ref (ptr type &optional (offset 0)) (lispify-value (jcall-raw (jmethod "com.sun.jna.Pointer" (jna-getter type) "long") ptr offset) type)) (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-raw (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) ;;;# Foreign Globals (let ((get-symbol-address-jmethod (private-jmethod "com.sun.jna.NativeLibrary" "getSymbolAddress"))) (defun %foreign-symbol-pointer (name library) "Returns a pointer to a foreign symbol NAME." (flet ((find-it (library) (ignore-errors (make-pointer (jcall-raw get-symbol-address-jmethod library name))))) (if (eq library :default) (or (find-it (jstatic "getProcess" "com.sun.jna.NativeLibrary")) ;; The above should find it, but I'm not exactly sure, so ;; let's still do it manually just in case. (loop for lib being the hash-values of *loaded-libraries* thereis (find-it lib))) (find-it library))))) ;;;# Calling Foreign Functions (defun find-foreign-function (name library) (flet ((find-it (library) (ignore-errors (jcall-raw (jmethod "com.sun.jna.NativeLibrary" "getFunction" "java.lang.String") library name)))) (if (eq library :default) (or (find-it (jstatic "getProcess" "com.sun.jna.NativeLibrary")) ;; The above should find it, but I'm not exactly sure, so ;; let's still do it manually just in case. (loop for lib being the hash-values of *loaded-libraries* thereis (find-it lib))) (find-it (gethash library *loaded-libraries*))))) (defun convert-calling-convention (convention) (ecase convention (:stdcall "ALT_CONVENTION") (:cdecl "C_CONVENTION"))) (defparameter *jna-string-encoding* "UTF-8" "Encoding for conversion between Java and native strings that occurs within JNA. Used with jna-4.0.0 or later.") ;;; c.f. (defvar *jna-4.0.0-or-later-p* (ignore-errors (private-jconstructor "com.sun.jna.Function" "com.sun.jna.Pointer" "int" "java.lang.String"))) (let ((jconstructor (if *jna-4.0.0-or-later-p* (private-jconstructor "com.sun.jna.Function" "com.sun.jna.Pointer" "int" "java.lang.String") (private-jconstructor "com.sun.jna.Function" "com.sun.jna.Pointer" "int")))) (defun make-function-pointer (pointer convention) (apply #'jnew jconstructor pointer (jfield "com.sun.jna.Function" (convert-calling-convention convention)) (when *jna-4.0.0-or-later-p* (list *jna-string-encoding*))))) (defun lisp-value-to-java (value foreign-type) (case foreign-type (:pointer value) (:void nil) (t (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-raw (jmethod "com.sun.jna.Function" "invoke" "[Ljava.lang.Object;") function jargs) (values)) (lispify-value (jcall-raw (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 convention) (declare (ignore 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 convention) (multiple-value-bind (types fargs rettype) (foreign-funcall-type-and-args args) `(%%foreign-funcall (make-function-pointer ,ptr ',convention) (list ,@fargs) ',types ',rettype))) ;;;# Callbacks (defun foreign-to-callback-type (type) (ecase type ((:int :unsigned-int) :int) ((:long :unsigned-long) (jvm::make-jvm-class-name "com.sun.jna.NativeLong")) ((:long-long :unsigned-long-long) (jvm::make-jvm-class-name "java.lang.Long")) (:pointer (jvm::make-jvm-class-name "com.sun.jna.Pointer")) (:float :float) (:double :double) ((:char :unsigned-char) :byte) ((:short :unsigned-short) :short) (:wchar_t :int) (:void :void))) (defvar *callbacks* (make-hash-table)) (defmacro convert-args-to-lisp-values (arg-names arg-types &body body) (let ((gensym-args (loop for name in arg-names collect (format-symbol t '#:callback-arg-~a- name)))) `(lambda (,@gensym-args) (let ,(loop for arg in arg-names for type in arg-types for gensym-arg in gensym-args collecting `(,arg (if (typep ,gensym-arg 'java:java-object) (lispify-value ,gensym-arg ,type) ,gensym-arg))) ,@body)))) (defmacro %defcallback (name return-type arg-names arg-types body &key convention) (declare (ignore convention)) ;; I'm always up for ignoring convention, but this is probably wrong. `(setf (gethash ',name *callbacks*) (jinterface-implementation (ensure-callback-interface ',return-type ',arg-types) "callback" (convert-args-to-lisp-values ,arg-names ,arg-types (lisp-value-to-java ,body ',return-type))))) ;; (lambda (,@arg-names) ,body)))) (jvm::define-class-name +callback-object+ "com.sun.jna.Callback") (defconstant +dynamic-callback-package+ "org/armedbear/jna/dynamic/callbacks" "The slash-delimited Java package in which we create classes dynamically to specify callback interfaces.") (defun ensure-callback-interface (returns args) "Ensure that the jvm interface for the callback exists in the current JVM. Returns the fully dot qualified name of the interface." (let* ((jvm-returns (foreign-to-callback-type returns)) (jvm-args (mapcar #'foreign-to-callback-type args)) (interface-name (qualified-callback-interface-classname jvm-returns jvm-args))) (handler-case (jss:find-java-class interface-name) (java-exception (e) (when (jinstance-of-p (java:java-exception-cause e) "java.lang.ClassNotFoundException") (let ((interface-class-bytes (%define-jna-callback-interface jvm-returns jvm-args)) (simple-interface-name (callback-interface-classname jvm-returns jvm-args))) (load-class interface-name interface-class-bytes))))) interface-name)) (defun qualified-callback-interface-classname (returns args) (format nil "~A.~A" (substitute #\. #\/ +dynamic-callback-package+) (callback-interface-classname returns args))) (defun callback-interface-classname (returns args) (flet ((stringify (thing) (typecase thing (jvm::jvm-class-name (substitute #\_ #\/ (jvm::class-name-internal thing))) (t (string thing))))) (format nil "~A__~{~A~^__~}" (stringify returns) (mapcar #'stringify args)))) (defun %define-jna-callback-interface (returns args) "Returns the Java byte[] array of a class representing a Java interface descending form +CALLBACK-OBJECT+ which contains the single function 'callback' which takes ARGS returning RETURNS. The fully qualified dotted name of the generated class is returned as the second value." (let ((name (callback-interface-classname returns args))) (values (define-java-interface name +dynamic-callback-package+ `(("callback" ,returns ,args)) `(,+callback-object+)) (qualified-callback-interface-classname returns args)))) (defun define-java-interface (name package methods &optional (superinterfaces nil)) "Returns the bytes of the Java class interface called NAME in PACKAGE with METHODS. METHODS is a list of (NAME RETURN-TYPE (ARG-TYPES)) entries. NAME is a string. The values of RETURN-TYPE and the list of ARG-TYPES for the defined method follow the are either references to Java objects as created by JVM::MAKE-JVM-CLASS-NAME, or keywords representing Java primtive types as contained in JVM::MAP-PRIMITIVE-TYPE. SUPERINTERFACES optionally contains a list of interfaces that this interface extends specified as fully qualifed dotted Java names." (let* ((class-name-string (format nil "~A/~A" package name)) (class-name (jvm::make-jvm-class-name class-name-string)) (class (jvm::make-class-interface-file class-name))) (dolist (superinterface superinterfaces) (jvm::class-add-superinterface class (if (typep superinterface 'jvm::jvm-class-name) superinterface (jvm::make-jvm-class-name superinterface)))) (dolist (method methods) (let ((name (first method)) (returns (second method)) (args (third method))) (jvm::class-add-method class (jvm::make-jvm-method name returns args :flags '(:public :abstract))))) (jvm::finalize-class-file class) (let ((s (sys::%make-byte-array-output-stream))) (jvm::write-class-file class s) (sys::%get-output-stream-bytes s)))) (defun load-class (name bytes) "Load the byte[] array BYTES as a Java class called NAME." (#"loadClassFromByteArray" java::*classloader* name bytes)) ;;; Test function: unused in CFFI (defun write-class (class-bytes pathname) "Write the Java byte[] array CLASS-BYTES to PATHNAME." (with-open-file (stream pathname :direction :output :element-type '(signed-byte 8)) (dotimes (i (jarray-length class-bytes)) (write-byte (jarray-ref class-bytes i) stream)))) (defun %callback (name) (or (#"getFunctionPointer" 'com.sun.jna.CallbackReference (gethash name *callbacks*)) (error "Undefined callback: ~S" name))) (defun native-namestring (pathname) (namestring pathname)) cffi_0.16.1/src/cffi-allegro.lisp000644 000765 000024 00000037562 12562363066 016747 0ustar00luisstaff000000 000000 ;;;; -*- 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 ,(eval size))) (declare (ignorable ,size-var)) (ff:with-static-fobject (,var '(:array :char ,(eval 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) (:long-long #+64bit :nat #-64bit (error "this platform does not support :long-long.")) (:unsigned-long-long #+64bit :unsigned-nat #-64bit (error "this platform does not support :unsigned-long-long")) (: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 :nat) `(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) #-(version>= 8 1) ff::ep-flag-never-release #+(version>= 8 1) ff::ep-flag-always-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 #+(version>= 8 1) ,@'(:release-heap :always) #+smp ,@'(:release-heap-implies-allow-gc t)) `(,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_0.16.1/src/cffi-clisp.lisp000644 000765 000024 00000037115 12562363066 016426 0ustar00luisstaff000000 000000 ;;;; -*- 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_0.16.1/src/cffi-cmucl.lisp000644 000765 000024 00000031644 12562363066 016420 0ustar00luisstaff000000 000000 ;;;; -*- 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_0.16.1/src/cffi-corman.lisp000644 000765 000024 00000026477 12562363066 016604 0ustar00luisstaff000000 000000 ;;;; -*- 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_0.16.1/src/cffi-ecl.lisp000644 000765 000024 00000037152 12562363066 016060 0ustar00luisstaff000000 000000 ;;;; -*- 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) (:import-from #:si #:null-pointer-p) (:export #:*cffi-ecl-method* #: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 #:%close-foreign-library #:native-namestring #:make-shareable-byte-vector #:with-pointer-to-vector-data #:%defcallback #:%callback #:%foreign-symbol-pointer)) (in-package #:cffi-sys) ;;; ;;; ECL allows many ways of calling a foreign function, and also many ;;; ways of finding the pointer associated to a function name. They ;;; depend on whether the FFI relies on libffi or on the C/C++ compiler, ;;; and whether they use the shared library loader to locate symbols ;;; or they are linked by the linker. ;;; ;;; :DFFI ;;; ;;; ECL uses libffi to call foreign functions. The only way to find out ;;; foreign symbols is by loading shared libraries and using dlopen() ;;; or similar. ;;; ;;; :DLOPEN ;;; ;;; ECL compiles FFI code as C/C++ statements. The names are resolved ;;; at run time by the shared library loader every time the function ;;; is called ;;; ;;; :C/C++ ;;; ;;; ECL compiles FFI code as C/C++ statements, but the name resolution ;;; happens at link time. In this case you have to tell the ECL ;;; compiler which are the right ld-flags (c:*ld-flags*) to link in ;;; the library. ;;; (defvar *cffi-ecl-method* #+dffi :dffi #+(and dlopen (not dffi)) :dlopen #-(or dffi dlopen) :c/c++ "The type of code that CFFI generates for ECL: :DFFI when using the dynamical foreign function interface; :DLOPEN when using C code and dynamical references to symbols; :C/C++ for C/C++ code with static references to symbols.") ;;;# Mis-features #-long-long (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 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))) (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 (si:make-foreign-data-from-array ,vector))) ,@body)) ;;;# 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") #+long-long (:long-long :long-long "long long") #+long-long (:unsigned-long-long :unsigned-long-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)))) ;;;# 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))) ;;; Inline versions that use C expressions instead of function calls. (defparameter +mem-ref-strings+ (loop for (cffi-type ecl-type c-string) in +translation-table+ for string = (format nil "*((~A *)(((char*)#0)+#1))" c-string) collect (list cffi-type ecl-type string))) (defparameter +mem-set-strings+ (loop for (cffi-type ecl-type c-string) in +translation-table+ for string = (format nil "*((~A *)(((char*)#0)+#1))=#2" c-string) collect (list cffi-type ecl-type string))) (define-compiler-macro %mem-ref (&whole whole ptr type &optional (offset 0)) (if (and (constantp type) (constantp offset)) (let ((record (assoc (eval type) +mem-ref-strings+))) `(ffi:c-inline (,ptr ,offset) (:pointer-void :cl-index) ; argument types ,(second record) ; return type ,(third record) ; the precomputed expansion :one-liner t)) whole)) (define-compiler-macro %mem-set (&whole whole value ptr type &optional (offset 0)) (if (and (constantp type) (constantp offset)) (let ((record (assoc (eval type) +mem-set-strings+))) `(ffi:c-inline (,ptr ,offset ,value) ; arguments with type translated (:pointer-void :cl-index ,(second record)) :void ; does not return anything ,(third record) ; precomputed expansion :one-liner t)) whole)) ;;;# 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 c-inline-function-pointer-call (pointer types values return-type) (cond ((not (stringp pointer)) `(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)) ((eq *cffi-ecl-method* :c/c++) `(ffi:c-inline ,values ,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 "{ extern ~A ~A(~@[~{~A~^, ~}~]); ~A~A(~A); }" (ecl-type->c-type return-type) pointer types (if (eq return-type :void) "" "@(return) = ") pointer (subseq +ecl-inline-codes+ 0 (max 0 (1- (* (length values) 3))))))) :one-liner nil :side-effects t)) (t (c-inline-function-pointer-call `(%foreign-symbol-pointer ,pointer nil) types values return-type)))) (defun dffi-function-pointer-call (pointer types values return-type) (when (stringp pointer) (setf pointer `(%foreign-symbol-pointer ,pointer nil))) #-dffi `(error "In interpreted code, attempted to call a foreign function~% ~A~%~ but ECL was built without support for that." ,pointer) #+dffi `(si::call-cfun ,pointer ,return-type (list ,@types) (list ,@values))) #.(cl:when (>= ext:+ecl-version-number+ 100402) (cl:pushnew :ecl-with-backend cl:*features*) cl:nil) (defun produce-function-pointer-call (pointer types values return-type) #-ecl-with-backend (progn (if (eq *cffi-ecl-method* :dffi) (dffi-function-pointer-call pointer types values return-type) (c-inline-function-pointer-call pointer types values return-type))) #+ecl-with-backend `(ext:with-backend :bytecodes ,(dffi-function-pointer-call pointer types values return-type) :c/c++ (if (eq *cffi-ecl-method* :dffi) ,(dffi-function-pointer-call pointer types values return-type) ,(c-inline-function-pointer-call pointer types values return-type)))) (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) "Close a foreign library." (handler-case (si::unload-foreign-module handle) (undefined-function () (restart-case (error "Detected ECL prior to version 15.2.21. ~ Function CFFI:CLOSE-FOREIGN-LIBRARY isn't implemented yet.") (ignore () :report "Continue anyway (foreign library will remain opened)."))))) (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)) (handler-case (si:find-foreign-symbol (coerce name 'base-string) :default :pointer-void 0) (error (c) nil))) cffi_0.16.1/src/cffi-gcl.lisp000644 000765 000024 00000024071 12562363066 016056 0ustar00luisstaff000000 000000 ;;;; -*- 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_0.16.1/src/cffi-lispworks.lisp000644 000765 000024 00000037054 12562363066 017353 0ustar00luisstaff000000 000000 ;;;; -*- 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_0.16.1/src/cffi-mcl.lisp000644 000765 000024 00000032530 12562363066 016063 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-mcl.lisp --- CFFI-SYS implementation for Digitool MCL. ;;; ;;; Copyright 2010 james.anderson@setf.de ;;; Copyright 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 is a stop-gap emulation. (at least) three things are not right ;;; - integer vector arguments are copied ;;; - return values are not typed ;;; - a shared library must be packaged as a framework and statically loaded ;;; ;;; on the topic of shared libraries, see ;;; http://developer.apple.com/library/mac/#documentation/DeveloperTools/Conceptual/MachOTopics/1-Articles/loading_code.html ;;; which describes how to package a shared library as a framework. ;;; once a framework exists, load it as, eg. ;;; (ccl::add-framework-bundle "fftw.framework" :pathname "ccl:frameworks;" ) ;;;# 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." (#_newPtr size)) (defun foreign-free (ptr) "Free a PTR allocated by FOREIGN-ALLOC." ;; TODO: Should we make this a dead macptr? (#_disposePtr 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)) (ccl:%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))) ;;; from openmcl::macros.lisp (defmacro with-pointer-to-vector-data ((ptr ivector) &body body) "Bind PTR-VAR to a foreign pointer to the data in VECTOR." (let* ((v (gensym)) (l (gensym))) `(let* ((,v ,ivector) (,l (length ,v))) (unless (typep ,v 'ccl::ivector) (ccl::report-bad-arg ,v 'ccl::ivector)) ;;;!!! this, unless it's possible to suppress gc (let ((,ptr (#_newPtr ,l))) (unwind-protect (progn (ccl::%copy-ivector-to-ptr ,v 0 ,ptr 0 ,l) (mutliple-value-prog1 (locally ,@body) (ccl::%copy-ptr-to-ivector ,ptr 0 ,v 0 ,l))) (#_disposePtr ,ptr)))))) ;;;# 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) (:long %get-signed-long) (:unsigned-long %get-unsigned-long) (: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)) (defun ccl::%get-unsigned-long-long (ptr offset) (let ((value 0) (bit 0)) (dotimes (i 8) (setf (ldb (byte 8 (shiftf bit (+ bit 8))) value) (ccl:%get-unsigned-byte ptr (+ offset i)))) value)) (setf (fdefinition 'ccl::%get-signed-long-long) (fdefinition 'ccl::%get-unsigned-long-long)) (defun (setf ccl::%get-unsigned-long-long) (value ptr offset) (let ((bit 0)) (dotimes (i 8) (setf (ccl:%get-unsigned-byte ptr (+ offset i)) (ldb (byte 8 (shiftf bit (+ bit 8))) value)))) ptr) (setf (fdefinition '(setf ccl::%get-signed-long-long)) (fdefinition '(setf ccl::%get-unsigned-long-long))) ;;;# Calling Foreign Functions (defun convert-foreign-type (type-keyword) "Convert a CFFI type keyword to a ppc-ff-call type." (ecase type-keyword (:char :signed-byte) (:unsigned-char :unsigned-byte) (:short :signed-short) (:unsigned-short :unsigned-short) (:int :signed-fullword) (:unsigned-int :unsigned-fullword) (:long :signed-fullword) (:unsigned-long :unsigned-fullword) (:long-long :signed-doubleword) (:unsigned-long-long :unsigned-doubleword) (:float :single-float) (:double :double-float) (:pointer :address) (:void :void))) (defun ppc-ff-call-type=>mactype-name (type-keyword) (ecase type-keyword (:signed-byte :sint8) (:unsigned-byte :uint8) (:signed-short :sint16) (:unsigned-short :uint16) (:signed-halfword :sint16) (:unsigned-halfword :uint16) (:signed-fullword :sint32) (:unsigned-fullword :uint32) ;(:signed-doubleword :long-long) ;(:unsigned-doubleword :unsigned-long-long) (:single-float :single-float) (:double-float :double-float) (:address :pointer) (:void :void))) (defun %foreign-type-size (type-keyword) "Return the size in bytes of a foreign type." (case type-keyword ((:long-long :unsigned-long-long) 8) (t (ccl::mactype-record-size (ccl::find-mactype (ppc-ff-call-type=>mactype-name (convert-foreign-type type-keyword))))))) ;; 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." (case type-keyword ((:long-long :unsigned-long-long) 4) (t (ccl::mactype-record-size (ccl::find-mactype (ppc-ff-call-type=>mactype-name (convert-foreign-type type-keyword))))))) (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) "no '_' is necessary here, the internal lookup operators handle it" name) (defmacro %foreign-funcall (function-name args &key library convention) "Perform a foreign function call, document it more later." (declare (ignore library convention)) `(ccl::ppc-ff-call (ccl::macho-address ,(ccl::get-macho-entry-point (convert-external-name function-name))) ,@(convert-foreign-funcall-types args))) (defmacro %foreign-funcall-pointer (ptr args &key convention) (declare (ignore convention)) `(ccl::ppc-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) (declare (ignore convention)) (let ((cb-name (intern-callback name))) `(progn (ccl::ppc-defpascal ,cb-name (;; ? ,@(when (eq convention :stdcall) '(:discard-stack-args)) ,@(mapcan (lambda (sym type) (list (ppc-ff-call-type=>mactype-name (convert-foreign-type type)) sym)) arg-names arg-types) ,(ppc-ff-call-type=>mactype-name (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 path)) (setf name (string name)) ;; for mcl emulate this wrt frameworks (unless (and (> (length name) 10) (string-equal name ".framework" :start1 (- (length name) 10))) (setf name (concatenate 'string name ".framework"))) ;; if the framework was not registered, add it (unless (gethash name ccl::*framework-descriptors*) (ccl::add-framework-bundle name :pathname "ccl:frameworks;" )) (ccl::load-framework-bundle name)) (defun %close-foreign-library (name) "Close the foreign library NAME." ;; for mcl do nothing (declare (ignore name)) nil) (defun native-namestring (pathname) (ccl::posix-namestring (ccl:full-pathname pathname))) ;;;# Foreign Globals (deftrap-inline "_findsymbol" ((map :pointer) (name :pointer)) :pointer ()) (defun %foreign-symbol-pointer (name library) "Returns a pointer to a foreign symbol NAME." (declare (ignore library)) (ccl::macho-address (ccl::get-macho-entry-point (convert-external-name name)))) cffi_0.16.1/src/cffi-mkcl.lisp000644 000765 000024 00000027420 12562363066 016240 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cffi-mkcl.lisp --- MKCL backend for CFFI. ;;; ;;; Copyright (C) 2010-2012, Jean-Claude Beaudoin ;;; 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 #: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)) (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) nil) (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) (defun null-pointer () "Construct and return a null pointer." (si:make-foreign-null-pointer)) (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) (si:foreignp ptr)) (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))) ;;; MKCL, built with the Boehm GC never moves allocated data, so this ;;; isn't nearly as hard to do. (defun %vector-address (vector) "Return the address of VECTOR's data." (check-type vector (vector (unsigned-byte 8))) #-mingw64 (ffi:c-inline (vector) (object) :unsigned-long "(uintptr_t) #0->vector.self.b8" :side-effects nil :one-liner t) #+mingw64 (ffi:c-inline (vector) (object) :unsigned-long-long "(uintptr_t) #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->mkcl-type type)) (type-size (ffi:size-of-foreign-type type))) (si:foreign-ref-elt (si:foreign-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->mkcl-type type)) (type-size (ffi:size-of-foreign-type type))) (si:foreign-set-elt (si:foreign-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") (:long-long :long-long "long long") (:unsigned-long-long :unsigned-long-long "unsigned long long") (:float :float "float") (:double :double "double") (:pointer :pointer-void "void*") (:void :void "void"))) (defun cffi-type->mkcl-type (type-keyword) "Convert a CFFI type keyword to an MKCL type keyword." (or (second (find type-keyword +translation-table+ :key #'first)) (error "~S is not a valid CFFI type" type-keyword))) (defun mkcl-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->mkcl-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->mkcl-type type-keyword)))) ;;;# Calling Foreign Functions #| (defconstant +mkcl-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) #| (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 #'mkcl-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)" (mkcl-type->c-type return-type) types (subseq +mkcl-inline-codes+ 3 (max 3 (+ 2 (* (length values) 3))))))) :one-liner t :side-effects t)) |# ;; The version here below is definitely not as efficient as the one above ;; but it has the great vertue of working in all cases, (contrary to the ;; silent and unsafe limitations of the one above). JCB ;; I should re-optimize this one day, when I get time... JCB (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->mkcl-type type) into types and collect arg into values else do (setf return-type (cffi-type->mkcl-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)) (handler-case (si:load-foreign-module path) (file-error () (error "file error while trying to load `~A'" path)))) (defun %close-foreign-library (handle) ;;(declare (ignore handle)) ;;(error "%CLOSE-FOREIGN-LIBRARY unimplemented.") (si:unload-foreign-module handle)) (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->mkcl-type rettype) ,(mapcar #'list arg-names (mapcar #'cffi-type->mkcl-type arg-types)) ;;(block ,cb-name ,@body) (block ,cb-name ,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)) (values (ignore-errors (si:find-foreign-symbol name :default :pointer-void 0)))) cffi_0.16.1/src/cffi-openmcl.lisp000644 000765 000024 00000024646 12562363066 016756 0ustar00luisstaff000000 000000 ;;;; -*- 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) #+(or 32-bit-target windows-target) (:long %get-signed-long) #+(and (not windows-target) 64-bit-target) (:long ccl::%%get-signed-longlong) #+(or 32-bit-target windows-target) (:unsigned-long %get-unsigned-long) #+(and 64-bit-target (not windows-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." ;; C-S-L sometimes ends in an endless loop ;; with :COMPLETELY T (close-shared-library name :completely nil)) (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_0.16.1/src/cffi-sbcl.lisp000644 000765 000024 00000034745 12562363066 016245 0ustar00luisstaff000000 000000 ;;;; -*- 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) (optimize speed)) (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)))) ;;; Look up alien type information and build both define-mem-accessors form ;;; and convert-foreign-type function definition. (defmacro define-type-mapping (accessor-table alien-table) (let* ((accessible-types (remove 'void alien-table :key #'second)) (size-and-signedp-forms (mapcar (lambda (name) (list (eval `(alien-size ,(second name))) (typep -1 `(alien ,(second name))))) accessible-types))) `(progn (define-mem-accessors ,@(loop for (cffi-keyword alien-type fixed-accessor) in accessible-types and (alien-size signedp) in size-and-signedp-forms for (signed-ref unsigned-ref) = (cdr (assoc alien-size accessor-table)) collect `(,cffi-keyword ,(or fixed-accessor (if signedp signed-ref unsigned-ref) (error "No accessor found for ~S" alien-type))))) (defun convert-foreign-type (type-keyword) (ecase type-keyword ,@(loop for (cffi-keyword alien-type) in alien-table collect `(,cffi-keyword (quote ,alien-type)))))))) (define-type-mapping ((8 sb-sys:signed-sap-ref-8 sb-sys:sap-ref-8) (16 sb-sys:signed-sap-ref-16 sb-sys:sap-ref-16) (32 sb-sys:signed-sap-ref-32 sb-sys:sap-ref-32) (64 sb-sys:signed-sap-ref-64 sb-sys:sap-ref-64)) ((: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 sb-sys:sap-ref-single) (:double double-float sb-sys:sap-ref-double) (:pointer system-area-pointer sb-sys:sap-ref-sap) (:void void))) ;;;# Calling Foreign Functions (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) (check-type convention (member :stdcall :cdecl)) `(setf (gethash ',name *callbacks*) (alien-sap (sb-alien::alien-lambda #+alien-callback-conventions (,convention ,(convert-foreign-type rettype)) #-alien-callback-conventions ,(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 #+darwin (defun call-within-initial-thread (fn &rest args) (let (result error (sem (sb-thread:make-semaphore))) (sb-thread:interrupt-thread ;; KLUDGE: find a better way to get the initial thread. (car (last (sb-thread:list-all-threads))) (lambda () (multiple-value-setq (result error) (ignore-errors (apply fn args))) (sb-thread:signal-semaphore sem))) (sb-thread:wait-on-semaphore sem) (if error (signal error) result))) (declaim (inline %load-foreign-library)) (defun %load-foreign-library (name path) "Load a foreign library." (declare (ignore name)) ;; As of MacOS X 10.6.6, loading things like CoreFoundation from a ;; thread other than the initial one results in a crash. #+darwin (call-within-initial-thread 'load-shared-object path) #-darwin (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_0.16.1/src/cffi-scl.lisp000644 000765 000024 00000025533 12562363066 016076 0ustar00luisstaff000000 000000 ;;;; -*- 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_0.16.1/src/early-types.lisp000644 000765 000024 00000055625 12562363066 016673 0ustar00luisstaff000000 000000 ;;;; -*- 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 :test 'equal) "Hash table of defined type parsers.") (defun find-type-parser (symbol &optional (namespace :default)) "Return the type parser for SYMBOL." (or (gethash (cons namespace symbol) *type-parsers*) (if (eq namespace :default) (error "unknown CFFI type: ~S." symbol) (error "unknown CFFI type: (~S ~S)." namespace symbol)))) (defun (setf find-type-parser) (func symbol &optional (namespace :default)) "Set the type parser for SYMBOL." (setf (gethash (cons namespace 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 &optional (namespace :default)) (setf (find-type-parser name namespace) (lambda () type)) name) ;;;# Generic Functions on Types (defgeneric canonicalize (foreign-type) (:documentation "Return the most primitive foreign type for FOREIGN-TYPE, either a built-in type--a keyword--or a struct/union type--a list of the form (:STRUCT/:UNION name). 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)))) (defvar *built-in-foreign-types* nil) (defmacro define-built-in-foreign-type (keyword) "Defines a built-in foreign-type." `(eval-when (:compile-toplevel :load-toplevel :execute) (pushnew ,keyword *built-in-foreign-types*) (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 (defgeneric bare-struct-type-p (foreign-type) (:documentation "Return true if FOREIGN-TYPE is a bare struct type or an alias of a bare struct type. ")) (defmethod bare-struct-type-p ((type foreign-type)) "Return true if FOREIGN-TYPE is a bare struct type or an alias of a bare struct type. " nil) (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) (bare ;; we use this flag to support the (old, deprecated) semantics of ;; bare struct types. FOO means (:POINTER (:STRUCT FOO) in ;; functions declarations whereas FOO in a structure definition is ;; a proper aggregate type: (:STRUCT FOO), etc. :initform nil :initarg :bare :reader bare-struct-type-p))) (defun slots-in-order (structure-type) "A list of the structure's slots in order." (sort (loop for slots being the hash-value of (structure-slots structure-type) collect slots) #'< :key 'slot-offset)) (defmethod canonicalize ((type foreign-struct-type)) (if (bare-struct-type-p type) :pointer `(:struct ,(name type)))) (defmethod unparse-type ((type foreign-struct-type)) (if (bare-struct-type-p type) (name type) (canonicalize type))) (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)) (defclass foreign-union-type (foreign-struct-type) ()) (defmethod canonicalize ((type foreign-union-type)) (if (bare-struct-type-p type) :pointer `(:union ,(name 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)) (defmethod bare-struct-type-p ((type foreign-typedef)) (bare-struct-type-p (follow-typedefs type))) (defun structure-slots (type) "The hash table of slots for the structure type." (slots (follow-typedefs type))) ;;;# Type Translators ;;; ;;; Type translation is done with generic functions at runtime for ;;; subclasses of TRANSLATABLE-FOREIGN-TYPE. ;;; ;;; The main interface for defining type translations is through the ;;; generic functions TRANSLATE-{TO,FROM}-FOREIGN and ;;; FREE-TRANSLATED-OBJECT. (defclass translatable-foreign-type (foreign-type) ()) ;;; ENHANCED-FOREIGN-TYPE is used to define translations on top of ;;; previously defined foreign types. (defclass enhanced-foreign-type (translatable-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 TRANSLATABLE-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)) (defgeneric translate-into-foreign-memory (value type pointer) (:documentation "Translate the Lisp value into the foreign memory location given by pointer. Return value is not used.") (:argument-precedence-order type value pointer)) ;;; 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 TRANSLATABLE-FOREIGN-TYPE. ;;; Returns the converted Lisp value. (defgeneric translate-from-foreign (value type) (:argument-precedence-order type value) (: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 ;;; TRANSLATABLE-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 translatable-foreign-type)) (let ((*runtime-translator-form* `(translate-from-foreign ,value ,type))) (call-next-method))) (defmethod expand-from-foreign (value (type translatable-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 translatable-foreign-type)) (let ((*runtime-translator-form* `(translate-to-foreign ,value ,type))) (call-next-method))) (defmethod expand-to-foreign (value (type translatable-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.) (defun foreign-expand-runtime-translator-or-binding (value var body type) (multiple-value-bind (expansion default-etp-p) (expand-to-foreign value type) (if default-etp-p *runtime-translator-form* `(let ((,var ,expansion)) ,@body)))) (defmethod expand-to-foreign-dyn (value var body (type enhanced-foreign-type)) (foreign-expand-runtime-translator-or-binding value var body type)) ;;; EXPAND-TO-FOREIGN-DYN-INDIRECT ;;; Like expand-to-foreign-dyn, but always give form that returns a ;;; pointer to the object, even if it's directly representable in ;;; CL, e.g. numbers. (defgeneric expand-to-foreign-dyn-indirect (value var body type) (:method (value var body type) (declare (ignore type)) `(let ((,var ,value)) ,@body))) (defmethod expand-to-foreign-dyn-indirect :around (value var body (type translatable-foreign-type)) (let ((*runtime-translator-form* `(with-foreign-object (,var ',(unparse-type type)) (translate-into-foreign-memory ,value ,type ,var) ,@body))) (call-next-method))) (defmethod expand-to-foreign-dyn-indirect (value var body (type foreign-pointer-type)) `(with-foreign-object (,var :pointer) (translate-into-foreign-memory ,value ,type ,var) ,@body)) (defmethod expand-to-foreign-dyn-indirect (value var body (type foreign-built-in-type)) `(with-foreign-object (,var ,type) (translate-into-foreign-memory ,value ,type ,var) ,@body)) (defmethod expand-to-foreign-dyn-indirect (value var body (type translatable-foreign-type)) (foreign-expand-runtime-translator-or-binding value var body type)) (defmethod expand-to-foreign-dyn-indirect (value var body (type foreign-type-alias)) (expand-to-foreign-dyn-indirect value var body (actual-type type))) ;;; 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-into-foreign-memory (value (type enhanced-typedef) pointer) (translate-into-foreign-memory value (actual-type type) pointer)) (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_0.16.1/src/enum.lisp000644 000765 000024 00000025047 12562363066 015354 0ustar00luisstaff000000 000000 ;;;; -*- 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-into-foreign-memory (value (type foreign-enum) pointer) (setf (mem-aref pointer (unparse-type (actual-type type))) (translate-to-foreign value type))) (defmethod translate-from-foreign (value (type foreign-enum)) (%foreign-enum-keyword type value :errorp t)) (defmethod expand-to-foreign (value (type foreign-enum)) (once-only (value) `(if (keywordp ,value) (%foreign-enum-value ,type ,value :errorp t) ,value))) ;;;# 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)))) (define-compiler-macro foreign-bitfield-value (&whole form type symbols) "Optimize for when TYPE and SYMBOLS are constant." (if (and (constantp type) (constantp symbols)) (let ((type-obj (parse-type (eval type)))) (if (not (typep type-obj 'foreign-bitfield)) (error "~S is not a foreign bitfield type." type) (%foreign-bitfield-value type-obj (eval symbols)))) form)) (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)))) (define-compiler-macro foreign-bitfield-symbols (&whole form type value) "Optimize for when TYPE and SYMBOLS are constant." (if (and (constantp type) (constantp value)) (let ((type-obj (parse-type (eval type)))) (if (not (typep type-obj 'foreign-bitfield)) (error "~S is not a foreign bitfield type." type) `(quote ,(%foreign-bitfield-symbols type-obj (eval value))))) form)) (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)) (defmethod expand-to-foreign (value (type foreign-bitfield)) (flet ((expander (value type) `(if (integerp ,value) ,value (%foreign-bitfield-value ,type (ensure-list ,value))))) (if (constantp value) (eval (expander value type)) (expander value type)))) (defmethod expand-from-foreign (value (type foreign-bitfield)) (flet ((expander (value type) `(%foreign-bitfield-symbols ,type ,value))) (if (constantp value) (eval (expander value type)) (expander value type)))) cffi_0.16.1/src/features.lisp000644 000765 000024 00000007560 12562363066 016226 0ustar00luisstaff000000 000000 ;;;; -*- 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_0.16.1/src/foreign-vars.lisp000644 000765 000024 00000007742 12562363066 017014 0ustar00luisstaff000000 000000 ;;;; -*- 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)) (check-type name string) (%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_0.16.1/src/functions.lisp000644 000765 000024 00000044335 12562363066 016421 0ustar00luisstaff000000 000000 ;;;; -*- 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 &optional indirect) "Helper function for FOREIGN-FUNCALL and DEFCFUN. If 'indirect is T, all arguments are represented by foreign pointers, even those that can be represented by CL objects." (if (null args) (expand-from-foreign call-form (parse-type rettype)) (funcall (if indirect #'expand-to-foreign-dyn-indirect #'expand-to-foreign-dyn) (car args) (car syms) (list (translate-objects (cdr syms) (cdr args) (cdr types) rettype call-form indirect)) (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 structure-by-value-p (ctype) "A structure or union is to be called or returned by value." (let ((actual-type (follow-typedefs (parse-type ctype)))) (or (and (typep actual-type 'foreign-struct-type) (not (bare-struct-type-p actual-type))) #+cffi::no-long-long (typep actual-type 'emulated-llong-type)))) (defun fn-call-by-value-p (argument-types return-type) "One or more structures in the arguments or return from the function are called by value." (or (some 'structure-by-value-p argument-types) (structure-by-value-p return-type))) (defvar *foreign-structures-by-value* (lambda (&rest args) (declare (ignore args)) (restart-case (error "Unable to call structures by value without cffi-libffi loaded.") (load-cffi-libffi () :report "Load cffi-libffi." (asdf:operate 'asdf:load-op 'cffi-libffi)))) "A function that produces a form suitable for calling structures by value.") (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))) (fsbvp (fn-call-by-value-p ctypes rettype))) (if fsbvp ;; Structures by value call through *foreign-structures-by-value* (funcall *foreign-structures-by-value* thing fargs syms types rettype ctypes pointerp) (translate-objects syms fargs types rettype `(,(if pointerp '%foreign-funcall-pointer '%foreign-funcall) ;; No structures by value, direct call ,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 #'first args)) (arg-types (mapcar #'second args)) (syms (make-gensym-list (length args))) (call-by-value (fn-call-by-value-p arg-types return-type))) (multiple-value-bind (prelude caller) (if call-by-value (values nil nil) (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) ,(if call-by-value `(foreign-funcall ,(cons foreign-name options) ,@(append (mapcan #'list arg-types arg-names) (list return-type))) (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))))) (defgeneric translate-underscore-separated-name (name) (:method ((name string)) (values (intern (canonicalize-symbol-name-case (substitute #\- #\_ name))))) (:method ((name symbol)) (substitute #\_ #\- (string-downcase (symbol-name name))))) (defun collapse-prefix (l special-words) (unless (null l) (multiple-value-bind (newpre skip) (check-prefix l special-words) (cons newpre (collapse-prefix (nthcdr skip l) special-words))))) (defun check-prefix (l special-words) (let ((pl (loop for i from (1- (length l)) downto 0 collect (apply #'concatenate 'simple-string (butlast l i))))) (loop for w in special-words for p = (position-if #'(lambda (s) (string= s w)) pl) when p do (return-from check-prefix (values (nth p pl) (1+ p)))) (values (first l) 1))) (defgeneric translate-camelcase-name (name &key upper-initial-p special-words) (:method ((name string) &key upper-initial-p special-words) (declare (ignore upper-initial-p)) (values (intern (reduce #'(lambda (s1 s2) (concatenate 'simple-string s1 "-" s2)) (mapcar #'string-upcase (collapse-prefix (split-if #'(lambda (ch) (or (upper-case-p ch) (digit-char-p ch))) name) special-words)))))) (:method ((name symbol) &key upper-initial-p special-words) (apply #'concatenate 'string (loop for str in (split-if #'(lambda (ch) (eq ch #\-)) (string name) :elide) for first-word-p = t then nil for e = (member str special-words :test #'equal :key #'string-upcase) collect (cond ((and first-word-p (not upper-initial-p)) (string-downcase str)) (e (first e)) (t (string-capitalize str))))))) (defgeneric translate-name-from-foreign (foreign-name package &optional varp) (:method (foreign-name package &optional varp) (declare (ignore package)) (let ((sym (translate-underscore-separated-name foreign-name))) (if varp (values (intern (format nil "*~A*" (canonicalize-symbol-name-case (symbol-name sym))))) sym)))) (defgeneric translate-name-to-foreign (lisp-name package &optional varp) (:method (lisp-name package &optional varp) (declare (ignore package)) (let ((name (translate-underscore-separated-name lisp-name))) (if varp (string-trim '(#\*) name) name)))) (defun lisp-name (spec varp) (check-type spec string) (translate-name-from-foreign spec *package* varp)) (defun foreign-name (spec varp) (check-type spec (and symbol (not null))) (translate-name-to-foreign spec *package* varp)) (defun foreign-options (opts varp) (if varp (funcall 'parse-defcvar-options opts) (parse-function-options opts))) (defun lisp-name-p (name) (and name (symbolp name) (not (keywordp name)))) (defun %parse-name-and-options (spec varp) (cond ((stringp spec) (values (lisp-name spec varp) spec nil)) ((symbolp spec) (assert (not (null spec))) (values spec (foreign-name spec varp) nil)) ((and (consp spec) (stringp (first spec))) (destructuring-bind (foreign-name &rest options) spec (cond ((or (null options) (keywordp (first options))) (values (lisp-name foreign-name varp) foreign-name options)) (t (assert (lisp-name-p (first options))) (values (first options) foreign-name (rest options)))))) ((and (consp spec) (lisp-name-p (first spec))) (destructuring-bind (lisp-name &rest options) spec (cond ((or (null options) (keywordp (first options))) (values lisp-name (foreign-name spec varp) options)) (t (assert (stringp (first options))) (values lisp-name (first options) (rest options)))))) (t (error "Not a valid foreign function specifier: ~A" spec)))) ;;; DEFCFUN's first argument has can have the following syntax: ;;; ;;; 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 parse-name-and-options (spec &optional varp) (multiple-value-bind (lisp-name foreign-name options) (%parse-name-and-options spec varp) (values lisp-name foreign-name (foreign-options options 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 (lastcar 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_0.16.1/src/libraries.lisp000644 000765 000024 00000043722 12562363066 016364 0ustar00luisstaff000000 000000 ;;;; -*- 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 ;;; and the evaluated form should yield a single pathname or a list of ;;; pathnames. ;;; ;;; 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. (defun explode-path-environment-variable (name) (mapcar #'uiop:ensure-directory-pathname (split-if (lambda (c) (eql #\: c)) (uiop:getenv name) :elide))) (defun darwin-fallback-library-path () (or (explode-path-environment-variable "DYLD_FALLBACK_LIBRARY_PATH") (list (merge-pathnames #p"lib/" (user-homedir-pathname)) #p"/usr/local/lib/" #p"/usr/lib/"))) (defvar *foreign-library-directories* (if (featurep :darwin) '((explode-path-environment-variable "LD_LIBRARY_PATH") (explode-path-environment-variable "DYLD_LIBRARY_PATH") (uiop:getcwd) (darwin-fallback-library-path)) '()) "List onto which user-defined library paths can be pushed.") (defun fallback-darwin-framework-directories () (or (explode-path-environment-variable "DYLD_FALLBACK_FRAMEWORK_PATH") (list (uiop:getcwd) (merge-pathnames #p"Library/Frameworks/" (user-homedir-pathname)) #p"/Library/Frameworks/" #p"/System/Library/Frameworks/"))) (defvar *darwin-framework-directories* '((explode-path-environment-variable "DYLD_FRAMEWORK_PATH") (fallback-darwin-framework-directories)) "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 parse-directories (list) (mappend (compose #'ensure-list #'mini-eval) list)) (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 (directory (parse-directories *darwin-framework-directories*)) (let ((path (make-pathname :name framework-name :directory (append (pathname-directory 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 () ((name :initform nil :initarg :name :accessor foreign-library-name) (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))) (defmethod print-object ((library foreign-library) stream) (with-slots (name pathname) library (print-unreadable-object (library stream :type t) (when name (format stream "~A" name)) (when pathname (format stream " ~S" (file-namestring pathname)))))) (define-condition foreign-library-undefined-error (error) ((name :initarg :name :reader fl-name)) (:report (lambda (c s) (format s "Undefined foreign library: ~S" (fl-name c))))) (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 'foreign-library-undefined-error :name 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 (foreign-library-handle (get-foreign-library lib))))) (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))))))) (defun register-foreign-library (name spec &rest options) (let ((old-handle (when-let ((old-lib (gethash name *foreign-libraries*))) (foreign-library-handle old-lib)))) (setf (get-foreign-library name) (apply #'make-instance 'foreign-library :name name :spec spec :handle old-handle options)) name)) (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) (check-type name symbol) `(register-foreign-library ',name ',pairs ,@options))) ;;;# 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) (let ((dirs (parse-directories *foreign-library-directories*))) (if-let (file (find-file path (append search-path dirs))) (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 ((or pathname string) (load-foreign-library-path (filter-pathname name) 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) (with-slots (handle pathname) lib (setf (values handle pathname) (load-foreign-library-helper name spec (foreign-library-search-path lib))))) lib)) (etypecase library (symbol (let* ((lib (get-foreign-library library)) (spec (foreign-library-spec lib))) (%do-load lib library spec))) ((or string list) (let* ((lib-name (gensym (format nil "~:@(~A~)-" (if (listp library) (first library) (file-namestring library))))) (lib (make-instance 'foreign-library :type :system :name lib-name :spec `((t ,library)) :search-path search-path))) ;; first try to load the anonymous library ;; and register it only if that worked (%do-load lib lib-name library) (setf (get-foreign-library lib-name) lib)))))) (defun filter-pathname (thing) (typecase thing (pathname (namestring thing)) (t thing))) (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 )." (let ((library (filter-pathname library))) (restart-case (progn (ignore-some-conditions (foreign-library-undefined-error) (close-foreign-library library)) (%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* ((library (filter-pathname library)) (lib (get-foreign-library library)) (handle (foreign-library-handle lib))) (when handle (%close-foreign-library handle) (setf (foreign-library-handle lib) nil) t))) (defun reload-foreign-libraries (&key (test #'foreign-library-loaded-p)) "(Re)load all currently loaded foreign libraries." (let ((libs (list-foreign-libraries))) (loop for l in libs for name = (foreign-library-name l) when (funcall test name) do (load-foreign-library name)) libs)) cffi_0.16.1/src/package.lisp000644 000765 000024 00000011273 12562363066 015777 0ustar00luisstaff000000 000000 ;;;; -*- 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 #:compose #:ensure-list #:featurep #:format-symbol #:hash-table-values #:if-let #:ignore-some-conditions #:lastcar #:make-gensym-list #:make-keyword #:mappend #:once-only #:parse-body #:simple-style-warning #:symbolicate #:when-let #:with-unique-names) (:export ;; Types. #:foreign-pointer ;; FIXME: the following types are undocumented. They should ;; probably be replaced with a proper type introspection API ;; though. #:*built-in-foreign-types* #:*other-builtin-types* #:*built-in-integer-types* #:*built-in-float-types* ;; Primitive pointer operations. #:foreign-free #:foreign-alloc #:mem-aptr #: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 #:translate-camelcase-name #:translate-name-from-foreign #:translate-name-to-foreign #:translate-underscore-separated-name ;; Foreign library operations. #:*foreign-library-directories* #:*darwin-framework-directories* #:foreign-library #:foreign-library-name #: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 #:reload-foreign-libraries ;; 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-type #:foreign-slot-offset #:foreign-slot-count #:foreign-slot-names #:foreign-type-alignment #:foreign-type-size #:with-foreign-object #:with-foreign-objects #:with-foreign-slots #:convert-to-foreign #:convert-from-foreign #:convert-into-foreign-memory #:free-converted-object #:translation-forms-for-class ;; Extensible foreign type operations. #:define-translation-method ; FIXME: undocumented #:translate-to-foreign #:translate-from-foreign #:translate-into-foreign-memory #:free-translated-object #:expand-to-foreign-dyn #:expand-to-foreign #:expand-from-foreign #:expand-into-foreign-memory ;; Foreign globals. #:defcvar #:get-var-pointer #:foreign-symbol-pointer )) cffi_0.16.1/src/strings.lisp000644 000765 000024 00000031727 12562363066 016103 0ustar00luisstaff000000 000000 ;;;; -*- 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)) (nul-length (if null-terminated-p (null-terminator-len encoding) 0)) (length (+ count nul-length)) (ptr (foreign-alloc :char :count length))) (funcall (encoder mapping) string start end ptr 0) (dotimes (i nul-length) (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))) (defmethod expand-to-foreign-dyn-indirect (value var body (type foreign-string-type)) (alexandria:with-gensyms (str) (expand-to-foreign-dyn value str (list (expand-to-foreign-dyn-indirect str var body (parse-type :pointer))) type))) ;;;# 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_0.16.1/src/structures.lisp000644 000765 000024 00000015502 12562363066 016626 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; structures.lisp --- Methods for translating foreign structures. ;;; ;;; Copyright (C) 2011, Liam M. Healy ;;; ;;; 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) ;;; Definitions for conversion of foreign structures. (defmethod translate-into-foreign-memory ((object list) (type foreign-struct-type) p) (unless (bare-struct-type-p type) (loop for (name value) on object by #'cddr do (setf (foreign-slot-value p (unparse-type type) name) (let ((slot (gethash name (structure-slots type)))) (convert-to-foreign value (slot-type slot))))))) (defun convert-into-foreign-memory (value type ptr) (let ((ptype (parse-type type))) (if (typep ptype 'foreign-built-in-type) value (translate-into-foreign-memory value ptype ptr))) ptr) (defmethod translate-to-foreign (value (type foreign-struct-type)) (let ((ptr (foreign-alloc type))) (translate-into-foreign-memory value type ptr) ptr)) (defmethod translate-from-foreign (p (type foreign-struct-type)) ;; Iterate over slots, make plist (if (bare-struct-type-p type) p (let ((plist (list))) (loop for slot being the hash-value of (structure-slots type) for name = (slot-name slot) do (setf (getf plist name) (foreign-struct-slot-value p slot))) plist))) (defmethod free-translated-object (ptr (type foreign-struct-type) freep) (unless (bare-struct-type-p type) ;; Look for any pointer slots and free them first (loop for slot being the hash-value of (structure-slots type) when (and (listp (slot-type slot)) (eq (first (slot-type slot)) :pointer)) do ;; Free if the pointer is to a specific type, not generic :pointer (free-translated-object (foreign-slot-value ptr type (slot-name slot)) (rest (slot-type slot)) freep)) (foreign-free ptr))) (defmacro define-translation-method ((object type method) &body body) "Define a translation method for the foreign structure type; 'method is one of :into, :from, or :to, meaning relation to foreign memory. If :into, the variable 'pointer is the foreign pointer. Note: type must be defined and loaded before this macro is expanded, and just the bare name (without :struct) should be specified." (let ((tclass (class-name (class-of (cffi::parse-type `(:struct ,type)))))) (when (eq tclass 'foreign-struct-type) (error "Won't replace existing translation method for foreign-struct-type")) `(defmethod ,(case method (:into 'translate-into-foreign-memory) (:from 'translate-from-foreign) (:to 'translate-to-foreign)) ;; Arguments to the method (,object (type ,tclass) ,@(when (eq method :into) '(pointer))) ; is intentional variable capture a good idea? ;; The body (declare (ignorable type)) ; I can't think of a reason why you'd want to use this ,@body))) (defmacro translation-forms-for-class (class type-class) "Make forms for translation of foreign structures to and from a standard class. The class slots are assumed to have the same name as the foreign structure." ;; Possible improvement: optional argument to map structure slot names to/from class slot names. `(progn (defmethod translate-from-foreign (pointer (type ,type-class)) ;; Make the instance from the plist (apply 'make-instance ',class (call-next-method))) (defmethod translate-into-foreign-memory ((object ,class) (type ,type-class) pointer) (call-next-method ;; Translate into a plist and call the general method (loop for slot being the hash-value of (structure-slots type) for name = (slot-name slot) append (list slot-name (slot-value object slot-name))) type pointer)))) ;;; For a class already defined and loaded, and a defcstruct already defined, use ;;; (translation-forms-for-class class type-class) ;;; to connnect the two. It would be nice to have a macro to do all three simultaneously. ;;; (defmacro define-foreign-structure (class )) #| (defmacro define-structure-conversion (value-symbol type lisp-class slot-names to-form from-form &optional (struct-name type)) "Define the functions necessary to convert to and from a foreign structure. The to-form sets each of the foreign slots in succession, assume the foreign object exists. The from-form creates the Lisp object, making it with the correct value by reference to foreign slots." `(flet ((map-slots (fn val) (maphash (lambda (name slot-struct) (funcall fn (foreign-slot-value val ',type name) (slot-type slot-struct))) (slots (follow-typedefs (parse-type ',type)))))) ;; Convert this to a separate function so it doesn't have to be recomputed on the fly each time. (defmethod translate-to-foreign ((,value-symbol ,lisp-class) (type ,type)) (let ((p (foreign-alloc ',struct-name))) ;;(map-slots #'translate-to-foreign ,value-symbol) ; recursive translation of slots (with-foreign-slots (,slot-names p ,struct-name) ,to-form) (values p t))) ; second value is passed to FREE-TRANSLATED-OBJECT (defmethod free-translated-object (,value-symbol (p ,type) freep) (when freep ;; Is this redundant? (map-slots #'free-translated-object value) ; recursively free slots (foreign-free ,value-symbol))) (defmethod translate-from-foreign (,value-symbol (type ,type)) (with-foreign-slots (,slot-names ,value-symbol ,struct-name) ,from-form)))) |# cffi_0.16.1/src/types.lisp000644 000765 000024 00000124015 12562363066 015547 0ustar00luisstaff000000 000000 ;;;; -*- 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) (defparameter *possible-float-types* '(:float :double :long-double)) (defparameter *other-builtin-types* '(:pointer :void) "List of types other than integer or float built in to CFFI.") (defparameter *built-in-integer-types* (set-difference cffi:*built-in-foreign-types* (append *possible-float-types* *other-builtin-types*)) "List of integer types supported by CFFI.") (defparameter *built-in-float-types* (set-difference cffi:*built-in-foreign-types* (append *built-in-integer-types* *other-builtin-types*)) "List of real float types supported by CFFI.") ;;;# 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* ((parsed-type (parse-type type)) (ctype (canonicalize parsed-type))) #+cffi-sys::no-long-long (when (member ctype '(:long-long :unsigned-long-long)) (return-from mem-ref (translate-from-foreign (%emulated-mem-ref-64 ptr ctype offset) parsed-type))) ;; normal branch (if (aggregatep parsed-type) (if (bare-struct-type-p parsed-type) (inc-pointer ptr offset) (translate-from-foreign (inc-pointer ptr offset) parsed-type)) (translate-from-foreign (%mem-ref ptr ctype offset) parsed-type)))) (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) (if (bare-struct-type-p parsed-type) `(inc-pointer ,ptr ,offset) (expand-from-foreign `(inc-pointer ,ptr ,offset) parsed-type)) (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))) (if (aggregatep ptype) ; XXX: backwards incompatible? (translate-into-foreign-memory value ptype (inc-pointer ptr 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)) (if (aggregatep parsed-type) ; XXX: skip for now. form ; use expand-into-foreign-memory when available. `(%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))))))) (defmethod translate-into-foreign-memory (value (type foreign-pointer-type) pointer) (setf (mem-aref pointer :pointer) value)) (defmethod translate-into-foreign-memory (value (type foreign-built-in-type) pointer) (setf (mem-aref pointer (unparse-type type)) value)) (defun mem-aptr (ptr type &optional (index 0)) "The pointer to the element." (inc-pointer ptr (* index (foreign-type-size type)))) (define-compiler-macro mem-aptr (&whole form ptr type &optional (index 0)) "The pointer to the element." (cond ((not (constantp type)) form) ((not (constantp index)) `(inc-pointer ,ptr (* ,index ,(foreign-type-size (eval type))))) ((zerop (eval index)) ptr) (t `(inc-pointer ,ptr ,(* (eval index) (foreign-type-size (eval type))))))) (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 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)) (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))) (defun parse-deprecated-struct-type (name struct-or-union) (check-type struct-or-union (member :struct :union)) (let* ((struct-type-name `(,struct-or-union ,name)) (struct-type (parse-type struct-type-name))) (simple-style-warning "bare references to struct types are deprecated. ~ Please use ~S or ~S instead." `(:pointer ,struct-type-name) struct-type-name) (make-instance (class-of struct-type) :alignment (alignment struct-type) :size (size struct-type) :slots (slots struct-type) :name (name struct-type) :bare t))) ;;; 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 :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 '(:struct ,name) ',slot)) collect `(defun (setf ,accessor) (value ,pointer-arg) (foreign-slot-set value ,pointer-arg '(:struct ,name) ',slot)))) (define-parse-method :struct (name) (funcall (find-type-parser name :struct))) (defvar *defcstruct-hook* nil) (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) (unless (getf options :class) (setf (getf options :class) (symbolicate name '-tclass))) `(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 translatable-foreign-type) ())) (notice-foreign-struct-definition ',name ',options ',fields) ,@(when conc-name (generate-struct-accessors name conc-name (mapcar #'car fields))) ,@(when *defcstruct-hook* ;; If non-nil, *defcstruct-hook* should be a function ;; of the arguments that returns NIL or a list of ;; forms to include in the expansion. (apply *defcstruct-hook* name-and-options fields)) (define-parse-method ,name () (parse-deprecated-struct-type ',name :struct)) '(:struct ,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-type (type slot-name) "Return the type of SLOT in a struct TYPE." (slot-type (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-count (type slot-name) "Return the number of items in SLOT in a struct TYPE." (slot-count (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. Each var can be of the form: slot-name - in which case slot-name will be bound to the value of the slot or: (:pointer slot-name) - in which case slot-name will be bound to the pointer to that slot." (let ((ptr-var (gensym "PTR"))) `(let ((,ptr-var ,ptr)) (symbol-macrolet ,(loop :for var :in vars :collect (if (listp var) (if (eq (first var) :pointer) `(,(second var) (foreign-slot-pointer ,ptr-var ',type ',(second var))) (error "Malformed slot specification ~a; must be:`name' or `(:pointer name)'" var)) `(,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 (list :struct 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 subclass of 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 ((union (make-instance 'foreign-union-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 union)) slot) (when (> size max-size) (setf max-size size)) (when (> align max-align) (setf max-align align))))) (setf (size union) (or size max-size)) (setf (alignment union) max-align) (notice-foreign-type name union :union)))) (define-parse-method :union (name) (funcall (find-type-parser name :union))) (defmacro defcunion (name-and-options &body fields) "Define the layout of a foreign union." (discard-docstring fields) (destructuring-bind (name &key size) (ensure-list name-and-options) (declare (ignore size)) `(eval-when (:compile-toplevel :load-toplevel :execute) (notice-foreign-union-definition ',name-and-options ',fields) (define-parse-method ,name () (parse-deprecated-struct-type ',name :union)) '(:union ,name)))) ;;;# Operations on Types (defmethod foreign-type-alignment (type) "Return the alignment in bytes of a foreign type." (foreign-type-alignment (parse-type type))) (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)))) ;;; Boolean type that represents C99 _Bool (defctype :bool (:boolean #+darwin :int #-darwin :char)) ;;;# 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_0.16.1/src/utils.lisp000644 000765 000024 00000007512 12562363066 015545 0ustar00luisstaff000000 000000 ;;;; -*- 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 (and (not (eq *package* (find-package '#:cffi))) (member package '(#:common-lisp #:keyword) :key #'find-package)) (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)) (defun split-if (test seq &optional (dir :before)) (remove-if #'(lambda (x) (equal x (subseq seq 0 0))) (loop for start fixnum = 0 then (if (eq dir :before) stop (the fixnum (1+ (the fixnum stop)))) while (< start (length seq)) for stop = (position-if test seq :start (if (eq dir :elide) start (the fixnum (1+ start)))) collect (subseq seq start (if (and stop (eq dir :after)) (the fixnum (1+ (the fixnum stop))) stop)) while stop))) cffi_0.16.1/scripts/release.lisp000755 000765 000024 00000023010 12562363066 016717 0ustar00luisstaff000000 000000 #!/usr/bin/env clisp ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- (defpackage :release-script (:use #:cl #:regexp)) (in-package :release-script) ;;;; Configuration ------------------------------------------------------------ (defparameter *project-name* "cffi") (defparameter *asdf-file* (format nil "~A.asd" *project-name*)) (defparameter *host* "common-lisp.net") (defparameter *release-dir* (format nil "/project/~A/public_html/releases" *project-name*)) (defparameter *version-file* "VERSION") (defparameter *version-file-dir* (format nil "/project/~A/public_html" *project-name*)) ;;;; -------------------------------------------------------------------------- ;;;; Utilities (defun ensure-list (x) (if (listp x) x (list x))) (defmacro string-case (expression &body clauses) `(let ((it ,expression)) ; yes, anaphoric, deal with it. (cond ,@(loop for clause in clauses collect `((or ,@(loop for alternative in (ensure-list (first clause)) collect (or (eq t alternative) `(string= it ,alternative)))) ,@(rest clause)))))) (defparameter *development-mode* nil) (defun die (format-control &rest format-args) (format *error-output* "~?" format-control format-args) (if *development-mode* (cerror "continue" "die") (ext:quit 1))) (defun numeric-split (string) (if (digit-char-p (char string 0)) (multiple-value-bind (number next-position) (parse-integer string :junk-allowed t) (cons number (when (< next-position (length string)) (numeric-split (subseq string next-position))))) (let ((next-digit-position (position-if #'digit-char-p string))) (if next-digit-position (cons (subseq string 0 next-digit-position) (numeric-split (subseq string next-digit-position))) (list string))))) (defun natural-string-< (s1 s2) (labels ((aux< (l1 l2) (cond ((null l1) (not (null l2))) ((null l2) nil) (t (destructuring-bind (x . xs) l1 (destructuring-bind (y . ys) l2 (cond ((and (numberp x) (stringp y)) t) ((and (numberp y) (stringp x)) nil) ((and (numberp x) (numberp y)) (or (< x y) (and (= x y) (aux< xs ys)))) (t (or (string-lessp x y) (and (string-equal x y) (aux< xs ys))))))))))) (aux< (numeric-split s1) (numeric-split s2)))) ;;;; Running commands (defparameter *dry-run* nil) (defun cmd? (format-control &rest format-args) (let ((cmd (format nil "~?" format-control format-args))) (with-open-stream (s1 (ext:run-shell-command cmd :output :stream)) (loop for line = (read-line s1 nil nil) while line collect line)))) ;; XXX: quote arguments. (defun cmd (format-control &rest format-args) (when *development-mode* (format *debug-io* "CMD: ~?~%" format-control format-args)) (let ((ret (ext:run-shell-command (format nil "~?" format-control format-args)))) (or (null ret) (zerop ret)))) (defun cmd! (format-control &rest format-args) (or (apply #'cmd format-control format-args) (die "cmd '~?' failed." format-control format-args))) (defun maybe-cmd! (format-control &rest format-args) (if *dry-run* (format t "SUPPRESSING: ~?~%" format-control format-args) (apply #'cmd! format-control format-args))) ;;;; (defun find-current-version () (subseq (reduce (lambda (x y) (if (natural-string-< x y) y x)) (or (cmd? "git tag -l v\\*") (die "no version tags found. Please specify initial version."))) 1)) (defun parse-version (string) (mapcar (lambda (x) (parse-integer x :junk-allowed t)) (loop repeat 3 ; XXX: parameterize for el in (regexp-split "\\." (find-current-version)) collect el))) (defun check-for-unrecorded-changes (&optional force) (unless (cmd "git diff --exit-code") (write-line "Unrecorded changes.") (if force (write-line "Continuing anyway.") (die "Aborting.~@ Use -f or --force if you want to make a release anyway.")))) (defun new-version-number-candidates (current-version) (labels ((alternatives (before after) (when after (cons (append before (list (1+ (first after))) (mapcar (constantly 0) (rest after))) (alternatives (append before (list (first after))) (rest after)))))) (loop for alt in (alternatives nil (parse-version current-version)) collect (format nil "~{~d~^.~}" alt)))) (defun ask-user-for-version (current-version next-versions) (format *query-io* "Current version is ~A. Which will be the next one?~%" current-version) (loop for i from 1 and version in next-versions do (format *query-io* "~T~A) ~A~%" i version)) (format *query-io* "? ") (finish-output *query-io*) (nth (1- (parse-integer (read-line) :junk-allowed t)) next-versions)) (defun git-tag-tree (version) (write-line "Tagging the tree...") (maybe-cmd! "git tag \"v~A\"" version)) (defun add-version-to-system-file (version path-in path-out) (let ((defsystem-line (format nil "(defsystem :~A" *project-name*))) (with-open-file (in path-in :direction :input) (with-open-file (out path-out :direction :output) (loop for line = (read-line in nil nil) while line do (write-line line out) when (string= defsystem-line line) do (format out " :version ~s~%" version)))))) (defun create-dist (version distname) (write-line "Creating distribution...") (cmd! "mkdir \"~a\"" distname) (cmd! "git archive master | tar xC \"~A\"" distname) (format t "Updating ~A with new version: ~A~%" *asdf-file* version) (let* ((asdf-file-path (format nil "~A/~A" distname *asdf-file*)) (tmp-asdf-file-path (format nil "~a.tmp" asdf-file-path))) (add-version-to-system-file version asdf-file-path tmp-asdf-file-path) (cmd! "mv \"~a\" \"~a\"" tmp-asdf-file-path asdf-file-path))) (defun tar-and-sign (distname tarball) (write-line "Creating and signing tarball...") (cmd! "tar czf \"~a\" \"~a\"" tarball distname) (cmd! "gpg -b -a \"~a\"" tarball)) (defparameter *remote-directory* (format nil "~A:~A" *host* *release-dir*)) (defun upload-tarball (tarball signature remote-directory) (write-line "Copying tarball to web server...") (maybe-cmd! "scp \"~A\" \"~A\" \"~A\"" tarball signature remote-directory) (format t "Uploaded ~A and ~A.~%" tarball signature)) (defun update-remote-links (tarball signature host release-dir project-name) (format t "Updating ~A_latest links...~%" project-name) (maybe-cmd! "ssh \"~A\" ln -sf \"~A\" \"~A/~A_latest.tar.gz\"" host tarball release-dir project-name) (maybe-cmd! "ssh \"~A\" ln -sf \"~A\" \"~A/~A_latest.tar.gz.asc\"" host signature release-dir project-name)) (defun upload-version-file (version version-file host version-file-dir) (format t "Uploading ~A...~%" version-file) (with-open-file (out version-file :direction :output) (write-string version out)) (maybe-cmd! "scp \"~A\" \"~A\":\"~A\"" version-file host version-file-dir) (maybe-cmd! "rm \"~A\"" version-file)) (defun maybe-clean-things-up (tarball signature) (when (y-or-n-p "Clean local tarball and signature?") (cmd! "rm \"~A\" \"~A\"" tarball signature))) (defun run (force version) (check-for-unrecorded-changes force) ;; figure out what version we'll be preparing. (unless version (let* ((current-version (find-current-version)) (next-versions (new-version-number-candidates current-version))) (setf version (or (ask-user-for-version current-version next-versions) (die "invalid selection."))))) (git-tag-tree version) (let* ((distname (format nil "~A_~A" *project-name* version)) (tarball (format nil "~A.tar.gz" distname)) (signature (format nil "~A.asc" tarball))) ;; package things up. (create-dist version distname) (tar-and-sign distname tarball) ;; upload. (upload-tarball tarball signature *remote-directory*) (update-remote-links tarball signature *host* *release-dir* *project-name*) (when *version-file* (upload-version-file version *version-file* *host* *version-file-dir*)) ;; clean up. (maybe-clean-things-up tarball signature) ;; documentation. (write-line "Building and uploading documentation...") (maybe-cmd! "make -C doc upload-docs") ;; push tags and any outstanding changes. (write-line "Pushing tags and changes...") (maybe-cmd! "git push --tags origin master"))) ;;;; Do it to it (let ((force nil) (version nil) (args ext:*args*)) (loop while args do (string-case (pop args) (("-h" "--help") (write-line "No help, sorry. Read the source.") (ext:quit 0)) (("-f" "--force") (setf force t)) (("-v" "--version") (setf version (pop args))) (("-n" "--dry-run") (setf *dry-run* t)) (t (die "Unrecognized argument '~a'" it)))) (run force version)) cffi_0.16.1/libffi/built-in-types.lisp000644 000765 000024 00000004474 12562363066 017742 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; built-in-types.lisp -- Define libffi-type-pointers for built-in types and typedefs ;;; ;;; Copyright (C) 2011 Liam M. Healy ;;; ;;; 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) (defun set-libffi-type-pointer-for-built-in (type &optional (libffi-name type)) (set-libffi-type-pointer type (foreign-symbol-pointer (format nil "ffi_type_~(~a~)" libffi-name)))) ;;; Set the type pointers for non-integer built-in types (dolist (type (append *built-in-float-types* *other-builtin-types*)) (set-libffi-type-pointer-for-built-in type)) ;;; Set the type pointers for integer built-in types (dolist (type *built-in-integer-types*) (set-libffi-type-pointer-for-built-in type (format nil "~aint~d" (if (string-equal type "unsigned" :end1 (min 8 (length (string type)))) "u" "s") (* 8 (foreign-type-size type))))) ;;; Set the type pointer on demand for alias (e.g. typedef) types (defmethod libffi-type-pointer ((type foreign-type-alias)) (libffi-type-pointer (follow-typedefs type))) ;;; Luis thinks this is unnecessary; FOREIGN-ENUM inherits from FOREIGN-TYPE-ALIAS. #+(or) (defmethod libffi-type-pointer ((type foreign-enum)) (libffi-type-pointer (actual-type type))) cffi_0.16.1/libffi/cif.lisp000644 000765 000024 00000003456 12562363066 015615 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cif.lisp --- Structure and function call function in libffi ;;; ;;; Copyright (C) 2009, 2010, 2011 Liam Healy ;;; ;;; 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) ;;; Structs (defcstruct ffi-cif (abi ffi-abi) (number-of-arguments unsigned) (argument-types :pointer) (return-type :pointer) (bytes unsigned) (flags unsigned)) ;;; Functions ;;; See file:///usr/share/doc/libffi-dev/html/The-Basics.html#The-Basics (defcfun ("ffi_prep_cif" prep-cif) status (ffi-cif :pointer) (ffi-abi abi) (nargs :uint) (rtype :pointer) (argtypes :pointer)) (defcfun ("ffi_call" call) :void (ffi-cif :pointer) (function :pointer) (rvalue :pointer) (avalues :pointer)) cffi_0.16.1/libffi/cstruct.lisp000644 000765 000024 00000005774 12562363066 016550 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; cstruct.lisp --- Hook to defcstruct ;;; ;;; Copyright (C) 2009, 2010, 2011 Liam Healy ;;; ;;; 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) (defun slot-multiplicity (slot) (if (typep slot 'aggregate-struct-slot) (slot-count slot) 1)) (defun number-of-items (structure-type) "Total number of items in the foreign structure." (loop for val being the hash-value of (structure-slots structure-type) sum (slot-multiplicity val))) (defmethod libffi-type-pointer ((type foreign-struct-type)) (or (call-next-method) (set-libffi-type-pointer type (let* ((ptr (foreign-alloc '(:struct ffi-type))) (nitems (number-of-items type)) (type-pointer-array (foreign-alloc :pointer :count (1+ nitems)))) (loop for slot in (slots-in-order type) for ltp = (libffi-type-pointer (parse-type (slot-type slot))) with slot-counter = 0 do (if ltp (loop repeat (slot-multiplicity slot) do (setf (mem-aref type-pointer-array :pointer slot-counter) ltp) (incf slot-counter)) (error "Slot type ~a in foreign structure is unknown to libffi." (unparse-type (slot-type slot))))) (setf (mem-aref type-pointer-array :pointer nitems) (null-pointer) ;; The ffi-type (foreign-slot-value ptr '(:struct ffi-type) 'size) 0 (foreign-slot-value ptr '(:struct ffi-type) 'alignment) 0 (foreign-slot-value ptr '(:struct ffi-type) 'type) +type-struct+ (foreign-slot-value ptr '(:struct ffi-type) 'elements) type-pointer-array) ptr)))) cffi_0.16.1/libffi/functions.lisp000644 000765 000024 00000012234 12562363066 017056 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; functions.lisp -- Calling foreign functions ;;; ;;; Copyright (C) 2009, 2010, 2011 Liam M. Healy ;;; ;;; 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) (defvar *cif-table* (make-hash-table :test 'equal) "A hash table of foreign functions and pointers to the foreign cif (Call InterFace) structure for that function.") (define-condition foreign-function-not-prepared (error) ((foreign-function-name :initarg :foreign-function-name :reader foreign-function-name)) (:report (lambda (condition stream) (format stream "Foreign function ~a did not prepare correctly" (foreign-function-name condition)))) (:documentation "Preparation of foreign function did not succeed, according to return from libffi library.")) (defun prepare-function (foreign-function-name return-type argument-types &optional (abi :default-abi)) "Generate or retrieve the CIF needed to call the function through libffi." (or (gethash foreign-function-name *cif-table*) (let* ((number-of-arguments (length argument-types)) (cif (foreign-alloc '(:struct ffi-cif))) (ffi-argtypes (foreign-alloc :pointer :count number-of-arguments))) (loop for type in argument-types for i from 0 do (setf (mem-aref ffi-argtypes :pointer i) (libffi-type-pointer (parse-type type)))) (unless (eql :OK (prep-cif cif abi number-of-arguments (libffi-type-pointer (parse-type return-type)) ffi-argtypes)) (error 'foreign-function-not-prepared :foreign-function-name foreign-function-name)) (setf (gethash foreign-function-name *cif-table*) cif) cif))) (defun unprepare-function (foreign-function-name) "Remove prepared definitions for the named foreign function. Returns foreign-function-name if function had been prepared, NIL otherwise." (let ((ptr (gethash foreign-function-name *cif-table*))) (when ptr (foreign-free (foreign-slot-value ptr '(:struct ffi-cif) 'argument-types)) (foreign-free ptr) (remhash foreign-function-name *cif-table*) foreign-function-name))) (defun translate-objects-ret (symbols function-arguments types return-type call-form) (if (eql return-type :void) (translate-objects symbols function-arguments types return-type call-form t) (if (typep (parse-type return-type) 'translatable-foreign-type) ;; just return the pointer so that expand-from-foreign ;; can apply translate-from-foreign (translate-objects symbols function-arguments types return-type call-form t) ;; built-in types won't be translated by ;; expand-from-foreign, we have to do it here `(mem-ref ,(translate-objects symbols function-arguments types return-type call-form t) ,(canonicalize-foreign-type return-type))))) (defun ffcall-body-libffi (function function-arguments symbols types return-type argument-types &optional pointerp (abi :default-abi)) "A body of foreign-funcall calling the libffi function #'call (ffi_call)." (let ((number-of-arguments (length argument-types))) `(with-foreign-objects ((argvalues :pointer ,number-of-arguments) ,@(unless (eql return-type :void) `((result ',return-type)))) ,(translate-objects-ret symbols function-arguments types return-type `(progn (loop :for arg :in (list ,@symbols) :for count :from 0 :do (setf (mem-aref argvalues :pointer count) arg)) (call (prepare-function ,function ',return-type ',argument-types ',abi) ,(if pointerp function `(foreign-symbol-pointer ,function)) ,(if (eql return-type :void) '(null-pointer) 'result) argvalues) ,(if (eql return-type :void) '(values) 'result)))))) (setf *foreign-structures-by-value* 'ffcall-body-libffi) (pushnew :fsbv *features*) cffi_0.16.1/libffi/init.lisp000644 000765 000024 00000004226 12562363066 016013 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; init.lisp --- Load libffi and define #'libffi-type-pointer ;;; ;;; Copyright (C) 2009, 2011 Liam M. Healy ;;; ;;; 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) (define-foreign-library (libffi) (:darwin (:or "libffi.dylib" "libffi32.dylib" "/usr/lib/libffi.dylib")) (:solaris (:or "/usr/lib/amd64/libffi.so" "/usr/lib/libffi.so")) (:openbsd "libffi.so") (:unix (:or "libffi.so.6" "libffi32.so.6" "libffi.so.5" "libffi32.so.5")) (:windows (:or "libffi-6.dll" "libffi-5.dll" "libffi.dll")) (t (:default "libffi"))) (load-foreign-library 'libffi) (defvar *libffi-type-pointer* (make-hash-table)) (defgeneric libffi-type-pointer (object) (:documentation "The type pointer defined by libffi.") (:method ((object symbol)) (libffi-type-pointer (parse-type object))) (:method (object) (gethash object *libffi-type-pointer*))) (defun set-libffi-type-pointer (type pointer) "Set the hash table entry for the libffi type pointer." (setf (gethash (if (symbolp type) (parse-type type) type) *libffi-type-pointer*) pointer)) cffi_0.16.1/libffi/libffi-unix.lisp000644 000765 000024 00000006356 12562363066 017272 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; libffi-unix.lisp -- libffi CFFI-Grovel definitions for unix systems. ;;; ;;; Copyright (C) 2009, 2010, 2011 Liam M. Healy ;;; ;;; 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) #+linux (define "_GNU_SOURCE") ;; When installed through Mac Ports, libffi include files ;; will be found in /opt/local/include. #+darwin (cc-flags "-I/opt/local/include/") #+openbsd (cc-flags "-I/usr/local/include") (pkg-config-cflags "libffi" :optional t) #+darwin (include "ffi/ffi.h") #-darwin (include "ffi.h") (cenum status ((:OK "FFI_OK")) ((:bad-typedef "FFI_BAD_TYPEDEF")) ((:bad-abi "FFI_BAD_ABI"))) (cenum abi ((:default-abi "FFI_DEFAULT_ABI")) ((:sysv "FFI_SYSV")) ((:unix64 "FFI_UNIX64"))) (ctype ffi-abi "ffi_abi") (ctype :sizet "size_t") (ctype ushort "unsigned short") (ctype unsigned "unsigned") (cstruct ffi-type "struct _ffi_type" (size "size" :type :sizet) (alignment "alignment" :type ushort) (type "type" :type ushort) (elements "elements" :type :pointer)) #| ;;; Will not compile ;;; error: invalid application of `sizeof' to incomplete type `struct ffi_cif' ;;; When structs are defined with the name at the end, apparently they ;;; are intended to be "opaque types". (cstruct ffi-cif "struct ffi_cif" (abi "abi" :type ffi-abi) (nargs "nargs" :type unsigned) (arg-types "arg_types" :type :pointer) (return-type "rtype" :type :pointer) (bytes "bytes" :type :unsigned) (flags "flags" :type :unsigned)) |# (constant (+type-void+ "FFI_TYPE_VOID")) (constant (+type-int+ "FFI_TYPE_INT")) (constant (+type-float+ "FFI_TYPE_FLOAT")) (constant (+type-double+ "FFI_TYPE_DOUBLE")) (constant (+type-longdouble+ "FFI_TYPE_LONGDOUBLE")) (constant (+type-uint8+ "FFI_TYPE_UINT8")) (constant (+type-sint8+ "FFI_TYPE_SINT8")) (constant (+type-uint16+ "FFI_TYPE_UINT16")) (constant (+type-sint16+ "FFI_TYPE_SINT16")) (constant (+type-uint32+ "FFI_TYPE_UINT32")) (constant (+type-sint32+ "FFI_TYPE_SINT32")) (constant (+type-uint64+ "FFI_TYPE_UINT64")) (constant (+type-sint64+ "FFI_TYPE_SINT64")) (constant (+type-struct+ "FFI_TYPE_STRUCT")) (constant (+type-pointer+ "FFI_TYPE_POINTER")) cffi_0.16.1/libffi/libffi-win32.lisp000644 000765 000024 00000005414 12562363066 017243 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; libffi-win32.lisp -- libffi CFFI-Grovel definitions for Windows. ;;; Note that despite the name, this includes 64 bit Windows as well as 32 bit. ;;; ;;; Copyright (C) 2009, 2010, 2011, 2012, 2015 Liam M. Healy ;;; ;;; 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. ;;; ;; by CRLF0710, modified from Liam Healy 2009-02-22 09:24:33EST libffi-unix.lisp (in-package #:cffi) (pkg-config-cflags "libffi" :optional t) (include "ffi.h") (cenum status ((:OK "FFI_OK")) ((:bad-typedef "FFI_BAD_TYPEDEF")) ((:bad-abi "FFI_BAD_ABI"))) #+x86-64 (cenum abi ((:default-abi "FFI_DEFAULT_ABI")) ((:win64 "FFI_WIN64"))) #-x86-64 (cenum abi ((:default-abi "FFI_DEFAULT_ABI")) ((:sysv "FFI_SYSV")) ((:stdcall "FFI_STDCALL"))) (ctype ffi-abi "ffi_abi") (ctype :sizet "size_t") (ctype ushort "unsigned short") (ctype unsigned "unsigned") (cstruct ffi-type "struct _ffi_type" (size "size" :type :sizet) (alignment "alignment" :type ushort) (type "type" :type ushort) (elements "elements" :type :pointer)) (constant (+type-void+ "FFI_TYPE_VOID")) (constant (+type-int+ "FFI_TYPE_INT")) (constant (+type-float+ "FFI_TYPE_FLOAT")) (constant (+type-double+ "FFI_TYPE_DOUBLE")) (constant (+type-longdouble+ "FFI_TYPE_LONGDOUBLE")) (constant (+type-uint8+ "FFI_TYPE_UINT8")) (constant (+type-sint8+ "FFI_TYPE_SINT8")) (constant (+type-uint16+ "FFI_TYPE_UINT16")) (constant (+type-sint16+ "FFI_TYPE_SINT16")) (constant (+type-uint32+ "FFI_TYPE_UINT32")) (constant (+type-sint32+ "FFI_TYPE_SINT32")) (constant (+type-uint64+ "FFI_TYPE_UINT64")) (constant (+type-sint64+ "FFI_TYPE_SINT64")) (constant (+type-struct+ "FFI_TYPE_STRUCT")) (constant (+type-pointer+ "FFI_TYPE_POINTER")) cffi_0.16.1/grovel/asdf.lisp000644 000765 000024 00000016274 12562363066 016036 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; asdf.lisp --- ASDF components for cffi-grovel. ;;; ;;; Copyright (C) 2005-2006, Dan Knap ;;; Copyright (C) 2005-2006, Emily 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)) (declare (ignorable op)) (let ((*cc-flags* (append (ensure-list (cc-flags-of file)) *cc-flags*))) (call-next-method))) (eval-when (:compile-toplevel :load-toplevel :execute) (defclass process-op (#-asdf3 asdf:operation #+asdf3 asdf:downward-operation) () (:documentation "This ASDF operation performs the steps necessary to generate a compilable and loadable lisp file from a PROCESS-OP-INPUT component.")) (defclass process-op-input (asdf:cl-source-file) ((generated-lisp-file-type :initarg :generated-lisp-file-type :accessor generated-lisp-file-type :documentation "The :TYPE argument to use for the generated lisp file.")) (:default-initargs :generated-lisp-file-type "generated-lisp-file") (:documentation "This ASDF component represents a file that is used as input to a function that generates lisp source file. This component acts as if it is a CL-SOURCE-FILE by applying the COMPILE-OP and LOAD-SOURCE-OP operations to the file generated by PROCESS-OP."))) (defmethod asdf:input-files ((op process-op) (c process-op-input)) (list (asdf:component-pathname c))) (defmethod asdf:component-depends-on ((op process-op) (c process-op-input)) `(#-asdf3 (asdf:load-op ,@(asdf::component-load-dependencies c)) #+asdf3 (asdf:prepare-op ,c) ,@(call-next-method))) (defmethod asdf:component-depends-on ((op asdf:compile-op) (c process-op-input)) (declare (ignorable op)) `((process-op ,(asdf:component-name c)) ,@(call-next-method))) (defmethod asdf:component-depends-on ((op asdf:load-source-op) (c process-op-input)) (declare (ignorable op)) `((process-op ,(asdf:component-name c)) ,@(call-next-method))) (defmethod asdf:perform ((op asdf:compile-op) (c process-op-input)) (let ((generated-lisp-file (first (asdf:output-files (make-instance 'process-op) c)))) (asdf:perform op (make-instance 'asdf:cl-source-file :name (asdf:component-name c) :parent (asdf:component-parent c) :pathname generated-lisp-file)))) (defmethod asdf:perform ((op asdf:load-source-op) (c process-op-input)) (let ((generated-lisp-file (first (asdf:output-files (make-instance 'process-op) c)))) (asdf:perform op (make-instance 'asdf:cl-source-file :name (asdf:component-name c) :parent (asdf:component-parent c) :pathname generated-lisp-file)))) ;;;# ASDF component: GROVEL-FILE (eval-when (:compile-toplevel :load-toplevel :execute) (defclass grovel-file (process-op-input cc-flags-mixin) () (:default-initargs :generated-lisp-file-type "processed-grovel-file") (:documentation "This ASDF component represents an input file that is processed by PROCESS-GROVEL-FILE."))) (defmethod asdf:output-files ((op process-op) (c grovel-file)) (let* ((input-file (asdf:component-pathname c)) (output-file (make-pathname :type (generated-lisp-file-type c) :defaults input-file)) (c-file (make-c-file-name output-file))) (list output-file c-file (exe-filename c-file)))) (defmethod asdf:perform ((op process-op) (c grovel-file)) (let ((output-file (first (asdf:output-files op c))) (input-file (asdf:component-pathname c))) (ensure-directories-exist (directory-namestring output-file)) (let ((tmp-file (process-grovel-file input-file output-file))) (unwind-protect (alexandria:copy-file tmp-file output-file :if-to-exists :supersede) (delete-file tmp-file))))) ;;;# ASDF component: WRAPPER-FILE (eval-when (:compile-toplevel :load-toplevel :execute) (defclass wrapper-file (process-op-input cc-flags-mixin) ((soname :initform nil :initarg :soname :accessor soname-of)) (:default-initargs :generated-lisp-file-type "processed-wrapper-file") (:documentation "This ASDF component represents an input file that is processed by PROCESS-WRAPPER-FILE. This generates a foreign library and matching CFFI bindings that are subsequently compiled and loaded."))) (defun wrapper-soname (c) (or (soname-of c) (asdf:component-name c))) (defmethod asdf:output-files ((op process-op) (c wrapper-file)) (let* ((input-file (asdf:component-pathname c)) (output-file (make-pathname :type (generated-lisp-file-type c) :defaults input-file)) (c-file (make-c-file-name output-file)) (lib-soname (wrapper-soname c))) (list output-file c-file (lib-filename (make-soname lib-soname output-file))))) (defmethod asdf:perform ((op process-op) (c wrapper-file)) (let ((output-file (first (asdf:output-files op c))) (input-file (asdf:component-pathname c))) (ensure-directories-exist (directory-namestring output-file)) (let ((tmp-file (process-wrapper-file input-file output-file (wrapper-soname c)))) (unwind-protect (alexandria:copy-file tmp-file output-file :if-to-exists :supersede) (delete-file tmp-file))))) ;; Allow for naked :grovel-file and :wrapper-file in asdf definitions. (eval-when (:compile-toplevel :load-toplevel :execute) (setf (find-class 'asdf::cffi-grovel-file) (find-class 'grovel-file)) (setf (find-class 'asdf::cffi-wrapper-file) (find-class 'wrapper-file))) cffi_0.16.1/grovel/common.h000644 000765 000024 00000003247 12562363066 015665 0ustar00luisstaff000000 000000 #include #include #include #include #include #ifndef offsetof #define offsetof(type, slot) ((long) ((char *) &(((type *) 0)->slot))) #endif #define getslot(type, slot) (((type *) 0)->slot) #define sizeofslot(type, slot) (sizeof(getslot(type, slot))) #define countofslot(type, slot) \ (sizeof(getslot(type, slot)) / sizeof(getslot(type, slot)[0])) #define stringify(x) #x #define indirect_stringify(x) stringify(x) #define TYPE_SIGNED_P(type) (((type)-1)<0LL) #define _64_BIT_VALUE_FITS_SIGNED_P(value) ( (value) <= 0x7FFFFFFFFFFFFFFFLL ) #define SLOT_SIGNED_P(result, type, slot) \ do { \ type slot_signed_p_struct; \ slot_signed_p_struct.slot = -1; \ (result) = slot_signed_p_struct.slot < 0; \ } while (0) 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_0.16.1/grovel/grovel.lisp000644 000765 000024 00000111414 12562363066 016407 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; grovel.lisp --- The CFFI Groveller. ;;; ;;; Copyright (C) 2005-2006, Dan Knap ;;; Copyright (C) 2005-2006, Emily 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 for trim = (string-trim '(#\Space #\Tab #\Newline) s) unless (string= "" trim) collect trim)) ;;;# Error Conditions (define-condition grovel-error (simple-error) ()) (defun grovel-error (format-control &rest format-arguments) (error 'grovel-error :format-control format-control :format-arguments format-arguments)) ;;; 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 ;;; 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) { int autotype_tmp; 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 "~& fputs(\"~A\", output);~%" 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 ");~%"))) (defun c-print-integer-constant (out arg &optional foreign-type) (let ((foreign-type (or foreign-type :int))) (c-format out "#.(cffi-grovel::convert-intmax-constant ") (format out "~& fprintf(output, \"%\"PRIiMAX, (intmax_t)~A);~%" arg) (c-format out " ") (c-write out `(quote ,foreign-type)) (c-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 &optional no-package) (cond ((and (listp form) (eq 'quote (car form))) (c-format out "'") (c-write out (cadr form) no-package)) ((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 no-package)) (c-format out ")")) ((symbolp form) (c-print-symbol out form no-package)))) ;;; 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)) (grovel-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 make-c-file-name (output-defaults) (make-pathname :type "c" :defaults output-defaults)) (defun generate-c-file (input-file output-defaults) (let ((c-file (make-c-file-name 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)) (defparameter *cc* #+(or cygwin (not windows)) "cc" #+(and windows (not cygwin)) "gcc") (defparameter *cc-flags* (append ;; For MacPorts #+darwin (list "-I" "/opt/local/include/") #-darwin nil ;; ECL internal flags #+ecl (list c::*cc-flags*) ;; FreeBSD non-base header files #+freebsd (list "-I" "/usr/local/include/"))) ;;; FIXME: is there a better way to detect whether these flags ;;; are necessary? (defparameter *cpu-word-size-flags* #+arm (list "-marm") #-arm (ecase (cffi:foreign-type-size :pointer) (4 (list "-m32")) (8 (list "-m64")))) (defparameter *platform-library-flags* (list #+darwin "-bundle" #-darwin "-shared" #-windows "-fPIC")) (defun host-and-directory-namestring (pathname) (namestring (make-pathname :name nil :type nil :defaults pathname))) (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" (host-and-directory-namestring (truename (asdf:system-definition-pathname :cffi-grovel)))) ,@(when library *platform-library-flags*) "-o" ,(native-namestring output-file) ,(native-namestring input-file)))) (when library ;; if it's a library that may be used, remove it ;; so we won't possibly be overwriting the code of any existing process (ignore-some-conditions (file-error) (delete-file output-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))) (define-grovel-syntax pkg-config-cflags (pkg &key optional) (block nil (handler-bind ((error (lambda (e) (when optional (format *debug-io* "~&ERROR: ~a" e) (format *debug-io* "~&Attempting to continue anyway.~%") (return))))) (appendf *cc-flags* (trim-whitespace (list (invoke "pkg-config" pkg "--cflags"))))))) ;;; 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, TYPE_SIGNED_P(~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(_64_BIT_VALUE_FITS_SIGNED_P(~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-write 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 " ") (etypecase type ((eql :auto) (format out "~& SLOT_SIGNED_P(autotype_tmp, ~A, ~A~@[[0]~]);~@*~%~ ~& type_name(output, autotype_tmp, sizeofslot(~A, ~A~@[[0]~]));~%" struct-c-name slot-c-name (not (null count)))) ((or cons symbol) (c-write out type)) (string (c-format out "~A" type))) (etypecase count (null t) (integer (c-format out " :count ~D" count)) ((eql :auto) (c-printf out " :count %i" (format nil "countofslot(~A, ~A)" 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 %li)" (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 '(:struct ") (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 :read-only ,read-only) ,type)) (list (unless (and (= (length c-parse) 2) (null (second c-parse)) (symbolp (first c-parse)) (eql #\* (char (symbol-name (first c-parse)) 0))) (grovel-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 (grovel-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-write 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-print-integer-constant out c-name base-type) (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-print-integer-constant out c-name base-type) (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))))) (defun convert-intmax-constant (constant base-type) "Convert the C CONSTANT to an integer of BASE-TYPE. The constant is assumed to be an integer printed using the PRIiMAX printf(3) format string." ;; | C Constant | Type | Return Value | Notes | ;; |------------+---------+--------------+---------------------------------------| ;; | -1 | :int32 | -1 | | ;; | 0xffffffff | :int32 | -1 | CONSTANT may be a positive integer if | ;; | | | | sizeof(intmax_t) > sizeof(int32_t) | ;; | 0xffffffff | :uint32 | 4294967295 | | ;; | -1 | :uint32 | 4294967295 | | ;; |------------+---------+--------------+---------------------------------------| (let* ((canonical-type (cffi::canonicalize-foreign-type base-type)) (type-bits (* 8 (cffi:foreign-type-size canonical-type))) (2^n (ash 1 type-bits))) (ecase canonical-type ((:unsigned-char :unsigned-short :unsigned-int :unsigned-long :unsigned-long-long) (mod constant 2^n)) ((:char :short :int :long :long-long) (let ((v (mod constant 2^n))) (if (logbitp (1- type-bits) v) (- (mask-field (byte (1- type-bits) 0) v) (ash 1 (1- type-bits))) v)))))) (defun foreign-type-to-printf-specification (type) "Return the printf specification associated with the foreign type TYPE." (ecase type (:char "\"%hhd\"") ((:unsigned-char :uchar) "\"%hhu\"") (:short "\"%hd\"") ((:unsigned-short :ushort) "\"%hu\"") (:int "\"%d\"") ((:unsigned-int :uint) "\"%u\"") (:long "\"%ld\"") ((:unsigned-long :ulong) "\"%lu\"") ((:long-long :llong) "\"%lld\"") ((:unsigned-long-long :ullong) "\"%llu\"") (:int8 "\"%\"PRId8") (:uint8 "\"%\"PRIu8") (:int16 "\"%\"PRId16") (:uint16 "\"%\"PRIu16") (:int32 "\"%\"PRId32") (:uint32 "\"%\"PRIu32") (:int64 "\"%\"PRId64") (:uint64 "\"%\"PRIu64"))) ;; Defines a bitfield, with elements specified as ((LISP-NAME C-NAME) ;; &key DOCUMENTATION). NAME-AND-OPTS can be either a symbol as name, ;; or a list (NAME &key BASE-TYPE). (define-grovel-syntax bitfield (name-and-opts &rest masks) (destructuring-bind (name &key base-type) (ensure-list name-and-opts) (c-section-header out "bitfield" name) (c-export out name) (c-format out "(cffi:defbitfield (") (c-print-symbol out name t) (when base-type (c-printf out " ") (c-print-symbol out base-type t)) (c-format out ")") (dolist (mask masks) (destructuring-bind ((lisp-name &rest c-names) &key optional documentation) mask (declare (ignore documentation)) (check-type lisp-name symbol) (c-format out "~% (") (c-print-symbol out lisp-name) (c-format out " ") (dolist (c-name c-names) (check-type c-name string) (format out "~&#ifdef ~A~%" c-name) (format out "~& fprintf(output, ~A, ~A);~%" (foreign-type-to-printf-specification (or base-type :int)) 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 ")~%"))) ;;;# 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-c-file-name 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)) (defun make-soname (lib-soname output-defaults) (make-pathname :name lib-soname :defaults output-defaults)) ;;; *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-soname lib-soname 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)) (grovel-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) nil)))))) (defun cffi-type (typespec) (if (and (listp typespec) (stringp (car typespec))) (second typespec) typespec)) (defun symbol* (s) (check-type s (and symbol (not null))) s) (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) nil))) 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 (symbol* (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) nil))) 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 (symbol* (first arg)) (cffi-type (second arg)))) args)) *lisp-forms*)))) cffi_0.16.1/grovel/invoke.lisp000644 000765 000024 00000013500 12562363066 016401 0ustar00luisstaff000000 000000 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; invoke.lisp --- Half-baked portable run-program. ;;; ;;; Copyright (C) 2005-2006, Dan Knap ;;; Copyright (C) 2005-2006, Emily 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) (grovel-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 " " str2)) arglist :initial-value command)) (stream (make-string-output-stream))) (values (ext:run-shell-command cmdline :output stream) (get-output-stream-string stream)))) (defun process-output (process-stream) (with-open-stream (process-stream process-stream) (with-output-to-string (str) (loop for char = (read-char process-stream nil) while char do (write-char char str))))) #+clisp (defun %invoke (command arglist) (let* ((output-file (make-pathname :name (format nil "clisp-cffi-invoke-~A-~A.tmp" (get-universal-time) (random 1000)))) (ret (ext:run-program command :arguments arglist :output output-file))) (with-open-file (stream output-file :direction :input) (multiple-value-prog1 (values (etypecase ret ((eql nil) 0) ((eql t) 1) (integer ret)) (process-output stream)) (delete-file output-file))))) #+ecl (defun %invoke (command arglist) (multiple-value-bind (output-stream exit-code) (ext:run-program "/bin/sh" (list "-c" (format nil "~A~{ ~A~}" command arglist)) :wait t :output :stream :input nil :error nil) (values exit-code (process-output output-stream)))) #+(or cmu scl) (defun %invoke (command arglist) (let* ((process (ext:run-program command arglist :output :stream :wait nil :error :output)) (output (process-output (ext:process-output process)))) (ext:process-wait process) (values (ext:process-exit-code process) output))) #+sbcl (defun %invoke (command arglist) (let* ((process (sb-ext:run-program command arglist :output :stream :wait nil :error :output :search t)) (output (process-output (sb-ext:process-output process)))) (sb-ext:process-wait process) (values (sb-ext:process-exit-code process) output))) #+openmcl (defun %invoke (command arglist) (let* ((exit-code) (output (with-output-to-string (s) (let ((process (ccl:run-program command arglist :output s :error :output))) (setq exit-code (nth-value 1 (ccl:external-process-status 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) (grovel-error "External process exited with code ~S.~@ Command was: ~S~{ ~S~}~@ Output was:~%~A" exit-code command args output)) output)) cffi_0.16.1/grovel/package.lisp000644 000765 000024 00000002760 12562363066 016507 0ustar00luisstaff000000 000000 ;;;; -*- 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 conditions #:grovel-error #:missing-definition) (:export ;; Class name #:wrapper-file #:process-wrapper-file)) cffi_0.16.1/examples/examples.lisp000644 000765 000024 00000005221 12562363066 017245 0ustar00luisstaff000000 000000 ;;;; -*- 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_0.16.1/examples/gethostname.lisp000644 000765 000024 00000004100 12562363066 017740 0ustar00luisstaff000000 000000 ;;;; -*- 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_0.16.1/examples/gettimeofday.lisp000644 000765 000024 00000007302 12562363066 020112 0ustar00luisstaff000000 000000 ;;;; -*- 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_0.16.1/examples/mapping.lisp000644 000765 000024 00000005536 12562363066 017073 0ustar00luisstaff000000 000000 ;;;; -*- 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_0.16.1/examples/run-examples.lisp000644 000765 000024 00000002777 12562363066 020064 0ustar00luisstaff000000 000000 ;;;; -*- 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_0.16.1/examples/translator-test.lisp000644 000765 000024 00000006755 12562363066 020612 0ustar00luisstaff000000 000000 ;;;; -*- 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_0.16.1/doc/allegro-internals.txt000644 000765 000024 00000012175 12562363066 017656 0ustar00luisstaff000000 000000 July 2005 These details were kindly provided by Duane Rettig of Franz. Regarding the following snippet of the macro expansion of FF:DEF-FOREIGN-CALL: (SYSTEM::FF-FUNCALL (LOAD-TIME-VALUE (EXCL::DETERMINE-FOREIGN-ADDRESS '("foo" :LANGUAGE :C) 2 NIL)) '(:INT (INTEGER * *)) ARG1 '(:DOUBLE (DOUBLE-FLOAT * *)) ARG2 '(:INT (INTEGER * *))) " ... in Allegro CL, if you define a foreign call FOO with C entry point "foo" and with :call-direct t in the arguments, and if other things are satisfied, then if a lisp function BAR is compiled which has a call to FOO, that call will not go through ff-funcall (and thus a large amount of argument manipulation and processing) but will instead set up its arguments directly on the stack, and will then perform the "call" more or less directly, through the "entry vec" (a small structure which keeps track of a foreign entry's address and status)." This is the code that generates what the compiler expects to see: (setq call-direct-form (if* call-direct then `(setf (get ',lispname 'sys::direct-ff-call) (list ',external-name ,callback ,convention ',returning ',arg-types ,arg-checking ,entry-vec-flags)) else `(remprop ',lispname 'sys::direct-ff-call))) Thus generating something like: (EVAL-WHEN (COMPILE LOAD EVAL) (SETF (GET 'FOO 'SYSTEM::DIRECT-FF-CALL) (LIST '("foo" :LANGUAGE :C) T :C '(:INT (INTEGER * *)) '((:INT (INTEGER * *)) (:FLOAT (SINGLE-FLOAT * *))) T 2 ; this magic value is explained later ))) " (defun determine-foreign-address (name &optional (flags 0) method-index) ;; return an entry-vec struct suitable for the foreign-call of name. ;; ;; name is either a string, which is taken without conversion, or ;; a list consisting of a string to convert or a conversion function ;; call. ;; flags is an integer representing the flags to place into the entry-vec. ;; method-index, if non-nil, is a word-index into a vtbl (virtual table). ;; If method-index is true, then the name must be a string uniquely ;; represented by the index and by the flags field. Note that not all architectures implement the :method-index argument to def-foreign-call, but your interface likely won't support it anyway, so just leave it nil. As for the flags, they are constants stored into the entry-vec returned by d-f-a and are given here: (defconstant ep-flag-call-semidirect 1) ; Real address stored in alt-address slot (defconstant ep-flag-never-release 2) ; Never release the heap (defconstant ep-flag-always-release 4) ; Always release the heap (defconstant ep-flag-release-when-ok 8) ; Release the heap unless without-interrupts (defconstant ep-flag-tramp-calls #x70) ; Make calls through special trampolines (defconstant ep-flag-tramp-shift 4) (defconstant ep-flag-variable-address #x100) ; Entry-point contains address of C var (defconstant ep-flag-strings-convert #x200) ; Convert strings automatically (defconstant ep-flag-get-errno #x1000) ;; [rfe5060]: Get errno value after call (defconstant ep-flag-get-last-error #x2000) ;; [rfe5060]: call GetLastError after call ;; Leave #x4000 and #x8000 open for expansion Mostly, you'll give the value 2 (never release the heap), but if you give 4 or 8, then d-f-a will automatically set the 1 bit as well, which takes the call through a heap-release/reacquire process. Some docs for entry-vec are: ;; -- entry vec -- ;; An entry-vec is an entry-point descriptor, usually a pointer into ;; a shared-library. It is represented as a 5-element struct of type ;; foreign-vector. The reason for this represntation is ;; that it allows the entry point to be stored in a table, called ;; the .saved-entry-points. table, and to be used by a foreign ;; function. When the location of the foreign function to which the entry ;; point refers changes, it is simply a matter of changing the value in entry ;; point vector and the foreign call code sees it immediately. There is ;; even an address that can be put in the entry point vector that denotes ;; a missing foreign function, thus lookup can happen dynamically. (defstruct (entry-vec (:type (vector excl::foreign (*))) (:constructor make-entry-vec-boa ())) name ; entry point name (address 0) ; jump address for foreign code (handle 0) ; shared-lib handle (flags 0) ; ep-* flags (alt-address 0) ; sometimes holds the real func addr ) [...] " Regarding the arguments to SYSTEM::FF-FUNCALL: '(:int (integer * *)) argN "The type-spec is as it is given in the def-foreign-call syntax, with a C type optionally followed by a lisp type, followed optionally by a user-conversion function name[...]" Getting the alignment: CL-USER(2): (ff:get-foreign-type :int) #S(FOREIGN-FUNCTIONS::IFOREIGN-TYPE :ATTRIBUTES NIL :SFTYPE #S(FOREIGN-FUNCTIONS::SIZED-FTYPE-PRIM :KIND :INT :WIDTH 4 :OFFSET 0 :ALIGN 4) ...) cffi_0.16.1/doc/cffi-manual.texinfo000644 000765 000024 00000631546 12562363066 017264 0ustar00luisstaff000000 000000 \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 @alias res = result @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-2015 Lu@'{@dotless{i}}s Oliveira @* Copyright @copyright{} 2005-2006 Dan Knapp @* Copyright @copyright{} 2005-2006 Emily Backes @* 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 @dircategory Software development @direntry * CFFI Manual: (cffi-manual). CFFI Manual. @end direntry @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-aptr:: The pointer to an element of an array. * 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. * translate-camelcase-name:: Converts a camelCase foreign name to/from a Lisp name. * translate-name-from-foreign:: Converts a foreign name to a Lisp name. * translate-name-to-foreign:: Converts a Lisp name to a foreign name. * translate-underscore-separated-name:: Converts an underscore_separated foreign name to/from a Lisp name. 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. @c * reload-foreign-libraries:: Reload foreign libraries. * 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/gitweb?p=projects/cffi/cffi.git,,git repository} @c snapshots have been disabled as of @c @item @c @uref{http://common-lisp.net/project/cffi/tarballs/?M=D,,nightly-generated @c 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. 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.} @ref{The Groveller} 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 (:darwin (:or "libcurl.3.dylib" "libcurl.dylib")) (: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 :count data-size)) 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:: * translate-into-foreign-memory:: * 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{:bool} The @code{:bool} type represents the C99 @code{_Bool} or C++ @code{bool}. Its size is usually 1 byte except on OSX where it's an @code{int}. @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 @c LMH structure translation By default, @ref{convert-from-foreign} (and also @ref{mem-ref}) will make a plist with slot names as keys, and @ref{convert-to-foreign} will translate such a plist to a foreign structure. A user wishing to define other translations should use the @code{:class} argument to @ref{defcstruct}, and then define methods for @ref{translate-from-foreign} and @ref{translate-into-foreign-memory} that specialize on this class, possibly calling @code{call-next-method} to translate from and to the plists rather than provide a direct interface to the foreign object. The macro @code{translation-forms-for-class} will generate the forms necessary to translate a Lisp class into a foreign structure and vice versa. @c Write separate function doc section for translation-forms-for-class? @c Examples, perhaps taken from the tests? 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. To pass or return a structure by value to a function, load the cffi-libffi system and specify the structure as @code{(:struct @var{structure-name})}. To pass or return the pointer, you can use either @code{:pointer} or @code{(:pointer (:struct @var{structure-name}))}. @emph{Compatibility note:} Previous versions of CFFI accepted the ``bare'' @var{structure-name} as a type specification, which was interpreted as a pointer to the structure. This is deprecated and produces a style warning. Using this deprecated form means that @ref{mem-aref} retains its prior meaning and returns a pointer. Using the @code{(:struct @var{structure-name})} form for the type, @ref{mem-aref} provides a Lisp object translated from the structure (by default a plist). Thus the semantics are consistent with all types in returning the object as represented in Lisp, and not a pointer, with the exception of the ``bare'' structure compatibility retained. In order to obtain the pointer, you should use the function @ref{mem-aptr}. See @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 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 '(:struct 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 '(:struct timeval) 'tv-secs) @result{} 0 CFFI> (foreign-slot-offset '(:struct 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 '(:struct point)) (foreign-slot-pointer ptr '(:struct 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 '(:struct point)) ;; @lispcmt{Initialize the slots} (setf (foreign-slot-value ptr '(:struct point) 'x) 42 (foreign-slot-value ptr '(:struct point) 'y) 42) ;; @lispcmt{Return a list with the coordinates} (with-foreign-slots ((x y) ptr (:struct 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 '(:struct 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 '(:struct 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, translate-into-foreign-memory, 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 TRANSLATE-INTO-FOREIGN-MEMORY @page @node translate-into-foreign-memory, with-foreign-slots, translate-to-foreign, Foreign Types @heading translate-into-foreign-memory @subheading Syntax @GenericFunction{translate-into-foreign-memory lisp-value type-name pointer} @subheading Arguments and Values @table @var @item lisp-value The Lisp value to convert to foreign representation. @item type-name A symbol or list @code{(:struct @var{structure-name})} naming a foreign type defined by @code{defctype}. @item pointer The foreign pointer where the translated object should be stored. @end table @subheading Description Translate the Lisp value into the foreign memory location given by pointer. The return value is not used. @c =================================================================== @c WITH-FOREIGN-SLOTS @page @node with-foreign-slots, , translate-into-foreign-memory, 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 with each element a symbol, or list of length two with the first element @code{:pointer} and the second a symbol. @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}. If the var is a list starting with @code{:pointer}, it will bind the pointer to the slot (rather than the value). 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 (:pointer (:struct tm)))) @result{} # CFFI> (with-foreign-slots ((sec min hour mday mon year) * (:struct 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-aptr:: * 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-aptr, 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-APTR @page @node mem-aptr, mem-aref, make-pointer, Pointers @heading mem-aptr @subheading Syntax @Accessor{mem-aptr ptr type &optional (index 0)} @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-aptr} function finds the pointer to an element of the array. @lisp (mem-aptr ptr type n) ;; @lispcmt{is identical to:} (inc-pointer ptr (* n (foreign-type-size type))) @end lisp @subheading Examples @lisp CFFI> (with-foreign-string (str "Hello, foreign world!") (mem-aptr str :char 6)) @result{} #.(SB-SYS:INT-SAP #X0063D4B6) @end lisp @c =================================================================== @c MEM-AREF @page @node mem-aref, mem-ref, mem-aptr, 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 Compatibility Note For compatibility with older versions of CFFI, @ref{mem-aref} will produce a pointer for the deprecated bare structure specification, but it is consistent with other types for the current specification form @code{(:struct @var{structure-name})} and provides a Lisp object translated from the structure (by default a plist). In order to obtain the pointer, you should use the new function @ref{mem-aptr}. @subheading See Also @seealso{mem-ref} @* @seealso{mem-aptr} @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 @emph @item @var{string} A Lisp string. @item @var{encoding} Foreign encoding. Defaults to @code{*default-foreign-encoding*}. @item @var{null-terminated-p} Boolean, defaults to true. @item @var{start}, @var{end} Bounding index designators of @var{string}. 0 and @code{nil}, by default. @item @var{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 &key 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 @emph @item @var{string} A Lisp string. @item @var{buffer} A foreign pointer. @item @var{bufsize} An integer. @item @var{start}, @var{end} Bounding index designators of @var{string}. 0 and @code{nil}, by default. @item @var{offset} An integer greater than or equal to 0. Defauls to 0. @item @var{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 @emph @item @var{var}, @var{byte-size-var} A symbol. @item @var{string} A Lisp string. @item @var{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:: * translate-camelcase-name:: * translate-name-from-foreign:: * translate-name-to-foreign:: * translate-underscore-separated-name:: @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.} If a foreign structure is to be passed or returned by value (that is, the type is of the form @code{(:struct ...)}), then the cffi-libffi system must be loaded, which in turn depends on @uref{http://sourceware.org/libffi/,libffi}, including the header files. Failure to load that system will result in an error. Variadic functions cannot at present accept or return structures by value. @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. If a foreign structure is to be passed or returned by value (that is, the type is of the form @code{(:struct ...)}), then the cffi-libffi system must be loaded, which in turn depends on @uref{http://sourceware.org/libffi/,libffi}, including the header files. Failure to load that system will result in an error. Variadic functions cannot at present accept or return structures by value. @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, translate-camelcase-name, 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 TRANSLATE-CAMELCASE-NAME @page @node translate-camelcase-name, translate-name-from-foreign, foreign-funcall-pointer, Functions @heading translate-camelcase-name @subheading Syntax @Function{translate-camelcase-name name &key upper-initial-p special-words @res{} return-value} @subheading Arguments and Values @table @var @item name Either a symbol or a string. @item upper-initial-p A generalized boolean. @item special words A list of strings. @item return-value If @var{name} is a symbol, this is a string, and vice versa. @end table @subheading Description @code{translate-camelcase-name} is a helper function for specializations of @code{translate-name-from-foreign} and @code{translate-name-to-foreign}. It handles the common case of converting between foreign camelCase names and lisp names. @var{upper-initial-p} indicates whether the first letter of the foreign name should be uppercase. @var{special-words} is a list of strings that should be treated atomically in translation. This list is case-sensitive. @subheading Examples @lisp CFFI> (translate-camelcase-name some-xml-function) @result{} "someXmlFunction" CFFI> (translate-camelcase-name some-xml-function :upper-initial-p t) @result{} "SomeXmlFunction" CFFI> (translate-camelcase-name some-xml-function :special-words '("XML")) @result{} "someXMLFunction" CFFI> (translate-camelcase-name "someXMLFunction") @result{} SOME-X-M-L-FUNCTION CFFI> (translate-camelcase-name "someXMLFunction" :special-words '("XML")) @result{} SOME-XML-FUNCTION @end lisp @subheading See Also @seealso{translate-name-from-foreign} @* @seealso{translate-name-to-foreign} @* @seealso{translate-underscore-separated-name} @c =================================================================== @c TRANSLATE-NAME-FROM-FOREIGN @page @node translate-name-from-foreign, translate-name-to-foreign, translate-camelcase-name, Functions @heading translate-name-from-foreign @subheading Syntax @Function{translate-name-from-foreign foreign-name package &optional varp @res{} symbol} @subheading Arguments and Values @table @var @item foreign-name A string denoting a foreign function. @item package A Lisp package @item varp A generalized boolean. @item symbol The Lisp symbol to be used a function name. @end table @subheading Description @code{translate-name-from-foreign} is used by @ref{defcfun} to handle the conversion of foreign names to lisp names. By default, it translates using @ref{translate-underscore-separated-name}. However, you can create specialized methods on this function to make translating more closely match the foreign library's naming conventions. Specialize @var{package} on some package. This allows other packages to load libraries with different naming conventions. @subheading Examples @lisp CFFI> (defcfun "someXmlFunction" ...) @result{} SOMEXMLFUNCTION CFFI> (defmethod translate-name-from-foreign ((spec string) (package (eql *package*)) &optional varp) (let ((name (translate-camelcase-name spec))) (if varp (intern (format nil "*~a*" name)) name))) @result{} #))> CFFI> (defcfun "someXmlFunction" ...) @result{} SOME-XML-FUNCTION @end lisp @subheading See Also @seealso{defcfun} @* @seealso{translate-camelcase-name} @* @seealso{translate-name-to-foreign} @* @seealso{translate-underscore-separated-name} @c =================================================================== @c TRANSLATE-NAME-TO-FOREIGN @page @node translate-name-to-foreign, translate-underscore-separated-name, translate-name-from-foreign, Functions @heading translate-name-to-foreign @subheading Syntax @Function{translate-name-to-foreign lisp-name package &optional varp @res{} string} @subheading Arguments and Values @table @var @item lisp-name A symbol naming the Lisp function to be created. @item package A Lisp package @item varp A generalized boolean. @item string The string representing the foreign function name. @end table @subheading Description @code{translate-name-to-foreign} is used by @ref{defcfun} to handle the conversion of lisp names to foreign names. By default, it translates using @ref{translate-underscore-separated-name}. However, you can create specialized methods on this function to make translating more closely match the foreign library's naming conventions. Specialize @var{package} on some package. This allows other packages to load libraries with different naming conventions. @subheading Examples @lisp CFFI> (defcfun some-xml-function ...) @result{} "some_xml_function" CFFI> (defmethod translate-name-to-foreign ((spec symbol) (package (eql *package*)) &optional varp) (let ((name (translate-camelcase-name spec))) (if varp (subseq name 1 (1- (length name))) name))) @result{} #))> CFFI> (defcfun some-xml-function ...) @result{} "someXmlFunction" @end lisp @subheading See Also @seealso{defcfun} @* @seealso{translate-camelcase-name} @* @seealso{translate-name-from-foreign} @* @seealso{translate-underscore-separated-name} @c =================================================================== @c TRANSLATE-UNDERSCORE-SEPARATED-NAME @page @node translate-underscore-separated-name, , translate-name-to-foreign, Functions @heading translate-underscore-separated-name @subheading Syntax @Function{translate-underscore-separated-name name @res{} return-value} @subheading Arguments and Values @table @var @item name Either a symbol or a string. @item return-value If @var{name} is a symbol, this is a string, and vice versa. @end table @subheading Description @code{translate-underscore-separated-name} is a helper function for specializations of @ref{translate-name-from-foreign} and @ref{translate-name-to-foreign}. It handles the common case of converting between foreign underscore_separated names and lisp names. @subheading Examples @lisp CFFI> (translate-underscore-separated-name some-xml-function) @result{} "some_xml_function" CFFI> (translate-camelcase-name "some_xml_function") @result{} SOME-XML-FUNCTION @end lisp @subheading See Also @seealso{translate-name-from-foreign} @* @seealso{translate-name-to-foreign} @* @seealso{translate-camelcase-name} @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> (let ((lib (load-foreign-library '(:framework "OpenGL")))) (foreign-library-pathname lib)) @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 search-path) load-clause ::= (feature library &key convention search-path) @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} @item search-path A path or list of paths where the library will be searched if not found in system-global directories. Paths specified in a load clause take priority over paths specified as library option, with *foreign-library-directories* having lowest priority. @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 The result of evaluating the @dfn{simple Lisp expression} should yield a @emph{designator} for a @emph{list} of @emph{pathname designators}. @strong{Note}: in Common Lisp, @code{#p"/foo/bar"} designates the @emph{bar} file within the @emph{/foo} directory whereas @code{#p"/foo/bar/"} designates the @emph{/foo/bar} directory. Keep that in mind when customising the value of @code{*foreign-library-directories*}. @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-designator @res{} library} @subheading Arguments and Values @table @var @item library-designator A library designator. @item library-designator An instance of @code{foreign-library}. @end table @subheading Description Load the library indicated by @var{library-designator}. 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 @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} pkg-config-cflags pkg &key optional Adds @var{pkg} to the command line arguments for the external program @code{pkg-config} and runs it to retrieve the relevant include flags used for the C compiler invocation. This syntax can be used instead of hard-coding paths using @code{cc-flags}, and ensures that include flags are added correctly on the build system. Assumes @code{pkg-config} is installed and working. @var{pkg} is a string that identifies an installed @code{pkg-config} package. See the pkg-config manual for more information. If @var{optional} is true, failure to execute @code{pkg-config} does @emph{not} abort compilation. @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 @deffn {Grovel Form} bitfield name-and-opts &rest elements Defines a bitfield, 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)}. For example: @end deffn @lisp (bitfield flags-ctype ((:flag-a "FLAG_A") :documentation "DOCU_A") ((:flag-b "FLAG_B" "FLAG_B_ALT") :documentation "DOCU_B") ((:flag-c "FLAG_C") :documentation "DOCU_C" :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_0.16.1/doc/cffi-sys-spec.texinfo000644 000765 000024 00000022716 12562363066 017546 0ustar00luisstaff000000 000000 \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 @dircategory Software development @direntry * CFFI Sys spec: (cffi-sys-spec). CFFI Sys spec. @end direntry @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_0.16.1/doc/colorize-lisp-examples.lisp000644 000765 000024 00000126324 12562363066 020775 0ustar00luisstaff000000 000000 ;;; 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)) ((#\") (write-string """ out)) ((#\RIGHTWARDS_DOUBLE_ARROW) (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-substitute (string-substitute string "&" "&") "<" "<") ">" ">") "⇒" (string #\RIGHTWARDS_DOUBLE_ARROW)) """ "\"")) (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+ 0 "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_0.16.1/doc/gendocs.sh000755 000765 000024 00000025120 12562363066 015446 0ustar00luisstaff000000 000000 #!/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="https://github.com/cffi/cffi/blob/master/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
install-info $PACKAGE.info dir
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_0.16.1/doc/gendocs_template��������������������������������������������������������������������000644 �000765 �000024 �00000013252 12562363066 016730� 0����������������������������������������������������������������������������������������������������ustar�00luis����������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������<?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_0.16.1/doc/Makefile000644 000765 000024 00000004010 12562363066 015120 0ustar00luisstaff000000 000000 # -*- 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.
#

export LC_ALL=C

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 dir

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_0.16.1/doc/mem-vector.txt000644 000765 000024 00000005147 12562363066 016313 0ustar00luisstaff000000 000000 
# 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_0.16.1/doc/shareable-vectors.txt000644 000765 000024 00000003001 12562363066 017631 0ustar00luisstaff000000 000000 
# 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_0.16.1/doc/style.css000644 000765 000024 00000005155 12562363066 015345 0ustar00luisstaff000000 000000 body {font-family: Georgia, 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}

pre.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; }