summaryrefslogtreecommitdiff
path: root/module/rnrs
diff options
context:
space:
mode:
authorJulian Graham <julian.graham@aya.yale.edu>2010-03-20 14:57:49 -0400
committerJulian Graham <julian.graham@aya.yale.edu>2010-05-20 21:18:02 -0400
commit00532e348ed773c9e0a564dd6ce71e203eded9d6 (patch)
tree56793bd90d9b32f418aa1fa552ec9a2d5a5d26a2 /module/rnrs
parentb3961e7ab37d367777924a8d0dd43b2fe35ed673 (diff)
downloadguile-00532e348ed773c9e0a564dd6ce71e203eded9d6.tar.gz
(rnrs conditions) should not depend on (rnrs records syntactic).
* module/rnrs/6/conditions.scm: (define-condition-type) Re-implement `define-condition-type' in terms of (rnrs records procedural).
Diffstat (limited to 'module/rnrs')
-rw-r--r--module/rnrs/6/conditions.scm37
1 files changed, 26 insertions, 11 deletions
diff --git a/module/rnrs/6/conditions.scm b/module/rnrs/6/conditions.scm
index b48999935..5916f51e7 100644
--- a/module/rnrs/6/conditions.scm
+++ b/module/rnrs/6/conditions.scm
@@ -84,7 +84,6 @@
undefined-violation?)
(import (rnrs base (6))
(rnrs records procedural (6))
- (rnrs records syntactic (6))
(rnrs syntax-case (6)))
(define &compound-condition (make-record-type-descriptor
@@ -102,17 +101,33 @@
(syntax-case stx ()
((_ condition-type supertype constructor predicate
(field accessor) ...)
- (let
- ((fields (let* ((field-spec-syntax #'((field accessor) ...))
+ (let*
+ ((fields (let* ((field-spec-syntax #'((field accessor) ...))
(field-specs (syntax->datum field-spec-syntax)))
- (datum->syntax stx
- (cons 'fields
- (map (lambda (field-spec)
- (cons 'immutable field-spec))
- field-specs))))))
- #`(define-record-type (condition-type constructor predicate)
- (parent supertype)
- #,fields))))))
+ (list->vector (map (lambda (field-spec)
+ (cons 'immutable field-spec))
+ field-specs))))
+ (fields-syntax (datum->syntax stx fields)))
+ #`(begin
+ (define condition-type
+ (make-record-type-descriptor
+ #,(datum->syntax
+ stx (list 'quote (syntax->datum #'condition-type)))
+ supertype #f #f #f #,fields-syntax))
+ (define constructor
+ (record-constructor
+ (make-record-constructor-descriptor condition-type #f #f)))
+ (define predicate (record-predicate condition-type))
+ #,@(let f ((accessors '())
+ (counter 0))
+ (if (>= counter (vector-length fields))
+ accessors
+ (f (cons #`(define #,(datum->syntax
+ stx (cadr (vector-ref fields
+ counter)))
+ (record-accessor condition-type #,counter))
+ accessors)
+ (+ counter 1))))))))))
(define &condition (@@ (rnrs records procedural) &condition))
(define &condition-constructor-descriptor