Skip to content

Commit

Permalink
Support CFFI pointer types whose element types are unspecified (#2)
Browse files Browse the repository at this point in the history
  • Loading branch information
@bohonghuang
bohonghuang committed May 23, 2024
1 parent 7862084 commit 85785b6
Show file tree
Hide file tree
Showing 5 changed files with 32 additions and 9 deletions.
8 changes: 4 additions & 4 deletions defcfun.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,7 +5,7 @@

(defun cffi-object-type-p (type)
(when-let ((type (cffi-pointer-type-p type)))
(and (typep (setf type (cffi::ensure-parsed-base-type (cffi::pointer-type type))) 'cffi::foreign-struct-type) type)))
(and (typep (setf type (cffi::ensure-parsed-base-type (cffi-pointer-type type))) 'cffi::foreign-struct-type) type)))

(defparameter *return-argument-names* '(#:%%claw-result-))

Expand Down Expand Up @@ -80,7 +80,7 @@
:collect `(push (cons nil (compose (lambda (,body) `(let ((,(assoc-value ,temp-vars ',name) ,,name)) . ,,body)) #'list)) ,dynamic-extent-forms))
(nreversef ,dynamic-extent-forms)
(lambda (,(caar args) ,body)
`(cffi:with-foreign-object (,,(caar args) ',',(cffi::pointer-type (cffi::ensure-parsed-base-type (cadar args))))
`(cffi:with-foreign-object (,,(caar args) ',',(cffi-pointer-type (cffi::ensure-parsed-base-type (cadar args))))
,(reduce #'funcall ,(if *optimize-out-temporary-object-p*
`(loop :for (,name . ,form) :in ,dynamic-extent-forms
:if ,name
Expand Down Expand Up @@ -122,8 +122,8 @@
(return-pointer-from-result-p `(pointer-cpointer ,result ',(or (ignore-some-conditions (cobject-class-definition-not-found-error)
(cobject-class-definition-class
(find-cobject-class-definition
(cffi::pointer-type return-pointer-from-result-p))))
(cffi::name (cffi::pointer-type return-pointer-from-result-p)))))
(cffi-pointer-type return-pointer-from-result-p))))
(cffi::name (cffi-pointer-type return-pointer-from-result-p)))))
(t result))))))
`(progn
(defun ,symbol ,(mapcar #'car args)
Expand Down
4 changes: 2 additions & 2 deletions definition.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -99,9 +99,9 @@
(cffi::foreign-string-type 'string)
(cffi::foreign-array-type
`(carray ,(cobject-class-definition-class
(find-cobject-class-definition (cffi::ensure-parsed-base-type (cffi::element-type type))))
(find-cobject-class-definition (cffi::ensure-parsed-base-type (cffi-element-type type))))
,(cffi::dimensions type)))
(cffi::foreign-pointer-type
`(cpointer ,(cobject-class-definition-class
(find-cobject-class-definition (cffi::ensure-parsed-base-type (cffi::pointer-type type))))))
(find-cobject-class-definition (cffi::ensure-parsed-base-type (cffi-pointer-type type))))))
(t (error 'cobject-class-definition-not-found-error :type type))))))))
6 changes: 3 additions & 3 deletions macros.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -91,15 +91,15 @@
:element-type ',(cobject-class-definition-class
(find-cobject-class-definition
(cffi::ensure-parsed-base-type
(cffi::element-type slot-type))))))
(cffi-element-type slot-type))))))
(cffi::foreign-pointer-type
`(%make-cpointer
:pointer ,slot-value
:shared-from ,instance
:element-type ',(cobject-class-definition-class
(find-cobject-class-definition
(cffi::ensure-parsed-base-type
(cffi::pointer-type slot-type))))))
(cffi-pointer-type slot-type))))))
(t slot-value))))
(etypecase slot
(cffi::aggregate-struct-slot
Expand Down Expand Up @@ -236,7 +236,7 @@
(when (typep (cffi::actual-type type) 'cffi::foreign-struct-type)
(push `(define-type-cobject-class (,name ,type)) definitions)))
(cffi::foreign-pointer-type
(push-definition (cffi::pointer-type type)))
(push-definition (cffi-pointer-type type)))
(cffi::foreign-struct-type
(mapc (compose #'push-definition #'cffi::parse-type #'cffi::slot-type)
(hash-table-values (cffi::slots type)))
Expand Down
18 changes: 18 additions & 0 deletions test/package.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -364,3 +364,21 @@
(of-type carray (aggregate-struct-c *aggregate-struct*))
(is equal '(unsigned-byte 8) (carray-element-type (aggregate-struct-b *aggregate-struct*)))
(is carray-equal (make-carray 2 :element-type '(unsigned-byte 8) :initial-contents '(2 3)) (aggregate-struct-c *aggregate-struct*))))

(defcstruct void-pointer-struct
(a :pointer)
(b (:pointer :pointer))
(c (:pointer :void))
(d (:pointer (:pointer :void))))

(define-cobject-class (:struct void-pointer-struct))

(define-test void-pointer :parent suite
(let* ((carray (make-carray 1 :element-type '(unsigned-byte 32) :initial-contents '(123456)))
(cpointer (make-carray 1 :element-type '(cpointer (unsigned-byte 32)) :initial-contents (list carray))))
(is = 123456 (cref (cref cpointer)))
(let ((struct (make-void-pointer-struct :a carray :b cpointer :c carray :d cpointer)))
(is = 123456 (cref (pointer-cpointer (cobject-pointer (void-pointer-struct-a struct)) '(unsigned-byte 32))))
(is = 123456 (cref (cref (pointer-cpointer (cobject-pointer (void-pointer-struct-b struct)) '(cpointer (unsigned-byte 32))))))
(is = 123456 (cref (pointer-cpointer (cobject-pointer (void-pointer-struct-c struct)) '(unsigned-byte 32))))
(is = 123456 (cref (cref (pointer-cpointer (cobject-pointer (void-pointer-struct-d struct)) '(cpointer (unsigned-byte 32)))))))))
5 changes: 5 additions & 0 deletions type.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -38,3 +38,8 @@
(or (type= type1 type2)
(and (symbolp type1) (symbolp type2)
(eql (find-class type1 nil) (find-class type2 nil))))))

(setf (fdefinition 'cffi-element-type) (fdefinition 'cffi::element-type))

(defun cffi-pointer-type (type)
(or (cffi::pointer-type type) :void))

0 comments on commit 85785b6

Please sign in to comment.