;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: gtkwidget.lisp,v 1.24 2006/09/05 13:37:07 espen Exp $
+;; $Id: gtkwidget.lisp,v 1.27 2007/02/19 14:29:33 espen Exp $
(in-package "GTK")
((call-next-method))))
-(defmethod compute-signal-function ((widget widget) signal function object)
+(defmethod compute-signal-function ((widget widget) signal function object args)
(declare (ignore signal))
(if (eq object :parent)
- #'(lambda (&rest args)
- (if (slot-boundp widget 'parent)
- (apply function (widget-parent widget) (rest args))
+ #'(lambda (&rest emission-args)
+ (let ((all-args (nconc (rest emission-args) args)))
+ (if (slot-boundp widget 'parent)
+ (apply function (widget-parent widget) all-args)
;; Delay until parent is set
(signal-connect widget 'parent-set
#'(lambda (old-parent)
(let ((*signal-stop-emission*
#'(lambda ()
(warn "Ignoring emission stop in delayed signal handler"))))
- (apply function (widget-parent widget) (rest args))))
+ (apply function (widget-parent widget) all-args)))
:remove t)
; (warn "Widget has no parent -- ignoring signal")
- ))
+ )))
(call-next-method)))
(defun child-property-value (widget slot)
for widget in (mklist root)
do (cond
((and (slot-boundp widget 'name) (string= name (widget-name widget)))
- (return widget))
+ (return-from widget-find widget))
((typep widget 'container)
(let ((descendant (widget-find name (container-children widget) nil)))
(when descendant
- (return descendant))))))
+ (return-from widget-find descendant))))))
(when error-p
(error "Widget not found: ~A" name)))
(defbinding widget-reset-shapes () nil
(widget widget))
-;; (defbinding widget-set-double-buffered () nil
-;; (widget widget)
-;; (double-buffered boolean))
+(defbinding widget-set-double-buffered () nil
+ (widget widget)
+ (double-buffered boolean))
;; (defbinding widget-set-redraw-on-allocate () nil
;; (widget widget)