projects
/
cl-gtk2.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Add impl-call option to define-vtable
[cl-gtk2.git]
/
glib
/
gobject.foreign-gobject-subclassing.lisp
diff --git
a/glib/gobject.foreign-gobject-subclassing.lisp
b/glib/gobject.foreign-gobject-subclassing.lisp
index
9914135
..
da188c5
100644
(file)
--- a/
glib/gobject.foreign-gobject-subclassing.lisp
+++ b/
glib/gobject.foreign-gobject-subclassing.lisp
@@
-78,7
+78,7
@@
(rest item)
(list (first item) :pointer)))
(rest item)
(list (first item) :pointer)))
-(defstruct vtable-method-info slot-name name return-type args callback-name)
+(defstruct vtable-method-info slot-name name return-type args callback-name impl-call)
(defmethod make-load-form ((object vtable-method-info) &optional environment)
(declare (ignore environment))
(defmethod make-load-form ((object vtable-method-info) &optional environment)
(declare (ignore environment))
@@
-91,14
+91,15
@@
(defun vtable-methods (iface-name items)
(iter (for item in items)
(when (eq :skip (first item)) (next-iteration))
(defun vtable-methods (iface-name items)
(iter (for item in items)
(when (eq :skip (first item)) (next-iteration))
- (destructuring-bind (name return-type &rest args) item
+ (destructuring-bind (name (return-type &rest args) &key impl-call) item
(for method-name = (intern (format nil "~A-~A-IMPL" (symbol-name iface-name) (symbol-name name))))
(for callback-name = (intern (format nil "~A-~A-CALLBACK" (symbol-name iface-name) (symbol-name name))))
(collect (make-vtable-method-info :slot-name name
:name method-name
:return-type return-type
:args args
(for method-name = (intern (format nil "~A-~A-IMPL" (symbol-name iface-name) (symbol-name name))))
(for callback-name = (intern (format nil "~A-~A-CALLBACK" (symbol-name iface-name) (symbol-name name))))
(collect (make-vtable-method-info :slot-name name
:name method-name
:return-type return-type
:args args
- :callback-name callback-name)))))
+ :callback-name callback-name
+ :impl-call impl-call)))))
(defvar *vtables* (make-hash-table :test 'equal))
(defvar *vtables* (make-hash-table :test 'equal))
@@
-114,13
+115,19
@@
:cstruct-name ',cstruct-name
:methods (list ,@(mapcar #'make-load-form methods))))
,@(iter (for method in methods)
:cstruct-name ',cstruct-name
:methods (list ,@(mapcar #'make-load-form methods))))
,@(iter (for method in methods)
- (collect `(defgeneric ,(vtable-method-info-name method)
- (,@(mapcar #'first (vtable-method-info-args method)))))
+ (for args =
+ (if (vtable-method-info-impl-call method)
+ (first (vtable-method-info-impl-call method))
+ (mapcar #'first (vtable-method-info-args method))))
+ (collect `(defgeneric ,(vtable-method-info-name method) (,@args)))
(collect `(glib-defcallback ,(vtable-method-info-callback-name method)
,(vtable-method-info-return-type method)
(,@(vtable-method-info-args method))
(collect `(glib-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)))
+ (restart-case
+ ,(if (vtable-method-info-impl-call method)
+ `(progn ,@(rest (vtable-method-info-impl-call method)))
+ `(,(vtable-method-info-name method)
+ ,@(mapcar #'first (vtable-method-info-args method))))
(return-from-interface-method-implementation (v)
:interactive (lambda () (list (eval (read)))) v))))))))
(return-from-interface-method-implementation (v)
:interactive (lambda () (list (eval (read)))) v))))))))