diff options
author | Andy Wingo <wingo@pobox.com> | 2019-11-07 15:55:23 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2019-11-07 15:55:23 +0100 |
commit | 92d767bae2035b2ad782cfb18befde838a752bac (patch) | |
tree | d4dc0a05b786df0b79b106b6d6bb9b4afdc4cf21 | |
parent | fc7a0a854fc85cbd51cfd6028945b433af07f1c1 (diff) | |
download | guile-92d767bae2035b2ad782cfb18befde838a752bac.tar.gz |
Move the core of exception objects into core
* module/ice-9/boot-9.scm (&exception, &compound-exception)
(simple-exceptions, make-exception, exception?, exception-type?)
(make-exception-type, exception-predicate, exception-accessor): Move
these definitions into core, from (ice-9 exceptions).
* module/ice-9/exceptions.scm: Re-export definitions from core.
-rw-r--r-- | module/ice-9/boot-9.scm | 96 | ||||
-rw-r--r-- | module/ice-9/exceptions.scm | 95 |
2 files changed, 105 insertions, 86 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 1d8dd759c..f725686c6 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1396,6 +1396,102 @@ written into the port is returned." n (loop (+ n 1) (cdr l)))))) + + + +(let-syntax ((define-values* (syntax-rules () + ((_ (id ...) body ...) + (define-values (id ...) + (let () + body ... + (values id ...))))))) + + (define-values* (&exception + &compound-exception + simple-exceptions + make-exception + exception? + exception-type? + make-exception-type + exception-predicate + exception-accessor) + (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 compound-exception-components + (record-accessor &compound-exception 'components)) + + (define (simple-exceptions exception) + "Return a list of the simple exceptions that compose the exception +object @var{exception}." + (cond ((compound-exception? exception) + (compound-exception-components exception)) + ((simple-exception? exception) + (list exception)) + (else + (error "not a exception" exception)))) + + (define (make-exception . exceptions) + (define (flatten exceptions) + (if (null? exceptions) + '() + (append (simple-exceptions (car exceptions)) + (flatten (cdr exceptions))))) + (let ((simple (flatten 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 catch and with-throw-handler, using some common helper routines and a diff --git a/module/ice-9/exceptions.scm b/module/ice-9/exceptions.scm index a97e16d83..721140ca7 100644 --- a/module/ice-9/exceptions.scm +++ b/module/ice-9/exceptions.scm @@ -23,15 +23,15 @@ (define-module (ice-9 exceptions) - #:export (&exception - make-exception - make-exception-type - simple-exceptions - exception? - exception-type? - exception-predicate - exception-accessor - define-exception-type + #:re-export (&exception + make-exception + make-exception-type + simple-exceptions + exception? + exception-type? + exception-predicate + exception-accessor) + #:export (define-exception-type &message make-exception-with-message @@ -94,83 +94,6 @@ raise-exception raise-continuable)) -(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 |