diff options
author | Andy Wingo <wingo@pobox.com> | 2019-10-30 15:49:25 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2019-10-30 15:53:38 +0100 |
commit | 9f1a6717349ce3a6c1617dd7d606bc02386f1183 (patch) | |
tree | e53dfaff22e35a03619af5c3c68257bce06b8eac /module/rnrs | |
parent | 73d0a3bccb3c2b79d7f0e3aaca88a84f3a5c3f43 (diff) | |
download | guile-9f1a6717349ce3a6c1617dd7d606bc02386f1183.tar.gz |
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.
Diffstat (limited to 'module/rnrs')
-rw-r--r-- | module/rnrs/conditions.scm | 110 | ||||
-rw-r--r-- | module/rnrs/exceptions.scm | 96 | ||||
-rw-r--r-- | module/rnrs/records/inspection.scm | 4 | ||||
-rw-r--r-- | module/rnrs/records/procedural.scm | 113 |
4 files changed, 121 insertions, 202 deletions
diff --git a/module/rnrs/conditions.scm b/module/rnrs/conditions.scm index fa2ed6782..c59d96f81 100644 --- a/module/rnrs/conditions.scm +++ b/module/rnrs/conditions.scm @@ -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 &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-condition-type &warning &condition + make-warning warning?) - (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?)) diff --git a/module/rnrs/exceptions.scm b/module/rnrs/exceptions.scm index 52f5c257f..fda87ff94 100644 --- a/module/rnrs/exceptions.scm +++ b/module/rnrs/exceptions.scm @@ -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) diff --git a/module/rnrs/records/inspection.scm b/module/rnrs/records/inspection.scm index 052e84f81..781f062f2 100644 --- a/module/rnrs/records/inspection.scm +++ b/module/rnrs/records/inspection.scm @@ -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))))) diff --git a/module/rnrs/records/procedural.scm b/module/rnrs/records/procedural.scm index 08a7fd220..9eb0934eb 100644 --- a/module/rnrs/records/procedural.scm +++ b/module/rnrs/records/procedural.scm @@ -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)) ) |