[cffi-objects-cvs] r17 -

[rklochkov at common-lisp.net]

Author: rklochkov
Date: Mon Dec 31 05:35:32 2012
New Revision: 17

Log:
Fixed memory leak. Added support of old (10.7) cffi

Modified:
   struct.lisp

Modified: struct.lisp
==============================================================================
--- struct.lisp	Sat Dec 29 06:39:56 2012	(r16)
+++ struct.lisp	Mon Dec 31 05:35:32 2012	(r17)
@@ -42,11 +42,12 @@
                 (slot-value struct 'free-after) nil)))
     (mapc
      (lambda (field) 
-       (let ((val (getf initargs (alexandria:make-keyword field))))
-         (if new-struct
-             (setf (foreign-slot-value pointer 
-                                       (struct-type class-name) field) val)
-             (setf (getf (slot-value struct 'value) field) val))))
+       (let ((val (getf initargs (alexandria:make-keyword field) :default)))
+         (unless (eq val :default)
+           (if new-struct
+               (setf (foreign-slot-value pointer 
+                                         (struct-type class-name) field) val)
+               (setf (getf (slot-value struct 'value) field) val)))))
      (foreign-slot-names (struct-type class-name)))
     pointer))
 
@@ -100,11 +101,19 @@
                  (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))
 
 (defmacro defcstruct* (class &body body)
   `(progn
      (defclass ,class (struct) ())
-     (defcstruct ,class , at body)
+     (defcstruct ,class ,@(parse-struct body))
      (defcstruct-accessors ,class)
      (init-slots ,class)))
 
@@ -121,7 +130,7 @@
   (if (slot-boundp object 'value)
       ;; use make-instance, not new-struct, because gconstructor
       ;;                                            may be redefined
-      (let ((res (make-instance class :new-struct t)))
+      (let ((res (make-instance class :new-struct t :free-after nil)))
         (clos->struct class object (pointer res))
         (pointer res))
       (pointer object)))