mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 03:30:27 +02:00
Remove circularity in r6rs by rebasing conditions on core records
* module/rnrs/conditions.scm: Use core record facilities to define the base condition types, define-condition-type, and the standard condition hierarchy. (simple-condition?): Rename from condition-internal?. * module/rnrs/exceptions.scm: Move `raise' definition here, out from the procedural records layer. (format-simple-condition): Reimplement in a simpler way, hopefully producing the same output. * module/rnrs/records/procedural.scm: * module/rnrs/records/inspection.scm: Import the exceptions and conditions modules, and use the normal raise function.
This commit is contained in:
Andy Wingo
parent
73d0a3bccb
commit
9f1a671734
4 changed files with 121 additions and 202 deletions
|
|
@ -82,25 +82,29 @@
|
|||
&undefined
|
||||
make-undefined-violation
|
||||
undefined-violation?)
|
||||
(import (only (guile) and=> @@)
|
||||
(import (only (guile)
|
||||
and=>
|
||||
make-record-type
|
||||
record-constructor
|
||||
record-predicate
|
||||
record-accessor)
|
||||
(rnrs base (6))
|
||||
(rnrs lists (6))
|
||||
(rnrs records procedural (6)))
|
||||
(rnrs lists (6)))
|
||||
|
||||
(define &compound-condition (make-record-type-descriptor
|
||||
'&compound-condition #f #f #f #f
|
||||
'#((immutable components))))
|
||||
(define &condition (make-record-type '&condition '() #:extensible? #t))
|
||||
(define simple-condition? (record-predicate &condition))
|
||||
|
||||
(define &compound-condition (make-record-type '&compound-condition
|
||||
'((immutable components))))
|
||||
(define compound-condition? (record-predicate &compound-condition))
|
||||
|
||||
(define make-compound-condition
|
||||
(record-constructor (make-record-constructor-descriptor
|
||||
&compound-condition #f #f)))
|
||||
(define make-compound-condition (record-constructor &compound-condition))
|
||||
|
||||
(define simple-conditions
|
||||
(let ((compound-ref (record-accessor &compound-condition 0)))
|
||||
(let ((compound-ref (record-accessor &compound-condition 'components)))
|
||||
(lambda (condition)
|
||||
(cond ((compound-condition? condition)
|
||||
(compound-ref condition))
|
||||
((condition-internal? condition)
|
||||
((simple-condition? condition)
|
||||
(list condition))
|
||||
(else
|
||||
(assertion-violation 'simple-conditions
|
||||
|
|
@ -108,7 +112,7 @@
|
|||
condition))))))
|
||||
|
||||
(define (condition? obj)
|
||||
(or (compound-condition? obj) (condition-internal? obj)))
|
||||
(or (compound-condition? obj) (simple-condition? obj)))
|
||||
|
||||
(define condition
|
||||
(lambda conditions
|
||||
|
|
@ -120,41 +124,12 @@
|
|||
(make-compound-condition (apply append (map flatten conditions)))
|
||||
(car conditions))))
|
||||
|
||||
(define-syntax define-condition-type
|
||||
(syntax-rules ()
|
||||
((_ condition-type supertype constructor predicate
|
||||
(field accessor) ...)
|
||||
(letrec-syntax
|
||||
((generate-accessors
|
||||
(syntax-rules ()
|
||||
((_ counter (f a) . rest)
|
||||
(begin (define a
|
||||
(condition-accessor
|
||||
condition-type
|
||||
(record-accessor condition-type counter)))
|
||||
(generate-accessors (+ counter 1) . rest)))
|
||||
((_ counter) (begin)))))
|
||||
(define condition-type
|
||||
(make-record-type-descriptor
|
||||
'condition-type supertype #f #f #f
|
||||
'#((immutable field) ...)))
|
||||
(define constructor
|
||||
(record-constructor
|
||||
(make-record-constructor-descriptor condition-type #f #f)))
|
||||
(define predicate (condition-predicate condition-type))
|
||||
(generate-accessors 0 (field accessor) ...)))))
|
||||
|
||||
(define &condition (@@ (rnrs records procedural) &condition))
|
||||
(define &condition-constructor-descriptor
|
||||
(make-record-constructor-descriptor &condition #f #f))
|
||||
(define condition-internal? (record-predicate &condition))
|
||||
|
||||
(define (condition-predicate rtd)
|
||||
(let ((rtd-predicate (record-predicate rtd)))
|
||||
(lambda (obj)
|
||||
(cond ((compound-condition? obj)
|
||||
(exists rtd-predicate (simple-conditions obj)))
|
||||
((condition-internal? obj) (rtd-predicate obj))
|
||||
((simple-condition? obj) (rtd-predicate obj))
|
||||
(else #f)))))
|
||||
|
||||
(define (condition-accessor rtd proc)
|
||||
|
|
@ -165,27 +140,37 @@
|
|||
(and=> (find rtd-predicate (simple-conditions obj)) proc))
|
||||
(else #f)))))
|
||||
|
||||
(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)))
|
||||
...))))
|
||||
|
||||
(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?)
|
||||
|
||||
(define-condition-type &message &condition
|
||||
make-message-condition message-condition?
|
||||
(message condition-message))
|
||||
|
||||
(define-condition-type &warning &condition make-warning warning?)
|
||||
(define-condition-type &warning &condition
|
||||
make-warning warning?)
|
||||
|
||||
(define &serious (@@ (rnrs records procedural) &serious))
|
||||
(define make-serious-condition
|
||||
(@@ (rnrs records procedural) make-serious-condition))
|
||||
(define serious-condition? (condition-predicate &serious))
|
||||
|
||||
(define-condition-type &error &serious make-error error?)
|
||||
|
||||
(define &violation (@@ (rnrs records procedural) &violation))
|
||||
(define make-violation (@@ (rnrs records procedural) make-violation))
|
||||
(define violation? (condition-predicate &violation))
|
||||
|
||||
(define &assertion (@@ (rnrs records procedural) &assertion))
|
||||
(define make-assertion-violation
|
||||
(@@ (rnrs records procedural) make-assertion-violation))
|
||||
(define assertion-violation? (condition-predicate &assertion))
|
||||
(define-condition-type &error &serious
|
||||
make-error error?)
|
||||
|
||||
(define-condition-type &irritants &condition
|
||||
make-irritants-condition irritants-condition?
|
||||
|
|
@ -199,8 +184,7 @@
|
|||
make-non-continuable-violation
|
||||
non-continuable-violation?)
|
||||
|
||||
(define-condition-type &implementation-restriction
|
||||
&violation
|
||||
(define-condition-type &implementation-restriction &violation
|
||||
make-implementation-restriction-violation
|
||||
implementation-restriction-violation?)
|
||||
|
||||
|
|
@ -213,6 +197,4 @@
|
|||
(subform syntax-violation-subform))
|
||||
|
||||
(define-condition-type &undefined &violation
|
||||
make-undefined-violation undefined-violation?)
|
||||
|
||||
)
|
||||
make-undefined-violation undefined-violation?))
|
||||
|
|
|
|||
|
|
@ -22,20 +22,23 @@
|
|||
(import (rnrs base (6))
|
||||
(rnrs control (6))
|
||||
(rnrs conditions (6))
|
||||
(rnrs records procedural (6))
|
||||
(rnrs records inspection (6))
|
||||
(only (guile)
|
||||
make-record-type
|
||||
record-type-name
|
||||
record-type-fields
|
||||
record-constructor
|
||||
record-predicate
|
||||
record-accessor
|
||||
struct-ref
|
||||
struct-vtable
|
||||
format
|
||||
newline
|
||||
display
|
||||
filter
|
||||
acons
|
||||
assv-ref
|
||||
throw
|
||||
set-exception-printer!
|
||||
with-throw-handler
|
||||
*unspecified*
|
||||
@@))
|
||||
with-throw-handler))
|
||||
|
||||
;; When a native guile exception is caught by an R6RS exception
|
||||
;; handler, we convert it to an R6RS compound condition that includes
|
||||
|
|
@ -77,19 +80,27 @@
|
|||
;; 'raise' so that native Guile exception handlers will continue to
|
||||
;; work when mixed with R6RS code.
|
||||
|
||||
(define &raise-object-wrapper
|
||||
(make-record-type '&raise-object-wrapper
|
||||
'((immutable obj) (immutable continuation))))
|
||||
(define make-raise-object-wrapper
|
||||
(record-constructor &raise-object-wrapper))
|
||||
(define raise-object-wrapper?
|
||||
(record-predicate &raise-object-wrapper))
|
||||
(define raise-object-wrapper-obj
|
||||
(record-accessor &raise-object-wrapper 'obj))
|
||||
(define raise-object-wrapper-continuation
|
||||
(record-accessor &raise-object-wrapper 'continuation))
|
||||
|
||||
(define (raise obj)
|
||||
(if (guile-condition? obj)
|
||||
(apply throw (guile-condition-key obj) (guile-condition-args obj))
|
||||
((@@ (rnrs records procedural) r6rs-raise) obj)))
|
||||
(define raise-continuable
|
||||
(@@ (rnrs records procedural) r6rs-raise-continuable))
|
||||
(throw 'r6rs:exception (make-raise-object-wrapper obj #f))))
|
||||
|
||||
(define raise-object-wrapper?
|
||||
(@@ (rnrs records procedural) raise-object-wrapper?))
|
||||
(define raise-object-wrapper-obj
|
||||
(@@ (rnrs records procedural) raise-object-wrapper-obj))
|
||||
(define raise-object-wrapper-continuation
|
||||
(@@ (rnrs records procedural) raise-object-wrapper-continuation))
|
||||
(define (raise-continuable obj)
|
||||
(call/cc
|
||||
(lambda (k)
|
||||
(throw 'r6rs:exception (make-raise-object-wrapper obj k)))))
|
||||
|
||||
(define (with-exception-handler handler thunk)
|
||||
(with-throw-handler #t
|
||||
|
|
@ -152,44 +163,23 @@
|
|||
(loop (+ i 1) (cdr components))))))))
|
||||
|
||||
(define (format-simple-condition port condition)
|
||||
(define (print-rtd-fields rtd field-names)
|
||||
(let ((n-fields (vector-length field-names)))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((>= i n-fields))
|
||||
(format port " ~a: ~s"
|
||||
(vector-ref field-names i)
|
||||
((record-accessor rtd i) condition))
|
||||
(unless (= i (- n-fields 1))
|
||||
(newline port)))))
|
||||
(let ((condition-name (record-type-name (record-rtd condition))))
|
||||
(let loop ((rtd (record-rtd condition))
|
||||
(rtd.fields-list '())
|
||||
(n-fields 0))
|
||||
(cond (rtd
|
||||
(let ((field-names (record-type-field-names rtd)))
|
||||
(loop (record-type-parent rtd)
|
||||
(cons (cons rtd field-names) rtd.fields-list)
|
||||
(+ n-fields (vector-length field-names)))))
|
||||
(else
|
||||
(let ((rtd.fields-list
|
||||
(filter (lambda (rtd.fields)
|
||||
(not (zero? (vector-length (cdr rtd.fields)))))
|
||||
(reverse rtd.fields-list))))
|
||||
(case n-fields
|
||||
((0) (format port "~a" condition-name))
|
||||
((1) (format port "~a: ~s"
|
||||
condition-name
|
||||
((record-accessor (caar rtd.fields-list) 0)
|
||||
condition)))
|
||||
(else
|
||||
(format port "~a:\n" condition-name)
|
||||
(let loop ((lst rtd.fields-list))
|
||||
(when (pair? lst)
|
||||
(let ((rtd.fields (car lst)))
|
||||
(print-rtd-fields (car rtd.fields) (cdr rtd.fields))
|
||||
(when (pair? (cdr lst))
|
||||
(newline port))
|
||||
(loop (cdr lst)))))))))))))
|
||||
(let* ((type (struct-vtable condition))
|
||||
(name (record-type-name type))
|
||||
(fields (record-type-fields type)))
|
||||
(cond
|
||||
((null? fields)
|
||||
(format port "~a" name))
|
||||
((null? (cdr fields))
|
||||
(format port "~a: ~s" name (struct-ref condition 0)))
|
||||
(else
|
||||
(format port "~a:\n" name)
|
||||
(let lp ((fields fields) (i 0))
|
||||
(let ((field (car fields))
|
||||
(fields (cdr fields)))
|
||||
(format port " ~a: ~s" field (struct-ref condition i))
|
||||
(unless (null? fields)
|
||||
(newline port)
|
||||
(lp fields (+ i 1)))))))))
|
||||
|
||||
(set-exception-printer! 'r6rs:exception exception-printer)
|
||||
|
||||
|
|
|
|||
|
|
@ -31,6 +31,8 @@
|
|||
(import (rnrs arithmetic bitwise (6))
|
||||
(rnrs base (6))
|
||||
(rnrs records procedural (6))
|
||||
(rnrs exceptions (6))
|
||||
(rnrs conditions (6))
|
||||
(rename (only (guile)
|
||||
unless
|
||||
logbit?
|
||||
|
|
@ -73,5 +75,5 @@
|
|||
(k (+ k parent-nfields)))
|
||||
(unless (and (<= parent-nfields k)
|
||||
(< k (length (record-type-fields rtd))))
|
||||
(r6rs-raise (make-assertion-violation)))
|
||||
(raise (make-assertion-violation)))
|
||||
(logbit? k (record-type-mutable-fields rtd)))))
|
||||
|
|
|
|||
|
|
@ -28,31 +28,27 @@
|
|||
record-mutator)
|
||||
|
||||
(import (rnrs base (6))
|
||||
(only (rename (guile)
|
||||
(record-accessor guile:record-accessor))
|
||||
cons*
|
||||
logbit?
|
||||
|
||||
when unless
|
||||
|
||||
throw
|
||||
|
||||
struct-ref
|
||||
struct-set!
|
||||
|
||||
make-record-type
|
||||
record-type?
|
||||
record-type-name
|
||||
record-type-fields
|
||||
record-type-constructor
|
||||
record-type-mutable-fields
|
||||
record-type-parent
|
||||
record-type-opaque?
|
||||
record-predicate
|
||||
guile:record-accessor
|
||||
record-modifier
|
||||
|
||||
vector->list))
|
||||
(rnrs conditions (6))
|
||||
(rnrs exceptions (6))
|
||||
(only (rename (guile)
|
||||
(record-accessor guile:record-accessor))
|
||||
logbit?
|
||||
when
|
||||
unless
|
||||
struct-ref
|
||||
struct-set!
|
||||
make-record-type
|
||||
record-type?
|
||||
record-type-name
|
||||
record-type-fields
|
||||
record-type-constructor
|
||||
record-type-mutable-fields
|
||||
record-type-parent
|
||||
record-type-opaque?
|
||||
record-predicate
|
||||
guile:record-accessor
|
||||
record-modifier
|
||||
vector->list))
|
||||
|
||||
(define (make-record-type-descriptor name parent uid sealed? opaque? fields)
|
||||
(make-record-type name (vector->list fields) #:parent parent #:uid uid
|
||||
|
|
@ -74,15 +70,15 @@
|
|||
|
||||
(define (make-record-constructor-descriptor rtd parent-rcd protocol)
|
||||
(unless (record-type? rtd)
|
||||
(r6rs-raise (make-assertion-violation)))
|
||||
(raise (make-assertion-violation)))
|
||||
(when protocol
|
||||
(unless (procedure? protocol)
|
||||
(r6rs-raise (make-assertion-violation))))
|
||||
(raise (make-assertion-violation))))
|
||||
(when parent-rcd
|
||||
(unless (eq? (rcd-rtd parent-rcd)
|
||||
(record-type-parent rtd))
|
||||
(when protocol
|
||||
(r6rs-raise (make-assertion-violation)))))
|
||||
(raise (make-assertion-violation)))))
|
||||
((record-type-constructor record-constructor-descriptor)
|
||||
rtd parent-rcd protocol))
|
||||
|
||||
|
|
@ -140,10 +136,10 @@
|
|||
(k (+ k parent-nfields)))
|
||||
(unless (and (<= parent-nfields k)
|
||||
(< k (length (record-type-fields rtd))))
|
||||
(r6rs-raise (make-assertion-violation)))
|
||||
(raise (make-assertion-violation)))
|
||||
(lambda (obj)
|
||||
(unless (pred obj)
|
||||
(r6rs-raise (make-assertion-violation)))
|
||||
(raise (make-assertion-violation)))
|
||||
(struct-ref obj k))))
|
||||
|
||||
(define (record-mutator rtd k)
|
||||
|
|
@ -155,63 +151,12 @@
|
|||
(k (+ k parent-nfields)))
|
||||
(unless (and (<= parent-nfields k)
|
||||
(< k (length (record-type-fields rtd))))
|
||||
(r6rs-raise (make-assertion-violation)))
|
||||
(raise (make-assertion-violation)))
|
||||
(unless (logbit? k (record-type-mutable-fields rtd))
|
||||
(r6rs-raise (make-assertion-violation)))
|
||||
(raise (make-assertion-violation)))
|
||||
(lambda (obj val)
|
||||
(unless (pred obj)
|
||||
(r6rs-raise (make-assertion-violation)))
|
||||
(raise (make-assertion-violation)))
|
||||
(struct-set! obj k val))))
|
||||
|
||||
;; Condition types that are used in the current library. These are defined
|
||||
;; here and not in (rnrs conditions) to avoid a circular dependency.
|
||||
|
||||
(define &condition (make-record-type-descriptor '&condition #f #f #f #f '#()))
|
||||
(define &condition-constructor-descriptor
|
||||
(make-record-constructor-descriptor &condition #f #f))
|
||||
|
||||
(define &serious (make-record-type-descriptor
|
||||
'&serious &condition #f #f #f '#()))
|
||||
(define &serious-constructor-descriptor
|
||||
(make-record-constructor-descriptor
|
||||
&serious &condition-constructor-descriptor #f))
|
||||
|
||||
(define make-serious-condition
|
||||
(record-constructor &serious-constructor-descriptor))
|
||||
|
||||
(define &violation (make-record-type-descriptor
|
||||
'&violation &serious #f #f #f '#()))
|
||||
(define &violation-constructor-descriptor
|
||||
(make-record-constructor-descriptor
|
||||
&violation &serious-constructor-descriptor #f))
|
||||
(define make-violation (record-constructor &violation-constructor-descriptor))
|
||||
|
||||
(define &assertion (make-record-type-descriptor
|
||||
'&assertion &violation #f #f #f '#()))
|
||||
(define make-assertion-violation
|
||||
(record-constructor
|
||||
(make-record-constructor-descriptor
|
||||
&assertion &violation-constructor-descriptor #f)))
|
||||
|
||||
;; Exception wrapper type, along with a wrapping `throw' implementation.
|
||||
;; These are used in the current library, and so they are defined here and not
|
||||
;; in (rnrs exceptions) to avoid a circular dependency.
|
||||
|
||||
(define &raise-object-wrapper
|
||||
(make-record-type-descriptor '&raise-object-wrapper #f #f #f #f
|
||||
'#((immutable obj) (immutable continuation))))
|
||||
(define make-raise-object-wrapper
|
||||
(record-constructor (make-record-constructor-descriptor
|
||||
&raise-object-wrapper #f #f)))
|
||||
(define raise-object-wrapper? (record-predicate &raise-object-wrapper))
|
||||
(define raise-object-wrapper-obj (record-accessor &raise-object-wrapper 0))
|
||||
(define raise-object-wrapper-continuation
|
||||
(record-accessor &raise-object-wrapper 1))
|
||||
|
||||
(define (r6rs-raise obj)
|
||||
(throw 'r6rs:exception (make-raise-object-wrapper obj #f)))
|
||||
(define (r6rs-raise-continuable obj)
|
||||
(define (r6rs-raise-continuable-internal continuation)
|
||||
(throw 'r6rs:exception (make-raise-object-wrapper obj continuation)))
|
||||
(call/cc r6rs-raise-continuable-internal))
|
||||
)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue