;; Common Lisp bindings for GTK+ v2.0
-;; Copyright (C) 2005 Espen S. Johnsen <espen@users.sf.net>
+;; Copyright 2005-2006 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: gerror.lisp,v 1.1 2005-02-14 00:39:39 espen Exp $
+;; $Id: gerror.lisp,v 1.10 2008-04-11 20:35:48 espen Exp $
(in-package "GLIB")
((domain :allocation :alien :type quark :reader gerror-domain)
(code :allocation :alien :type int :reader gerror-code)
(message :allocation :alien :type string :reader gerror-message))
- (:metaclass struct-class))
+ (:metaclass struct-class)
+ (:ref %gerror-copy)
+ (:unref %gerror-free))
(defbinding (%gerror-copy "g_error_copy") () pointer
(location pointer))
(defbinding (%gerror-free "g_error_free") () nil
(location pointer))
-(defmethod reference-foreign ((class (eql (find-class 'gerror))) location)
- (declare (ignore class))
- (%gerror-copy location))
-
-(defmethod unreference-foreign ((class (eql (find-class 'gerror))) location)
- (declare (ignore class))
- (%gerror-free location))
-
-
(define-condition glib-error (error)
- ((code :initarg :domain :reader gerror-code)
+ ((code :initarg :code :reader gerror-code)
(message :initarg :message :reader gerror-message))
(:report (lambda (condition stream)
(write-string (gerror-message condition) stream))))
(error condition :code (gerror-code gerror) :message (gerror-message gerror))))
+(deftype gerror-signal () 'gerror)
+
+(define-type-method return-type ((type gerror-signal))
+ (declare (ignore type))
+ '(or null gerror))
+
+(define-type-method from-alien-form ((type gerror-signal) gerror &key (ref :free))
+ (declare (ignore type))
+ `(let ((gerror ,(from-alien-form 'gerror gerror :ref ref)))
+ (when gerror
+ (signal-gerror gerror))))
+
+
;;; Message logging
(eval-when (:compile-toplevel :load-toplevel :execute)
(define-condition warning-log-level (log-level)
())
+(define-condition message-log-level (log-level)
+ ())
+
(define-condition info-log-level (log-level)
())
(defparameter *fatal-log-levels* '(error-log-level critical-log-level))
-(defcallback log-handler (nil
- (domain (copy-of string))
- (log-level log-levels)
- (message (copy-of string)))
+(define-callback log-handler nil
+ ((domain string) (log-level log-levels) (message string))
(let ((fatal-p (or
(find :fatal log-level)
(some
(funcall (if fatal-p #'error #'warn) condition
:domain domain :message message)))
-(setf (extern-alien "log_handler" system-area-pointer) (callback log-handler))
+#-clisp
+(setf
+ #+cmu(alien:extern-alien "log_handler" alien:system-area-pointer)
+ #+sbcl(sb-alien:extern-alien "log_handler" sb-alien:system-area-pointer)
+ (callback-address log-handler))
-#+glib2.6
+#?(pkg-exists-p "glib-2.0" :atleast-version "2.6.0")
(progn
;; Unfortunately this will only work as long as we don't abort to
;; toplevel from within the log handler. If we do that, the next
;; invocation of g_log will be handled as a recursion and cause an
;; abort (SIGABORT being signaled). To make things even worse, SBCL
;; doesn't handle SIGABRT at all.
- (defbinding %log-set-default-handler () pointer
- ((callback log-handler) pointer)
+ (defbinding %log-set-default-handler (nil) pointer
+ (log-handler callback)
(nil null))
(%log-set-default-handler))
~mdw / clg / blobdiff