mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 13:30:26 +02:00
Code Activity

Rebase SRFI-35 on top of (ice-9 exceptions)

Browse source 
* module/ice-9/exceptions.scm (exception-type?): New export.
* module/srfi/srfi-35.scm: Rewrite in terms of (ice-9 exceptions).
This commit is contained in:
Andy Wingo 2019-11-04 15:18:57 +01:00
parent 54ab2175f9
commit 86bc3da9e0
2 changed files with 69 additions and 178 deletions
Download patch file Download diff file Expand all files Collapse all files

1
module/ice-9/exceptions.scm
View file

@ -28,6 +28,7 @@
make-exception-type make-exception-type
simple-exceptions simple-exceptions
exception? exception?
exception-type?
exception-predicate exception-predicate
exception-accessor exception-accessor
define-exception-type define-exception-type

246
module/srfi/srfi-35.scm
View file

@ -28,95 +28,69 @@
(define-module (srfi srfi-35) (define-module (srfi srfi-35)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (make-condition-type condition-type? #:use-module (ice-9 exceptions)
make-condition condition? condition-has-type? condition-ref #:re-export ((make-exception-type . make-condition-type)
make-compound-condition extract-condition (exception-type? . condition-type?)
define-condition-type condition (exception? . condition?)
&condition (make-exception . make-compound-condition)
&message message-condition? condition-message (&exception . &condition)
&serious serious-condition? &message
&error error?)) (exception-with-message? . message-condition?)
(exception-message . condition-message)
(&error . &serious)
(error? . serious-condition?)
(&external-error . &error)
(external-error? . error?))
#:export (make-condition
define-condition-type
condition-has-type?
condition-ref
extract-condition
condition))
(cond-expand-provide (current-module) '(srfi-35)) (cond-expand-provide (current-module) '(srfi-35))
(define (make-condition type . field+value)
;;; "Return a new condition of type TYPE with fields initialized as specified
;;; Condition types. by FIELD+VALUE, a sequence of field names (symbols) and values."
;;; (unless (exception-type? type)
(scm-error 'wrong-type-arg "make-condition" "Not a condition type: ~S"
;; Like default-record-printer, but prefixed with "condition ": (list type) #f))
;; #<condition TYPE FIELD: VALUE ...>. (let* ((fields (record-type-fields type))
(define (print-condition c p) (uninitialized (list 'uninitialized))
(display "#<condition " p) (inits (make-vector (length fields) uninitialized)))
(display (record-type-name (record-type-descriptor c)) p) (let lp ((args field+value))
(let loop ((fields (record-type-fields (record-type-descriptor c))) (match args
(off 0)) (()
(match fields (let lp ((i 0) (fields fields))
(() (display ">" p)) (when (< i (vector-length inits))
((field . fields) (when (eq? (vector-ref inits i) uninitialized)
(display " " p) (error "field not specified" (car fields)))
(display field p) (lp (1+ i) (cdr fields))))
(display ": " p) (apply make-struct/simple type (vector->list inits)))
(display (struct-ref c off) p) (((and (? symbol?) field) value . args)
(loop fields (+ 1 off)))))) (let lp ((i 0) (fields fields))
(when (null? fields)
;; FIXME: Perhaps use a `define-record-type' which allows for parent types. (error "unknown field" field))
(define &condition (cond
(make-record-type '&condition '() print-condition #:extensible? #t)) ((eq? field (car fields))
(unless (eq? (vector-ref inits i) uninitialized)
(define (make-condition-type id parent field-names) (error "duplicate initializer" field))
"Return a new condition type named @var{id}, inheriting from (vector-set! inits i value))
@var{parent}, and with the fields whose names are listed in (else
@var{field-names}. @var{field-names} must be a list of symbols and must (lp (1+ i) (cdr fields)))))
not contain names already used by @var{parent} or one of its (lp args))
supertypes." (inits
(unless (condition-type? parent) (scm-error 'wrong-type-arg "make-condition"
(error "parent is not a condition type" parent)) "Bad initializer list tail: ~S"
(make-record-type id field-names print-condition #:parent parent (list inits) #f))))))
#:extensible? #t))
(define (condition-type? obj)
"Return true if OBJ is a condition type."
(and (record-type? obj)
(record-type-has-parent? obj &condition)))
(define simple-condition?
(record-predicate &condition))
;; Compound conditions are represented as a disjoint type, as users
;; never have access to compound condition types.
(define &compound-condition
(make-record-type 'compound-condition '(conditions)))
(define compound-condition?
(record-predicate &compound-condition))
(define %make-compound-condition
(record-constructor &compound-condition))
(define compound-condition-conditions
(record-accessor &compound-condition 'conditions))
;;;
;;; Conditions.
;;;
(define (condition? obj)
"Return true if @var{obj} is a condition."
(or (simple-condition? obj)
(compound-condition? obj)))
(define (condition-has-type? c type) (define (condition-has-type? c type)
"Return true if condition C has type TYPE." "Return true if condition C has type TYPE."
(unless (condition-type? type) (unless (exception-type? type)
(scm-error 'wrong-type-arg "condition-has-type?" "Not a condition type: ~S" (scm-error 'wrong-type-arg "condition-has-type?" "Not a condition type: ~S"
(list type) #f)) (list type) #f))
(match c (or-map (record-predicate type) (simple-exceptions c)))
(($ &compound-condition conditions)
(or-map (lambda (c) (condition-has-type? c type)) conditions))
((? simple-condition?)
((record-predicate type) c))
(_
(scm-error 'wrong-type-arg "condition-has-type?" "Not a condition: ~S"
(list c) #f))))
;; Precondition: C is a simple condition. ;; Precondition: C is a simple condition.
(define (simple-condition-ref c field-name not-found) (define (simple-condition-ref c field-name not-found)
@ -126,96 +100,29 @@ supertypes."
(define (condition-ref c field-name) (define (condition-ref c field-name)
"Return the value of the field named FIELD-NAME from condition C." "Return the value of the field named FIELD-NAME from condition C."
(match c (let lp ((conditions (simple-exceptions c)))
(($ &compound-condition conditions) (match conditions
(let lp ((conditions conditions)) (() (error "invalid field name" field-name))
(match conditions ((c . conditions)
(() (error "invalid field name" field-name)) (simple-condition-ref c field-name (lambda () (lp conditions)))))))
((c . conditions)
(simple-condition-ref c field-name (lambda () (lp conditions)))))))
((? simple-condition?)
(simple-condition-ref c field-name
(lambda ()
(error "invalid field name" field-name))))
(_
(scm-error 'wrong-type-arg "condition-ref" "Not a condition: ~S"
(list c) #f))))
(define (make-condition-from-values type values) (define (make-condition-from-values type values)
(apply make-struct/simple type values)) (apply make-struct/simple type values))
(define (make-condition type . field+value)
"Return a new condition of type TYPE with fields initialized as specified
by FIELD+VALUE, a sequence of field names (symbols) and values."
(unless (condition-type? type)
(scm-error 'wrong-type-arg "make-condition" "Not a condition type: ~S"
(list type) #f))
(let ((c (make-struct/no-tail type)))
(let lp ((inits field+value) (fields (record-type-fields type)))
(match inits
(()
(match fields
(() c)
((field . fields)
(error "field not specified" field))))
(((and (? symbol?) field) value . inits)
(unless (memq field fields)
(error "unknown field, or duplicate initializer" field))
((record-modifier type field) c value)
(lp inits (delq field fields)))
(inits
(scm-error 'wrong-type-arg "make-condition"
"Bad initializer list tail: ~S"
(list inits) #f))))))
(define (make-compound-condition . conditions)
"Return a new compound condition composed of CONDITIONS."
(%make-compound-condition
(let lp ((conditions conditions))
(if (null? conditions)
'()
(let ((c (car conditions))
(conditions (cdr conditions)))
(cond
((compound-condition? c)
(append (compound-condition-conditions c) (lp conditions)))
(else
(unless (condition? c)
(throw 'wrong-type-arg "make-compound-condition"
"Not a condition: ~S" c))
(cons c (lp conditions)))))))))
(define (extract-condition c type) (define (extract-condition c type)
"Return a condition of condition type TYPE with the field values specified "Return a condition of condition type TYPE with the field values specified
by C." by C."
(unless (condition-type? type) (unless (exception-type? type)
(scm-error 'wrong-type-arg "extract-condition" "Not a condition type: ~S" (scm-error 'wrong-type-arg "extract-condition" "Not a condition type: ~S"
(list type) #f)) (list type) #f))
(match c (let ((pred (record-predicate type)))
(($ &compound-condition conditions) (or-map (lambda (x) (and (pred x) x)) (simple-exceptions c))))
(or-map (lambda (c) (extract-condition c type))
conditions))
((? simple-condition?)
(and ((record-predicate type) c)
c))
(_
(scm-error 'wrong-type-arg "extract-condition" "Not a condition: ~S"
(list c) #f))))
(define-syntax-rule (define-condition-type type parent predicate
;;; (field accessor) ...)
;;; Syntax. (define-exception-type type parent
;;; unused-constructor predicate
(field accessor) ...))
(define-syntax-rule (define-condition-type name parent pred (field-name field-accessor) ...)
(begin
(define name
(make-condition-type 'name parent '(field-name ...)))
(define (pred c)
(condition-has-type? c name))
(define (field-accessor c)
(condition-ref c 'field-name))
...))
(define-syntax condition-instantiation (define-syntax condition-instantiation
;; Build the `(make-condition type ...)' call. ;; Build the `(make-condition type ...)' call.
@ -232,20 +139,3 @@ by C."
((_ (type field ...) ...) ((_ (type field ...) ...)
(make-compound-condition (condition-instantiation type () field ...) (make-compound-condition (condition-instantiation type () field ...)
...)))) ...))))
;;;
;;; Standard condition types.
;;;
(define-condition-type &message &condition
message-condition?
(message condition-message))
(define-condition-type &serious &condition
serious-condition?)
(define-condition-type &error &serious
error?)
;;; srfi-35.scm ends here