X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/65f5a6e1820a3671ca44181074672e350452b3f6..953030a3519ecb9d66d9f55d46f8c8b6906094ed:/glib/gerror.lisp diff --git a/glib/gerror.lisp b/glib/gerror.lisp index ed2ad71..18289d1 100644 --- a/glib/gerror.lisp +++ b/glib/gerror.lisp @@ -1,21 +1,26 @@ ;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 2005 Espen S. Johnsen +;; Copyright 2005-2006 Espen S. Johnsen ;; -;; 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.9 2007-12-29 19:21:26 espen Exp $ (in-package "GLIB") @@ -24,7 +29,9 @@ ((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)) @@ -32,17 +39,8 @@ (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)))) @@ -60,6 +58,15 @@ (error condition :code (gerror-code gerror) :message (gerror-message gerror)))) +(deftype gerror-signal () '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) @@ -93,6 +100,9 @@ (define-condition warning-log-level (log-level) ()) +(define-condition message-log-level (log-level) + ()) + (define-condition info-log-level (log-level) ()) @@ -101,10 +111,8 @@ (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 @@ -118,17 +126,21 @@ (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))