diff options
author | Julian Graham <julian.graham@aya.yale.edu> | 2010-03-20 14:57:49 -0400 |
---|---|---|
committer | Julian Graham <julian.graham@aya.yale.edu> | 2010-05-20 21:18:02 -0400 |
commit | 00532e348ed773c9e0a564dd6ce71e203eded9d6 (patch) | |
tree | 56793bd90d9b32f418aa1fa552ec9a2d5a5d26a2 /module/rnrs | |
parent | b3961e7ab37d367777924a8d0dd43b2fe35ed673 (diff) | |
download | guile-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.scm | 37 |
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 |