From d2b671c59e17cbee173f4e118e7c40120128d91d Mon Sep 17 00:00:00 2001 From: Dmitry Kalyanov Date: Sat, 24 Oct 2009 21:31:47 +0400 Subject: [PATCH] Cleanup --- .gitignore | 1 + gboxed | 106 ------------- gboxed.test.lisp | 264 ------------------------------- gboxed.variant-struct.lisp | 70 --------- gboxed.vs.lisp | 164 -------------------- gboxed.vs.test.lisp | 26 ---- mm-test.lisp | 161 ------------------- subclass.lisp | 370 -------------------------------------------- subtest.lisp | 223 -------------------------- test.boxed-ng.lisp | 84 ---------- 10 files changed, 1 insertion(+), 1468 deletions(-) delete mode 100644 gboxed delete mode 100644 gboxed.test.lisp delete mode 100644 gboxed.variant-struct.lisp delete mode 100644 gboxed.vs.lisp delete mode 100644 gboxed.vs.test.lisp delete mode 100644 mm-test.lisp delete mode 100644 subclass.lisp delete mode 100644 subtest.lisp delete mode 100644 test.boxed-ng.lisp diff --git a/.gitignore b/.gitignore index e94f582..b2c9e1c 100644 --- a/.gitignore +++ b/.gitignore @@ -11,3 +11,4 @@ *.lib bugs/html/ *.lx64fsl +tmp diff --git a/gboxed b/gboxed deleted file mode 100644 index f1f483c..0000000 --- a/gboxed +++ /dev/null @@ -1,106 +0,0 @@ -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/gboxed.test.lisp b/gboxed.test.lisp deleted file mode 100644 index e2e56e3..0000000 --- a/gboxed.test.lisp +++ /dev/null @@ -1,264 +0,0 @@ -(in-package :gobject) - -(define-foreign-type g-boxed-foreign-type () - ((info :initarg :info - :accessor g-boxed-foreign-info - :initform (error "info must be specified")) - (free-from-foreign :initarg :free-from-foreign - :initform nil - :accessor g-boxed-foreign-free-from-foreign) - (free-to-foreign :initarg :free-to-foreign - :initform nil - :accessor g-boxed-foreign-free-to-foreign) - (for-callback :initarg :for-callback - :initform nil - :accessor g-boxed-foreign-for-callback)) - (:actual-type :pointer)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defstruct g-boxed-info - name - g-type)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun get-g-boxed-foreign-info (name) - (get name 'g-boxed-foreign-info))) - -(define-parse-method g-boxed-foreign (name &key free-from-foreign free-to-foreign for-callback) - (let ((info (get-g-boxed-foreign-info name))) - (assert info nil "Unknown foreign GBoxed type ~A" name) - (make-instance 'g-boxed-foreign-type - :info info - :free-from-foreign free-from-foreign - :free-to-foreign free-to-foreign - :for-callback for-callback))) - -(eval-when (:load-toplevel :compile-toplevel :execute) - (defstruct (g-boxed-cstruct-wrapper-info (:include g-boxed-info)) - cstruct - slots)) - -(defmacro define-g-boxed-cstruct (name cstruct-name g-type-name &body slots) - `(progn - (defstruct ,name - ,@(iter (for (name type &key initarg) in slots) - (collect (list name initarg)))) - (defcstruct ,cstruct-name - ,@(iter (for (name type &key initarg) in slots) - (collect `(,name ,type)))) - (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (get ',name 'g-boxed-foreign-info) - (make-g-boxed-cstruct-wrapper-info :name ',name - :g-type ,g-type-name - :cstruct ',cstruct-name - :slots ',(iter (for (name type &key initarg) in slots) - (collect name))))))) - -(define-g-boxed-cstruct gdk-rectangle gdk-rectangle-cstruct "GdkRectangle" - (x :int :initarg 0) - (y :int :initarg 0) - (width :int :initarg 0) - (height :int :initarg 0)) - -(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-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-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.")) - -(defmethod create-temporary-native ((type g-boxed-cstruct-wrapper-info) proxy) - (format t "create-temporary-native~%") - (let* ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type)) - (native-structure (foreign-alloc native-structure-type))) - (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type)) - (setf (foreign-slot-value native-structure native-structure-type slot) - (slot-value proxy slot))) - native-structure)) - -(defmethod free-temporary-native ((type g-boxed-cstruct-wrapper-info) proxy native-structure) - (format t "free-temporary-native~%") - (let ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type))) - (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type)) - (setf (slot-value proxy slot) - (foreign-slot-value native-structure native-structure-type slot)))) - (foreign-free native-structure)) - -(defmethod create-proxy-for-native ((type g-boxed-cstruct-wrapper-info) native-structure) - (format t "create-proxy-for-native~%") - (let* ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type)) - (proxy (make-instance (g-boxed-info-name type)))) - (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type)) - (setf (slot-value proxy slot) - (foreign-slot-value native-structure native-structure-type slot))) - proxy)) - -(defmethod create-reference-proxy ((type g-boxed-cstruct-wrapper-info) native-structure) - (format t "create-reference-proxy~%") - (create-proxy-for-native type native-structure)) - -(defmethod free-reference-proxy ((type g-boxed-cstruct-wrapper-info) proxy native-structure) - (format t "free-reference-proxy~%") - (let ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type))) - (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type)) - (setf (foreign-slot-value native-structure native-structure-type slot) - (slot-value proxy slot))))) - -(defmethod translate-to-foreign (proxy (type g-boxed-foreign-type)) - (if proxy - (let* ((info (g-boxed-foreign-info type))) - (values (create-temporary-native info proxy) proxy)) - (null-pointer))) - -(defmethod free-translated-object (native-structure (type g-boxed-foreign-type) proxy) - (when proxy - (free-temporary-native (g-boxed-foreign-info type) proxy native-structure))) - -(defmethod translate-from-foreign (native-structure (type g-boxed-foreign-type)) - (unless (null-pointer-p native-structure) - (let* ((info (g-boxed-foreign-info type))) - (cond - ((g-boxed-foreign-for-callback type) - (create-reference-proxy info native-structure)) - ((or (g-boxed-foreign-free-to-foreign type) - (g-boxed-foreign-free-from-foreign type)) - (error "Feature not yet handled")) - (t (create-proxy-for-native info native-structure)))))) - -(defmethod cleanup-translated-object-for-callback ((type g-boxed-foreign-type) proxy native-structure) - (unless (null-pointer-p native-structure) - (free-reference-proxy (g-boxed-foreign-info type) proxy native-structure))) - -(defmethod has-callback-cleanup ((type g-boxed-foreign-type)) - t) - -(defcallback incf-rectangle :void ((rectangle (g-boxed-foreign gdk-rectangle :for-callback t)) - (delta :int)) - (incf (gdk-rectangle-x rectangle) delta) - (incf (gdk-rectangle-y rectangle) delta) - (incf (gdk-rectangle-width rectangle) delta) - (incf (gdk-rectangle-height rectangle) delta) - (format t "~A~%" rectangle)) - -(defun do-incf-rect (r &optional (delta 1)) - (foreign-funcall-pointer (callback incf-rectangle) () - (g-boxed-foreign gdk-rectangle) r - :int delta - :void) - r) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defstruct (g-boxed-opaque-wrapper-info (:include g-boxed-info)) - alloc free)) - -(defclass g-boxed-opaque () - ((pointer :initarg :pointer - :initform nil - :accessor g-boxed-opaque-pointer))) - -(defmethod create-temporary-native ((type g-boxed-opaque-wrapper-info) proxy) - (declare (ignore type)) - (g-boxed-opaque-pointer proxy)) - -(defmethod free-temporary-native ((type g-boxed-opaque-wrapper-info) proxy native-structure) - (declare (ignore type proxy native-structure))) - -(defmethod create-reference-proxy ((type g-boxed-opaque-wrapper-info) native-structure) - (make-instance (g-boxed-info-g-type type) :pointer native-structure)) - -(defmethod free-reference-proxy ((type g-boxed-opaque-wrapper-info) proxy native-structure) - (declare (ignore type native-structure)) - (setf (g-boxed-opaque-pointer proxy) nil)) - -(defmethod create-proxy-for-native ((type g-boxed-opaque-wrapper-info) native-structure) - (let* ((g-type (g-boxed-info-g-type type)) - (native-copy (g-boxed-copy g-type native-structure))) - (flet ((finalizer () (g-boxed-free g-type native-copy))) - (let ((proxy (make-instance (g-boxed-opaque-wrapper-info-g-type type) :pointer native-copy))) - (tg:finalize proxy #'finalizer) - proxy)))) - -(defmacro define-g-boxed-opaque (name g-type-name &key - (alloc (error "Alloc must be specified"))) - (let ((native-copy (gensym "NATIVE-COPY-")) - (instance (gensym "INSTANCE-")) - (finalizer (gensym "FINALIZER-"))) - `(progn (defclass ,name (g-boxed-opaque) ()) - (defmethod initialize-instance :after ((,instance ,name) &key &allow-other-keys) - (unless (g-boxed-opaque-pointer ,instance) - (let ((,native-copy ,alloc)) - (flet ((,finalizer () (g-boxed-free ,g-type-name ,native-copy))) - (setf (g-boxed-opaque-pointer ,instance) ,native-copy) - (finalize ,instance #',finalizer))))) - (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (get ',name 'g-boxed-foreign-info) - (make-g-boxed-opaque-wrapper-info :name ',name - :g-type ,g-type-name)))))) - -(define-g-boxed-opaque gtk-tree-path "GtkTreePath" - :alloc (let* ((native-structure (gtk-tree-path-new)) - (native-copy (g-boxed-copy "GtkTreePath" native-structure))) - (gtk-tree-path-free native-structure) - native-copy)) - -(defcfun gtk-tree-path-new :pointer) - -(defcfun gtk-tree-path-free :void - (gtk-tree-path :pointer)) - -(defcfun gtk-tree-path-copy :pointer - (gtk-tree-path :pointer)) - -(defcfun (%gtk-tree-path-get-depth "gtk_tree_path_get_depth") :int - (path (g-boxed-foreign gtk-tree-path))) - -(defcfun (%gtk-tree-path-get-indices "gtk_tree_path_get_indices") (:pointer :int) - (path (g-boxed-foreign gtk-tree-path))) - -(defcfun gtk-tree-path-append-index :void - (path (g-boxed-foreign gtk-tree-path)) - (index :int)) - -(defun tree-path-get-indices (path) - (let ((n (%gtk-tree-path-get-depth path)) - (indices (%gtk-tree-path-get-indices path))) - (loop - for i from 0 below n - collect (mem-aref indices :int i)))) diff --git a/gboxed.variant-struct.lisp b/gboxed.variant-struct.lisp deleted file mode 100644 index da25cf1..0000000 --- a/gboxed.variant-struct.lisp +++ /dev/null @@ -1,70 +0,0 @@ -(in-package :gobject) - -(defstruct var-structure - name - parent - slots - discriminator-slot - variants) - -(defstruct var-structure-variant - discriminating-values - structure) - -(defstruct var-structure-slot - name - type - initform - count) - -(defmethod make-load-form ((object var-structure) &optional env) - (make-load-form-saving-slots object :environment env)) - -(defmethod make-load-form ((object var-structure-slot) &optional env) - (make-load-form-saving-slots object :environment env)) - -(defmethod make-load-form ((object var-structure-variant) &optional env) - (make-load-form-saving-slots object :environment env)) - -(defun var-struct-all-slots (struct) - (when struct - (append (var-struct-all-slots (var-structure-parent struct)) - (var-structure-slots struct)))) - -(defun all-structures (structure) - (append (iter (for variant in (var-structure-variants structure)) - (appending (all-structures (var-structure-variant-structure variant)))) - (list structure))) - -(defun parse-variant-structure-definition (name slots &optional parent) - (iter (with result = (make-var-structure :name name - :parent parent - :slots nil - :discriminator-slot nil - :variants nil)) - (for slot in slots) - (if (eq :variant (first slot)) - (progn - (when (var-structure-discriminator-slot result) - (error "Structure has more than one discriminator slot")) - (setf (var-structure-discriminator-slot result) (second slot) - (var-structure-variants result) (parse-variants result (nthcdr 2 slot)))) - (push (parse-slot slot) (var-structure-slots result))) - (finally (setf (var-structure-slots result) - (reverse (var-structure-slots result))) - (return result)))) - -(defun parse-slot (slot) - (destructuring-bind (name type &key count initform) slot - (make-var-structure-slot :name name :type type :count count :initform initform))) - -(defun parse-variants (parent variants) - (iter (for var-descr in variants) - (for (options variant-name . slots) in variants) - (for variant = - (make-var-structure-variant - :discriminating-values (ensure-list options) - :structure (parse-variant-structure-definition variant-name slots parent))) - (collect variant))) - - diff --git a/gboxed.vs.lisp b/gboxed.vs.lisp deleted file mode 100644 index b670606..0000000 --- a/gboxed.vs.lisp +++ /dev/null @@ -1,164 +0,0 @@ -(in-package :gobject) - -(defun generated-cstruct-name (symbol) - (or (get symbol 'generated-cstruct-name) - (setf (get symbol 'generated-cstruct-name) (gensym (format nil "GEN-~A-CSTRUCT-" (symbol-name symbol)))))) - -(defun generated-cunion-name (symbol) - (or (get symbol 'generated-cunion-name) - (setf (get symbol 'generated-cunion-name) (gensym (format nil "GEN-~A-CSTRUCT-" (symbol-name symbol)))))) - -(defun generate-cstruct-1 (struct) - `(defcstruct ,(generated-cstruct-name (var-structure-name struct)) - ,@(iter (for slot in (var-struct-all-slots struct)) - (collect `(,(var-structure-slot-name slot) ,(var-structure-slot-type slot) - ,@(when (var-structure-slot-count slot) - (list `(:count ,(var-structure-slot-count slot))))))))) - -(defun generate-c-structures (structure) - (iter (for str in (all-structures structure)) - (collect (generate-cstruct-1 str)))) - -(defun generate-union-1 (struct) - `(defcunion ,(generated-cunion-name (var-structure-name struct)) - ,@(iter (for variant in (all-structures struct)) - (unless (eq struct variant) - (collect `(,(var-structure-name variant) - ,(generated-cunion-name (var-structure-name variant)))))))) - -(defun generate-unions (struct) - (iter (for str in (all-structures struct)) - (collect (generate-union-1 str)))) - -(defun generate-structure-1 (str) - `(defstruct ,(if (var-structure-parent str) - `(,(var-structure-name str) (:include ,(var-structure-name (var-structure-parent str)) - (,(var-structure-discriminator-slot (var-structure-parent str)) - ,(first (var-structure-variant-discriminating-values - (find str - (var-structure-variants - (var-structure-parent str)) - :key #'var-structure-variant-structure)))))) - `,(var-structure-name str)) - ,@(iter (for slot in (var-structure-slots str)) - (collect `(,(var-structure-slot-name slot) - ,(var-structure-slot-initform slot)))))) - -(defun generate-structures (str) - (iter (for variant in (reverse (all-structures str))) - (collect (generate-structure-1 variant)))) - -(defun generate-native-type-decision-procedure-1 (str proxy-var) - (if (null (var-structure-discriminator-slot str)) - `(values ',(generated-cstruct-name (var-structure-name str)) - ',(mapcar #'var-structure-slot-name (var-struct-all-slots str))) - `(typecase ,proxy-var - ,@(iter (for variant in (var-structure-variants str)) - (for v-str = (var-structure-variant-structure variant)) - (collect `(,(var-structure-name v-str) - ,(generate-native-type-decision-procedure-1 v-str proxy-var)))) - (,(var-structure-name str) - (values ',(generated-cstruct-name (var-structure-name str)) - ',(mapcar #'var-structure-slot-name (var-struct-all-slots str))))))) - -(defun generate-proxy-type-decision-procedure-1 (str native-var) - (if (null (var-structure-discriminator-slot str)) - `(values ',(var-structure-name str) - ',(mapcar #'var-structure-slot-name (var-struct-all-slots str)) - ',(generated-cstruct-name (var-structure-name str))) - `(case (foreign-slot-value ,native-var - ',(generated-cstruct-name (var-structure-name str)) - ',(var-structure-discriminator-slot str)) - ,@(iter (for variant in (var-structure-variants str)) - (for v-str = (var-structure-variant-structure variant)) - (collect `(,(var-structure-variant-discriminating-values variant) - ,(generate-proxy-type-decision-procedure-1 - v-str - native-var)))) - (t (values ',(var-structure-name str) - ',(mapcar #'var-structure-slot-name (var-struct-all-slots str)) - ',(generated-cstruct-name (var-structure-name str))))))) - -(defun generate-proxy-type-decision-procedure (str) - (let ((native (gensym "NATIVE-"))) - `(lambda (,native) - ,(generate-proxy-type-decision-procedure-1 str native)))) - -(defun generate-native-type-decision-procedure (str) - (let ((proxy (gensym "PROXY-"))) - `(lambda (,proxy) - ,(generate-native-type-decision-procedure-1 str proxy)))) - -(defun compile-proxy-type-decision-procedure (str) - (compile nil (generate-proxy-type-decision-procedure str))) - -(defun compile-native-type-decision-procedure (str) - (compile nil (generate-native-type-decision-procedure str))) - -(defstruct (g-boxed-variant-cstruct-info (:include g-boxed-info)) - root - native-type-decision-procedure - proxy-type-decision-procedure) - -(defmethod make-load-form ((object g-boxed-variant-cstruct-info) &optional env) - (make-load-form-saving-slots object :environment env)) - -(defmacro define-boxed-variant-cstruct (name g-type-name &body slots) - (let* ((structure (parse-variant-structure-definition name slots))) - `(progn ,@(generate-c-structures structure) - ,@(generate-unions structure) - ,@(generate-structures structure) - (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (get ',name 'g-boxed-foreign-info) - (make-g-boxed-variant-cstruct-info :name ',name - :g-type ,g-type-name - :root ,structure - :native-type-decision-procedure - ,(generate-native-type-decision-procedure structure) - :proxy-type-decision-procedure - ,(generate-proxy-type-decision-procedure structure))))))) - -(defun decide-native-type (info proxy) - (funcall (g-boxed-variant-cstruct-info-native-type-decision-procedure info) proxy)) - -(defmethod create-temporary-native ((type g-boxed-variant-cstruct-info) proxy) - (multiple-value-bind (actual-cstruct slots) (decide-native-type type proxy) - (let ((native-structure (foreign-alloc - (generated-cstruct-name - (var-structure-name - (g-boxed-variant-cstruct-info-root type)))))) - (iter (for slot in slots) - (setf (foreign-slot-value native-structure actual-cstruct slot) - (slot-value proxy slot))) - native-structure))) - -(defun decide-proxy-type (info native-structure) - (funcall (g-boxed-variant-cstruct-info-proxy-type-decision-procedure info) native-structure)) - -(defmethod free-temporary-native ((type g-boxed-variant-cstruct-info) proxy native-ptr) - (multiple-value-bind (actual-struct slots actual-cstruct) (decide-proxy-type type native-ptr) - (unless (eq (type-of proxy) actual-struct) - (restart-case - (error "Expected type of boxed variant structure ~A and actual type ~A do not match" - (type-of proxy) actual-struct) - (skip-parsing-values () (return-from free-temporary-native)))) - (iter (for slot in slots) - (setf (slot-value proxy slot) - (foreign-slot-value native-ptr actual-cstruct slot))))) - -(defmethod create-proxy-for-native ((type g-boxed-variant-cstruct-info) native-ptr) - (multiple-value-bind (actual-struct slots actual-cstruct) (decide-proxy-type type native-ptr) - (let ((proxy (make-instance actual-struct))) - (iter (for slot in slots) - (setf (slot-value proxy slot) - (foreign-slot-value native-ptr actual-cstruct slot))) - proxy))) - -(defmethod create-reference-proxy ((type g-boxed-variant-cstruct-info) native-ptr) - (create-proxy-for-native type native-ptr)) - -(defmethod free-reference-proxy ((type g-boxed-variant-cstruct-info) proxy native-ptr) - (multiple-value-bind (actual-cstruct slots) (decide-native-type type proxy) - (iter (for slot in slots) - (setf (foreign-slot-value native-ptr actual-cstruct slot) - (slot-value proxy slot))))) diff --git a/gboxed.vs.test.lisp b/gboxed.vs.test.lisp deleted file mode 100644 index 7984183..0000000 --- a/gboxed.vs.test.lisp +++ /dev/null @@ -1,26 +0,0 @@ -(in-package :gobject) - -(define-boxed-variant-cstruct evt "evt" - (type :int :initform 0) - (time :uint :initform 0) - (:variant type - (0 evt-zero - (x :double :initform 0.0d0) - (y :double :initform 0.0d0)) - ((1 2 3) evt-multi - (t2 :int :initform 0) - (:variant t2 - (1 evt-single - (item :uchar :initform 0)))))) - -(defcallback test-evt (g-boxed-foreign evt) - ((time :int) (e1 (g-boxed-foreign evt))) - (print time) - (print e1) - (when e1 - (incf (evt-time e1) time)) - (make-evt-multi :time time :t2 123)) - -(defun do-test-evt (e1 time) - (let ((e2 (foreign-funcall-pointer (callback test-evt) () :int time (g-boxed-foreign evt) e1 (g-boxed-foreign evt)))) - (values e1 e2))) diff --git a/mm-test.lisp b/mm-test.lisp deleted file mode 100644 index d152bc5..0000000 --- a/mm-test.lisp +++ /dev/null @@ -1,161 +0,0 @@ -(eval-when (:load-toplevel :compile-toplevel :execute) - (require :fiveam)) - -(defpackage :mm-test - (:use :cl :gtk :glib :gobject :iter :tg :5am)) - -(in-package :mm-test) - -(defun get-object (ptr) - (when (cffi:pointerp ptr) (setf ptr (cffi:pointer-address ptr))) - (or (gethash ptr gobject::*foreign-gobjects-strong*) - (gethash ptr gobject::*foreign-gobjects-weak*))) - -(defun do-gc () - (gc :full t) - (gobject::activate-gc-hooks) - (gethash 0 gobject::*foreign-gobjects-strong*) - (gobject::activate-gc-hooks) - (gc :full t) - (gethash 0 gobject::*foreign-gobjects-weak*) - (gobject::activate-gc-hooks) - (gc :full t)) - -(defun object-handlers (object) - (when object - (remove nil (gobject::g-object-signal-handlers object)))) - -(defun print-refs-table (table &optional (stream *standard-output*)) - (iter (for (ptr object) in-hashtable table) - (format stream "~A => ~A (~A refs~@[~*, floating~])~@[ handlers: ~A~]~%" - ptr object (gobject::ref-count object) - (gobject.ffi:g-object-is-floating (cffi:make-pointer ptr)) - (object-handlers object)))) - -(defun print-refs (&optional (stream *standard-output*)) - (format stream "Strong:~%") - (print-refs-table gobject::*foreign-gobjects-strong*) - (format stream "Weak:~%") - (print-refs-table gobject::*foreign-gobjects-weak*)) - -(defun count-refs () - (+ (hash-table-count gobject::*foreign-gobjects-strong*) - (hash-table-count gobject::*foreign-gobjects-weak*))) - -(defun print-sps (&optional (stream *standard-output*)) - (iter (initially (format stream "Stable pointers:~%")) - (for v in-vector gobject::*registered-stable-pointers*) - (for i from 0) - (when v - (format stream "~A => ~A~%" i v)) - (finally (format stream "~%")))) - -(defun print-hooks (&optional (stream *standard-output*)) - (format stream "~A~%" gobject::*gobject-gc-hooks*)) - -(defun delete-refs () - (maphash (lambda (key value) - (declare (ignore value)) - (remhash key gobject::*foreign-gobjects-strong*)) - gobject::*foreign-gobjects-strong*) - (maphash (lambda (key value) - (declare (ignore value)) - (remhash key gobject::*foreign-gobjects-weak*)) - gobject::*foreign-gobjects-weak*)) - -(when nil (defvar *builder* (make-instance 'builder :from-string - " - - - - -"))) - -(setf gobject::*debug-stream* *standard-output* - gobject::*debug-gc* t - gobject::*debug-subclass* t) - -(defclass my-button (gtk:button) () (:metaclass gobject-class)) - -(def-suite mm-tests) - -(defun run-all-tests () - (run! 'mm-tests)) - -(in-suite mm-tests) - -(defmacro with-gc-same-counting (&body body) - (let ((count (gensym))) - (multiple-value-bind (body gc-count) - (if (integerp (first body)) - (values (rest body) (first body)) - (values body 1)) - `(progn - (gc :full t) - (gobject::activate-gc-hooks) - (count-refs) - (let ((,count (count-refs))) - (funcall (lambda () ,@body)) - (iter (repeat ,gc-count) - (format t "gc'ing~%") - (gc :full t) - (gobject::activate-gc-hooks) - (count-refs)) - (is (= ,count (count-refs)))))))) - -(test test-1 - (with-gc-same-counting - 2 - (make-instance 'my-button))) - -(test test-with-signal - (with-gc-same-counting - 2 - (let ((b (make-instance 'my-button))) - (connect-signal b "clicked" (lambda (bb) (declare (ignore bb)) (print b))) - nil))) - -(test test-repassing - (with-gc-same-counting - 2 - (let ((b (make-instance 'my-button))) - (cffi:convert-from-foreign (pointer b) 'g-object) - nil))) - -(test test-builder - (with-gc-same-counting - 5 - (let ((b (make-instance 'builder :from-string " - - -"))) - (builder-get-object b "button1") - (gc :full t) - (gobject::activate-gc-hooks)) - nil)) - -(test test-builder-with-signals - (with-gc-same-counting - 6 - (let ((b (make-instance 'builder :from-string " - - -"))) - (let ((btn (builder-get-object b "button1"))) - (connect-signal btn "clicked" (lambda (bb) (declare (ignore bb)) (print btn)))) - (gc :full t) - (gobject::activate-gc-hooks)) - nil)) - -(defun make-builder (&optional return) - (let* ((builder (make-instance 'gtk:builder - :from-file (namestring (merge-pathnames "demo/demo1.ui" gtk-demo::*src-location*)))) - (text-view (builder-get-object builder "textview1")) - (window (builder-get-object builder "window1"))) - (builder-connect-signals-simple - builder - `(("quit_cb" - ,(lambda (&rest args) - (print args) - (object-destroy window))))) - (when return builder))) diff --git a/subclass.lisp b/subclass.lisp deleted file mode 100644 index 9cf9e1e..0000000 --- a/subclass.lisp +++ /dev/null @@ -1,370 +0,0 @@ -(eval-when (:load-toplevel :compile-toplevel :execute) - (asdf:oos 'asdf:load-op :gtk) - (asdf:oos 'asdf:load-op :iterate) - (asdf:oos 'asdf:load-op :metabang-bind) - (use-package :cffi) - (use-package :gobject) - (use-package :iter) - (use-package :bind)) - -(define-g-boxed-class nil g-type-info () - (class-size :uint16 :initform 0) - (base-init :pointer :initform (null-pointer)) - (base-finalize :pointer :initform (null-pointer)) - (class-init :pointer :initform (null-pointer)) - (class-finalize :pointer :initform (null-pointer)) - (class-data :pointer :initform (null-pointer)) - (instance-size :uint16 :initform 0) - (n-preallocs :uint16 :initform 0) - (instance-init :pointer :initform (null-pointer)) - (value-type :pointer :initform (null-pointer))) - -(defcfun (%g-type-register-static "g_type_register_static") gobject::g-type - (parent-type gobject::g-type) - (type-name :string) - (info (g-boxed-ptr g-type-info)) - (flags gobject::g-type-flags)) - -(defcfun (%g-type-regiser-static-simple "g_type_register_static_simple") gobject::g-type - (parent-type gobject::g-type) - (type-name :string) - (class-size :uint) - (class-init :pointer) - (instance-size :uint) - (instance-init :pointer) - (flags gobject::g-type-flags)) - -(define-g-boxed-class nil g-type-query () - (type gobject::g-type :initform 0) - (name (:string :free-from-foreign nil :free-to-foreign nil) :initform (null-pointer)) - (class-size :uint :initform 0) - (instance-size :uint :initform 0)) - -(defcfun (%g-type-query "g_type_query") :void - (type gobject::g-type) - (query (g-boxed-ptr g-type-query :in-out))) - -(define-foreign-type g-quark () - () - (:actual-type :uint32) - (:simple-parser g-quark)) - -(defcfun g-quark-from-string :uint32 - (string :string)) - -(defcfun g-quark-to-string (:string :free-from-foreign nil) - (quark :uint32)) - -(defmethod translate-to-foreign (string (type g-quark)) - (g-quark-from-string string)) - -(defmethod translate-from-foreign (value (type g-quark)) - (g-quark-to-string value)) - -(defvar *stable-pointers-to-symbols* (make-array 0 :adjustable t :fill-pointer t)) - -(defun stable-pointer (symbol) - (vector-push-extend symbol *stable-pointers-to-symbols*) - (length *stable-pointers-to-symbols*)) - -(defun deref-stable-pointer (p) - (aref *stable-pointers-to-symbols* (1- p))) - -(defcfun g-type-set-qdata :void - (type gobject::g-type) - (quark g-quark) - (data :pointer)) - -(defcfun g-type-get-qdata :pointer - (type gobject::g-type) - (quark g-quark)) - -(defun g-object-register-sub-type (name parent-type lisp-class) - (let ((q (make-g-type-query))) - (%g-type-query (gobject::ensure-g-type parent-type) q) - (let ((new-type-id (%g-type-regiser-static-simple (gobject::ensure-g-type parent-type) - name - (g-type-query-class-size q) - (null-pointer) - (g-type-query-instance-size q) - (null-pointer) - nil))) - (when (zerop new-type-id) - (error "Type registration failed for ~A" name)) - (g-type-set-qdata new-type-id "lisp-class-name" (make-pointer (stable-pointer lisp-class))) - (setf (get lisp-class 'g-type-name) name)))) - -(defun g-type-lisp-class (type) - (let ((sp (pointer-address (g-type-get-qdata (gobject::ensure-g-type type) "lisp-class-name")))) - (when (zerop sp) - (error "Type ~A is not a lisp-based type" type)) - (deref-stable-pointer sp))) - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun vtable-item->cstruct-item (member) - (if (eq (first member) :skip) - (second member) - `(,(first member) :pointer))) - - (defun vtable->cstruct (table-name options members) - (bind (((&key cstruct-name &allow-other-keys) options)) - `(defcstruct ,cstruct-name - ,@(mapcar #'vtable-item->cstruct-item members)))) - - (defun arg-name->name (name) - (if (listp name) - (second name) - name)) - - (defun arg->arg-name (arg) - (arg-name->name (first arg))) - - (defun vtable-member->callback (table-name options member) - (bind (((name return-type &rest args) member)) - `(defcallback ,name ,return-type ,args - (funcall ',name ,@(mapcar #'arg->arg-name args))))) - - (defun vtable->callbacks (table-name options members) - (mapcar (lambda (member) (vtable-member->callback table-name options member)) - (remove-if (lambda (member) (eq (first member) :skip)) members))) - - (defun vtable-member->init-member (iface-ptr-var table-name options member) - (bind (((&key cstruct-name &allow-other-keys) options)) - `(setf (foreign-slot-value ,iface-ptr-var ',cstruct-name ',(first member)) - (callback ,(first member))))) - - (defun vtable->interface-init (table-name options members) - (bind (((&key interface-initializer &allow-other-keys) options)) - `(defcallback ,interface-initializer :void ((iface :pointer) (data :pointer)) - (declare (ignore data)) - ,@(mapcar (lambda (member) (vtable-member->init-member 'iface table-name options member)) - (remove-if (lambda (member) (eq (first member) :skip)) members))))) - - (defun vtable-member->generic-function (table-name options member) - (bind (((name return-type &rest arguments) member)) - `(defgeneric ,name (,@(mapcar #'first arguments))))) - - (defun vtable->generics-def (table-name options members) - (mapcar (lambda (member) (vtable-member->generic-function table-name options member)) - (remove-if (lambda (member) (eq (first member) :skip)) members)))) - -(defmacro define-vtable (name options &body members) - `(progn - ,(vtable->cstruct name options members) - ,@(vtable->callbacks name options members) - ,(vtable->interface-init name options members) - ,@(vtable->generics-def name options members) - (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (get ',name 'options) ',options - (get ',name 'members) ',members)))) - -(define-g-flags "GtkTreeModelFlags" tree-model-flags (t) - (:iters-persist 1) (:list-only 2)) - -(define-g-boxed-class "GtkTreeIter" tree-iter () - (stamp :int) - (user-data :pointer) - (user-data-2 :pointer) - (user-data-3 :pointer)) - -(defctype tree-path :pointer) - -(define-vtable tree-model (:interface "GtkTreeModel" :class-name gtk-tree-model :cstruct-name gtk-tree-model-iface :interface-initializer gtk-tree-model-iface-init) - (:skip (parent-instance gobject::g-type-interface)) - ;;some signals - (tree-model-row-changed :void (tree-model :pointer) (path :pointer) (iter :pointer)) - (tree-model-row-inserted :void (tree-model :pointer) (path :pointer) (iter :pointer)) - (tree-model-row-has-child-toggled :void (tree-model :pointer) (path :pointer) (iter :pointer)) - (tree-model-row-deleted :void (tree-model :pointer) (path :pointer)) - (tree-model-rows-reordered :void (tree-model :pointer) (path :pointer) (iter :pointer) (new-order :pointer)) - ;;methods - (tree-model-get-flags tree-model-flags (tree-model g-object)) - (tree-model-get-n-columns :int (tree-model g-object)) - (tree-model-get-column-type gobject::g-type (tree-model g-object) (index :int)) - (tree-model-get-iter :boolean (tree-model g-object) (iter (:pointer tree-iter)) (path tree-path)) - (tree-model-get-path tree-path (tree-model g-object) (iter (g-boxed-ptr tree-iter))) - (tree-model-get-value :void (tree-model g-object) (iter (g-boxed-ptr tree-iter)) (n :int) (value (:pointer gobject::g-value))) - (tree-model-iter-next :boolean (tree-model g-object) (iter (:pointer tree-iter))) - (tree-model-iter-children :boolean (tree-model g-object) (iter (:pointer tree-iter)) (parent (g-boxed-ptr tree-iter))) - (tree-model-iter-has-child :boolean (tree-model g-object) (iter (g-boxed-ptr tree-iter))) - (tree-model-iter-n-children :int (tree-model g-object) (iter (g-boxed-ptr tree-iter))) - (tree-model-iter-nth-child :boolean (tree-model g-object) (iter (:pointer tree-iter)) (parent (g-boxed-ptr tree-iter)) (n :int)) - (tree-model-iter-parent :boolean (tree-model g-object) (iter (:pointer tree-iter)) (child (g-boxed-ptr tree-iter))) - (tree-model-ref-node :void (tree-model g-object) (iter (g-boxed-ptr tree-iter))) - (tree-model-unref-node :void (tree-model g-object) (iter (g-boxed-ptr tree-iter)))) - -(defcfun g-type-add-interface-static :void - (instance-type gobject::g-type) - (interface-type gobject::g-type) - (info (:pointer gobject::g-interface-info))) - -(defun add-interface (lisp-class vtable-name) - (with-foreign-object (iface-info 'gobject::g-interface-info) - (setf (foreign-slot-value iface-info 'gobject::g-interface-info 'gobject::interface-init) (get-callback (getf (get vtable-name 'options) :interface-initializer)) - (foreign-slot-value iface-info 'gobject::g-interface-info 'gobject::interface-finalize) (null-pointer) - (foreign-slot-value iface-info 'gobject::g-interface-info 'gobject::interface-data) (null-pointer)) - (unless (getf (get vtable-name 'options) :interface) - (error "Vtable ~A is not a vtable of an interface")) - (g-type-add-interface-static (gobject::g-type-from-name (get lisp-class 'g-type-name)) - (gobject::g-type-from-name (getf (get vtable-name 'options) :interface)) - iface-info))) - -(defvar *o1* nil) -(defvar *o2* nil) - -(unless *o1* - (g-object-register-sub-type "LispTreeStore" "GObject" 'lisp-tree-store) - (setf *o1* t)) -(unless *o2* - (add-interface 'lisp-tree-store 'tree-model) - (setf *o2* t)) - -(defclass tree-model (g-object) ()) -(defmethod initialize-instance :before ((object tree-model) &key pointer) - (unless pointer - (setf (gobject::pointer object) (gobject::g-object-call-constructor (gobject::g-type-from-name "LispTreeStore") nil nil nil)))) - -(defmethod tree-model-get-flags ((model tree-model)) - (list :list-only)) - -(defmethod tree-model-get-n-columns ((model tree-model)) - 1) - -(defmethod tree-model-get-column-type ((model tree-model) index) - (gobject::g-type-from-name "gchararray")) - -(defcfun (%gtk-tree-path-get-depth "gtk_tree_path_get_depth") :int - (path tree-path)) - -(defcfun (%gtk-tree-path-get-indices "gtk_tree_path_get_indices") (:pointer :int) - (path tree-path)) - -(defcfun (%gtk-tree-path-new "gtk_tree_path_new") :pointer) - -(defcfun (%gtk-tree-path-append-index "gtk_tree_path_append_index") :void - (path :pointer) - (index :int)) - -(defun tree-path-indices (path) - (let ((n (%gtk-tree-path-get-depth path)) - (indices (%gtk-tree-path-get-indices path))) - (loop - for i from 0 below n - collect (mem-aref indices :int i)))) - -(defmethod tree-model-get-iter ((model tree-model) iter path) - (let ((indices (tree-path-indices path))) - (when (= 1 (length indices)) - (with-foreign-slots ((stamp user-data user-data-2 user-data-3) iter tree-iter) - (setf stamp 0 user-data (make-pointer (first indices)) user-data-2 (null-pointer) user-data-3 (null-pointer))) - t))) - -(defmethod tree-model-ref-node ((model tree-model) iter)) -(defmethod tree-model-unref-node ((model tree-model) iter)) - -(defmethod tree-model-iter-next ((model tree-model) iter) - (with-foreign-slots ((stamp user-data) iter tree-iter) - (let ((n (pointer-address user-data))) - (when (< n 5) - (setf user-data (make-pointer (1+ n))) - t)))) - -(defmethod tree-model-iter-nth-child ((model tree-model) iter parent n) - (with-foreign-slots ((stamp user-data user-data-2 user-data-3) iter tree-iter) - (setf stamp 0 user-data (make-pointer n) user-data-2 (null-pointer) user-data-3 (null-pointer))) - t) - -(defmethod tree-model-iter-n-children ((model tree-model) iter) - (if (null iter) - 5 - 0)) - -(defmethod tree-model-get-path ((model tree-model) iter) - (let ((path (%gtk-tree-path-new))) - (%gtk-tree-path-append-index path (pointer-address (tree-iter-user-data iter))) - path)) - -(defmethod tree-model-iter-has-child ((model tree-model) iter) - nil) - -(defmethod tree-model-get-value ((model tree-model) iter n value) - (let ((n-row (pointer-address (tree-iter-user-data iter)))) - (gobject::set-g-value value (format nil "~A" (expt n-row 2)) (gobject::g-type-from-name "gchararray")))) - -(defcfun (%gtk-tree-view-append-column "gtk_tree_view_append_column") :int - (tree-view (g-object gtk:tree-view)) - (column (g-object gtk:tree-view-column))) - -(defcfun (%gtk-tree-view-column-pack-start "gtk_tree_view_column_pack_start") :void - (tree-column (g-object gtk:tree-view-column)) - (cell (g-object gtk:cell-renderer)) - (expand :boolean)) - -(defcfun (%gtk-tree-view-column-add-attribute "gtk_tree_view_column_add_attribute") :void - (tree-column (g-object gtk:tree-view-column)) - (cell-renderer (g-object gtk:cell-renderer)) - (attribute :string) - (column-number :int)) - -(defun test-treeview () - (let* ((window (make-instance 'gtk:gtk-window :type :toplevel :title "Treeview" :border-width 30)) - (model (make-instance 'tree-model)) - (tv (make-instance 'gtk:tree-view :model model :headers-visible t))) - (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (gtk:gtk-main-quit))) - (let ((column (make-instance 'gtk:tree-view-column :title "Number")) - (renderer (make-instance 'gtk:cell-renderer-text :text "A text"))) - (%gtk-tree-view-column-pack-start column renderer t) - (%gtk-tree-view-column-add-attribute column renderer "text" 0) - (%gtk-tree-view-append-column tv column)) - (gtk:container-add window tv) - (gtk:gtk-widget-show-all window) - (gtk:gtk-main))) - -(defcfun (%gtk-cell-layout-pack-start "gtk_cell_layout_pack_start") :void - (cell-layout g-object) - (cell (g-object gtk:cell-renderer)) - (expand :boolean)) - -(defcfun (%gtk-cell-layout-add-attribute "gtk_cell_layout_add_attribute") :void - (cell-layout g-object) - (cell (g-object gtk:cell-renderer)) - (attribute :string) - (column :int)) - -(defun test-combobox () - (let* ((window (make-instance 'gtk:gtk-window :type :toplevel :title "cb" :border-width 30)) - (model (make-instance 'tree-model)) - (combobox (make-instance 'gtk:combo-box :model model))) - (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (gtk:gtk-main-quit))) - (g-signal-connect combobox "changed" (lambda (w) (declare (ignore w)) (format t "Changed cb; active now = ~A~%" (gtk:combo-box-active combobox)))) - (let ((renderer (make-instance 'gtk:cell-renderer-text))) - (%gtk-cell-layout-pack-start combobox renderer t) - (%gtk-cell-layout-add-attribute combobox renderer "text" 0)) - (gtk:container-add window combobox) - (gtk:gtk-widget-show-all window) - (gtk:gtk-main))) - -(define-vtable widget (:class "GtkWidget" :cstruct-name widget-vtable :interface-initializer gtk-tree-model-iface-init) - (:skip (parent-instance gobject::g-type-interface)) - ;;some signals - (tree-model-row-changed :void (tree-model :pointer) (path :pointer) (iter :pointer)) - (tree-model-row-inserted :void (tree-model :pointer) (path :pointer) (iter :pointer)) - (tree-model-row-has-child-toggled :void (tree-model :pointer) (path :pointer) (iter :pointer)) - (tree-model-row-deleted :void (tree-model :pointer) (path :pointer)) - (tree-model-rows-reordered :void (tree-model :pointer) (path :pointer) (iter :pointer) (new-order :pointer)) - ;;methods - (tree-model-get-flags tree-model-flags (tree-model g-object)) - (tree-model-get-n-columns :int (tree-model g-object)) - (tree-model-get-column-type gobject::g-type (tree-model g-object) (index :int)) - (tree-model-get-iter :boolean (tree-model g-object) (iter (:pointer tree-iter)) (path tree-path)) - (tree-model-get-path tree-path (tree-model g-object) (iter (g-boxed-ptr tree-iter))) - (tree-model-get-value :void (tree-model g-object) (iter (g-boxed-ptr tree-iter)) (n :int) (value (:pointer gobject::g-value))) - (tree-model-iter-next :boolean (tree-model g-object) (iter (:pointer tree-iter))) - (tree-model-iter-children :boolean (tree-model g-object) (iter (:pointer tree-iter)) (parent (g-boxed-ptr tree-iter))) - (tree-model-iter-has-child :boolean (tree-model g-object) (iter (g-boxed-ptr tree-iter))) - (tree-model-iter-n-children :int (tree-model g-object) (iter (g-boxed-ptr tree-iter))) - (tree-model-iter-nth-child :boolean (tree-model g-object) (iter (:pointer tree-iter)) (parent (g-boxed-ptr tree-iter)) (n :int)) - (tree-model-iter-parent :boolean (tree-model g-object) (iter (:pointer tree-iter)) (child (g-boxed-ptr tree-iter))) - (tree-model-ref-node :void (tree-model g-object) (iter (g-boxed-ptr tree-iter))) - (tree-model-unref-node :void (tree-model g-object) (iter (g-boxed-ptr tree-iter)))) \ No newline at end of file diff --git a/subtest.lisp b/subtest.lisp deleted file mode 100644 index c422022..0000000 --- a/subtest.lisp +++ /dev/null @@ -1,223 +0,0 @@ -(gobject:define-g-flags "GtkTreeModelFlags" tree-model-flags (:type-initializer "gtk_tree_model_flags_get_type") - (:iters-persist 1) (:list-only 2)) - -(cffi:defcstruct tree-iter - (stamp :int) - (user-data :pointer) - (user-data-2 :pointer) - (user-data-3 :pointer)) - -(defun tree-iter-get-stamp (i) (cffi:foreign-slot-value (gobject::pointer i) 'tree-iter 'stamp)) -(defun tree-iter-set-stamp (value i) (setf (cffi:foreign-slot-value (gobject::pointer i) 'tree-iter 'stamp) value)) -(defun tree-iter-get-user-data (i) (cffi:pointer-address (cffi:foreign-slot-value (gobject::pointer i) 'tree-iter 'user-data))) -(defun tree-iter-set-user-data (value i) (setf (cffi:foreign-slot-value (gobject::pointer i) 'tree-iter 'user-data) (cffi:make-pointer value))) - -(defun tree-iter-alloc () (glib::g-malloc (cffi:foreign-type-size 'tree-iter))) -(defun tree-iter-free (v) (glib::g-free v)) - -(gobject:define-g-boxed-ref "GtkTreeIter" tree-iter - (:slots (stamp :reader tree-iter-get-stamp :writer tree-iter-set-stamp :accessor tree-iter-stamp) - (user-data :reader tree-iter-get-user-data :writer tree-iter-set-user-data :accessor tree-iter-user-data)) - (:alloc-function tree-iter-alloc) - (:free-function tree-iter-free)) - -(cffi:defctype tree-path :pointer) -(cffi:defcfun (%gtk-tree-path-get-depth "gtk_tree_path_get_depth") :int - (path tree-path)) - -(cffi:defcfun (%gtk-tree-path-get-indices "gtk_tree_path_get_indices") (:pointer :int) - (path tree-path)) - -(cffi:defcfun (%gtk-tree-path-new "gtk_tree_path_new") :pointer) - -(cffi:defcfun (%gtk-tree-path-append-index "gtk_tree_path_append_index") :void - (path :pointer) - (index :int)) - -(defun tree-path-get-indices (path) - (setf path (gobject::pointer path)) - (let ((n (%gtk-tree-path-get-depth path)) - (indices (%gtk-tree-path-get-indices path))) - (loop - for i from 0 below n - collect (cffi:mem-aref indices :int i)))) - -(defun tree-path-set-indices (indices path) - (setf path (gobject::pointer path)) - (loop - repeat (%gtk-tree-path-get-depth path) - do (cffi:foreign-funcall "gtk_tree_path_up" :pointer path :boolean)) - (loop - for index in indices - do(cffi:foreign-funcall "gtk_tree_path_append_index" :pointer path :int index :void))) - -(cffi:defcfun gtk-tree-path-new :pointer) -(cffi:defcfun gtk-tree-path-free :void (path :pointer)) - -(gobject::define-g-boxed-ref "GtkTreePath" tree-path - (:alloc-function gtk-tree-path-new) - (:free-function gtk-tree-path-free) - (:slots (indices :reader tree-path-get-indices :writer tree-path-set-indices :accessor tree-path-indices))) - -(gobject::define-vtable ("GtkTreeModel" c-gtk-tree-model) - (:skip parent-instance gobject::g-type-interface) - ;;some signals - (:skip tree-model-row-changed :pointer) - (:skip tree-model-row-inserted :pointer) - (:skip tree-model-row-has-child-toggled :pointer) - (:skip tree-model-row-deleted :pointer) - (:skip tree-model-rows-reordered :pointer) - ;;methods - (tree-model-get-flags-impl tree-model-get-flags-cb tree-model-flags (tree-model gobject:g-object)) - (tree-model-get-n-columns-impl tree-model-get-n-columns-cb :int (tree-model gobject:g-object)) - (tree-model-get-column-type-impl tree-model-get-column-type-cb gobject::g-type (tree-model gobject:g-object) (index :int)) - (tree-model-get-iter-impl tree-model-get-iter-cb :boolean (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter)) (path (gobject:g-boxed-ref tree-path))) - (tree-model-get-path-impl tree-model-get-path-cb (gobject:g-boxed-ref tree-path) (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter))) - (tree-model-get-value-impl tree-model-get-value-cb :void (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter)) (n :int) (value (:pointer gobject::g-value))) - (tree-model-iter-next-impl tree-model-iter-next-cb :boolean (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter))) - (tree-model-iter-children-impl tree-model-iter-children-cb :boolean (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter)) (parent (gobject:g-boxed-ref tree-iter))) - (tree-model-iter-has-child-impl tree-model-iter-has-child-cb :boolean (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter))) - (tree-model-iter-n-children-impl tree-model-iter-n-children-cb :int (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter))) - (tree-model-iter-nth-child-impl tree-model-iter-nth-child-cb :boolean (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter)) (parent (gobject:g-boxed-ref tree-iter)) (n :int)) - (tree-model-iter-parent-impl tree-model-iter-parent-cb :boolean (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter)) (child (gobject:g-boxed-ref tree-iter))) - (tree-model-ref-node-impl tree-model-ref-node-cb :void (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter))) - (tree-model-unref-node-impl tree-model-unref-node-cb :void (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter)))) - -(defclass array-list-store (gobject:g-object gtk:tree-model) - ((items :initform (make-array 0 :adjustable t :fill-pointer t) :reader store-items) - (columns-getters :initform (make-array 0 :adjustable t :fill-pointer t) :reader store-getters) - (columns-types :initform (make-array 0 :adjustable t :fill-pointer t) :reader store-types))) - -(gobject::register-object-type-implementation "LispArrayListStore" array-list-store "GObject" ("GtkTreeModel") nil) - -(defun store-add-item (store item) - (vector-push-extend item (store-items store)) - (gobject:using* ((path (make-instance 'tree-path)) - (iter (make-instance 'tree-iter))) - (setf (tree-path-indices path) (list (1- (length (store-items store))))) - (setf (tree-iter-stamp iter) 0 (tree-iter-user-data iter) (1- (length (store-items store)))) - (gobject::emit-signal store "row-inserted" path iter))) - -(defun store-add-column (store type getter) - (vector-push-extend (gobject::ensure-g-type type) (store-types store)) - (vector-push-extend getter (store-getters store)) - (1- (length (store-types store)))) - -(defmethod tree-model-get-flags-impl ((model array-list-store)) - '(:list-only)) - -(defmethod tree-model-get-n-columns-impl ((model array-list-store)) - (length (store-types model))) - -(defmethod tree-model-get-column-type-impl ((tree-model array-list-store) index) - (aref (store-types tree-model) index)) - -(defmethod tree-model-get-iter-impl ((model array-list-store) iter path) - (gobject:using* (iter path) - (let ((indices (tree-path-indices path))) - (when (= 1 (length indices)) - (setf (tree-iter-stamp iter) 0 (tree-iter-user-data iter) (first indices)) - t)))) - -(defmethod tree-model-ref-node-impl ((model array-list-store) iter) (gobject:release iter)) -(defmethod tree-model-unref-node-impl ((model array-list-store) iter) (gobject:release iter)) - -(defmethod tree-model-iter-next-impl ((model array-list-store) iter) - (gobject:using* (iter) - (let ((n (tree-iter-user-data iter))) - (when (< n (1- (length (store-items model)))) - (setf (tree-iter-user-data iter) (1+ n)) - t)))) - -(defmethod tree-model-iter-nth-child-impl ((model array-list-store) iter parent n) - (gobject:using* (iter parent) - (setf (tree-iter-stamp iter) 0 - (tree-iter-user-data iter) n) - t)) - -(defmethod tree-model-iter-n-children-impl ((model array-list-store) iter) - (if (cffi:null-pointer-p iter) - (length (store-items model)) - 0)) - -(defmethod tree-model-get-path-impl ((model array-list-store) iter) - (gobject:using* (iter) - (let ((path (make-instance 'tree-path))) - (setf (tree-path-indices path) (list (tree-iter-user-data iter))) - (gobject:disown-boxed-ref path) - path))) - -(defmethod tree-model-iter-has-child-impl ((model array-list-store) iter) - (gobject:release iter) - nil) - -(defmethod tree-model-get-value-impl ((model array-list-store) iter n value) - (gobject:using (iter) - (let ((n-row (tree-iter-user-data iter))) - (gobject::set-g-value value - (funcall (aref (store-getters model) n) - (aref (store-items model) n-row)) - (aref (store-types model) n))))) - -(cffi:defcfun (%gtk-tree-view-append-column "gtk_tree_view_append_column") :int - (tree-view (gobject:g-object gtk:tree-view)) - (column (gobject:g-object gtk:tree-view-column))) - -(cffi:defcfun (%gtk-tree-view-column-pack-start "gtk_tree_view_column_pack_start") :void - (tree-column (gobject:g-object gtk:tree-view-column)) - (cell (gobject:g-object gtk:cell-renderer)) - (expand :boolean)) - -(cffi:defcfun (%gtk-tree-view-column-add-attribute "gtk_tree_view_column_add_attribute") :void - (tree-column (gobject:g-object gtk:tree-view-column)) - (cell-renderer (gobject:g-object gtk:cell-renderer)) - (attribute :string) - (column-number :int)) - -(defstruct item title value) - -(defun test-treeview () - (let* ((window (make-instance 'gtk:gtk-window :type :toplevel :title "Treeview")) - (model (make-instance 'array-list-store)) - (scroll (make-instance 'gtk:scrolled-window :hscrollbar-policy :automatic :vscrollbar-policy :automatic)) - (tv (make-instance 'gtk:tree-view :headers-visible t :width-request 100 :height-request 400)) - (h-box (make-instance 'gtk:h-box)) - (v-box (make-instance 'gtk:v-box)) - (title-entry (make-instance 'gtk:entry)) - (value-entry (make-instance 'gtk:entry)) - (button (make-instance 'gtk:button :label "Add"))) - (store-add-column model "gchararray" #'item-title) - (store-add-column model "gint" #'item-value) - (store-add-item model (make-item :title "Monday" :value 1)) - (store-add-item model (make-item :title "Tuesday" :value 2)) - (store-add-item model (make-item :title "Wednesday" :value 3)) - (store-add-item model (make-item :title "Thursday" :value 4)) - (store-add-item model (make-item :title "Friday" :value 5)) - (store-add-item model (make-item :title "Saturday" :value 6)) - (store-add-item model (make-item :title "Sunday" :value 7)) - (setf (gtk:tree-view-model tv) model) - (gobject:g-signal-connect window "destroy" (lambda (w) (gobject:release w) (gtk:gtk-main-quit))) - (gobject:g-signal-connect button "clicked" (lambda (b) (gobject:release b) (store-add-item model (make-item :title (gtk:entry-text title-entry) - :value (parse-integer (gtk:entry-text value-entry) - :junk-allowed t))) - #+nil(setf (gtk:tree-view-model tv) nil) - #+nil(setf (gtk:tree-view-model tv) model))) - (gtk:container-add window v-box) - (gtk:box-pack-start v-box h-box :expand nil) - (gtk:box-pack-start h-box title-entry :expand nil) - (gtk:box-pack-start h-box value-entry :expand nil) - (gtk:box-pack-start h-box button :expand nil) - (gtk:box-pack-start v-box scroll) - (gtk:container-add scroll tv) - (let ((column (make-instance 'gtk:tree-view-column :title "Title")) - (renderer (make-instance 'gtk:cell-renderer-text :text "A text"))) - (%gtk-tree-view-column-pack-start column renderer t) - (%gtk-tree-view-column-add-attribute column renderer "text" 0) - (%gtk-tree-view-append-column tv column)) - (let ((column (make-instance 'gtk:tree-view-column :title "Value")) - (renderer (make-instance 'gtk:cell-renderer-text :text "A text"))) - (%gtk-tree-view-column-pack-start column renderer t) - (%gtk-tree-view-column-add-attribute column renderer "text" 1) - (%gtk-tree-view-append-column tv column)) - (gtk:gtk-widget-show-all window) - (gtk:gtk-main))) \ No newline at end of file diff --git a/test.boxed-ng.lisp b/test.boxed-ng.lisp deleted file mode 100644 index d8f716c..0000000 --- a/test.boxed-ng.lisp +++ /dev/null @@ -1,84 +0,0 @@ -(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))) - -- 1.7.10.4