mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

(rnrs conditions) should not depend on (rnrs records syntactic).

Browse source 
* module/rnrs/6/conditions.scm: (define-condition-type) Re-implement
  `define-condition-type' in terms of (rnrs records procedural).
This commit is contained in:
Julian Graham 2010-03-20 14:57:49 -04:00
parent b3961e7ab3
commit 00532e348e
1 changed files with 26 additions and 11 deletions
Download patch file Download diff file Expand all files Collapse all files

33
module/rnrs/6/conditions.scm
View file

@ -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
(let*
((fields (let* ((field-spec-syntax #'((field accessor) ...))
(field-specs (syntax->datum field-spec-syntax)))
(datum->syntax stx
(cons 'fields
(map (lambda (field-spec)
(list->vector (map (lambda (field-spec)
(cons 'immutable field-spec))
field-specs))))))
#`(define-record-type (condition-type constructor predicate)
(parent supertype)
#,fields))))))
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