Some semi-useful implementation notes of GBoxed

diff --git a/gboxed b/gboxed
new file mode 100644 (file)
index 0000000..f1f483c
--- /dev/null
+++ b/gboxed
@@ -0,0 +1,106 @@
+1) GBoxed - это структуры, у которых нет идентичности
+2) При передаче ссылок, ссылки всегда имеют ограниченное время действия
+3) Структуры могут быть открытыми и закрытыми (opaque)
+
+Основной критерий: лисповский код не должен заботиться о владении структурами. Идентичности нет.
+
+Следствия:
+1) Все GBoxed, созданные в лиспе, удаляются только лиспом (при необходимости делается копия)
+2) Если foreign-функции возвращают GBoxed, то им владеет лисп (при необходимости делается копия)
+3) В callback'и возможна передача по ссылке (в том случае, если не знаем, как присвоить значение исходной структуре);
+в этом случае после выхода из callback'а лисповский прокси помечается как невалидный и операции с ним приводят к исключению
+
+Для реализации надо, чтобы CFFI позволяло совершать действия по очистке в конце callback'а.
+
+Код:
+
+(defclass g-boxed-type ()
+  ((g-type-designator :initarg :g-type
+                      :initform ":G-TYPE must be specified"
+                      :accessor g-boxed-type-type)))
+
+;;Some terminology:
+;; * native structure - a C structure in foreign memory that
+;; has the data and is expected to be passed/received by foreign functions
+;; * proxy - a Lisp object (class or a structure) that is
+;; equivalent to native structure (has the same data in it). Its lifetime is indefinite
+;; and it is not affected by foreign code.
+;; A proxy may (but not required to) contain pointer to its own copy of a
+;; native structure.
+;; * reference proxy - a proxy that is whose lifetime is equal to a duration
+;; of a callback. Reference proxies can only be used during a callback that created them.
+
+;(defgeneric create-proxy (type)
+;  "Creates a new proxy of a specified TYPE.")
+
+(defgeneric create-proxy-for-native (type native-ptr)
+  (:documentation "Creates a proxy that is initialized by data contained in native
+structured pointed to by NATIVE-PTR.
+
+Created proxy should not be linked to NATIVE-PTR and should have
+indefinite lifetime (until garbage collector collects it). Specifically,
+if proxy need a pointer to native structure, it should make a copy of
+a structure.
+
+If proxy requires finalization, finalizers should be added."))
+
+(defgeneric create-temporary-native (type proxy)
+  (:documentation "Creates a native structure (or passes a pointer to copy contained in PROXY)
+that contains the same data that the PROXY contains and returns a pointer to it.
+
+This call is always paired by call to FREE-TEMPORARY-NATIVE and calls may be nested."))
+
+(defgeneric free-temporary-native (type proxy native-ptr)
+  (:documentation "Frees the native structure that was previously created
+by CREATE-TEMPORARY-NATIVE for the same PROXY.
+
+Also reads data from native structure pointer to by NATIVE-PTR
+and sets the PROXY to contain the same data.
+
+This call is always paired by call to CREATE-TEMPORARY-NATIVE and calls may be nested."))
+
+(defgeneric create-reference-proxy (type native-ptr)
+  (:documentation "Creates a reference proxy for a native structure pointed to by NATIVE-PTR.
+
+Reference proxy's lifetime is bound to duration of a callback. When the
+callback returns the reference proxy is declared invalid and operations on it are errors.
+
+This call is always paired by call to FREE-REFERENCE-PROXY and calls will not nest."))
+
+(defgeneric free-reference-proxy (type proxy native-ptr)
+  (:documentation "Frees a reference proxy PROXY previously created by call to
+CREATE-REFERENCE-PROXY. This call should ensure that all changes on PROXY are
+reflected in native structure pointed to by NATIVE-PTR.
+
+After a call to FREE-REFERENCE-PROXY, PROXY is declared invalid and using it is an error,
+operations on it should signal erros.
+
+This call is always paired by call to CREATE-REFERENCE-PROXY."))
+
+(define-foreign-type g-boxed-foreign ()
+  ((g-type :initarg :g-type
+           :initform (error ":G-TYPE must be specified")
+           :reader g-boxed-foreign-g-type)
+   (pass-type :initarg :pass-type
+              :reader g-boxed-foreign-g-type
+              :type (member :callback :normal)
+              :initform :normal))
+  (:actual-type :pointer))
+
+(defun g-boxed-foreign->boxed-type (type)
+  nil)
+
+(defmethod translate-to-foreign (proxy (type g-boxed-foreign))
+  (let* ((boxed-type (g-boxed-foreign->boxed-type type))
+         (native-ptr (create-temporary-native boxed-type proxy)))
+    (values native-ptr proxy)))
+
+(defmethod free-translated-object (native-ptr (type g-boxed-foreign) proxy)
+  (let ((boxed-type (g-boxed-foreign->boxed-type type)))
+    (free-temporary-native boxed-type proxy native-ptr)))
+
+(defmethod translate-from-foreign (native-ptr (type g-boxed-foreign))
+  (let ((boxed-type (g-boxed-foreign->boxed-type type)))
+    (ecase )
+    (create-proxy-for-native boxed-type native-ptr)))
+

diff --git a/test.boxed-ng.lisp b/test.boxed-ng.lisp
new file mode 100644 (file)
index 0000000..d8f716c
--- /dev/null
+++ b/test.boxed-ng.lisp
@@ -0,0 +1,84 @@
+(in-package :gobject)
+
+(define-g-boxed-cstruct rectangle "GdkRectangle"
+  (left :int :initform 0)
+  (top :int :initform 0)
+  (width :int :initform 0)
+  (height :int :initform 0))
+
+(at-init () (eval (type-initializer-call "gdk_rectangle_get_type")))
+
+(define-g-boxed-cstruct point nil
+  (x :int :initform 0)
+  (y :int :initform 0))
+
+(defun mem-copy (source destination count)
+  (iter (for i from 0 below count)
+        (setf (mem-aref destination :uchar i)
+              (mem-aref source :uchar i))))
+
+(defmethod boxed-copy-fn ((type-info (eql (get 'point 'g-boxed-foreign-info))) native)
+  (let ((native-copy (foreign-alloc (generated-cstruct-name (g-boxed-info-name type-info)))))
+    (mem-copy native native-copy (foreign-type-size (generated-cstruct-name (g-boxed-info-name type-info))))
+    native-copy))
+
+(defmethod boxed-free-fn ((type-info (eql (get 'point 'g-boxed-foreign-info))) native)
+  (foreign-free native))
+
+(defcallback make-rect-cb (g-boxed-foreign rectangle :return)
+    ((a (g-boxed-foreign point)) (b (g-boxed-foreign point)))
+  (make-rectangle :left (min (point-x a) (point-x b))
+                  :top (min (point-y a) (point-y b))
+                  :width (abs (- (point-x a) (point-x b)))
+                  :height (abs (- (point-y a) (point-y b)))))
+
+(defun call-make-rect-cb (a b)
+  (foreign-funcall-pointer (callback make-rect-cb) ()
+                           (g-boxed-foreign point) a
+                           (g-boxed-foreign point) b
+                           (g-boxed-foreign rectangle :return)))
+
+(define-g-boxed-cstruct vector4 nil
+  (coords :double :count 4 :initform (vector 0d0 0d0 0d0 0d0)))
+
+(define-g-boxed-cstruct segment nil
+  (a point :inline t :initform (make-point))
+  (b point :inline t :initform (make-point)))
+
+(define-g-boxed-variant-cstruct var-segment nil
+  (deep :boolean :initform t)
+  (a point :inline t :initform (make-point))
+  (b point :inline t :initform (make-point))
+  (:variant deep
+            (t deep-segment
+               (depth point :inline t :initform (make-point)))))
+
+(define-g-boxed-variant-cstruct event nil
+  (type :int :initform 0)
+  (time :int :initform 0)
+  (:variant type
+            (0 zero-event
+               (x :int :initform 0))
+            (1 one-event
+               (x :double :initform 0.0d0))
+            (2 three-event
+               (three-type :int :initform 0)
+               (:variant three-type
+                         (1 three-one-event
+                            (y :uchar :initform 0))
+                         (2 three-two-event
+                            (z :double :initform 0.0d0))
+                         (3 segment-event
+                            (segment segment :inline t :initform (make-segment)))))))
+
+(defcallback copy-event-cb (g-boxed-foreign event :return)
+    ((event (g-boxed-foreign event)))
+  (let ((new-event (copy-event event)))
+    (incf (event-time new-event) (random 100))
+    new-event))
+
+(defun call-copy-event (e)
+  (foreign-funcall-pointer (callback copy-event-cb) ()
+                           (g-boxed-foreign event) e
+                           (g-boxed-foreign event :return)))
+