/[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 18 by rklochkov, Sat Jan 12 21:26:46 2013 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) :default)))
46             (unless (eq val :default)
47               (if new-struct
48                   (setf (foreign-slot-value pointer
49                                             (struct-type class-name) field) val)
50                   (setf (getf (slot-value struct 'value) field) val)))))
51         (foreign-slot-names (struct-type class-name)))
52        pointer))
53    
54  (defun pair (maybe-pair)  (defun pair (maybe-pair)
55    (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))    (if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))
56    
57  (defmacro defcstruct-accessors (class)  (defun slot-accessor (designator)
58      (flet ((count-args (list)
59               (do ((list list (cdr list))
60                    (count 0 (1+ count)))
61                   ((or (null list)
62                        (char= (char (string (car list)) 0) #\&))
63                    count))))
64        (let ((lambda-list
65               (closer-mop:generic-function-lambda-list (fdefinition designator))))
66          (= (count-args lambda-list) (if (listp designator) 2 1)))))
67    
68    (defmacro defaccessor (name c-name class &body body)
69      #-message-oo (declare (ignore c-name))
70      (let ((val* (when (listp name) (list 'val))))
71        `(progn
72           (unless (fboundp ',name)
73             (defgeneric ,name (,@val* ,class)))
74           (if (slot-accessor ',name)
75               (defmethod ,name (,@val* (,class ,class))
76                 . ,body)
77               (warn 'style-warning
78                     "~a is not a slot accessor" ',name))
79           #+message-oo
80           ,(if val*
81                `(defmessage ,class (,(alexandria:format-symbol
82                                        :keyword "~A=" c-name)
83                                      val)
84                   . ,body)
85                `(defmessage ,class ,(alexandria:make-keyword c-name)
86                   . ,body)))))
87    
88    
89    (defmacro defcstruct-accessors (class &rest fields)
90    "CLASS may be symbol = class-name = struct name,    "CLASS may be symbol = class-name = struct name,
91  or may be cons (class-name . struct-name)"  or may be cons (class-name . struct-name)"
92    (destructuring-bind (class-name . struct-name) (pair class)    (destructuring-bind (class-name . struct-name) (pair class)
93      `(progn      `(progn
94         (clear-setters ,class-name)         (clear-setters ,class-name)
95         ,@(mapcar         ,@(mapcar
96            (lambda (x)            (lambda (field)
97             `(progn              (destructuring-bind (lisp-name . c-name) (pair field)
98                (unless (fboundp ',x)                `(progn
99                  (defgeneric ,x (,class-name)))                   (defaccessor ,lisp-name ,c-name ,class-name
100                (defmethod ,x ((,class-name ,class-name))                     (if (slot-boundp ,class-name 'value)
101                  (if (slot-boundp ,class-name 'value)                         (getf (slot-value ,class-name 'value) ',c-name)
102                      (getf (slot-value ,class-name 'value) ',x)                         (foreign-slot-value (pointer ,class-name)
103                      (foreign-slot-value (pointer ,class-name)                                             ',(struct-type struct-name)
104                                          '(:struct ,struct-name) ',x)))                                             ',c-name)))
105                (unless (fboundp '(setf ,x))                   (defaccessor (setf ,lisp-name) ,c-name ,class-name
106                  (defgeneric (setf ,x) (val ,class-name)))                     (if (slot-boundp ,class-name 'value)
107                (defmethod (setf ,x) (val (,class-name ,class-name))                         (setf (getf (slot-value ,class-name 'value)
108                  (if (slot-boundp ,class-name 'value)                                     ',c-name)
109                      (setf (getf (slot-value ,class-name 'value) ',x) val)                               val)
110                      (setf (foreign-slot-value (pointer ,class-name)                         (setf (foreign-slot-value
111                                                '(:struct ,struct-name) ',x)                                 (pointer ,class-name)
112                                   ',(struct-type struct-name) ',c-name)
113                            val)))                            val)))
114                (save-setter ,class-name ,x)))                (save-setter ,class-name ,lisp-name))))
115            (foreign-slot-names `(:struct ,struct-name))))))            (or (mapcan (lambda (field)
116                            (unless (stringp field) (list (car field))))
117                          fields)
118                  (foreign-slot-names (struct-type struct-name)))))))
119    
120  (defmacro defbitaccessors (class slot &rest fields)  (defmacro defbitaccessors (class slot &rest fields)
121    (let ((pos 0))    (let ((pos 0))
122      (flet ((build-field (field)      (flet ((build-field (field)
123               (destructuring-bind (name type size) field               (destructuring-bind (name type size) field
124                 (prog1                 (destructuring-bind (lisp-name . c-name) (pair name)
125                     `(progn                   (prog1
126                        (unless (fboundp ',name)                       `(progn
127                          (defgeneric ,name (,class)))                          (defaccessor ,lisp-name ,c-name ,class
128                        (defmethod ,name ((,class ,class))                              (convert-from-foreign
129                          (convert-from-foreign                               (ldb (byte ,size ,pos) (slot-value ,class ',slot))
130                           (ldb (byte ,size ,pos) (slot-value ,class ',slot))                               ,type))
131                           ,type))                          (defaccessor (setf ,lisp-name) ,c-name ,class
132                        (unless (fboundp '(setf ,name))                              (setf (ldb (byte ,size ,pos)
133                          (defgeneric (setf ,name) (value ,class)))                                         (slot-value ,class ',slot))
134                        (defmethod (setf ,name) (value (,class ,class))                                    (convert-to-foreign val ,type))))
135                          (setf (ldb (byte ,size ,pos) (slot-value ,class ',slot))                     (incf pos size))))))
                               (convert-to-foreign value ,type))))  
                  (incf pos size)))))  
136        (cons 'progn (mapcar #'build-field fields)))))        (cons 'progn (mapcar #'build-field fields)))))
137    
138    (defun parse-struct (body)
139      (flet ((struct? (type)
140               (and (consp type) (eq (car type) :struct)))
141             (cname (name)
142               (destructuring-bind (lisp-name . c-name) (pair name)
143                 (declare (ignore lisp-name))
144                 c-name)))
145        (mapcar (lambda (str)
146                  (if (stringp str) str
147                      (list*
148                       (cname (first str))
149                       (let ((type (second str)))
150                         (if (struct? type)
151                             (struct-type (second type))
152                             type))
153                       (cddr str))))
154                body)))
155    
156  (defmacro defcstruct* (class &body body)  (defmacro defcstruct* (class &body body)
157    `(progn    `(progn
158       (defclass ,class (struct) ())       (defclass ,class (struct) ())
159       (defcstruct ,class ,@body)       (defcstruct ,class ,@(parse-struct body))
160       (defcstruct-accessors ,class)       (defcstruct-accessors ,class)
161       (init-slots ,class)))       (init-slots ,class)))
162    
# Line 96  or may be cons (class-name . struct-name Line 165  or may be cons (class-name . struct-name
165      (mapc (lambda (slot)      (mapc (lambda (slot)
166              (let ((val (getf (slot-value object 'value) slot default)))              (let ((val (getf (slot-value object 'value) slot default)))
167                (unless (eq val default)                (unless (eq val default)
168                  (setf (foreign-slot-value struct (list :struct class) slot)                  (setf (foreign-slot-value struct (struct-type class) slot)
169                        val))))                        val))))
170            (foreign-slot-names (list :struct class)))))            (foreign-slot-names (struct-type class)))))
171    
172  (defun clos->new-struct (class object)  (defun clos->new-struct (class object)
173    (if (slot-boundp object 'value)    (if (slot-boundp object 'value)
174        (let ((res (new-struct class)))        ;; use make-instance, not new-struct, because gconstructor
175          (clos->struct class object res)        ;;                                            may be redefined
176          res)        (let ((res (make-instance class :new-struct t :free-after nil)))
177            (clos->struct class object (pointer res))
178            (pointer res))
179        (pointer object)))        (pointer object)))
180    
181  (defun struct->clos (class struct &optional object)  (defun struct->clos (class struct &optional object)
# Line 120  Only exception is the presence of OBJECT Line 191  Only exception is the presence of OBJECT
191            (progn            (progn
192              (setf (slot-value %object 'value) nil)              (setf (slot-value %object 'value) nil)
193              (unless (null-pointer-p struct)              (unless (null-pointer-p struct)
194                (dolist (slot (foreign-slot-names (list :struct class)))                (dolist (slot (foreign-slot-names (struct-type class)))
195                  (setf (getf (slot-value %object 'value) slot)                  (setf (getf (slot-value %object 'value) slot)
196                        (foreign-slot-value struct (list :struct class) slot)))))                        (foreign-slot-value struct (struct-type class) slot)))))
197            (setf (pointer %object) struct))            (setf (pointer %object) struct))
198        %object)))        %object)))
199    
# Line 141  Only exception is the presence of OBJECT Line 212  Only exception is the presence of OBJECT
212    
213  (defmethod foreign-type-size ((type cffi-struct))  (defmethod foreign-type-size ((type cffi-struct))
214    "Return the size in bytes of a foreign typedef."    "Return the size in bytes of a foreign typedef."
215    (foreign-type-size (list :struct (object-class type))))    (foreign-type-size (struct-type (object-class type))))
216    
217  (define-parse-method struct (class &rest rest)  (define-parse-method struct (class &rest rest)
218    (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 250  Only exception is the presence of OBJECT
250  (defun struct-p (type)  (defun struct-p (type)
251    (and (consp type) (eq (car type) 'struct)))    (and (consp type) (eq (car type) 'struct)))
252    
253    (defun ptr-struct (ptr type i)
254      (inc-pointer ptr (* i (foreign-type-size type))))
255    
256  (defun from-foreign (var type count)  (defun from-foreign (var type count)
257    "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"    "VAR - symbol; type - symbol or list -- CFFI type; count -- integer"
258    (if count    (if count
# Line 186  Only exception is the presence of OBJECT Line 260  Only exception is the presence of OBJECT
260          (if (struct-p type)          (if (struct-p type)
261              (dotimes (i count)              (dotimes (i count)
262                (setf (aref res i)                (setf (aref res i)
263                      (convert-from-foreign (mem-aptr var type i) type)))                      (convert-from-foreign (ptr-struct var type i) type)))
264              (dotimes (i count)              (dotimes (i count)
265                (setf (aref res i)                (setf (aref res i)
266                      (mem-aref var type i))))                      (mem-aref var type i))))

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

  ViewVC Help
Powered by ViewVC 1.1.5