mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
Add (ice-9 exceptions) module
* module/ice-9/exceptions.scm: New file, derived from (rnrs conditions). Perhaps unadvisedly, in this file I've renamed a number of the identifiers. I have never found that the R6RS identifiers made sense to me. For now this is an internal module that R6RS and SRFI-35 will be based on. * module/Makefile.am (SOURCES): Add the new file. * module/rnrs/conditions.scm (rnrs): Export renamed identifiers from (ice-9 exceptions).
This commit is contained in:
Andy Wingo
parent
90d52a9e1d
commit
54ab2175f9
3 changed files with 271 additions and 104 deletions
|
|
@ -57,6 +57,7 @@ SOURCES = \
|
|||
ice-9/documentation.scm \
|
||||
ice-9/eval-string.scm \
|
||||
ice-9/eval.scm \
|
||||
ice-9/exceptions.scm \
|
||||
ice-9/expect.scm \
|
||||
ice-9/fdes-finalizers.scm \
|
||||
ice-9/format.scm \
|
||||
|
|
|
|||
226
module/ice-9/exceptions.scm
Normal file
226
module/ice-9/exceptions.scm
Normal file
|
|
@ -0,0 +1,226 @@
|
|||
;;; Exceptions
|
||||
;;; Copyright (C) 2019 Free Software Foundation, Inc.
|
||||
;;;
|
||||
;;; 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 3 of the
|
||||
;;; License, or (at your option) any later version.
|
||||
;;;
|
||||
;;; 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.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU Lesser General Public
|
||||
;;; License along with this program. If not, see
|
||||
;;; <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; Definition of the standard exception types.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
|
||||
(define-module (ice-9 exceptions)
|
||||
#:export (&exception
|
||||
make-exception
|
||||
make-exception-type
|
||||
simple-exceptions
|
||||
exception?
|
||||
exception-predicate
|
||||
exception-accessor
|
||||
define-exception-type
|
||||
|
||||
&message
|
||||
make-exception-with-message
|
||||
exception-with-message?
|
||||
exception-message
|
||||
|
||||
&warning
|
||||
make-warning
|
||||
warning?
|
||||
|
||||
&error
|
||||
make-error
|
||||
error?
|
||||
|
||||
&external-error
|
||||
make-external-error
|
||||
external-error?
|
||||
|
||||
&programming-error
|
||||
make-programming-error
|
||||
programming-error?
|
||||
|
||||
&assertion-failure
|
||||
make-assertion-failure
|
||||
assertion-failure?
|
||||
|
||||
&irritants
|
||||
make-exception-with-irritants
|
||||
exception-with-irritants?
|
||||
exception-irritants
|
||||
|
||||
&origin
|
||||
make-exception-with-origin
|
||||
exception-with-origin?
|
||||
exception-origin
|
||||
|
||||
&non-continuable
|
||||
make-non-continuable-error
|
||||
non-continuable-error?
|
||||
|
||||
&implementation-restriction
|
||||
make-implementation-restriction-error
|
||||
implementation-restriction-error?
|
||||
|
||||
&lexical
|
||||
make-lexical-error
|
||||
lexical-error?
|
||||
|
||||
&syntax
|
||||
make-syntax-error
|
||||
syntax-error?
|
||||
syntax-error-form
|
||||
syntax-error-subform
|
||||
|
||||
&undefined-variable
|
||||
make-undefined-variable-error
|
||||
undefined-variable-error?))
|
||||
|
||||
(define &exception (make-record-type '&exception '() #:extensible? #t))
|
||||
(define simple-exception? (record-predicate &exception))
|
||||
|
||||
(define &compound-exception (make-record-type '&compound-exception
|
||||
'((immutable components))))
|
||||
(define compound-exception? (record-predicate &compound-exception))
|
||||
(define make-compound-exception (record-constructor &compound-exception))
|
||||
|
||||
(define simple-exceptions
|
||||
(let ((compound-ref (record-accessor &compound-exception 'components)))
|
||||
(lambda (exception)
|
||||
"Return a list of the simple exceptions that compose the exception
|
||||
object @var{exception}."
|
||||
(cond ((compound-exception? exception)
|
||||
(compound-ref exception))
|
||||
((simple-exception? exception)
|
||||
(list exception))
|
||||
(else
|
||||
(error "not a exception" exception))))))
|
||||
|
||||
(define make-exception
|
||||
(lambda exceptions
|
||||
(let ((simple
|
||||
(let flatten ((exceptions exceptions))
|
||||
(if (null? exceptions)
|
||||
'()
|
||||
(append (simple-exceptions (car exceptions))
|
||||
(flatten (cdr exceptions)))))))
|
||||
(if (and (pair? simple) (null? (cdr simple)))
|
||||
(car simple)
|
||||
(make-compound-exception simple)))))
|
||||
|
||||
(define (exception? obj)
|
||||
"Return true if @var{obj} is an exception."
|
||||
(or (compound-exception? obj) (simple-exception? obj)))
|
||||
|
||||
(define (exception-type? obj)
|
||||
"Return true if OBJ is an exception type."
|
||||
(and (record-type? obj)
|
||||
(record-type-has-parent? obj &exception)))
|
||||
|
||||
(define (make-exception-type id parent field-names)
|
||||
"Return a new exception type named @var{id}, inheriting from
|
||||
@var{parent}, and with the fields whose names are listed in
|
||||
@var{field-names}. @var{field-names} must be a list of symbols and must
|
||||
not contain names already used by @var{parent} or one of its
|
||||
supertypes."
|
||||
(unless (exception-type? parent)
|
||||
(error "parent is not a exception type" parent))
|
||||
(unless (and-map symbol? field-names)
|
||||
(error "field names should be a list of symbols" field-names))
|
||||
(make-record-type id field-names #:parent parent #:extensible? #t))
|
||||
|
||||
(define (exception-predicate rtd)
|
||||
"Return a procedure that will return true if its argument is a simple
|
||||
exception that is an instance of @var{rtd}, or a compound exception
|
||||
composed of such an instance."
|
||||
(let ((rtd-predicate (record-predicate rtd)))
|
||||
(lambda (obj)
|
||||
(cond ((compound-exception? obj)
|
||||
(or-map rtd-predicate (simple-exceptions obj)))
|
||||
(else (rtd-predicate obj))))))
|
||||
|
||||
(define (exception-accessor rtd proc)
|
||||
(let ((rtd-predicate (record-predicate rtd)))
|
||||
(lambda (obj)
|
||||
(if (rtd-predicate obj)
|
||||
(proc obj)
|
||||
(let lp ((exceptions (if (compound-exception? obj)
|
||||
(simple-exceptions obj)
|
||||
'())))
|
||||
(when (null? exceptions)
|
||||
(error "object is not an exception of the right type" obj rtd))
|
||||
(if (rtd-predicate (car exceptions))
|
||||
(proc (car exceptions))
|
||||
(lp (cdr exceptions))))))))
|
||||
|
||||
(define-syntax define-exception-type
|
||||
(syntax-rules ()
|
||||
((_ exception-type supertype constructor predicate
|
||||
(field accessor) ...)
|
||||
(begin
|
||||
(define exception-type
|
||||
(make-record-type 'exception-type '((immutable field) ...)
|
||||
#:parent supertype #:extensible? #t))
|
||||
(define constructor (record-constructor exception-type))
|
||||
(define predicate (exception-predicate exception-type))
|
||||
(define accessor
|
||||
(exception-accessor exception-type
|
||||
(record-accessor exception-type 'field)))
|
||||
...))))
|
||||
|
||||
(define-exception-type &error &exception
|
||||
make-error error?)
|
||||
(define-exception-type &programming-error &error
|
||||
make-programming-error programming-error?)
|
||||
(define-exception-type &assertion-failure &programming-error
|
||||
make-assertion-failure assertion-failure?)
|
||||
|
||||
(define-exception-type &message &exception
|
||||
make-exception-with-message exception-with-message?
|
||||
(message exception-message))
|
||||
|
||||
(define-exception-type &warning &exception
|
||||
make-warning warning?)
|
||||
|
||||
(define-exception-type &external-error &error
|
||||
make-external-error external-error?)
|
||||
|
||||
(define-exception-type &irritants &exception
|
||||
make-exception-with-irritants exception-with-irritants?
|
||||
(irritants exception-irritants))
|
||||
|
||||
(define-exception-type &origin &exception
|
||||
make-exception-with-origin exception-with-origin?
|
||||
(origin exception-origin))
|
||||
|
||||
(define-exception-type &non-continuable &programming-error
|
||||
make-non-continuable-error
|
||||
non-continuable-error?)
|
||||
|
||||
(define-exception-type &implementation-restriction &programming-error
|
||||
make-implementation-restriction-error
|
||||
implementation-restriction-error?)
|
||||
|
||||
(define-exception-type &lexical &programming-error
|
||||
make-lexical-error lexical-error?)
|
||||
|
||||
(define-exception-type &syntax &programming-error
|
||||
make-syntax-error syntax-error?
|
||||
(form syntax-error-form)
|
||||
(subform syntax-error-subform))
|
||||
|
||||
(define-exception-type &undefined-variable &programming-error
|
||||
make-undefined-variable-error undefined-variable-error?)
|
||||
|
|
@ -82,119 +82,59 @@
|
|||
&undefined
|
||||
make-undefined-violation
|
||||
undefined-violation?)
|
||||
(import (only (guile)
|
||||
and=>
|
||||
make-record-type
|
||||
record-constructor
|
||||
record-predicate
|
||||
record-accessor)
|
||||
(rnrs base (6))
|
||||
(rnrs lists (6)))
|
||||
(import (rename (ice-9 exceptions)
|
||||
(&exception &condition)
|
||||
(make-exception condition)
|
||||
(simple-exceptions simple-conditions)
|
||||
(exception? condition?)
|
||||
(exception-predicate condition-predicate)
|
||||
(exception-accessor condition-accessor)
|
||||
(define-exception-type define-condition-type)
|
||||
|
||||
(define &condition (make-record-type '&condition '() #:extensible? #t))
|
||||
(define simple-condition? (record-predicate &condition))
|
||||
(make-exception-with-message make-message-condition)
|
||||
(exception-with-message? message-condition?)
|
||||
(exception-message condition-message)
|
||||
|
||||
(define &compound-condition (make-record-type '&compound-condition
|
||||
'((immutable components))))
|
||||
(define compound-condition? (record-predicate &compound-condition))
|
||||
(define make-compound-condition (record-constructor &compound-condition))
|
||||
(&error &serious)
|
||||
(make-error make-serious-condition)
|
||||
(error? serious-condition?)
|
||||
|
||||
(define simple-conditions
|
||||
(let ((compound-ref (record-accessor &compound-condition 'components)))
|
||||
(lambda (condition)
|
||||
(cond ((compound-condition? condition)
|
||||
(compound-ref condition))
|
||||
((simple-condition? condition)
|
||||
(list condition))
|
||||
(else
|
||||
(assertion-violation 'simple-conditions
|
||||
"not a condition"
|
||||
condition))))))
|
||||
(&external-error &error)
|
||||
(make-external-error make-error)
|
||||
(external-error? error?)
|
||||
|
||||
(define (condition? obj)
|
||||
(or (compound-condition? obj) (simple-condition? obj)))
|
||||
(&programming-error &violation)
|
||||
(make-programming-error make-violation)
|
||||
(programming-error? violation?)
|
||||
|
||||
(define condition
|
||||
(lambda conditions
|
||||
(define (flatten cond)
|
||||
(if (compound-condition? cond) (simple-conditions cond) (list cond)))
|
||||
(or (for-all condition? conditions)
|
||||
(assertion-violation 'condition "non-condition argument" conditions))
|
||||
(if (or (null? conditions) (> (length conditions) 1))
|
||||
(make-compound-condition (apply append (map flatten conditions)))
|
||||
(car conditions))))
|
||||
|
||||
(define (condition-predicate rtd)
|
||||
(let ((rtd-predicate (record-predicate rtd)))
|
||||
(lambda (obj)
|
||||
(cond ((compound-condition? obj)
|
||||
(exists rtd-predicate (simple-conditions obj)))
|
||||
((simple-condition? obj) (rtd-predicate obj))
|
||||
(else #f)))))
|
||||
(&assertion-failure &assertion-violation)
|
||||
(make-assertion-failure make-assertion-violation)
|
||||
(assertion-failure? assertion-violation?)
|
||||
|
||||
(define (condition-accessor rtd proc)
|
||||
(let ((rtd-predicate (record-predicate rtd)))
|
||||
(lambda (obj)
|
||||
(cond ((rtd-predicate obj) (proc obj))
|
||||
((compound-condition? obj)
|
||||
(and=> (find rtd-predicate (simple-conditions obj)) proc))
|
||||
(else #f)))))
|
||||
(make-exception-with-irritants make-irritants-condition)
|
||||
(exception-with-irritants? irritants-condition?)
|
||||
(exception-irritants condition-irritants)
|
||||
|
||||
(define-syntax define-condition-type
|
||||
(syntax-rules ()
|
||||
((_ condition-type supertype constructor predicate
|
||||
(field accessor) ...)
|
||||
(begin
|
||||
(define condition-type
|
||||
(make-record-type 'condition-type '((immutable field) ...)
|
||||
#:parent supertype #:extensible? #t))
|
||||
(define constructor (record-constructor condition-type))
|
||||
(define predicate (condition-predicate condition-type))
|
||||
(define accessor
|
||||
(condition-accessor condition-type
|
||||
(record-accessor condition-type 'field)))
|
||||
...))))
|
||||
(make-exception-with-origin make-who-condition)
|
||||
(exception-with-origin? who-condition?)
|
||||
(exception-origin condition-who)
|
||||
|
||||
(define-condition-type &serious &condition
|
||||
make-serious-condition serious-condition?)
|
||||
(define-condition-type &violation &serious
|
||||
make-violation violation?)
|
||||
(define-condition-type &assertion &violation
|
||||
make-assertion-violation assertion-violation?)
|
||||
(make-non-continuable-error make-non-continuable-violation)
|
||||
(non-continuable-error? non-continuable-violation?)
|
||||
|
||||
(define-condition-type &message &condition
|
||||
make-message-condition message-condition?
|
||||
(message condition-message))
|
||||
(make-implementation-restriction-error
|
||||
make-implementation-restriction-violation)
|
||||
(implementation-restriction-error?
|
||||
implementation-restriction-violation?)
|
||||
|
||||
(define-condition-type &warning &condition
|
||||
make-warning warning?)
|
||||
(make-lexical-error make-lexical-violation)
|
||||
(lexical-error? lexical-violation?)
|
||||
|
||||
(define-condition-type &error &serious
|
||||
make-error error?)
|
||||
(make-syntax-error make-syntax-violation)
|
||||
(syntax-error? syntax-violation?)
|
||||
(syntax-error-form syntax-violation-form)
|
||||
(syntax-error-subform syntax-violation-subform)
|
||||
|
||||
(define-condition-type &irritants &condition
|
||||
make-irritants-condition irritants-condition?
|
||||
(irritants condition-irritants))
|
||||
|
||||
(define-condition-type &who &condition
|
||||
make-who-condition who-condition?
|
||||
(who condition-who))
|
||||
|
||||
(define-condition-type &non-continuable &violation
|
||||
make-non-continuable-violation
|
||||
non-continuable-violation?)
|
||||
|
||||
(define-condition-type &implementation-restriction &violation
|
||||
make-implementation-restriction-violation
|
||||
implementation-restriction-violation?)
|
||||
|
||||
(define-condition-type &lexical &violation
|
||||
make-lexical-violation lexical-violation?)
|
||||
|
||||
(define-condition-type &syntax &violation
|
||||
make-syntax-violation syntax-violation?
|
||||
(form syntax-violation-form)
|
||||
(subform syntax-violation-subform))
|
||||
|
||||
(define-condition-type &undefined &violation
|
||||
make-undefined-violation undefined-violation?))
|
||||
(&undefined-variable &undefined)
|
||||
(make-undefined-variable-error make-undefined-violation)
|
||||
(undefined-variable-error? undefined-violation?))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue