From rklochkov at common-lisp.net  Sat Jan 12 21:26:46 2013
From: rklochkov at common-lisp.net (rklochkov at common-lisp.net)
Date: Sat, 12 Jan 2013 13:26:46 -0800
Subject: [cffi-objects-cvs] r18 -
Message-ID: <E1Tu8bG-0006Pr-Mj@common-lisp.net>

Author: rklochkov
Date: Sat Jan 12 13:26:46 2013
New Revision: 18

Log:
Added support for MESSAGE-OO and (lisp-name . c-name) syntax for structure fields

Modified:
   cffi-objects.asd
   freeable.lisp
   package.lisp
   struct.lisp

Modified: cffi-objects.asd
==============================================================================
--- cffi-objects.asd	Mon Dec 31 05:35:32 2012	(r17)
+++ cffi-objects.asd	Sat Jan 12 13:26:46 2013	(r18)
@@ -12,9 +12,9 @@
 (defsystem cffi-objects
   :description "CFFI in-place replacement with object wrappers, structs and arrays"
   :author "Roman Klochkov <monk at slavsoft.surgut.ru>"
-  :version "0.9"
+  :version "0.9.1"
   :license "BSD"
-  :depends-on (cffi trivial-garbage)
+  :depends-on (cffi trivial-garbage closer-mop)
   :components
   ((:file package)
    (:file redefines :depends-on (package freeable))

Modified: freeable.lisp
==============================================================================
--- freeable.lisp	Mon Dec 31 05:35:32 2012	(r17)
+++ freeable.lisp	Sat Jan 12 13:26:46 2013	(r18)
@@ -30,6 +30,7 @@
 \begin{itemize}
 \item [[freeable-base]] introduces all necessary fields and handlers
 \item [[freeable]] have ready cffi-translator methods
+\end{itemize}
 |#
 
 (define-foreign-type freeable-base ()
@@ -55,9 +56,9 @@
 This generic describes, how to free an object with CFFI type [[type]] and
 pointer [[ptr]]. As [[type]] should be a symbol, you should specialize
 this generic with EQL specifier if your objects shouldn't be freed with
-[[foreign-free].
+[[foreign-free]].
 
-One can ask, why normal specializer by type of object and [[object] as
+One can ask, why normal specializer by type of object and [[object]] as
 a first parameter is not used. Such strange API is developed, 
 because [[free-ptr]] is used in [[trivial-garbage:finalize]] and in some 
 implementation (for example, SBCL) finalizer shouldn't have reference
@@ -69,19 +70,46 @@
 
 (defgeneric free-ptr (type ptr)
   (:documentation "Called to free ptr, unless overriden free-sent-ptr 
-or free-returned-ptr. TYPE should be specialized with EQL")
+or free-returned-ptr. TYPE should be symbol and be specialized with EQL")
   (:method (type ptr) (foreign-free ptr)))
 
 ;;;[ <generic free-sent-ptr>
 
+#|<doc>
+This generic describes, how to free an object with CFFI type [[type]] and
+pointer [[ptr]] after sending to foreign space. It has the same parameters
+as [[cffi:free-translated-object]]. If complex foreign type has additional
+conditionals or any additional actions when freeing, specialize it on you type.
+
+Please, don't call it directly. Use [[free-sent-if-needed]] instead.
+|#
+
 (defgeneric free-sent-ptr (cffi-type ptr param)
+  (:documentation "Will be called in free-translated-object.
+CFFI-TYPE: type defined with define-foreign-type.
+PTR: foreign pointer
+PARAM: third parameter of free-translated-object == 
+       returned second value of translate-to-foreign.")
   (:method ((cffi-type freeable-base) ptr param)
     (unless (null-pointer-p ptr)
       (free-ptr (type-of cffi-type) ptr))))
 
 ;;;[ <generic free-returned-ptr>
 
+#|<doc>
+This generic describes, how to free an object with CFFI type [[type]] and
+pointer [[ptr]] after receiving from foreign space. It has the same parameters
+as [[cffi:translate-to-foreign]]. If complex foreign type has additional
+conditionals or any additional actions when freeing, specialize it on you type.
+
+Please, don't call it directly. Use [[free-returned-if-needed]] instead.
+|#
+
+
 (defgeneric free-returned-ptr (cffi-type ptr)
+  (:documentation "Will be called in translate-from-foreign after conversion.
+CFFI-TYPE: type defined with define-foreign-type.
+PTR: foreign pointer")
   (:method ((cffi-type freeable-base) ptr)
     (unless (null-pointer-p ptr)
       (free-ptr (type-of cffi-type) ptr))))
@@ -89,22 +117,38 @@
 ;;;[ <function free-sent-if-needed
 
 (defun free-sent-if-needed (cffi-type ptr param)
+  "This function should be placed in appropriate place of 
+free-translated-object"
   (when (fst-free-to-foreign-p cffi-type)
     (free-sent-ptr cffi-type ptr param)))
 
 ;;;[ <function free-returned-if-needed
 
 (defun free-returned-if-needed (cffi-type ptr)
+  "This function should be placed in appropriate place of 
+translate-from-foreign"
   (when (fst-free-from-foreign-p cffi-type)
     (free-returned-ptr cffi-type ptr)))
 
 ;;;[ <class freeable>
 
+#|<doc>
+This is standard base class for freeable pointers. If you happy with
+default free algorithm, which implies, that [[free-sent-ptr]] is called after
+[[free-translated-object]] when type described with [[:free-to-foreign t]] 
+and [[free-returned-ptr]] is called when type described with 
+[[:free-from-foreign t]] after [[translate-from-foreign]].
+
+If you need more complicated logic (for example, to free object in 
+translate-from-foreign, not after), you should inherit your class from
+[[freeable-base]] and 
+call [[free-sent-if-needed]] from [[free-translated-object]]
+and [[free-returned-if-needed]] from [[translate-from-foreign]].
+|#
+
 (defclass freeable (freeable-base) ()
   (:documentation "Mixing to auto-set translators"))
 
-
-
 (defmethod free-translated-object :after (ptr (type freeable) param)
   (free-sent-if-needed type ptr param))
 
@@ -113,14 +157,39 @@
 
 ;;;[ <class freeable-out>
 
+#|<doc>
+This is standard base class for objects, that should be copied back
+to lisp after foreign function: so-called ``out parameters''.
+
+For every class, inherited from [[freeable-out]], you must
+implement method [[copy-from-foreign]].
+
+Then user of your class may set [[:out t]] in initargs for your class
+and be sure, that all changed data will be copied back to the variables.
+
+When implementing [[translate-to-foreign]] you must return (values ptr value),
+because second value will be passed to [[free-translated-object]], and then
+as PLACE to [[copy-from-foreign]].
+|#
+
 (define-foreign-type freeable-out (freeable)
   ((out :accessor object-out :initarg :out :initform nil
         :documentation "This is out param (for fill in foreign side)"))
   (:documentation "For returning data in out params.
 If OUT is t, then translate-to-foreign MUST return (values ptr place)"))
 
-(defgeneric copy-from-foreign (type ptr place)
-  (:documentation "Transfers data from pointer PTR to PLACE"))
+;;;[ <generic copy-from-foreign>
+
+#|<doc>
+This generic must have an implementation for every class inherited from [[freeable-out]].
+|#
+
+(defgeneric copy-from-foreign (cffi-type ptr place)
+  (:documentation "Transfers data from pointer PTR to PLACE.
+CFFI-TYPE: type defined with define-foreign-type.
+PTR: foreign pointer
+PLACE: third parameter of free-translated-object == 
+       returned second value of translate-to-foreign"))
 
 (defmethod free-translated-object :before (ptr (type freeable-out) place)
   (when (object-out type)

Modified: package.lisp
==============================================================================
--- package.lisp	Mon Dec 31 05:35:32 2012	(r17)
+++ package.lisp	Sat Jan 12 13:26:46 2013	(r18)
@@ -24,7 +24,7 @@
         (unexport (list v) p)))))
 
 (defpackage #:cffi-objects
-  (:use #:common-lisp #:cffi)
+  (:use #:common-lisp #:cffi #+message-oo #:message-oo)
   (:export
    #:freeable-base
    ;; slots
@@ -57,7 +57,6 @@
    ;; methods
    #:free
 
-
    #:*array-length*
    ;; types
    #:pstring
@@ -74,19 +73,20 @@
    #:cffi-string
 
    #:struct
-;   #:cffi-struct
+   #:cffi-struct
    #:new-struct
    #:free-struct
 
-   
    #:defcstruct-accessors
    #:defcstruct*
    #:defbitaccessors
 
+   ;; not for objects, but useful with cffi
    #:with-foreign-out
    #:with-foreign-outs
    #:with-foreign-outs-list
 
+   ;; for creating object models on top of C objects
    #:pair
    #:setf-init
    #:init-slots
@@ -136,6 +136,7 @@
 to free foreign pointer, you should use [[foo-as-value]].
 
 \include{redefines}
+\include{freeable}
 |#
 ;;; </define>
 

Modified: struct.lisp
==============================================================================
--- struct.lisp	Mon Dec 31 05:35:32 2012	(r17)
+++ struct.lisp	Sat Jan 12 13:26:46 2013	(r18)
@@ -54,61 +54,104 @@
 (defun pair (maybe-pair)
   (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))
 
-(defmacro defcstruct-accessors (class)
+(defun slot-accessor (designator)
+  (flet ((count-args (list)
+           (do ((list list (cdr list))
+                (count 0 (1+ count))) 
+               ((or (null list) 
+                    (char= (char (string (car list)) 0) #\&))
+                count))))
+    (let ((lambda-list
+           (closer-mop:generic-function-lambda-list (fdefinition designator))))
+      (= (count-args lambda-list) (if (listp designator) 2 1)))))
+
+(defmacro defaccessor (name c-name class &body body)
+  #-message-oo (declare (ignore c-name))
+  (let ((val* (when (listp name) (list 'val))))
+    `(progn
+       (unless (fboundp ',name)
+         (defgeneric ,name (, at val* ,class)))
+       (if (slot-accessor ',name)
+           (defmethod ,name (, at val* (,class ,class))
+             . ,body)
+           (warn 'style-warning 
+                 "~a is not a slot accessor" ',name))
+       #+message-oo 
+       ,(if val*
+            `(defmessage ,class (,(alexandria:format-symbol 
+                                    :keyword "~A=" c-name)
+                                  val)
+               . ,body)
+            `(defmessage ,class ,(alexandria:make-keyword c-name)
+               . ,body)))))
+
+
+(defmacro defcstruct-accessors (class &rest fields)
   "CLASS may be symbol = class-name = struct name,
 or may be cons (class-name . struct-name)"
   (destructuring-bind (class-name . struct-name) (pair class)
     `(progn
        (clear-setters ,class-name)
        ,@(mapcar
-          (lambda (x) 
-           `(progn
-              (unless (fboundp ',x)
-                (defgeneric ,x (,class-name)))
-              (defmethod ,x ((,class-name ,class-name))
-                (if (slot-boundp ,class-name 'value)
-                    (getf (slot-value ,class-name 'value) ',x)
-                    (foreign-slot-value (pointer ,class-name)
-                                        ',(struct-type struct-name) ',x)))
-              (unless (fboundp '(setf ,x))
-                (defgeneric (setf ,x) (val ,class-name)))
-              (defmethod (setf ,x) (val (,class-name ,class-name))
-                (if (slot-boundp ,class-name 'value)
-                    (setf (getf (slot-value ,class-name 'value) ',x) val)
-                    (setf (foreign-slot-value (pointer ,class-name) 
-                                              ',(struct-type struct-name) ',x) 
+          (lambda (field)
+            (destructuring-bind (lisp-name . c-name) (pair field)
+              `(progn
+                 (defaccessor ,lisp-name ,c-name ,class-name
+                   (if (slot-boundp ,class-name 'value)
+                       (getf (slot-value ,class-name 'value) ',c-name)
+                       (foreign-slot-value (pointer ,class-name)
+                                           ',(struct-type struct-name) 
+                                           ',c-name)))
+                 (defaccessor (setf ,lisp-name) ,c-name ,class-name
+                   (if (slot-boundp ,class-name 'value)
+                       (setf (getf (slot-value ,class-name 'value) 
+                                   ',c-name) 
+                             val)
+                       (setf (foreign-slot-value 
+                               (pointer ,class-name) 
+                               ',(struct-type struct-name) ',c-name)
                           val)))
-              (save-setter ,class-name ,x)))
-          (foreign-slot-names (struct-type struct-name))))))
+              (save-setter ,class-name ,lisp-name))))
+          (or (mapcan (lambda (field) 
+                        (unless (stringp field) (list (car field))))
+                      fields)
+              (foreign-slot-names (struct-type struct-name)))))))
 
 (defmacro defbitaccessors (class slot &rest fields)
   (let ((pos 0))
     (flet ((build-field (field)
              (destructuring-bind (name type size) field
-               (prog1 
-                   `(progn
-                      (unless (fboundp ',name)
-                        (defgeneric ,name (,class)))
-                      (defmethod ,name ((,class ,class))
-                        (convert-from-foreign 
-                         (ldb (byte ,size ,pos) (slot-value ,class ',slot))
-                         ,type))
-                      (unless (fboundp '(setf ,name))
-                        (defgeneric (setf ,name) (value ,class)))
-                      (defmethod (setf ,name) (value (,class ,class))
-                        (setf (ldb (byte ,size ,pos) (slot-value ,class ',slot))
-                              (convert-to-foreign value ,type))))
-                 (incf pos size)))))
+               (destructuring-bind (lisp-name . c-name) (pair name)
+                 (prog1 
+                     `(progn
+                        (defaccessor ,lisp-name ,c-name ,class
+                            (convert-from-foreign 
+                             (ldb (byte ,size ,pos) (slot-value ,class ',slot))
+                             ,type))
+                        (defaccessor (setf ,lisp-name) ,c-name ,class
+                            (setf (ldb (byte ,size ,pos) 
+                                       (slot-value ,class ',slot))
+                                  (convert-to-foreign val ,type))))
+                   (incf pos size))))))
       (cons 'progn (mapcar #'build-field fields)))))
 
 (defun parse-struct (body)
-  (mapcar (lambda (str)
-            (if (stringp str) str
-                (let ((str2 (second str)))
-                  (if (and (consp str2) (eq (car str2) :struct))
-                      (list (first str) (struct-type (second str2)))
-                      str))))
-          body))
+  (flet ((struct? (type)
+           (and (consp type) (eq (car type) :struct)))
+         (cname (name)
+           (destructuring-bind (lisp-name . c-name) (pair name)
+             (declare (ignore lisp-name))
+             c-name)))
+    (mapcar (lambda (str)
+              (if (stringp str) str
+                  (list*
+                   (cname (first str))
+                   (let ((type (second str)))
+                     (if (struct? type)
+                         (struct-type (second type))
+                         type)) 
+                   (cddr str))))
+            body)))
 
 (defmacro defcstruct* (class &body body)
   `(progn