diff --git a/src/enum.lisp b/src/enum.lisp index 81ba310..b24ce6f 100644 --- a/src/enum.lisp +++ b/src/enum.lisp @@ -13,6 +13,7 @@ (defmethod shared-initialize :after ((enum-desc enum-desc) slot-names &key enum-info) (declare (ignore slot-names)) + (when enum-info (with-slots (name values-dict methods-dict) enum-desc (setf name @@ -26,7 +27,7 @@ (iter (for i below (g-enum-info-get-n-methods enum-info)) (let ((func-info (g-enum-info-get-method enum-info i))) (collect (cons (info-get-name func-info) - (build-function func-info)))))))) + (build-function func-info))))))))) (defmethod build-interface-desc ((enum-info enum-info)) (make-instance 'enum-desc :enum-info enum-info)) diff --git a/src/ffi.lisp b/src/ffi.lisp index 7590844..ed88d92 100644 --- a/src/ffi.lisp +++ b/src/ffi.lisp @@ -67,9 +67,10 @@ (defmethod shared-initialize :after ((namespace namespace) slot-names &key name version) (declare (ignore slot-names)) - (repository-require nil name (if version version (cffi:null-pointer))) - (setf (slot-value namespace 'version) - (repository-get-version nil name))) + (when name ;don't handle calls from make-instances-obsolete + (repository-require nil name (if version version (cffi:null-pointer))) + (setf (slot-value namespace 'version) + (repository-get-version nil name)))) (defmethod nsget ((namespace namespace) name) (let ((cname (c-name name))) diff --git a/src/function.lisp b/src/function.lisp index a553818..7b83905 100644 --- a/src/function.lisp +++ b/src/function.lisp @@ -80,6 +80,7 @@ :initform nil :type boolean))) (defmethod initialize-copy ((obj freeable-type) (copy freeable-type)) + (when (next-method-p) (call-next-method)) (copy-slots ((free-from-foreign free-to-foreign)) (obj copy))) (defgeneric mem-size (type)) @@ -93,7 +94,9 @@ (defmethod alloc-foreign (type &key (initial-value nil initial-value-p)) (let* ((size (mem-size type)) - (pos (cffi:foreign-alloc :uint8 :count size))) + (pos (if initial-value-p + (cffi:foreign-alloc :uint8 :count size) + (cffi:foreign-alloc :uint8 :count size :initial-element 0)))) (when initial-value-p (mem-set pos initial-value type)) pos)) @@ -367,6 +370,9 @@ (defclass struct-type (interface-type) ()) +(defmethod mem-alloc (pos (struct-type struct-type)) + (setf (cffi:mem-ref pos :pointer) (alloc-foreign struct-type))) + (defmethod free-from-foreign-aggregated-p ((struct-type struct-type)) (declare (ignore struct-type))) @@ -394,6 +400,9 @@ (defclass union-type () ((size :initarg :size))) +(defmethod mem-alloc (pos (union-type union-type)) + (setf (cffi:mem-ref pos :pointer) (alloc-foreign union-type))) + (defmethod free-from-foreign-aggregated-p ((union-type union-type)) (declare (ignore union-type))) @@ -685,34 +694,34 @@ (direction :reader direction-of) (for-array-length-p :initform nil :accessor for-array-length-p-of) (array-length :reader array-length-of) - (ugly-offset :initform nil :accessor ugly-offset) (caller-allocates) (transfer))) (defmethod shared-initialize :after ((arg-data arg-data) slot-names &key arg-info) - (with-slots (name type is-array-type direction - array-length caller-allocates) - arg-data - (case arg-info - (:object-argument - (setf name :this - type (make-object/struct-pointer-type) - caller-allocates nil - direction :in - is-array-type nil - array-length nil)) - (otherwise - (let ((type-info (arg-info-get-type arg-info)) - (transfer (arg-info-get-ownership-transfer arg-info))) - (setf name (info-get-name arg-info) - caller-allocates (arg-info-is-caller-allocates arg-info) - type (build-argument-type type-info transfer - :force-pointer caller-allocates) - direction (arg-info-get-direction arg-info) - is-array-type - (find-object-with-class type (find-class 'c-array-type)) - array-length (get-array-length type-info))))))) + (when arg-info ;don't handle calls from make-instances-obsolete + (with-slots (name type is-array-type direction + array-length caller-allocates) + arg-data + (case arg-info + (:object-argument + (setf name :this + type (make-object/struct-pointer-type) + caller-allocates nil + direction :in + is-array-type nil + array-length nil)) + (otherwise + (let ((type-info (arg-info-get-type arg-info)) + (transfer (arg-info-get-ownership-transfer arg-info))) + (setf name (info-get-name arg-info) + caller-allocates (arg-info-is-caller-allocates arg-info) + type (build-argument-type type-info transfer + :force-pointer caller-allocates) + direction (arg-info-get-direction arg-info) + is-array-type + (find-object-with-class type (find-class 'c-array-type)) + array-length (get-array-length type-info)))))))) (let ((o-a-d-cache (make-instance 'arg-data :arg-info :object-argument))) @@ -775,9 +784,10 @@ (setf giarg inp) (incf-giargs inp)) (:in-out - (setf giarg voutp) - (pointer->giarg inp voutp) - (pointer->giarg outp voutp) + (mem-alloc voutp type) + (setf giarg (cffi:mem-ref voutp :pointer)) + (pointer->giarg inp (cffi:mem-ref voutp :pointer)) + (pointer->giarg outp (cffi:mem-ref voutp :pointer)) (incf-giargs inp) (incf-giargs outp) (incf-giargs voutp)) @@ -800,12 +810,6 @@ :then (make-arg data inp outp voutp)) (collect arg))) -(defun ugly-nth (data array-length args) - (nth (if (ugly-offset data) - (1+ array-length) - array-length) - args)) - (defun arg-setup-length (arg args methodp) (with-slots (data length-arg) arg @@ -831,14 +835,16 @@ (defun out-arg->value (arg) (with-slots (data giarg length-arg) arg - (with-slots (type) + (with-slots (type direction) data (let ((real-type (if length-arg (copy-find-set-c-array-type-length type (out-arg->value length-arg)) type))) - (mem-get giarg real-type))))) + (prog1 (mem-get giarg real-type) + (when (and (eql direction :in-out)) + (mem-free giarg real-type))))))) (defun in-arg-clear (arg) (with-slots (data giarg length-arg (arg-value value)) @@ -850,8 +856,8 @@ (if is-array-type (copy-find-set-c-array-type-length type - (when length-arg (slot-value length-arg 'value))) - type))) + (length arg-value)) + type))) (mem-free giarg real-type)))))) (defun in/out-args (args) @@ -882,16 +888,17 @@ (defmethod shared-initialize :after ((return-data return-data) slot-names &key callable-info return-interface) - (with-slots (type array-length) - return-data - (let ((type-info (callable-info-get-return-type callable-info)) - (transfer (callable-info-get-caller-owns callable-info))) - (setf type - (if return-interface - (let ((intf-ptr-type (make-interface-pointer-type return-interface :everything))) - (make-instance 'argument-type :contained-type intf-ptr-type :field 'v-pointer)) - (build-argument-type type-info transfer)) - array-length (get-array-length type-info))))) + (when callable-info ;don't handle calls from make-instances-obsolete + (with-slots (type array-length) + return-data + (let ((type-info (callable-info-get-return-type callable-info)) + (transfer (callable-info-get-caller-owns callable-info))) + (setf type + (if return-interface + (let ((intf-ptr-type (make-interface-pointer-type return-interface :everything))) + (make-instance 'argument-type :contained-type intf-ptr-type :field 'v-pointer)) + (build-argument-type type-info transfer)) + array-length (get-array-length type-info)))))) (defclass return-value () ((data :initarg :data) @@ -1033,6 +1040,7 @@ #'c2mop:slot-definition-name (c2mop:class-slots (class-of arg))))) + (assert (not (find-method #'print-object '(:around) (list t t)))) (defmethod print-object :around (obj stream) (if (member (class-of obj) (mapcar 'find-class '(arg argument-type arg-data return-data return-value c-array-type pointer-type))) (print-unreadable-object (obj stream :type t :identity t) diff --git a/src/gvalue.lisp b/src/gvalue.lisp index 656e2a2..979681d 100644 --- a/src/gvalue.lisp +++ b/src/gvalue.lisp @@ -156,8 +156,8 @@ ((eq type +g-type-ulong+) (g-value-set-ulong gvalue (round value))) ((eq type +g-type-int64+) (g-value-set-int64 gvalue (round value))) ((eq type +g-type-uint64+) (g-value-set-uint64 gvalue (round value))) - ((eq type +g-type-enum+) (g-value-set-enum gvalue (ffi-enum value gtype))) - ((eq type +g-type-flags+) (g-value-set-flags gvalue (ffi-enum value gtype))) + ((eq type +g-type-enum+) (g-value-set-enum gvalue (ffi-enum value type))) + ((eq type +g-type-flags+) (g-value-set-flags gvalue (ffi-enum value type))) ((eq type +g-type-float+) (g-value-set-float gvalue (coerce value 'single-float))) ((eq type +g-type-double+) (g-value-set-double gvalue (coerce value 'double-float))) ((eq type +g-type-string+) (g-value-set-string gvalue value)) diff --git a/src/object.lisp b/src/object.lisp index 73acf92..a0aebd5 100644 --- a/src/object.lisp +++ b/src/object.lisp @@ -129,12 +129,53 @@ (cffi:defcfun g-object-ref :pointer (obj :pointer)) (cffi:defcfun g-object-unref :void (obj :pointer)) +;; ParamSpecs need special treatement during object creation because +;; GParamSpecs (and their kin) are not GObjects but are some strange +;; subtypes of GTypeClass. E.g. G_IS_OBJECT ( g_param_spec_int(...) +;; ) is FALSE. However g_base_info_get_type +;; (g_irepository_find_by_name (repository, "GObject", "ParamSpec")) +;; == GI_INFO_TYPE_OBJECT, and so cl-gir tries to call +;; `build-object-ptr' when it comes across it. The problem is that +;; since it is not an GObject, calling `g-object-is-floating' on it +;; will fail. The following code attempts to work around that problem +;; by having `object-setup-gc' detect that it is dealing with a +;; ParamSpec and choose a different code path which calls +;; `param-spec-setup-gc' + +;; given the above background perhaps the atrocious name +;; `g-object-is-param-spec' can be excused. also the call to +;; `g-type-fundamental' in this function makes object.lisp depend on +;; gvalue.lisp. note (%gtype :param) == 76 + +(defun g-object-is-param-spec (object) + (= (g-type-fundamental (gtype (this-of object))) 76)) + +(cffi:defcfun g-param-spec-ref :pointer (pspec :pointer)) +(cffi:defcfun g-param-spec-ref-sink :pointer (pspec :pointer)) +(cffi:defcfun g-param-spec-sink :void (pspec :pointer)) +(cffi:defcfun g-param-spec-unref :void (pspec :pointer)) + +(defun param-spec-setup-gc (object transfer) + (let* ((this (this-of object)) + (a (cffi:pointer-address this))) + (if (eq transfer :everything) ; a new ParamSpec is always floating + (g-param-spec-ref-sink this) + (g-param-spec-ref this)) + (tg:finalize this (lambda () (g-param-spec-unref (cffi:make-pointer a))))) + object) + + (defun object-setup-gc (object transfer) + (if (g-object-is-param-spec object) + (return-from object-setup-gc + (param-spec-setup-gc object transfer))) (let* ((this (this-of object)) (floating? (g-object-is-floating this)) (a (cffi:pointer-address this))) (if (eq transfer :everything) - (if floating? (g-object-ref-sink this)) + (if floating? + (g-object-ref-sink this) + (g-object-ref this)) (g-object-ref this)) (tg:finalize this (lambda () (g-object-unref (cffi:make-pointer a))))) object) @@ -174,17 +215,25 @@ :name (cffi:foreign-funcall "g_type_name" :ulong gtype :string))))))) +(defvar use-fake-objects nil) + (defun gobject (gtype ptr) - (let* ((info (repository-find-by-gtype nil gtype)) + (let* ((info (or (repository-find-by-gtype nil gtype) + (if (not use-fake-objects) + (some (lambda (gtype) + (repository-find-by-gtype nil gtype)) + (g-type-interfaces gtype))))) (info-type (and info (info-get-type info))) (object-class (if (null info) (find-fake-object-class gtype)))) (when object-class (return-from gobject (build-object-ptr object-class ptr))) - (if (member info-type '(:object :struct)) + (if (member info-type '(:object :struct :interface)) (let ((object-class (find-build-interface info))) (if (eq info-type :object) (build-object-ptr object-class ptr) - (build-struct-ptr object-class ptr))) + (if (eq info-type :interface) + (build-object-ptr object-class ptr) + (build-struct-ptr object-class ptr)))) (error "gtype ~a not found in GI. Found ~a" gtype info-type))))