/[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 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 102  or may be cons (class-name . struct-name Line 113  or may be cons (class-name . struct-name
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          (clos->struct class object res)        ;;                                            may be redefined
118          res)        (let ((res (make-instance class :new-struct t)))
119            (clos->struct class object (pointer res))
120            (pointer res))
121        (pointer object)))        (pointer object)))
122    
123  (defun struct->clos (class struct &optional object)  (defun struct->clos (class struct &optional object)

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

  ViewVC Help
Powered by ViewVC 1.1.5