Madhu critical fixes 2023 02 1

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))

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)))

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)

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))

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))))