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

Diff of /struct.lisp

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

revision 15 by rklochkov, Tue Dec 25 01:10:43 2012 UTC revision 17 by rklochkov, Mon Dec 31 13:35:32 2012 UTC
# 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    (if (find-symbol "MEM-APTR" "CFFI") ;; new cffi
29        (defun struct-type (type)
30          (list :struct type))
31        (defun struct-type (type)
32          type))
33    
34  (defmethod gconstructor ((struct struct) &rest initargs  (defmethod gconstructor ((struct struct) &rest initargs
35                           &key new-struct &allow-other-keys)                           &key new-struct &allow-other-keys)
36    (let ((class-name (class-name (class-of struct)))    (let ((class-name (class-name (class-of struct)))
# Line 36  Struct may be used in OBJECT cffi-type o Line 42  Struct may be used in OBJECT cffi-type o
42                  (slot-value struct 'free-after) nil)))                  (slot-value struct 'free-after) nil)))
43      (mapc      (mapc
44       (lambda (field)       (lambda (field)
45         (let ((val (getf initargs (alexandria:make-keyword field))))         (let ((val (getf initargs (alexandria:make-keyword field) :default)))
46           (if new-struct           (unless (eq val :default)
47               (setf (foreign-slot-value pointer             (if new-struct
48                                         (list :struct class-name) field) val)                 (setf (foreign-slot-value pointer
49               (setf (getf (slot-value struct 'value) field) val))))                                           (struct-type class-name) field) val)
50       (foreign-slot-names (list :struct class-name)))                 (setf (getf (slot-value struct 'value) field) val)))))
51         (foreign-slot-names (struct-type class-name)))
52      pointer))      pointer))
53    
54  (defun pair (maybe-pair)  (defun pair (maybe-pair)
# Line 62  or may be cons (class-name . struct-name Line 69  or may be cons (class-name . struct-name
69                  (if (slot-boundp ,class-name 'value)                  (if (slot-boundp ,class-name 'value)
70                      (getf (slot-value ,class-name 'value) ',x)                      (getf (slot-value ,class-name 'value) ',x)
71                      (foreign-slot-value (pointer ,class-name)                      (foreign-slot-value (pointer ,class-name)
72                                          '(:struct ,struct-name) ',x)))                                          ',(struct-type struct-name) ',x)))
73                (unless (fboundp '(setf ,x))                (unless (fboundp '(setf ,x))
74                  (defgeneric (setf ,x) (val ,class-name)))                  (defgeneric (setf ,x) (val ,class-name)))
75                (defmethod (setf ,x) (val (,class-name ,class-name))                (defmethod (setf ,x) (val (,class-name ,class-name))
76                  (if (slot-boundp ,class-name 'value)                  (if (slot-boundp ,class-name 'value)
77                      (setf (getf (slot-value ,class-name 'value) ',x) val)                      (setf (getf (slot-value ,class-name 'value) ',x) val)
78                      (setf (foreign-slot-value (pointer ,class-name)                      (setf (foreign-slot-value (pointer ,class-name)
79                                                '(:struct ,struct-name) ',x)                                                ',(struct-type struct-name) ',x)
80                            val)))                            val)))
81                (save-setter ,class-name ,x)))                (save-setter ,class-name ,x)))
82            (foreign-slot-names `(:struct ,struct-name))))))            (foreign-slot-names (struct-type struct-name))))))
83    
84  (defmacro defbitaccessors (class slot &rest fields)  (defmacro defbitaccessors (class slot &rest fields)
85    (let ((pos 0))    (let ((pos 0))
# Line 94  or may be cons (class-name . struct-name Line 101  or may be cons (class-name . struct-name
101                   (incf pos size)))))                   (incf pos size)))))
102        (cons 'progn (mapcar #'build-field fields)))))        (cons 'progn (mapcar #'build-field fields)))))
103    
104    (defun parse-struct (body)
105      (mapcar (lambda (str)
106                (if (stringp str) str
107                    (let ((str2 (second str)))
108                      (if (and (consp str2) (eq (car str2) :struct))
109                          (list (first str) (struct-type (second str2)))
110                          str))))
111              body))
112    
113  (defmacro defcstruct* (class &body body)  (defmacro defcstruct* (class &body body)
114    `(progn    `(progn
115       (defclass ,class (struct) ())       (defclass ,class (struct) ())
116       (defcstruct ,class ,@body)       (defcstruct ,class ,@(parse-struct body))
117       (defcstruct-accessors ,class)       (defcstruct-accessors ,class)
118       (init-slots ,class)))       (init-slots ,class)))
119    
# Line 107  or may be cons (class-name . struct-name Line 122  or may be cons (class-name . struct-name
122      (mapc (lambda (slot)      (mapc (lambda (slot)
123              (let ((val (getf (slot-value object 'value) slot default)))              (let ((val (getf (slot-value object 'value) slot default)))
124                (unless (eq val default)                (unless (eq val default)
125                  (setf (foreign-slot-value struct (list :struct class) slot)                  (setf (foreign-slot-value struct (struct-type class) slot)
126                        val))))                        val))))
127            (foreign-slot-names (list :struct class)))))            (foreign-slot-names (struct-type class)))))
128    
129  (defun clos->new-struct (class object)  (defun clos->new-struct (class object)
130    (if (slot-boundp object 'value)    (if (slot-boundp object 'value)
131        ;; use make-instance, not new-struct, because gconstructor        ;; use make-instance, not new-struct, because gconstructor
132        ;;                                            may be redefined        ;;                                            may be redefined
133        (let ((res (make-instance class :new-struct t)))        (let ((res (make-instance class :new-struct t :free-after nil)))
134          (clos->struct class object (pointer res))          (clos->struct class object (pointer res))
135          (pointer res))          (pointer res))
136        (pointer object)))        (pointer object)))
# Line 133  Only exception is the presence of OBJECT Line 148  Only exception is the presence of OBJECT
148            (progn            (progn
149              (setf (slot-value %object 'value) nil)              (setf (slot-value %object 'value) nil)
150              (unless (null-pointer-p struct)              (unless (null-pointer-p struct)
151                (dolist (slot (foreign-slot-names (list :struct class)))                (dolist (slot (foreign-slot-names (struct-type class)))
152                  (setf (getf (slot-value %object 'value) slot)                  (setf (getf (slot-value %object 'value) slot)
153                        (foreign-slot-value struct (list :struct class) slot)))))                        (foreign-slot-value struct (struct-type class) slot)))))
154            (setf (pointer %object) struct))            (setf (pointer %object) struct))
155        %object)))        %object)))
156    
# Line 154  Only exception is the presence of OBJECT Line 169  Only exception is the presence of OBJECT
169    
170  (defmethod foreign-type-size ((type cffi-struct))  (defmethod foreign-type-size ((type cffi-struct))
171    "Return the size in bytes of a foreign typedef."    "Return the size in bytes of a foreign typedef."
172    (foreign-type-size (list :struct (object-class type))))    (foreign-type-size (struct-type (object-class type))))
173    
174  (define-parse-method struct (class &rest rest)  (define-parse-method struct (class &rest rest)
175    (apply #'make-instance 'cffi-struct :class class rest))    (apply #'make-instance 'cffi-struct :class class rest))
# Line 192  Only exception is the presence of OBJECT Line 207  Only exception is the presence of OBJECT
207  (defun struct-p (type)  (defun struct-p (type)
208    (and (consp type) (eq (car type) 'struct)))    (and (consp type) (eq (car type) 'struct)))
209    
210    (defun ptr-struct (ptr type i)
211      (inc-pointer ptr (* i (foreign-type-size type))))
212    
213  (defun from-foreign (var type count)  (defun from-foreign (var type count)
214    "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"    "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"
215    (if count    (if count
# Line 199  Only exception is the presence of OBJECT Line 217  Only exception is the presence of OBJECT
217          (if (struct-p type)          (if (struct-p type)
218              (dotimes (i count)              (dotimes (i count)
219                (setf (aref res i)                (setf (aref res i)
220                      (convert-from-foreign (mem-aptr var type i) type)))                      (convert-from-foreign (ptr-struct var type i) type)))
221              (dotimes (i count)              (dotimes (i count)
222                (setf (aref res i)                (setf (aref res i)
223                      (mem-aref var type i))))                      (mem-aref var type i))))

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

  ViewVC Help
Powered by ViewVC 1.1.5