From: Dmitry Kalyanov Date: Wed, 25 Feb 2009 12:17:04 +0000 (+0300) Subject: Added signals X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=62cc89f6f3f9bfeb14da7e788e4417f7a8212976;p=cl-gtk2.git Added signals --- diff --git a/glib/gobject.foreign-gboxed.lisp b/glib/gobject.foreign-gboxed.lisp index 00aff15..ff1753a 100644 --- a/glib/gobject.foreign-gboxed.lisp +++ b/glib/gobject.foreign-gboxed.lisp @@ -326,8 +326,11 @@ (gethash name *registered-boxed-types*)) (defun set-gvalue-boxed (gvalue value) - (declare (ignore gvalue value)) - (error "Can not set GBoxed!")) + (if value + (progn + (unless (typep value 'g-boxed-ref) (error "Can only set g-boxed-ref!")) + (g-value-set-boxed gvalue (pointer value))) + (g-value-set-boxed gvalue (null-pointer)))) (defun parse-gvalue-boxed (gvalue) (let* ((g-type (gvalue-type gvalue)) diff --git a/glib/gobject.foreign-gobject-subclassing.lisp b/glib/gobject.foreign-gobject-subclassing.lisp index 4a195ad..53b424d 100644 --- a/glib/gobject.foreign-gobject-subclassing.lisp +++ b/glib/gobject.foreign-gobject-subclassing.lisp @@ -48,7 +48,8 @@ (1- (ash 1 (* 8 (foreign-type-size type)))))) (defun property->param-spec (property) - (destructuring-bind (property-name property-type property-get-fn property-set-fn) property + (destructuring-bind (property-name property-type accessor property-get-fn property-set-fn) property + (declare (ignore accessor)) (let ((property-g-type (ensure-g-type property-type)) (flags (append (when property-get-fn (list :readable)) (when property-set-fn (list :writable))))) @@ -76,6 +77,77 @@ ;(+g-type-interface+ ) (t (error "Unknown type: ~A (~A)" property-g-type (g-type-name property-g-type))))))) +(defun install-properties (class) + (let* ((name (g-type-name (foreign-slot-value class 'g-type-class 'type))) + (lisp-type-info (gethash name *registered-types*))) + (iter (for property in (object-type-properties lisp-type-info)) + (for param-spec = (property->param-spec property)) + (for property-id from 123) + (debugf "installing property ~A~%" property) + (g-object-class-install-property class property-id param-spec)))) + +(defun vtable-item->cstruct-item (item) + (if (eq :skip (first item)) + (rest item) + (list (first item) :pointer))) + +(defstruct vtable-method-info name return-type args callback-name) + +(defmethod make-load-form ((object vtable-method-info) &optional environment) + (declare (ignore environment)) + `(make-vtable-method-info :name ',(vtable-method-info-name object) + :return-type ',(vtable-method-info-return-type object) + :args ',(vtable-method-info-args object) + :callback-name ',(vtable-method-info-callback-name object))) + +(defun vtable-methods (items) + (iter (for item in items) + (when (eq :skip (first item)) (next-iteration)) + (destructuring-bind (name callback-name return-type &rest args) item + (collect (make-vtable-method-info :name name :return-type return-type :args args :callback-name callback-name))))) + +(defvar *vtables* (make-hash-table :test 'equal)) + +(defstruct vtable-description type-name cstruct-name methods) + +(defmacro define-vtable ((type-name cstruct-name) &body items) + `(progn + (defcstruct ,cstruct-name ,@(mapcar #'vtable-item->cstruct-item items)) + (setf (gethash ,type-name *vtables*) + (make-vtable-description :type-name ,type-name :cstruct-name ',cstruct-name :methods (list ,@(mapcar #'make-load-form (vtable-methods items))))) + ,@(iter (for method in (vtable-methods items)) + (collect `(defgeneric ,(vtable-method-info-name method) (,@(mapcar #'first (vtable-method-info-args method))))) + (collect `(defcallback ,(vtable-method-info-callback-name method) ,(vtable-method-info-return-type method) + (,@(vtable-method-info-args method)) + (restart-case + (,(vtable-method-info-name method) ,@(mapcar #'first (vtable-method-info-args method))) + (return-from-interface-method-implementation (v) :interactive (lambda () (list (eval (read)))) v))))))) + +(defun interface-init (iface data) + (bind (((class-name interface-name) (prog1 (get-stable-pointer-value data) (free-stable-pointer data))) + (vtable (gethash interface-name *vtables*)) + (vtable-cstruct (vtable-description-cstruct-name vtable))) + (debugf "interface-init for class ~A and interface ~A~%" class-name interface-name) + (iter (for method in (vtable-description-methods vtable)) + (setf (foreign-slot-value iface vtable-cstruct (vtable-method-info-name method)) (get-callback (vtable-method-info-callback-name method)))))) + +(defcallback c-interface-init :void ((iface :pointer) (data :pointer)) + (interface-init iface data)) + +(defun add-interface (name interface) + (let* ((interface-info (list name interface)) + (interface-info-ptr (allocate-stable-pointer interface-info))) + (with-foreign-object (info 'g-interface-info) + (setf (foreign-slot-value info 'g-interface-info 'interface-init) (callback c-interface-init) + (foreign-slot-value info 'g-interface-info 'interface-data) interface-info-ptr) + (g-type-add-interface-static (g-type-from-name name) (ensure-g-type interface) info)))) + +(defun add-interfaces (name) + (let* ((lisp-type-info (gethash name *registered-types*)) + (interfaces (object-type-interfaces lisp-type-info))) + (iter (for interface in interfaces) + (add-interface name interface)))) + (defun class-init (class data) (declare (ignore data)) (debugf "class-init for ~A~%" (g-type-name (g-type-from-class class))) @@ -83,14 +155,8 @@ (callback c-object-property-get) (foreign-slot-value class 'g-object-class 'set-property) (callback c-object-property-set)) - (let* ((name (g-type-name (foreign-slot-value class 'g-type-class 'type))) - (lisp-type-info (gethash name *registered-types*))) - (iter (for property in (object-type-properties lisp-type-info)) - (for param-spec = (property->param-spec property)) - (for property-id from 123) - (debugf "installing property ~A~%" property) - (g-object-class-install-property class property-id param-spec))) - ) + + (install-properties class)) (defun object-property-get (object property-id g-value pspec) (declare (ignore property-id)) @@ -100,7 +166,7 @@ (type-name (g-type-name (foreign-slot-value pspec 'g-param-spec 'owner-type))) (lisp-type-info (gethash type-name *registered-types*)) (property-info (find property-name (object-type-properties lisp-type-info) :test 'string= :key 'first)) - (property-get-fn (third property-info))) + (property-get-fn (fourth property-info))) (debugf "get(~A,'~A')~%" lisp-object property-name) (let ((value (restart-case (funcall property-get-fn lisp-object) @@ -117,7 +183,7 @@ (type-name (g-type-name (foreign-slot-value pspec 'g-param-spec 'owner-type))) (lisp-type-info (gethash type-name *registered-types*)) (property-info (find property-name (object-type-properties lisp-type-info) :test 'string= :key 'first)) - (property-set-fn (fourth property-info)) + (property-set-fn (fifth property-info)) (new-value (parse-gvalue value))) (debugf "set(~A,'~A',~A)~%" lisp-object property-name new-value) (restart-case @@ -125,20 +191,27 @@ (return-without-error-from-property-setter () nil)))) (defcallback c-object-property-set :void ((object :pointer) (property-id :uint) (value :pointer) (pspec :pointer)) - (debugf "c-setter") (object-property-set object property-id value pspec)) (defmacro register-object-type-implementation (name class parent interfaces properties) (unless (stringp parent) (setf parent (g-type-name (ensure-g-type parent)))) `(progn - (setf (gethash ,name *registered-types*) (make-object-type :name ,name :class ',class :parent ,parent :interfaces ,interfaces :properties ,properties)) + (setf (gethash ,name *registered-types*) (make-object-type :name ,name :class ',class :parent ,parent :interfaces ',interfaces :properties ',properties)) (with-foreign-object (query 'g-type-query) (g-type-query (g-type-from-name ,parent) query) (with-foreign-slots ((class-size instance-size) query g-type-query) (g-type-register-static-simple (g-type-from-name ,parent) ,name class-size (callback c-class-init) instance-size (callback c-instance-init) nil))) + (add-interfaces ,name) (defmethod initialize-instance :before ((object ,class) &key pointer) (unless (or pointer (and (slot-boundp object 'gobject::pointer) (gobject::pointer object))) (setf (gobject::pointer object) (gobject::g-object-call-constructor ,name nil nil) - (gobject::g-object-has-reference object) t))))) \ No newline at end of file + (gobject::g-object-has-reference object) t))) + (progn + ,@(iter (for (prop-name prop-type prop-accessor prop-reader prop-writer) in properties) + (when prop-reader + (collect `(defun ,prop-accessor (object) (g-object-call-get-property object ,prop-name)))) + (when prop-writer + (collect `(defun (setf ,prop-accessor) (new-value object) (g-object-call-set-property object ,prop-name new-value)))))) + ,name)) \ No newline at end of file diff --git a/glib/gobject.signals.lisp b/glib/gobject.signals.lisp index 1531f16..8659cd1 100644 --- a/glib/gobject.signals.lisp +++ b/glib/gobject.signals.lisp @@ -4,4 +4,57 @@ (instance :pointer) (detailed-signal :string) (closure (:pointer g-closure)) - (after :boolean)) \ No newline at end of file + (after :boolean)) + +(defcfun g-signal-emitv :void + (instance-and-params (:pointer g-value)) + (signal-id :uint) + (detail g-quark) + (return-value (:pointer g-value))) + +(defcfun g-signal-lookup :uint + (name :string) + (type g-type)) + +(defbitfield g-signal-flags + :run-first :run-last :run-cleanup :no-recurse :detailed :action :no-hooks) + +(defcstruct g-signal-query + (signal-id :uint) + (signal-name :string) + (owner-type g-type) + (signal-flags g-signal-flags) + (return-type g-type) + (n-params :uint) + (param-types (:pointer g-type))) + +(defcfun g-signal-query :void + (signal-id :uint) + (query (:pointer g-signal-query))) + +(defun unmangle-type (type) + (logxor type (ldb (byte 1 0) type)));;subtract the G_SIGNAL_TYPE_STATIC_SCOPE + +(defun emit-signal (object signal-name &rest args) + (let ((signal-id (g-signal-lookup signal-name (g-type-from-object (pointer object))))) + (when (= signal-id 0) + (error "Signal ~A not found on object ~A" signal-name object)) + (with-foreign-object (q 'g-signal-query) + (g-signal-query signal-id q) + (with-foreign-object (params 'g-value (+ 1 (foreign-slot-value q 'g-signal-query 'n-params))) + (set-g-value (mem-aref params 'g-value 0) object (g-type-from-object (pointer object)) :zero-g-value t) + (iter (for i from 0 below (foreign-slot-value q 'g-signal-query 'n-params)) + (for arg in args) + (for type = (unmangle-type (mem-aref (foreign-slot-value q 'g-signal-query 'param-types) 'g-type i))) + (set-g-value (mem-aref params 'g-value (1+ i)) arg type :zero-g-value t)) + (with-foreign-object (return-value 'g-value) + (g-value-zero return-value) + (g-value-init return-value (foreign-slot-value q 'g-signal-query 'return-type)) + (g-signal-emitv params signal-id signal-name return-value) + (prog1 (if (= (foreign-slot-value q 'g-signal-query 'return-type) + +g-type-void+) + (values) + (parse-gvalue return-value)) + (g-value-unset return-value) + (iter (for i from 0 below (foreign-slot-value q 'g-signal-query 'n-params)) + (g-value-unset (mem-aref params 'g-value (1+ i)))))))))) \ No newline at end of file