src/structures.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; structures.lisp --- Methods for translating foreign structures.
   4 ;;;
   5 ;;; Copyright (C) 2011, Liam M. Healy  <lhealy@common-lisp.net>
   6 ;;;
   7 ;;; Permission is hereby granted, free of charge, to any person
   8 ;;; obtaining a copy of this software and associated documentation
   9 ;;; files (the "Software"), to deal in the Software without
  10 ;;; restriction, including without limitation the rights to use, copy,
  11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  12 ;;; of the Software, and to permit persons to whom the Software is
  13 ;;; furnished to do so, subject to the following conditions:
  14 ;;;
  15 ;;; The above copyright notice and this permission notice shall be
  16 ;;; included in all copies or substantial portions of the Software.
  17 ;;;
  18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  21 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  25 ;;; DEALINGS IN THE SOFTWARE.
  26 ;;;
  27
  28 (in-package #:cffi)
  29
  30 ;;; Definitions for conversion of foreign structures.
  31
  32 (defmethod translate-into-foreign-memory ((object list)
  33                                           (type foreign-struct-type)
  34                                           p)
  35   (unless (bare-struct-type-p type)
  36     (loop for (name value) on object by #'cddr
  37           do (setf (foreign-slot-value p (unparse-type type) name)
  38                    (let ((slot (gethash name (structure-slots type))))
  39                      (convert-to-foreign value (slot-type slot)))))))
  40
  41 (defmethod translate-to-foreign (value (type foreign-struct-type))
  42   (let ((ptr (foreign-alloc type)))
  43     (translate-into-foreign-memory value type ptr)
  44     ptr))
  45
  46 (defmethod translate-from-foreign (p (type foreign-struct-type))
  47   ;; Iterate over slots, make plist
  48   (if (bare-struct-type-p type)
  49       p
  50       (let ((plist (list)))
  51         (loop for slot being the hash-value of (structure-slots type)
  52               for name = (slot-name slot)
  53               do (setf (getf plist name)
  54                        (foreign-struct-slot-value p slot)))
  55         plist)))
  56
  57 (defmethod free-translated-object (ptr (type foreign-struct-type) freep)
  58   (unless (bare-struct-type-p type)
  59     ;; Look for any pointer slots and free them first
  60     (loop for slot being the hash-value of (structure-slots type)
  61           when (and (listp (slot-type slot)) (eq (first (slot-type slot)) :pointer))
  62             do
  63                ;; Free if the pointer is to a specific type, not generic :pointer
  64                (free-translated-object
  65                 (foreign-slot-value ptr type (slot-name slot))
  66                 (rest (slot-type slot))
  67                 freep))
  68     (foreign-free ptr)))
  69
  70 (defmacro define-translation-method ((object type method) &body body)
  71   "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."
  72   (let ((tclass (class-name (class-of (cffi::parse-type `(:struct ,type))))))
  73     (when (eq tclass 'foreign-struct-type)
  74       (error "Won't replace existing translation method for foreign-struct-type"))
  75     `(defmethod
  76          ,(case method
  77             (:into 'translate-into-foreign-memory)
  78             (:from 'translate-from-foreign)
  79             (:to 'translate-to-foreign))
  80        ;; Arguments to the method
  81        (,object
  82         (type ,tclass)
  83         ,@(when (eq method :into) '(pointer))) ; is intentional variable capture a good idea?
  84        ;; The body
  85        (declare (ignorable type)) ; I can't think of a reason why you'd want to use this
  86        ,@body)))
  87
  88 (defmacro translation-forms-for-class (class type-class)
  89   "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."
  90   ;; Possible improvement: optional argument to map structure slot names to/from class slot names.
  91   `(progn
  92      (defmethod translate-from-foreign (pointer (type ,type-class))
  93        ;; Make the instance from the plist
  94        (apply 'make-instance ',class (call-next-method)))
  95      (defmethod translate-into-foreign-memory ((object ,class) (type ,type-class) pointer)
  96        (call-next-method
  97         ;; Translate into a plist and call the general method
  98         (loop for slot being the hash-value of (structure-slots type)
  99               for name = (slot-name slot)
 100               append (list slot-name (slot-value object slot-name)))
 101         type
 102         pointer))))
 103
 104 ;;; For a class already defined and loaded, and a defcstruct already defined, use
 105 ;;; (translation-forms-for-class class type-class)
 106 ;;; to connnect the two.  It would be nice to have a macro to do all three simultaneously.
 107 ;;; (defmacro define-foreign-structure (class ))
 108
 109 #|
 110 (defmacro define-structure-conversion
 111     (value-symbol type lisp-class slot-names to-form from-form &optional (struct-name type))
 112   "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."
 113   `(flet ((map-slots (fn val)
 114             (maphash
 115              (lambda (name slot-struct)
 116                (funcall fn (foreign-slot-value val ',type name) (slot-type slot-struct)))
 117              (slots (follow-typedefs (parse-type ',type))))))
 118      ;; Convert this to a separate function so it doesn't have to be recomputed on the fly each time.
 119      (defmethod translate-to-foreign ((,value-symbol ,lisp-class) (type ,type))
 120        (let ((p (foreign-alloc ',struct-name)))
 121          ;;(map-slots #'translate-to-foreign ,value-symbol) ; recursive translation of slots
 122          (with-foreign-slots (,slot-names p ,struct-name)
 123            ,to-form)
 124          (values p t))) ; second value is passed to FREE-TRANSLATED-OBJECT
 125      (defmethod free-translated-object (,value-symbol (p ,type) freep)
 126        (when freep
 127          ;; Is this redundant?
 128          (map-slots #'free-translated-object value) ; recursively free slots
 129          (foreign-free ,value-symbol)))
 130      (defmethod translate-from-foreign (,value-symbol (type ,type))
 131        (with-foreign-slots (,slot-names ,value-symbol ,struct-name)
 132          ,from-form))))
 133 |#