/[cffi-objects]/struct.lisp
ViewVC logotype

Diff of /struct.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 8 by rklochkov, Sun Aug 12 17:36:30 2012 UTC revision 15 by rklochkov, Tue Dec 25 01:10:43 2012 UTC
# Line 16  Struct may be used in OBJECT cffi-type o Line 16  Struct may be used in OBJECT cffi-type o
16    
17  (defgeneric new-struct (class)  (defgeneric new-struct (class)
18    (:method (class)    (:method (class)
19      (foreign-alloc class)))      (foreign-alloc class)))
20    
21  (defgeneric free-struct (class value)  (defgeneric free-struct (class value)
22    (:method (class value)    (:method (class value)
# Line 25  Struct may be used in OBJECT cffi-type o Line 25  Struct may be used in OBJECT cffi-type o
25      ;(format t "Free ~a ~a~%" class value)      ;(format t "Free ~a ~a~%" class value)
26      (foreign-free value)))      (foreign-free value)))
27    
28  (defmethod gconstructor ((struct struct) &key new-struct &allow-other-keys)  (defmethod gconstructor ((struct struct) &rest initargs
29    (if new-struct                           &key new-struct &allow-other-keys)
30        (new-struct (class-name (class-of struct)))    (let ((class-name (class-name (class-of struct)))
31        (progn          (pointer (null-pointer)))
32          (setf (slot-value struct 'value) nil)      (if new-struct
33          (setf (slot-value struct 'free-after) nil)          (setf pointer (new-struct class-name))
34          (null-pointer))))          (progn
35              (setf (slot-value struct 'value) nil
36                    (slot-value struct 'free-after) nil)))
37        (mapc
38         (lambda (field)
39           (let ((val (getf initargs (alexandria:make-keyword field))))
40             (if new-struct
41                 (setf (foreign-slot-value pointer
42                                           (list :struct class-name) field) val)
43                 (setf (getf (slot-value struct 'value) field) val))))
44         (foreign-slot-names (list :struct class-name)))
45        pointer))
46    
47  (defun pair (maybe-pair)  (defun pair (maybe-pair)
48    (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))    (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))
# Line 91  or may be cons (class-name . struct-name Line 102  or may be cons (class-name . struct-name
102       (defcstruct-accessors ,class)       (defcstruct-accessors ,class)
103       (init-slots ,class)))       (init-slots ,class)))
104    
105    (defun clos->struct (class object struct)
106      (let ((default (gensym)))
107        (mapc (lambda (slot)
108                (let ((val (getf (slot-value object 'value) slot default)))
109                  (unless (eq val default)
110                    (setf (foreign-slot-value struct (list :struct class) slot)
111                          val))))
112              (foreign-slot-names (list :struct class)))))
113    
114  (defun clos->new-struct (class object)  (defun clos->new-struct (class object)
115    (if (slot-boundp object 'value)    (if (slot-boundp object 'value)
116        (let ((res (new-struct class))        ;; use make-instance, not new-struct, because gconstructor
117              (default (gensym)))        ;;                                            may be redefined
118          (mapc (lambda (slot)        (let ((res (make-instance class :new-struct t)))
119                  (let ((val (getf (slot-value object 'value) slot default)))          (clos->struct class object (pointer res))
120                    (unless (eq val default)          (pointer res))
                     (setf (foreign-slot-value res class slot) val))))  
               (foreign-slot-names class))  
         res)  
121        (pointer object)))        (pointer object)))
122    
123  (defun struct->clos (class struct &optional object)  (defun struct->clos (class struct &optional object)
# Line 111  object). Line 127  object).
127  Only exception is the presence of OBJECT with not boundp value"  Only exception is the presence of OBJECT with not boundp value"
128    (let ((%object (or object    (let ((%object (or object
129                       (unless (null-pointer-p struct)                       (unless (null-pointer-p struct)
130                         (make-instance class :pointer struct)))))                         (make-instance class)))))
131      (when %object      (when %object
132        (if (slot-boundp %object 'value)        (if (slot-boundp %object 'value)
133            (progn            (progn
134              (setf (slot-value %object 'value) nil)              (setf (slot-value %object 'value) nil)
135              (unless (null-pointer-p struct)              (unless (null-pointer-p struct)
136                (dolist (slot (foreign-slot-names class))                (dolist (slot (foreign-slot-names (list :struct class)))
137                  (setf (getf (slot-value %object 'value) slot)                  (setf (getf (slot-value %object 'value) slot)
138                        (foreign-slot-value struct class slot)))))                        (foreign-slot-value struct (list :struct class) slot)))))
139            (setf (pointer %object) struct))            (setf (pointer %object) struct))
140        %object)))        %object)))
141    
# Line 127  Only exception is the presence of OBJECT Line 143  Only exception is the presence of OBJECT
143    ()    ()
144    (:actual-type :pointer))    (:actual-type :pointer))
145    
 (defmethod free-ptr ((type cffi-struct) ptr)  
   (free-struct (object-class type) ptr))  
   
146  (defmethod free-sent-ptr ((type cffi-struct) ptr place)  (defmethod free-sent-ptr ((type cffi-struct) ptr place)
147    (when (and (slot-boundp place 'value) (not (null-pointer-p ptr)))    (when (and (not (null-pointer-p ptr)) (slot-boundp place 'value))
148        (free-struct (object-class type) ptr)))
149    
150    (defmethod free-returned-ptr ((type cffi-struct) ptr)
151      (unless (null-pointer-p ptr)
152      (free-struct (object-class type) ptr)))      (free-struct (object-class type) ptr)))
153    
154    
155  (defmethod foreign-type-size ((type cffi-struct))  (defmethod foreign-type-size ((type cffi-struct))
156    "Return the size in bytes of a foreign typedef."    "Return the size in bytes of a foreign typedef."
157    (foreign-type-size (object-class type)))    (foreign-type-size (list :struct (object-class type))))
158    
159  (define-parse-method struct (class &rest rest)  (define-parse-method struct (class &rest rest)
160    (apply #'make-instance 'cffi-struct :class class rest))    (apply #'make-instance 'cffi-struct :class class rest))
# Line 161  Only exception is the presence of OBJECT Line 178  Only exception is the presence of OBJECT
178    
179    
180  ;; to allow using array of structs  ;; to allow using array of structs
181  (eval-when (:compile-toplevel :load-toplevel :execute)  ;; (eval-when (:compile-toplevel :load-toplevel :execute)
182     (unless (get 'mem-ref 'struct)  ;;    (unless (get 'mem-ref 'struct)
183       (let ((old (fdefinition 'mem-ref)))  ;;      (let ((old (fdefinition 'mem-ref)))
184         (fmakunbound 'mem-ref)  ;;        (fmakunbound 'mem-ref)
185         (defun mem-ref (ptr type &optional (offset 0))  ;;        (defun mem-ref (ptr type &optional (offset 0))
186           (let ((ptype (cffi::parse-type type)))  ;;          (let ((ptype (cffi::parse-type type)))
187             (if (subtypep (type-of ptype) 'cffi-struct)  ;;            (if (subtypep (type-of ptype) 'cffi-struct)
188                 (translate-from-foreign (inc-pointer ptr offset) ptype)  ;;                (translate-from-foreign (inc-pointer ptr offset) ptype)
189                 (funcall old ptr type offset)))))  ;;                (funcall old ptr type offset)))))
190       (setf (get 'mem-ref 'struct) t)))  ;;      (setf (get 'mem-ref 'struct) t)))
191    
192    (defun struct-p (type)
193      (and (consp type) (eq (car type) 'struct)))
194    
195  (defun from-foreign (var type count)  (defun from-foreign (var type count)
196    "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"    "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"
197    (if count    (if count
198        (let ((res (make-array count)))        (let ((res (make-array count)))
199          (dotimes (i count)          (if (struct-p type)
200            (setf (aref res i)              (dotimes (i count)
201                  (mem-aref var type i)))                (setf (aref res i)
202                        (convert-from-foreign (mem-aptr var type i) type)))
203                (dotimes (i count)
204                  (setf (aref res i)
205                        (mem-aref var type i))))
206          res)          res)
207        (mem-ref var type)))        (mem-ref var type)))
208    

Legend:
Removed from v.8  
changed lines
  Added in v.15

  ViewVC Help
Powered by ViewVC 1.1.5