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

Diff of /struct.lisp

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

revision 13 by rklochkov, Sat Dec 22 19:24:45 2012 UTC revision 16 by rklochkov, Sat Dec 29 14:39:56 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)  (if (find-symbol "MEM-APTR" "CFFI") ;; new cffi
29    (if new-struct      (defun struct-type (type)
30        (new-struct (class-name (class-of struct)))        (list :struct type))
31        (progn      (defun struct-type (type)
32          (setf (slot-value struct 'value) nil)        type))
33          (setf (slot-value struct 'free-after) nil)  
34          (null-pointer))))  (defmethod gconstructor ((struct struct) &rest initargs
35                             &key new-struct &allow-other-keys)
36      (let ((class-name (class-name (class-of struct)))
37            (pointer (null-pointer)))
38        (if new-struct
39            (setf pointer (new-struct class-name))
40            (progn
41              (setf (slot-value struct 'value) nil
42                    (slot-value struct 'free-after) nil)))
43        (mapc
44         (lambda (field)
45           (let ((val (getf initargs (alexandria:make-keyword field))))
46             (if new-struct
47                 (setf (foreign-slot-value pointer
48                                           (struct-type class-name) field) val)
49                 (setf (getf (slot-value struct 'value) field) val))))
50         (foreign-slot-names (struct-type class-name)))
51        pointer))
52    
53  (defun pair (maybe-pair)  (defun pair (maybe-pair)
54    (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))    (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))
# Line 51  or may be cons (class-name . struct-name Line 68  or may be cons (class-name . struct-name
68                  (if (slot-boundp ,class-name 'value)                  (if (slot-boundp ,class-name 'value)
69                      (getf (slot-value ,class-name 'value) ',x)                      (getf (slot-value ,class-name 'value) ',x)
70                      (foreign-slot-value (pointer ,class-name)                      (foreign-slot-value (pointer ,class-name)
71                                          '(:struct ,struct-name) ',x)))                                          ',(struct-type struct-name) ',x)))
72                (unless (fboundp '(setf ,x))                (unless (fboundp '(setf ,x))
73                  (defgeneric (setf ,x) (val ,class-name)))                  (defgeneric (setf ,x) (val ,class-name)))
74                (defmethod (setf ,x) (val (,class-name ,class-name))                (defmethod (setf ,x) (val (,class-name ,class-name))
75                  (if (slot-boundp ,class-name 'value)                  (if (slot-boundp ,class-name 'value)
76                      (setf (getf (slot-value ,class-name 'value) ',x) val)                      (setf (getf (slot-value ,class-name 'value) ',x) val)
77                      (setf (foreign-slot-value (pointer ,class-name)                      (setf (foreign-slot-value (pointer ,class-name)
78                                                '(:struct ,struct-name) ',x)                                                ',(struct-type struct-name) ',x)
79                            val)))                            val)))
80                (save-setter ,class-name ,x)))                (save-setter ,class-name ,x)))
81            (foreign-slot-names `(:struct ,struct-name))))))            (foreign-slot-names (struct-type struct-name))))))
82    
83  (defmacro defbitaccessors (class slot &rest fields)  (defmacro defbitaccessors (class slot &rest fields)
84    (let ((pos 0))    (let ((pos 0))
# Line 96  or may be cons (class-name . struct-name Line 113  or may be cons (class-name . struct-name
113      (mapc (lambda (slot)      (mapc (lambda (slot)
114              (let ((val (getf (slot-value object 'value) slot default)))              (let ((val (getf (slot-value object 'value) slot default)))
115                (unless (eq val default)                (unless (eq val default)
116                  (setf (foreign-slot-value struct (list :struct class) slot)                  (setf (foreign-slot-value struct (struct-type class) slot)
117                        val))))                        val))))
118            (foreign-slot-names (list :struct class)))))            (foreign-slot-names (struct-type class)))))
119    
120  (defun clos->new-struct (class object)  (defun clos->new-struct (class object)
121    (if (slot-boundp object 'value)    (if (slot-boundp object 'value)
122        (let ((res (new-struct class)))        ;; use make-instance, not new-struct, because gconstructor
123          (clos->struct class object res)        ;;                                            may be redefined
124          res)        (let ((res (make-instance class :new-struct t)))
125            (clos->struct class object (pointer res))
126            (pointer res))
127        (pointer object)))        (pointer object)))
128    
129  (defun struct->clos (class struct &optional object)  (defun struct->clos (class struct &optional object)
# Line 120  Only exception is the presence of OBJECT Line 139  Only exception is the presence of OBJECT
139            (progn            (progn
140              (setf (slot-value %object 'value) nil)              (setf (slot-value %object 'value) nil)
141              (unless (null-pointer-p struct)              (unless (null-pointer-p struct)
142                (dolist (slot (foreign-slot-names (list :struct class)))                (dolist (slot (foreign-slot-names (struct-type class)))
143                  (setf (getf (slot-value %object 'value) slot)                  (setf (getf (slot-value %object 'value) slot)
144                        (foreign-slot-value struct (list :struct class) slot)))))                        (foreign-slot-value struct (struct-type class) slot)))))
145            (setf (pointer %object) struct))            (setf (pointer %object) struct))
146        %object)))        %object)))
147    
# Line 141  Only exception is the presence of OBJECT Line 160  Only exception is the presence of OBJECT
160    
161  (defmethod foreign-type-size ((type cffi-struct))  (defmethod foreign-type-size ((type cffi-struct))
162    "Return the size in bytes of a foreign typedef."    "Return the size in bytes of a foreign typedef."
163    (foreign-type-size (list :struct (object-class type))))    (foreign-type-size (struct-type (object-class type))))
164    
165  (define-parse-method struct (class &rest rest)  (define-parse-method struct (class &rest rest)
166    (apply #'make-instance 'cffi-struct :class class rest))    (apply #'make-instance 'cffi-struct :class class rest))
# Line 179  Only exception is the presence of OBJECT Line 198  Only exception is the presence of OBJECT
198  (defun struct-p (type)  (defun struct-p (type)
199    (and (consp type) (eq (car type) 'struct)))    (and (consp type) (eq (car type) 'struct)))
200    
201    (defun ptr-struct (ptr type i)
202      (inc-pointer ptr (* i (foreign-type-size type))))
203    
204  (defun from-foreign (var type count)  (defun from-foreign (var type count)
205    "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"    "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"
206    (if count    (if count
# Line 186  Only exception is the presence of OBJECT Line 208  Only exception is the presence of OBJECT
208          (if (struct-p type)          (if (struct-p type)
209              (dotimes (i count)              (dotimes (i count)
210                (setf (aref res i)                (setf (aref res i)
211                      (convert-from-foreign (mem-aptr var type i) type)))                      (convert-from-foreign (ptr-struct var type i) type)))
212              (dotimes (i count)              (dotimes (i count)
213                (setf (aref res i)                (setf (aref res i)
214                      (mem-aref var type i))))                      (mem-aref var type i))))

Legend:
Removed from v.13  
changed lines
  Added in v.16

  ViewVC Help
Powered by ViewVC 1.1.5