1: ;;;
    2: ;;; exclib.stub - exceptions
    3: ;;;  
    4: ;;;   Copyright (c) 2000-2007  Shiro Kawai  <shiro@acm.org>
    5: ;;;   
    6: ;;;   Redistribution and use in source and binary forms, with or without
    7: ;;;   modification, are permitted provided that the following conditions
    8: ;;;   are met:
    9: ;;;   
   10: ;;;   1. Redistributions of source code must retain the above copyright
   11: ;;;      notice, this list of conditions and the following disclaimer.
   12: ;;;  
   13: ;;;   2. Redistributions in binary form must reproduce the above copyright
   14: ;;;      notice, this list of conditions and the following disclaimer in the
   15: ;;;      documentation and/or other materials provided with the distribution.
   16: ;;;  
   17: ;;;   3. Neither the name of the authors nor the names of its contributors
   18: ;;;      may be used to endorse or promote products derived from this
   19: ;;;      software without specific prior written permission.
   20: ;;;  
   21: ;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22: ;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23: ;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
   24: ;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
   25: ;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
   26: ;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
   27: ;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
   28: ;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
   29: ;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
   30: ;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
   31: ;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
   32: ;;;  
   33: ;;; $Id: exclib.stub,v 1.22 2007/05/20 04:55:24 shirok Exp $
   34: ;;;
   35: 
   36: "
   37: #include <gauche/class.h>
   38: #include <gauche/exception.h>
   39: "
   40: 
   41: ;;
   42: ;; Exception procedures
   43: ;;
   44: 
   45: ;; NB: rewind-before keyword arg is EXPERIMENTAL.
   46: (define-cproc with-error-handler (handler thunk
   47:                                   &keyword (rewind-before::<boolean> #f))
   48:   (body <top>
   49:         (unless (SCM_PROCEDURE_TAKE_NARG_P handler 1)
   50:           (Scm_Error "error handler must take at least 1 argument, but got %S"
   51:                      handler))
   52:         (unless (SCM_PROCEDURE_THUNK_P thunk)
   53:           (Scm_Error "thunk required, but got %S" thunk))
   54:         (if rewind-before
   55:           (result (Scm_VMWithGuardHandler handler thunk))
   56:           (result (Scm_VMWithErrorHandler handler thunk)))))
   57: 
   58: ;; srfi-18 primitive exception mechanism
   59: (define-cproc current-exception-handler ()
   60:   (expr <top> (-> (Scm_VM) exceptionHandler)))
   61: 
   62: (define-cproc with-exception-handler (handler thunk)
   63:   (call "Scm_VMWithExceptionHandler"))
   64: 
   65: (define-cproc raise (exception) (call "Scm_Raise"))
   66: 
   67: (define-cproc report-error (exception) (call <void> "Scm_ReportError"))
   68: 
   69: ;;
   70: ;; Condition procedures (srfi-35)
   71: ;;
   72: 
   73: (define-cproc condition? (obj)
   74:   (call <boolean> "SCM_CONDITIONP"))
   75: 
   76: (define-cproc condition-has-type? (c k)
   77:   (call <boolean> "Scm_ConditionHasType"))
   78: 
   79: (define-cproc make-compound-condition (&rest conditions)
   80:   (call "Scm_MakeCompoundCondition"))
   81: 
   82: 
   83: ;; Local variables:
   84: ;; mode: scheme
   85: ;; end: