[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/04: Remove circularity in r6rs by rebasing conditions
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/04: Remove circularity in r6rs by rebasing conditions on core records |
|
Date: |
Mon, 4 Nov 2019 09:21:20 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 9f1a6717349ce3a6c1617dd7d606bc02386f1183
Author: Andy Wingo <address@hidden>
Date: Wed Oct 30 15:49:25 2019 +0100
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.
---
module/rnrs/conditions.scm | 110 +++++++++++++++---------------------
module/rnrs/exceptions.scm | 96 ++++++++++++++-----------------
module/rnrs/records/inspection.scm | 4 +-
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 fa2ed67..c59d96f 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 52f5c25..fda87ff 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 052e84f..781f062 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 08a7fd2..9eb0934 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))
)