diff --git a/cffi-fsbv.asd b/cffi-fsbv.asd new file mode 100644 index 000000000000..882ee36f6ca8 --- /dev/null +++ b/cffi-fsbv.asd @@ -0,0 +1,49 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; cffi-fsbv.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) + +;;; Shouldn't the :defsystem-depends-on take care of loading cffi-grovel? +(eval-when (:compile-toplevel :execute) + (asdf:oos 'asdf:load-op :cffi-grovel)) + +(defsystem cffi-fsbv + :description "Foreign structures by value" + :author "Liam Healy " + :maintainer "Liam Healy " + :defsystem-depends-on (#:cffi-grovel #:trivial-features) + :components + ((:module fsbv + :serial t + :components + ((:file "package") + (:file "init") + (cffi-grovel:grovel-file "libffi" :pathname #+unix "libffi-unix") + (:file "type-pointers") + (:file "cif") + (:file "cstruct")))) + :depends-on (#:cffi #:cffi-grovel #:trivial-features)) diff --git a/cffi.asd b/cffi.asd index fa65a5e5d58d..113968f58753 100644 --- a/cffi.asd +++ b/cffi.asd @@ -58,6 +58,7 @@ (:file "types") (:file "enum") (:file "strings") + (:file "structures") (:file "functions") (:file "foreign-vars") (:file "features"))))) diff --git a/fsbv/cbuiltin.lisp b/fsbv-standalone/cbuiltin.lisp similarity index 100% rename from fsbv/cbuiltin.lisp rename to fsbv-standalone/cbuiltin.lisp diff --git a/fsbv/convert.lisp b/fsbv-standalone/convert.lisp similarity index 100% rename from fsbv/convert.lisp rename to fsbv-standalone/convert.lisp diff --git a/fsbv/defs.lisp b/fsbv-standalone/defs.lisp similarity index 100% rename from fsbv/defs.lisp rename to fsbv-standalone/defs.lisp diff --git a/fsbv/examples.lisp b/fsbv-standalone/examples.lisp similarity index 100% rename from fsbv/examples.lisp rename to fsbv-standalone/examples.lisp diff --git a/fsbv/foreign-object-components.lisp b/fsbv-standalone/foreign-object-components.lisp similarity index 100% rename from fsbv/foreign-object-components.lisp rename to fsbv-standalone/foreign-object-components.lisp diff --git a/fsbv/fsbv.asd b/fsbv-standalone/fsbv.asd similarity index 100% rename from fsbv/fsbv.asd rename to fsbv-standalone/fsbv.asd diff --git a/fsbv/functions.lisp b/fsbv-standalone/functions.lisp similarity index 100% rename from fsbv/functions.lisp rename to fsbv-standalone/functions.lisp diff --git a/fsbv/pkgdcl.lisp b/fsbv-standalone/pkgdcl.lisp similarity index 100% rename from fsbv/pkgdcl.lisp rename to fsbv-standalone/pkgdcl.lisp diff --git a/fsbv/readme.html b/fsbv-standalone/readme.html similarity index 100% rename from fsbv/readme.html rename to fsbv-standalone/readme.html diff --git a/fsbv/.gitignore b/fsbv/.gitignore deleted file mode 100644 index b25c15b81fae..000000000000 --- a/fsbv/.gitignore +++ /dev/null @@ -1 +0,0 @@ -*~ diff --git a/fsbv/cif.lisp b/fsbv/cif.lisp new file mode 100644 index 000000000000..f6a3631d9107 --- /dev/null +++ b/fsbv/cif.lisp @@ -0,0 +1,54 @@ +;;;; -*- 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-fsbv) + +;;; Structs + +(cffi: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 + +(cffi:defcfun ("ffi_prep_cif" prep-cif) status + (ffi-cif :pointer) + (ffi-abi abi) + (nargs :uint) + (rtype :pointer) + (argtypes :pointer)) + +(cffi:defcfun ("ffi_call" call) :void + (ffi-cif :pointer) + (function :pointer) + (rvalue :pointer) + (avalues :pointer)) diff --git a/fsbv/cstruct.lisp b/fsbv/cstruct.lisp index aa843b13688c..bbe0dd3fda20 100644 --- a/fsbv/cstruct.lisp +++ b/fsbv/cstruct.lisp @@ -25,15 +25,13 @@ ;;; DEALINGS IN THE SOFTWARE. ;;; -(in-package :fsbv) - -(export '(defined-type-p)) +(in-package #:cffi-fsbv) ;;; The hook defcstruct-hook is provided to add definitions need to ;;; use structures by value in function calls. It will be called when ;;; defcstruct is expanded, inserting some forms at the end. -;;; Potential efficiency improvement: when a filed has count > 1, +;;; Potential efficiency improvement: when a field has count > 1, ;;; define a pointer to the first element, and reference from that, ;;; instead of recomputing the pointer each element. @@ -41,21 +39,38 @@ (or `(libffi-type-pointer ,symbol) (error "Element type ~a is not known to libffi." symbol))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *libffi-struct-defs* nil)) +(defun name-from-name-and-options (name-and-options) + (if (listp name-and-options) + (first name-and-options) + name-and-options)) + +(defun option-from-name-and-options (name-and-options option default) + (if (listp name-and-options) + (getf (rest name-and-options) option default) + default)) + +(defun field-count (field &optional (default 1)) + (getf field :count default)) -(defun defined-type-p (name) - "This structure has been defined for call-by-value." - (member name *libffi-struct-defs*)) +(defun iterate-foreign-structure (fields form) + "Iterate over the foreign structure, generating forms + with form-function, a function of field, fn and gn. + The argument fn is the count within the field, and + gn is the overall count from 0." + (loop for field in fields with gn = 0 + append + (loop for fn from 0 below (field-count field) + append + (prog1 + (funcall form field fn gn) + (incf gn))))) -(defun defcstruct-hook (name-and-options &rest fields) +(defun cstruct-libffi-hook (name-and-options &rest fields) "A function to produce forms in defcstruct to define the struct to CFFI and to libffi simultaneously." (let ((total-number-of-elements (apply '+ (mapcar 'field-count fields))) (name (name-from-name-and-options name-and-options))) - (pushnew name *libffi-struct-defs*) - `((pushnew ',name *libffi-struct-defs*) - (setf (libffi-type-pointer ,name) + `((setf (libffi-type-pointer ,name) (let ((ptr (cffi:foreign-alloc 'ffi-type)) (elements (cffi:foreign-alloc :pointer @@ -77,28 +92,7 @@ (cffi:foreign-slot-value ptr 'ffi-type 'alignment) 0 (cffi:foreign-slot-value ptr 'ffi-type 'type) +type-struct+ (cffi:foreign-slot-value ptr 'ffi-type 'elements) elements) - ptr) - (get ',name 'foreign-object-components) - (lambda (object &optional (index 0)) - (,(option-from-name-and-options name-and-options :constructor 'list) - ,@(iterate-foreign-structure - fields - (lambda (field fn gn) - (declare (ignore gn)) - `(,(structure-slot-form field name fn)))))) - (get ',name 'setf-foreign-object-components) - (lambda (value object &optional (index 0)) - (setf - ,@(iterate-foreign-structure - fields - (lambda (field fn gn) - `(,(structure-slot-form field name fn) - ,(let ((decon - (option-from-name-and-options - name-and-options :deconstructor 'elt))) - (if (listp decon) - `(,(nth gn decon) value) - `(,decon value ,gn)))))))))))) + ptr))))) (eval-when (:compile-toplevel :load-toplevel :execute) - (setf cffi::*defcstruct-hook* 'defcstruct-hook)) + (setf cffi::*defcstruct-hook* 'cstruct-libffi-hook)) diff --git a/fsbv/init.lisp b/fsbv/init.lisp index ba41f66a7f85..e3cb3421e0b2 100644 --- a/fsbv/init.lisp +++ b/fsbv/init.lisp @@ -1,11 +1,32 @@ -;; Load foreign library -;; Liam Healy 2009-02-22 09:55:45EST pkgdcl.lisp -;; Time-stamp: <2010-11-30 12:26:11EST init.lisp> +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; init.lisp --- Load libffi +;;; +;;; 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 :common-lisp-user) +(in-package #:cffi-fsbv) (cffi:load-foreign-library #+darwin "libffi.dylib" #+(and (not darwin) unix) "libffi.so") - -(pushnew :fsbv *features*) diff --git a/fsbv/libffi-unix.lisp b/fsbv/libffi-unix.lisp index b958a3eaff4c..a7b833e64bc0 100644 --- a/fsbv/libffi-unix.lisp +++ b/fsbv/libffi-unix.lisp @@ -1,9 +1,9 @@ ;; CFFI-Grovel definitions for unix systems. ;; Liam Healy 2009-02-22 09:24:33EST libffi-unix.lisp -;; Time-stamp: <2009-08-23 09:51:01EDT libffi-unix.lisp> +;; Time-stamp: <2011-09-10 22:25:10EDT libffi-unix.lisp> ;; $Id: $ -(in-package :fsbv) +(in-package #:cffi-fsbv) #+linux (define "_GNU_SOURCE") diff --git a/fsbv/package.lisp b/fsbv/package.lisp new file mode 100644 index 000000000000..be56beecf496 --- /dev/null +++ b/fsbv/package.lisp @@ -0,0 +1,34 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; package.lisp --- Define foreign structures by value package +;;; +;;; 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 #:cl-user) + +(defpackage #:cffi-fsbv + (:use #:common-lisp) + ;;(:import-from #:cffi-sys #:native-namestring) + ;;(:export) + ) diff --git a/fsbv/type-pointers.lisp b/fsbv/type-pointers.lisp new file mode 100644 index 000000000000..8be651a3ff4e --- /dev/null +++ b/fsbv/type-pointers.lisp @@ -0,0 +1,96 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; types.lisp --- Types of pointers 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-fsbv) + +(cffi:defcvar ("ffi_type_double" +size-double+ :read-only t) :int) +(cffi:defcvar ("ffi_type_float" +size-float+ :read-only t) :int) +(cffi:defcvar ("ffi_type_longdouble" +size-longdouble+ :read-only t) :int) +(cffi:defcvar ("ffi_type_pointer" +size-pointer+ :read-only t) :int) +(cffi:defcvar ("ffi_type_sint16" +size-sint16+ :read-only t) :int) +(cffi:defcvar ("ffi_type_sint32" +size-sint32+ :read-only t) :int) +(cffi:defcvar ("ffi_type_sint64" +size-sint64+ :read-only t) :int) +(cffi:defcvar ("ffi_type_sint8" +size-sint8+ :read-only t) :int) +(cffi:defcvar ("ffi_type_uint16" +size-uint16+ :read-only t) :int) +(cffi:defcvar ("ffi_type_uint32" +size-uint32+ :read-only t) :int) +(cffi:defcvar ("ffi_type_uint64" +size-uint64+ :read-only t) :int) +(cffi:defcvar ("ffi_type_uint8" +size-uint8+ :read-only t) :int) +(cffi:defcvar ("ffi_type_void" +size-void+ :read-only t) :int) + +(defmacro libffi-type-pointer (symbol) + "Get the pointer into the libffi library that represents the type + for the given symbol." + `(get ',symbol 'type-pointer)) + +(defmacro defsynonym (name type) + "Define a new name for an existing type." + `(setf + (libffi-type-pointer ,name) + (libffi-type-pointer ,type))) + +;;; Handle built-in types; see +;;; http://common-lisp.net/project/cffi/manual/html_node/Built_002dIn-Types.html#Built_002dIn-Types + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun ffi-builtin-name (type) + "The libffi string from the built-in name of the CFFI type." + (let ((str (string-downcase type))) + (format nil "ffi_type_~a~a" + (if (string= str "int" :end1 3) "s" "") + str)))) + +(defmacro defcbuiltin (type) + "Define the foreign object components reader and writer, assuming + the cffi:mem-aref works on them." + `(setf (libffi-type-pointer ,type) + (cffi:foreign-symbol-pointer ,(ffi-builtin-name type)))) + +(defcbuiltin :double) +(defcbuiltin :float) +(defcbuiltin :pointer) +(defcbuiltin :int8) +(defcbuiltin :int16) +(defcbuiltin :int32) +(defcbuiltin :int64) +(defcbuiltin :uint8) +(defcbuiltin :uint16) +(defcbuiltin :uint32) +(defcbuiltin :uint64) +(defcbuiltin :void) + +;;; Assign these more accurately? +(defsynonym :char :int8) +(defsynonym :uchar :uint8) +(defsynonym :unsigned-char :uint8) +(defsynonym :short :int16) +(defsynonym :ushort :uint16) +(defsynonym :unsigned-short :uint16) +(defsynonym :int :int32) +(defsynonym :uint :uint32) +(defsynonym :long :int64) +(defsynonym :ulong :uint64) +(defsynonym :unsigned-long :uint64) diff --git a/src/structures.lisp b/src/structures.lisp index d626c1f05dd1..90d56bb9439c 100644 --- a/src/structures.lisp +++ b/src/structures.lisp @@ -1,5 +1,5 @@ ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- -;;; Time-stamp: <2011-09-10 18:36:53EDT structures.lisp> +;;; Time-stamp: <2011-09-11 00:14:20EDT structures.lisp> ;;; ;;; strings.lisp --- Operations on foreign strings. ;;;