-;; Common Lisp bindings for GTK+ v2.0
-;; Copyright (C) 2000 Espen S. Johnsen <esj@stud.cs.uit.no>
+;; Common Lisp bindings for GTK+ v2.x
+;; Copyright 2000 Espen S. Johnsen <espen@users.sf.net>
;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 2 of the License, or (at your option) any later version.
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: gcallback.lisp,v 1.23 2005-03-06 17:18:00 espen Exp $
+;; $Id: gcallback.lisp,v 1.27 2006-02-06 11:56:22 espen Exp $
(in-package "GLIB")
(gvalue-type return-value)))
(args (loop
for n from 0 below n-params
- collect (gvalue-get (sap+ param-values (* n +gvalue-size+))))))
- (let ((result (apply #'invoke-callback callback-id return-type args)))
- (when return-type
- (gvalue-set return-value result)))))
+ for offset from 0 by +gvalue-size+
+ collect (gvalue-weak-get (sap+ param-values offset)))))
+ (unwind-protect
+ (let ((result (apply #'invoke-callback callback-id return-type args)))
+ (when return-type
+ (gvalue-set return-value result)))
+ (loop
+ for arg in args
+ when (typep arg 'proxy)
+ do (invalidate-instance arg)))))
+
(defun invoke-callback (callback-id return-type &rest args)
(restart-case
;;;; Signal connecting and controlling
+(defvar *overridden-signals* (make-hash-table :test 'equalp))
+
+(defbinding %signal-override-class-closure () nil
+ (signal-id unsigned-int)
+ (type-number type-number)
+ (callback-closure pointer))
+
+
+(defun signal-override-class-closure (name type function)
+ (let* ((signal-id (ensure-signal-id-from-type name type))
+ (type-number (find-type-number type t))
+ (callback-id (gethash (cons type-number signal-id) *overridden-signals*)))
+ (if callback-id
+ (update-user-data callback-id function)
+ (multiple-value-bind (callback-closure callback-id)
+ (make-callback-closure function)
+ (%signal-override-class-closure signal-id type-number callback-closure)
+ (setf
+ (gethash (cons type-number signal-id) *overridden-signals*)
+ callback-id)))))
+
+
+(defbinding %signal-chain-from-overridden () nil
+ (args pointer)
+ (return-value (or null gvalue)))
+
+;; TODO: implement same semantics as CALL-NEXT-METHOD
+(defun %call-next-handler (n-params types args defaults return-type)
+ (let ((params (allocate-memory (* n-params +gvalue-size+))))
+ (loop
+ as tmp = args then (rest tmp)
+ for default in defaults
+ for type in types
+ for offset from 0 by +gvalue-size+
+ as arg = (if tmp (car tmp) default)
+ do (gvalue-init (sap+ params offset) type arg))
+
+ (unwind-protect
+ (if return-type
+ (with-gvalue (return-value return-type)
+ (%signal-chain-from-overridden params return-value))
+ (%signal-chain-from-overridden params nil))
+ (progn
+ (loop
+ repeat n-params
+ for offset from 0 by +gvalue-size+
+ do (gvalue-unset (sap+ params offset)))
+ (deallocate-memory params)))))
+
+
+(defmacro define-signal-handler (name ((object class) &rest args) &body body)
+ (let* ((info (signal-query (ensure-signal-id-from-type name class)))
+ (types (cons class (signal-param-types info)))
+ (n-params (1+ (slot-value info 'n-params)))
+ (return-type (type-from-number (slot-value info 'return-type)))
+ (vars (loop
+ for arg in args
+ until (eq arg '&rest)
+ collect arg))
+ (rest (cadr (member '&rest args)))
+ (next (make-symbol "ARGS")))
+
+ `(progn
+ (signal-override-class-closure ',name ',class
+ #'(lambda (,object ,@args)
+ (flet ((call-next-handler (&rest ,next)
+ (let ((defaults (list* ,object ,@vars ,rest)))
+ (%call-next-handler
+ ,n-params ',types ,next defaults ',return-type))))
+ ,@body)))
+ ',name)))
+
+
(defbinding %signal-stop-emission () nil
(instance ginstance)
(signal-id unsigned-int)
(handler-id unsigned-int))
(deftype gclosure () 'pointer)
+(register-type 'gclosure "GClosure")
(defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
(callback-id unsigned-int)
~mdw / clg / blobdiff