Define structure interface to libffi

Generic function translate-into-foreign-memory and funtion
convert-into-foreign-memory definitions now loaded by cffi.  System
cffi-fsbv defined for calling functions with foreign structures by
value using libffi.  Current state of this system is to make
libffi-type-pointer and associate with the structure in defcstruct.
This works on test structure
(macroexpand '(defcstruct (complex :class complex-type) (real :double) (imag :double)))
but nothing further is done with the libffi-type-pointer.

To do: fix lookup-type so that if there is no type defined, it returns
nil.  Do iterate-foreign-structure in advance of macro expansion in
cstruct-libffi-hook, if any arguments lack type translation, then
return nil.  This means that that structure can not be passed/returned
by value.  Then load cif after cstruct.  Secondary bug fix: defsynonym
'unsigned to something, not sure what it's supposed to be; :uint?

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 <lhealy@common-lisp.net>"
+  :maintainer "Liam Healy <lhealy@common-lisp.net>"
+  :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))

cffi.asd

@@ -58,6 +58,7 @@
      (:file "types")
      (:file "enum")
      (:file "strings")
+     (:file "structures")
      (:file "functions")
      (:file "foreign-vars")
      (:file "features")))))

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  <lhealy@common-lisp.net>
+;;;
+;;; 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))

fsbv/cstruct.lisp

@@ -25,37 +25,52 @@
 ;;; 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.
 
 (defun lookup-type (symbol)
   (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))

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

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

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

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  <lhealy@common-lisp.net>
+;;;
+;;; 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)