* r6rs define-record-type is unhygienic
@ 2011-06-11 13:36 Ian Price
2011-06-17 8:34 ` Andy Wingo
0 siblings, 1 reply; 4+ messages in thread
From: Ian Price @ 2011-06-11 13:36 UTC (permalink / raw)
To: bug-guile
[-- Attachment #1: Type: text/plain, Size: 2731 bytes --]
Hello Guilers,
Yesterday, I posted this example on IRC
;;; type.scm
#!r6rs
(library (type)
(export define-type)
(import (rnrs))
(define-syntax define-type
(lambda (stx)
(syntax-case stx ()
[(define-type type-id (field guard) ...)
#'(begin
(assert (symbol? 'type-id))
(display "yep\n")
(define-record-type type-id
(protocol
(lambda (x)
(lambda (field ...)
(assert (guard field)) ...
(x field ...))))
(fields field ...)))])))
)
;;; foo.scm
(import (type))
;; not importing (rnrs), because it would hide the bug
(define true (lambda _ #t))
(define-type kons (kar true) (kdr true))
(define k1 (make-kons 3 4))
(write k1)
I expected this to print
yep
#<r6rs:record:kons>
but instead I get
yep
Backtrace:
In module/ice−9/boot−9.scm:
170: 8 [catch #t #<catch−closure a250ed0> ...]
In unknown file:
?: 7 [catch−closure]
In module/ice−9/boot−9.scm:
62: 6 [call−with−prompt prompt0 ...]
In module/ice−9/eval.scm:
389: 5 [eval # #]
In module/ice−9/boot−9.scm:
2103: 4 [save−module−excursion #<procedure a263ce0 at module/ice−9/boot−9.scm:3528:3 ()>]
3535: 3 [#<procedure a263ce0 at module/ice−9/boot−9.scm:3528:3 ()>]
In unknown file:
?: 2 [load−compiled/vm "/home/Ian/src/guile/cache/guile/ccache/2.0−LE−4−2.0/tmp/foo.scm.go"]
In tmp/foo.scm:
6: 1 [#<procedure a5e1a30 ()>]
In unknown file:
?: 0 [#<procedure a5e1790 (kar kdr)> 3 4]
ERROR: In procedure #<procedure a5e1790 (kar kdr)>:
ERROR: In procedure module−lookup: Unbound variable: assert
As you can see, it claims that 'assert' is unbound, but 'yep' gets
printed, so the first assert must have been successful (and so must have
been bound). Therefore, I came to the conclusion that the protocol
expression was not evaluated in the same environment as the define-type
macro, but instead the environment of the use i.e. it is non-hygienic.
Another example is
(let ((immutable #f))
(define-record-type foo (fields (immutable bar)))
#t)
This should be a syntax error as immutable does not have the same
binding as it does in the definition of define-record-type, and
therefore we have an invalid field spec, but in guile it is evaluated to
#t.
I have attached a patch for stable-2.0 to deal with these
issues. Keywords are now matched as syntax-case literals, and
sub-expressions are de-structured as necessary, rather than by using
syntax->datum on all the clauses at the start. There are some issues I
didn't touch, e.g. I think that the error messages should be improved,
but I can do that too if you would like.
If there are any problems let me know,
Ian
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Record hygiene patch --]
[-- Type: text/x-patch, Size: 16238 bytes --]
From 05dcbb4625dfaf38209292430096881fc00d6c68 Mon Sep 17 00:00:00 2001
From: Ian Price <ianprice90@googlemail.com>
Date: Sat, 11 Jun 2011 02:43:08 +0100
Subject: [PATCH] Fix hygiene issues with `define-record-type'
* module/rnrs/records/syntactic.scm(define-record-type0, process-fields):
Preserve hygiene of record clauses.
* test-suite/tests/r6rs-records-syntactic.test("record hygiene"): Add tests.
---
module/rnrs/records/syntactic.scm | 284 ++++++++++++--------------
test-suite/tests/r6rs-records-syntactic.test | 34 +++
2 files changed, 166 insertions(+), 152 deletions(-)
diff --git a/module/rnrs/records/syntactic.scm b/module/rnrs/records/syntactic.scm
index 6431fcf..6e57c22 100644
--- a/module/rnrs/records/syntactic.scm
+++ b/module/rnrs/records/syntactic.scm
@@ -75,172 +75,152 @@
(number-fields-inner fields 0))
(define (process-fields record-name fields)
- (define record-name-str (symbol->string record-name))
+ (define (wrap x) (datum->syntax record-name x))
+ (define (id->string x)
+ (symbol->string (syntax->datum x)))
+ (define record-name-str (id->string record-name))
(define (guess-accessor-name field-name)
- (string->symbol (string-append
- record-name-str "-" (symbol->string field-name))))
+ (wrap
+ (string->symbol (string-append
+ record-name-str "-" (id->string field-name)))))
(define (guess-mutator-name field-name)
- (string->symbol
- (string-append
- record-name-str "-" (symbol->string field-name) "-set!")))
-
+ (wrap
+ (string->symbol
+ (string-append
+ record-name-str "-" (id->string field-name) "-set!"))))
(define (f x)
- (define (lose)
- (syntax-violation 'define-record-type "invalid field specifier" x))
- (cond ((symbol? x) (list 'immutable x (guess-accessor-name x) #f))
- ((not (list? x)) (lose))
- ((eq? (car x) 'immutable)
- (cons 'immutable
- (case (length x)
- ((2) (list (cadr x) (guess-accessor-name (cadr x)) #f))
- ((3) (list (cadr x) (caddr x) #f))
- (else (lose)))))
- ((eq? (car x) 'mutable)
- (cons 'mutable
- (case (length x)
- ((2) (list (cadr x)
- (guess-accessor-name (cadr x))
- (guess-mutator-name (cadr x))))
- ((4) (cdr x))
- (else (lose)))))
- (else (lose))))
+ (syntax-case x (immutable mutable)
+ [(immutable name)
+ (list (wrap `(immutable ,(syntax->datum #'name))) (guess-accessor-name #'name) #f)]
+ [(immutable name accessor)
+ (list (wrap `(immutable ,(syntax->datum #'name))) #'accessor #f)]
+ [(mutable name)
+ (list (wrap `(mutable ,(syntax->datum #'name)))
+ (guess-accessor-name #'name)
+ (guess-mutator-name #'name))]
+ [(mutable name accessor mutator)
+ (list (wrap `(mutable ,(syntax->datum #'name))) #'accessor #'mutator)]
+ [name
+ (identifier? #'name)
+ (list (wrap `(immutable ,(syntax->datum #'name))) (guess-accessor-name #'name) #f)]
+ [else
+ (syntax-violation 'define-record-type "invalid field specifier" x)]))
(map f fields))
(define-syntax define-record-type0
(lambda (stx)
(syntax-case stx ()
- ((_ (record-name constructor-name predicate-name) record-clause ...)
- (let loop ((fields *unspecified*)
- (parent *unspecified*)
- (protocol *unspecified*)
- (sealed *unspecified*)
- (opaque *unspecified*)
- (nongenerative *unspecified*)
- (constructor *unspecified*)
- (parent-rtd *unspecified*)
- (record-clauses (syntax->datum #'(record-clause ...))))
- (if (null? record-clauses)
- (let*
- ((fields (if (unspecified? fields) '() fields))
- (field-names
- (datum->syntax
- #'record-name
- (list->vector (map (lambda (x) (take x 2)) fields))))
- (field-accessors
- (fold-left (lambda (x c lst)
- (cons #`(define #,(datum->syntax
- #'record-name (caddr x))
- (record-accessor record-name #,c))
- lst))
- '() fields (sequence (length fields))))
- (field-mutators
- (fold-left (lambda (x c lst)
- (if (cadddr x)
- (cons #`(define #,(datum->syntax
- #'record-name (cadddr x))
- (record-mutator record-name #,c))
- lst)
- lst))
- '() fields (sequence (length fields))))
-
- (parent-cd
- (datum->syntax
- stx (cond ((not (unspecified? parent))
- `(record-constructor-descriptor ,parent))
- ((not (unspecified? parent-rtd)) (cadr parent-rtd))
- (else #f))))
- (parent-rtd
- (datum->syntax
- stx (cond ((not (unspecified? parent))
- `(record-type-descriptor ,parent))
- ((not (unspecified? parent-rtd)) (car parent-rtd))
- (else #f))))
-
- (protocol (datum->syntax
- #'record-name (if (unspecified? protocol)
- #f protocol)))
- (uid (datum->syntax
- #'record-name (if (unspecified? nongenerative)
- #f nongenerative)))
- (sealed? (if (unspecified? sealed) #f sealed))
- (opaque? (if (unspecified? opaque) #f opaque))
-
- (record-name-sym (datum->syntax
- stx (list 'quote
- (syntax->datum #'record-name)))))
-
- #`(begin
- (define record-name
- (make-record-type-descriptor
- #,record-name-sym
- #,parent-rtd #,uid #,sealed? #,opaque?
- #,field-names))
- (define constructor-name
- (record-constructor
- (make-record-constructor-descriptor
- record-name #,parent-cd #,protocol)))
+ ((_ (record-name constructor-name predicate-name) record-clause ...)
+ (let loop ((_fields *unspecified*)
+ (_parent *unspecified*)
+ (_protocol *unspecified*)
+ (_sealed *unspecified*)
+ (_opaque *unspecified*)
+ (_nongenerative *unspecified*)
+ (_constructor *unspecified*)
+ (_parent-rtd *unspecified*)
+ (record-clauses #'(record-clause ...)))
+ (syntax-case record-clauses
+ (fields parent protocol sealed opaque nongenerative constructor parent-rtd)
+ [()
+ (let* ((fields (if (unspecified? _fields) '() _fields))
+ (field-names (list->vector (map car fields)))
+ (field-accessors
+ (fold-left (lambda (x c lst)
+ (cons #`(define #,(cadr x)
+ (record-accessor record-name #,c))
+ lst))
+ '() fields (sequence (length fields))))
+ (field-mutators
+ (fold-left (lambda (x c lst)
+ (if (caddr x)
+ (cons #`(define #,(caddr x)
+ (record-mutator record-name #,c))
+ lst)
+ lst))
+ '() fields (sequence (length fields))))
+ (parent-cd (cond ((not (unspecified? _parent))
+ #`(record-constructor-descriptor #,_parent))
+ ((not (unspecified? _parent-rtd))
+ (cadr _parent-rtd))
+ (else #f)))
+ (parent-rtd (cond ((not (unspecified? _parent))
+ #`(record-type-descriptor #,_parent))
+ ((not (unspecified? _parent-rtd))
+ (car _parent-rtd))
+ (else #f)))
+ (protocol (if (unspecified? _protocol) #f _protocol))
+ (uid (if (unspecified? _nongenerative) #f _nongenerative))
+ (sealed? (if (unspecified? _sealed) #f _sealed))
+ (opaque? (if (unspecified? _opaque) #f _opaque)))
+ #`(begin
+ (define record-name
+ (make-record-type-descriptor
+ (quote record-name)
+ #,parent-rtd #,uid #,sealed? #,opaque?
+ #,field-names))
+ (define constructor-name
+ (record-constructor
+ (make-record-constructor-descriptor
+ record-name #,parent-cd #,protocol)))
(define dummy
(let ()
(register-record-type
- #,record-name-sym
+ (quote record-name)
record-name (make-record-constructor-descriptor
record-name #,parent-cd #,protocol))
'dummy))
- (define predicate-name (record-predicate record-name))
- #,@field-accessors
- #,@field-mutators))
- (let ((cr (car record-clauses)))
- (case (car cr)
- ((fields)
- (if (unspecified? fields)
- (loop (process-fields (syntax->datum #'record-name)
- (cdr cr))
- parent protocol sealed opaque nongenerative
- constructor parent-rtd (cdr record-clauses))
- (raise (make-assertion-violation))))
- ((parent)
- (if (not (unspecified? parent-rtd))
- (raise (make-assertion-violation)))
- (if (unspecified? parent)
- (loop fields (cadr cr) protocol sealed opaque
- nongenerative constructor parent-rtd
- (cdr record-clauses))
- (raise (make-assertion-violation))))
- ((protocol)
- (if (unspecified? protocol)
- (loop fields parent (cadr cr) sealed opaque
- nongenerative constructor parent-rtd
- (cdr record-clauses))
- (raise (make-assertion-violation))))
- ((sealed)
- (if (unspecified? sealed)
- (loop fields parent protocol (cadr cr) opaque
- nongenerative constructor parent-rtd
- (cdr record-clauses))
- (raise (make-assertion-violation))))
- ((opaque) (if (unspecified? opaque)
- (loop fields parent protocol sealed (cadr cr)
- nongenerative constructor parent-rtd
- (cdr record-clauses))
- (raise (make-assertion-violation))))
- ((nongenerative)
- (if (unspecified? nongenerative)
- (let ((uid (list 'quote
- (or (and (> (length cr) 1) (cadr cr))
- (gensym)))))
- (loop fields parent protocol sealed
- opaque uid constructor
- parent-rtd (cdr record-clauses)))
- (raise (make-assertion-violation))))
- ((parent-rtd)
- (if (not (unspecified? parent))
- (raise (make-assertion-violation)))
- (if (unspecified? parent-rtd)
- (loop fields parent protocol sealed opaque
- nongenerative constructor (cdr cr)
- (cdr record-clauses))
- (raise (make-assertion-violation))))
- (else (raise (make-assertion-violation)))))))))))
+ (define predicate-name (record-predicate record-name))
+ #,@field-accessors
+ #,@field-mutators))]
+ [((fields record-fields ...) . rest)
+ (if (unspecified? _fields)
+ (loop (process-fields #'record-name #'(record-fields ...))
+ _parent _protocol _sealed _opaque _nongenerative
+ _constructor _parent-rtd #'rest)
+ (raise (make-assertion-violation)))]
+ [((parent parent-name) . rest)
+ (if (not (unspecified? _parent-rtd))
+ (raise (make-assertion-violation))
+ (if (unspecified? _parent)
+ (loop _fields #'parent-name _protocol _sealed _opaque
+ _nongenerative _constructor _parent-rtd #'rest)
+ (raise (make-assertion-violation))))]
+ [((protocol expression) . rest)
+ (if (unspecified? _protocol)
+ (loop _fields _parent #'expression _sealed _opaque
+ _nongenerative _constructor _parent-rtd #'rest)
+ (raise (make-assertion-violation)))]
+ [((sealed sealed?) . rest)
+ (if (unspecified? _sealed)
+ (loop _fields _parent _protocol #'sealed? _opaque
+ _nongenerative _constructor _parent-rtd #'rest)
+ (raise (make-assertion-violation)))]
+ [((opaque opaque?) . rest)
+ (if (unspecified? _opaque)
+ (loop _fields _parent _protocol _sealed #'opaque?
+ _nongenerative _constructor _parent-rtd #'rest)
+ (raise (make-assertion-violation)))]
+ [((nongenerative) . rest)
+ (if (unspecified? _nongenerative)
+ (loop _fields _parent _protocol _sealed
+ _opaque #`(quote #,(datum->syntax #'record-name (gensym)))
+ _constructor _parent-rtd #'rest)
+ (raise (make-assertion-violation)))]
+ [((nongenerative uid) . rest)
+ (if (unspecified? _nongenerative)
+ (loop _fields _parent _protocol _sealed
+ _opaque #''uid _constructor
+ _parent-rtd #'rest)
+ (raise (make-assertion-violation)))]
+ [((parent-rtd rtd cd) . rest)
+ (if (not (unspecified? _parent))
+ (raise (make-assertion-violation))
+ (if (unspecified? _parent-rtd)
+ (loop _fields _parent _protocol _sealed _opaque
+ _nongenerative _constructor #'(rtd cd)
+ #'rest)
+ (raise (make-assertion-violation))))]))))))
(define-syntax record-type-descriptor
(lambda (stx)
diff --git a/test-suite/tests/r6rs-records-syntactic.test b/test-suite/tests/r6rs-records-syntactic.test
index 152e31c..d320997 100644
--- a/test-suite/tests/r6rs-records-syntactic.test
+++ b/test-suite/tests/r6rs-records-syntactic.test
@@ -22,6 +22,9 @@
:use-module ((rnrs records syntactic) :version (6))
:use-module ((rnrs records procedural) :version (6))
:use-module ((rnrs records inspection) :version (6))
+ :use-module ((rnrs conditions) :version (6))
+ :use-module ((rnrs exceptions) :version (6))
+ :use-module ((system base compile) #:select (compile))
:use-module (test-suite lib))
(define-record-type simple-rtd)
@@ -115,3 +118,34 @@
(pass-if "record-constructor-descriptor returns rcd"
(procedure? (record-constructor (record-constructor-descriptor simple-rtd))))
+
+(with-test-prefix "record hygiene"
+ (pass-if-exception "using shadowed record keywords fails" exception:syntax-pattern-unmatched
+ (compile '(let ((fields #f))
+ (define-record-type foo (fields bar))
+ #t)
+ #:env (current-module)))
+ (pass-if "using shadowed record keywords fails 2"
+ (guard (condition ((syntax-violation? condition) #t))
+ (compile '(let ((immutable #f))
+ (define-record-type foo (fields (immutable bar)))
+ #t)
+ #:env (current-module))
+ #f))
+ (pass-if "hygiene preserved when using macros"
+ (compile '(begin
+ (define pass #t)
+ (define-syntax define-record
+ (syntax-rules ()
+ ((define-record name field)
+ (define-record-type name
+ (protocol
+ (lambda (x)
+ (lambda ()
+ ;; pass refers to pass in scope of macro not use
+ (x pass))))
+ (fields field)))))
+ (let ((pass #f))
+ (define-record foo bar)
+ (foo-bar (make-foo))))
+ #:env (current-module))))
--
1.7.3.4
^ permalink raw reply related [flat|nested] 4+ messages in thread* Re: r6rs define-record-type is unhygienic
2011-06-11 13:36 r6rs define-record-type is unhygienic Ian Price
@ 2011-06-17 8:34 ` Andy Wingo
2011-06-17 22:36 ` Ian Price
0 siblings, 1 reply; 4+ messages in thread
From: Andy Wingo @ 2011-06-17 8:34 UTC (permalink / raw)
To: Ian Price; +Cc: bug-guile
Hi Ian,
Great debugging, and great patch.
On Sat 11 Jun 2011 15:36, Ian Price <ianprice90@googlemail.com> writes:
> I have attached a patch for stable-2.0 to deal with these
> issues. Keywords are now matched as syntax-case literals, and
> sub-expressions are de-structured as necessary, rather than by using
> syntax->datum on all the clauses at the start. There are some issues I
> didn't touch, e.g. I think that the error messages should be improved,
> but I can do that too if you would like.
Please feel free to improve the error messages, or anything else
really.
Only a couple of nits with the patch:
> * module/rnrs/records/syntactic.scm(define-record-type0, process-fields):
^ a space goes here
> + (list (wrap `(immutable ,(syntax->datum #'name))) (guess-accessor-name #'name) #f)]
Please avoid lines longer than 80 characters, if possible.
> + (let loop ((_fields *unspecified*)
> + (_parent *unspecified*)
I realize this was in the original code, but better to use some other
value to indicate a non-initialized value. In the future *unspecified*
will be the same as (values).
> :use-module ((rnrs records inspection) :version (6))
> + :use-module ((rnrs conditions) :version (6))
> + :use-module ((rnrs exceptions) :version (6))
> + :use-module ((system base compile) #:select (compile))
> :use-module (test-suite lib))
Along the same lines, #:use-module and #:version are the preferred
spellings now.
> +(with-test-prefix "record hygiene"
Thanks for the test.
Want to fix the line wrapping and the commit message and resubmit?
Thanks!
Andy
--
http://wingolog.org/
^ permalink raw reply [flat|nested] 4+ messages in thread* Re: r6rs define-record-type is unhygienic
2011-06-17 8:34 ` Andy Wingo
@ 2011-06-17 22:36 ` Ian Price
2011-06-19 19:44 ` Andy Wingo
0 siblings, 1 reply; 4+ messages in thread
From: Ian Price @ 2011-06-17 22:36 UTC (permalink / raw)
To: Andy Wingo; +Cc: bug-guile
[-- Attachment #1: Type: text/plain, Size: 1475 bytes --]
Andy Wingo <wingo@pobox.com> writes:
> Only a couple of nits with the patch:
>
>> * module/rnrs/records/syntactic.scm(define-record-type0, process-fields):
> ^ a space goes here
Fixed
>
>> + (list (wrap `(immutable ,(syntax->datum #'name))) (guess-accessor-name #'name) #f)]
>
> Please avoid lines longer than 80 characters, if possible.
Fixed them all
>
>> + (let loop ((_fields *unspecified*)
>> + (_parent *unspecified*)
>
> I realize this was in the original code, but better to use some other
> value to indicate a non-initialized value. In the future *unspecified*
> will be the same as (values).
For now, I've went with putting
(define *unspecified* (cons #f #f))
(define (unspecified? x) (eq? *unspecified* x))
in the body of the lambda. I think the macro could use a rethink though,
and I'll try to give it one over the weekend.
>> :use-module ((rnrs records inspection) :version (6))
>> + :use-module ((rnrs conditions) :version (6))
>> + :use-module ((rnrs exceptions) :version (6))
>> + :use-module ((system base compile) #:select (compile))
>> :use-module (test-suite lib))
>
> Along the same lines, #:use-module and #:version are the preferred
> spellings now.
Done.
> Want to fix the line wrapping and the commit message and resubmit?
Attached.
--
Ian Price
"There are only two hard problems in Computer Science: cache invalidation
and naming things." - Phil Karlton
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: amended patch --]
[-- Type: text/x-patch, Size: 17146 bytes --]
From f331ecbe9d0f35ef88099d41a5045c01ef5b04ad Mon Sep 17 00:00:00 2001
From: Ian Price <ianprice90@googlemail.com>
Date: Sat, 11 Jun 2011 02:43:08 +0100
Subject: [PATCH] Fix hygiene issues with `define-record-type'
* module/rnrs/records/syntactic.scm (define-record-type0, process-fields):
Preserve hygiene of record clauses.
* test-suite/tests/r6rs-records-syntactic.test ("record hygiene"):
Add tests.
---
module/rnrs/records/syntactic.scm | 296 +++++++++++++-------------
test-suite/tests/r6rs-records-syntactic.test | 42 ++++-
2 files changed, 181 insertions(+), 157 deletions(-)
diff --git a/module/rnrs/records/syntactic.scm b/module/rnrs/records/syntactic.scm
index 6431fcf..a497b90 100644
--- a/module/rnrs/records/syntactic.scm
+++ b/module/rnrs/records/syntactic.scm
@@ -21,7 +21,7 @@
(export define-record-type
record-type-descriptor
record-constructor-descriptor)
- (import (only (guile) *unspecified* and=> gensym unspecified?)
+ (import (only (guile) and=> gensym)
(rnrs base (6))
(rnrs conditions (6))
(rnrs exceptions (6))
@@ -75,172 +75,162 @@
(number-fields-inner fields 0))
(define (process-fields record-name fields)
- (define record-name-str (symbol->string record-name))
+ (define (wrap x) (datum->syntax record-name x))
+ (define (id->string x)
+ (symbol->string (syntax->datum x)))
+ (define record-name-str (id->string record-name))
(define (guess-accessor-name field-name)
- (string->symbol (string-append
- record-name-str "-" (symbol->string field-name))))
+ (wrap
+ (string->symbol (string-append
+ record-name-str "-" (id->string field-name)))))
(define (guess-mutator-name field-name)
- (string->symbol
- (string-append
- record-name-str "-" (symbol->string field-name) "-set!")))
-
+ (wrap
+ (string->symbol
+ (string-append
+ record-name-str "-" (id->string field-name) "-set!"))))
(define (f x)
- (define (lose)
- (syntax-violation 'define-record-type "invalid field specifier" x))
- (cond ((symbol? x) (list 'immutable x (guess-accessor-name x) #f))
- ((not (list? x)) (lose))
- ((eq? (car x) 'immutable)
- (cons 'immutable
- (case (length x)
- ((2) (list (cadr x) (guess-accessor-name (cadr x)) #f))
- ((3) (list (cadr x) (caddr x) #f))
- (else (lose)))))
- ((eq? (car x) 'mutable)
- (cons 'mutable
- (case (length x)
- ((2) (list (cadr x)
- (guess-accessor-name (cadr x))
- (guess-mutator-name (cadr x))))
- ((4) (cdr x))
- (else (lose)))))
- (else (lose))))
+ (syntax-case x (immutable mutable)
+ [(immutable name)
+ (list (wrap `(immutable ,(syntax->datum #'name)))
+ (guess-accessor-name #'name)
+ #f)]
+ [(immutable name accessor)
+ (list (wrap `(immutable ,(syntax->datum #'name))) #'accessor #f)]
+ [(mutable name)
+ (list (wrap `(mutable ,(syntax->datum #'name)))
+ (guess-accessor-name #'name)
+ (guess-mutator-name #'name))]
+ [(mutable name accessor mutator)
+ (list (wrap `(mutable ,(syntax->datum #'name))) #'accessor #'mutator)]
+ [name
+ (identifier? #'name)
+ (list (wrap `(immutable ,(syntax->datum #'name)))
+ (guess-accessor-name #'name)
+ #f)]
+ [else
+ (syntax-violation 'define-record-type "invalid field specifier" x)]))
(map f fields))
(define-syntax define-record-type0
(lambda (stx)
+ (define *unspecified* (cons #f #f))
+ (define (unspecified? obj)
+ (eq? *unspecified* obj))
(syntax-case stx ()
- ((_ (record-name constructor-name predicate-name) record-clause ...)
- (let loop ((fields *unspecified*)
- (parent *unspecified*)
- (protocol *unspecified*)
- (sealed *unspecified*)
- (opaque *unspecified*)
- (nongenerative *unspecified*)
- (constructor *unspecified*)
- (parent-rtd *unspecified*)
- (record-clauses (syntax->datum #'(record-clause ...))))
- (if (null? record-clauses)
- (let*
- ((fields (if (unspecified? fields) '() fields))
- (field-names
- (datum->syntax
- #'record-name
- (list->vector (map (lambda (x) (take x 2)) fields))))
- (field-accessors
- (fold-left (lambda (x c lst)
- (cons #`(define #,(datum->syntax
- #'record-name (caddr x))
- (record-accessor record-name #,c))
- lst))
- '() fields (sequence (length fields))))
- (field-mutators
- (fold-left (lambda (x c lst)
- (if (cadddr x)
- (cons #`(define #,(datum->syntax
- #'record-name (cadddr x))
- (record-mutator record-name #,c))
- lst)
- lst))
- '() fields (sequence (length fields))))
-
- (parent-cd
- (datum->syntax
- stx (cond ((not (unspecified? parent))
- `(record-constructor-descriptor ,parent))
- ((not (unspecified? parent-rtd)) (cadr parent-rtd))
- (else #f))))
- (parent-rtd
- (datum->syntax
- stx (cond ((not (unspecified? parent))
- `(record-type-descriptor ,parent))
- ((not (unspecified? parent-rtd)) (car parent-rtd))
- (else #f))))
-
- (protocol (datum->syntax
- #'record-name (if (unspecified? protocol)
- #f protocol)))
- (uid (datum->syntax
- #'record-name (if (unspecified? nongenerative)
- #f nongenerative)))
- (sealed? (if (unspecified? sealed) #f sealed))
- (opaque? (if (unspecified? opaque) #f opaque))
-
- (record-name-sym (datum->syntax
- stx (list 'quote
- (syntax->datum #'record-name)))))
-
- #`(begin
- (define record-name
- (make-record-type-descriptor
- #,record-name-sym
- #,parent-rtd #,uid #,sealed? #,opaque?
- #,field-names))
- (define constructor-name
- (record-constructor
- (make-record-constructor-descriptor
- record-name #,parent-cd #,protocol)))
+ ((_ (record-name constructor-name predicate-name) record-clause ...)
+ (let loop ((_fields *unspecified*)
+ (_parent *unspecified*)
+ (_protocol *unspecified*)
+ (_sealed *unspecified*)
+ (_opaque *unspecified*)
+ (_nongenerative *unspecified*)
+ (_constructor *unspecified*)
+ (_parent-rtd *unspecified*)
+ (record-clauses #'(record-clause ...)))
+ (syntax-case record-clauses
+ (fields parent protocol sealed opaque nongenerative
+ constructor parent-rtd)
+ [()
+ (let* ((fields (if (unspecified? _fields) '() _fields))
+ (field-names (list->vector (map car fields)))
+ (field-accessors
+ (fold-left (lambda (x c lst)
+ (cons #`(define #,(cadr x)
+ (record-accessor record-name #,c))
+ lst))
+ '() fields (sequence (length fields))))
+ (field-mutators
+ (fold-left (lambda (x c lst)
+ (if (caddr x)
+ (cons #`(define #,(caddr x)
+ (record-mutator record-name
+ #,c))
+ lst)
+ lst))
+ '() fields (sequence (length fields))))
+ (parent-cd (cond ((not (unspecified? _parent))
+ #`(record-constructor-descriptor
+ #,_parent))
+ ((not (unspecified? _parent-rtd))
+ (cadr _parent-rtd))
+ (else #f)))
+ (parent-rtd (cond ((not (unspecified? _parent))
+ #`(record-type-descriptor #,_parent))
+ ((not (unspecified? _parent-rtd))
+ (car _parent-rtd))
+ (else #f)))
+ (protocol (if (unspecified? _protocol) #f _protocol))
+ (uid (if (unspecified? _nongenerative) #f _nongenerative))
+ (sealed? (if (unspecified? _sealed) #f _sealed))
+ (opaque? (if (unspecified? _opaque) #f _opaque)))
+ #`(begin
+ (define record-name
+ (make-record-type-descriptor
+ (quote record-name)
+ #,parent-rtd #,uid #,sealed? #,opaque?
+ #,field-names))
+ (define constructor-name
+ (record-constructor
+ (make-record-constructor-descriptor
+ record-name #,parent-cd #,protocol)))
(define dummy
(let ()
(register-record-type
- #,record-name-sym
+ (quote record-name)
record-name (make-record-constructor-descriptor
record-name #,parent-cd #,protocol))
'dummy))
- (define predicate-name (record-predicate record-name))
- #,@field-accessors
- #,@field-mutators))
- (let ((cr (car record-clauses)))
- (case (car cr)
- ((fields)
- (if (unspecified? fields)
- (loop (process-fields (syntax->datum #'record-name)
- (cdr cr))
- parent protocol sealed opaque nongenerative
- constructor parent-rtd (cdr record-clauses))
- (raise (make-assertion-violation))))
- ((parent)
- (if (not (unspecified? parent-rtd))
- (raise (make-assertion-violation)))
- (if (unspecified? parent)
- (loop fields (cadr cr) protocol sealed opaque
- nongenerative constructor parent-rtd
- (cdr record-clauses))
- (raise (make-assertion-violation))))
- ((protocol)
- (if (unspecified? protocol)
- (loop fields parent (cadr cr) sealed opaque
- nongenerative constructor parent-rtd
- (cdr record-clauses))
- (raise (make-assertion-violation))))
- ((sealed)
- (if (unspecified? sealed)
- (loop fields parent protocol (cadr cr) opaque
- nongenerative constructor parent-rtd
- (cdr record-clauses))
- (raise (make-assertion-violation))))
- ((opaque) (if (unspecified? opaque)
- (loop fields parent protocol sealed (cadr cr)
- nongenerative constructor parent-rtd
- (cdr record-clauses))
- (raise (make-assertion-violation))))
- ((nongenerative)
- (if (unspecified? nongenerative)
- (let ((uid (list 'quote
- (or (and (> (length cr) 1) (cadr cr))
- (gensym)))))
- (loop fields parent protocol sealed
- opaque uid constructor
- parent-rtd (cdr record-clauses)))
- (raise (make-assertion-violation))))
- ((parent-rtd)
- (if (not (unspecified? parent))
- (raise (make-assertion-violation)))
- (if (unspecified? parent-rtd)
- (loop fields parent protocol sealed opaque
- nongenerative constructor (cdr cr)
- (cdr record-clauses))
- (raise (make-assertion-violation))))
- (else (raise (make-assertion-violation)))))))))))
+ (define predicate-name (record-predicate record-name))
+ #,@field-accessors
+ #,@field-mutators))]
+ [((fields record-fields ...) . rest)
+ (if (unspecified? _fields)
+ (loop (process-fields #'record-name #'(record-fields ...))
+ _parent _protocol _sealed _opaque _nongenerative
+ _constructor _parent-rtd #'rest)
+ (raise (make-assertion-violation)))]
+ [((parent parent-name) . rest)
+ (if (not (unspecified? _parent-rtd))
+ (raise (make-assertion-violation))
+ (if (unspecified? _parent)
+ (loop _fields #'parent-name _protocol _sealed _opaque
+ _nongenerative _constructor _parent-rtd #'rest)
+ (raise (make-assertion-violation))))]
+ [((protocol expression) . rest)
+ (if (unspecified? _protocol)
+ (loop _fields _parent #'expression _sealed _opaque
+ _nongenerative _constructor _parent-rtd #'rest)
+ (raise (make-assertion-violation)))]
+ [((sealed sealed?) . rest)
+ (if (unspecified? _sealed)
+ (loop _fields _parent _protocol #'sealed? _opaque
+ _nongenerative _constructor _parent-rtd #'rest)
+ (raise (make-assertion-violation)))]
+ [((opaque opaque?) . rest)
+ (if (unspecified? _opaque)
+ (loop _fields _parent _protocol _sealed #'opaque?
+ _nongenerative _constructor _parent-rtd #'rest)
+ (raise (make-assertion-violation)))]
+ [((nongenerative) . rest)
+ (if (unspecified? _nongenerative)
+ (loop _fields _parent _protocol _sealed _opaque
+ #`(quote #,(datum->syntax #'record-name (gensym)))
+ _constructor _parent-rtd #'rest)
+ (raise (make-assertion-violation)))]
+ [((nongenerative uid) . rest)
+ (if (unspecified? _nongenerative)
+ (loop _fields _parent _protocol _sealed
+ _opaque #''uid _constructor
+ _parent-rtd #'rest)
+ (raise (make-assertion-violation)))]
+ [((parent-rtd rtd cd) . rest)
+ (if (not (unspecified? _parent))
+ (raise (make-assertion-violation))
+ (if (unspecified? _parent-rtd)
+ (loop _fields _parent _protocol _sealed _opaque
+ _nongenerative _constructor #'(rtd cd)
+ #'rest)
+ (raise (make-assertion-violation))))]))))))
(define-syntax record-type-descriptor
(lambda (stx)
diff --git a/test-suite/tests/r6rs-records-syntactic.test b/test-suite/tests/r6rs-records-syntactic.test
index 152e31c..9f9d373 100644
--- a/test-suite/tests/r6rs-records-syntactic.test
+++ b/test-suite/tests/r6rs-records-syntactic.test
@@ -19,10 +19,13 @@
\f
(define-module (test-suite test-rnrs-records-syntactic)
- :use-module ((rnrs records syntactic) :version (6))
- :use-module ((rnrs records procedural) :version (6))
- :use-module ((rnrs records inspection) :version (6))
- :use-module (test-suite lib))
+ #:use-module ((rnrs records syntactic) #:version (6))
+ #:use-module ((rnrs records procedural) #:version (6))
+ #:use-module ((rnrs records inspection) #:version (6))
+ #:use-module ((rnrs conditions) #:version (6))
+ #:use-module ((rnrs exceptions) #:version (6))
+ #:use-module ((system base compile) #:select (compile))
+ #:use-module (test-suite lib))
(define-record-type simple-rtd)
(define-record-type
@@ -115,3 +118,34 @@
(pass-if "record-constructor-descriptor returns rcd"
(procedure? (record-constructor (record-constructor-descriptor simple-rtd))))
+
+(with-test-prefix "record hygiene"
+ (pass-if-exception "using shadowed record keywords fails" exception:syntax-pattern-unmatched
+ (compile '(let ((fields #f))
+ (define-record-type foo (fields bar))
+ #t)
+ #:env (current-module)))
+ (pass-if "using shadowed record keywords fails 2"
+ (guard (condition ((syntax-violation? condition) #t))
+ (compile '(let ((immutable #f))
+ (define-record-type foo (fields (immutable bar)))
+ #t)
+ #:env (current-module))
+ #f))
+ (pass-if "hygiene preserved when using macros"
+ (compile '(begin
+ (define pass #t)
+ (define-syntax define-record
+ (syntax-rules ()
+ ((define-record name field)
+ (define-record-type name
+ (protocol
+ (lambda (x)
+ (lambda ()
+ ;; pass refers to pass in scope of macro not use
+ (x pass))))
+ (fields field)))))
+ (let ((pass #f))
+ (define-record foo bar)
+ (foo-bar (make-foo))))
+ #:env (current-module))))
--
1.7.5.4
^ permalink raw reply related [flat|nested] 4+ messages in thread
end of thread, other threads:[~2011-06-19 19:44 UTC | newest]
Thread overview: 4+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2011-06-11 13:36 r6rs define-record-type is unhygienic Ian Price
2011-06-17 8:34 ` Andy Wingo
2011-06-17 22:36 ` Ian Price
2011-06-19 19:44 ` Andy Wingo
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).