mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

Fix hygiene issues with `define-record-type'

Browse source 
* 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.
This commit is contained in:
Ian Price 2011-06-11 02:43:08 +01:00 • committed by Andy Wingo
parent d1f2417102
commit 5f09e4ba3c
2 changed files with 181 additions and 157 deletions
Download patch file Download diff file Expand all files Collapse all files

246
module/rnrs/records/syntactic.scm
View file

@ -21,7 +21,7 @@
(export define-record-type (export define-record-type
record-type-descriptor record-type-descriptor
record-constructor-descriptor) record-constructor-descriptor)
(import (only (guile) *unspecified* and=> gensym unspecified?) (import (only (guile) and=> gensym)
(rnrs base (6)) (rnrs base (6))
(rnrs conditions (6)) (rnrs conditions (6))
(rnrs exceptions (6)) (rnrs exceptions (6))
@ -75,104 +75,98 @@
(number-fields-inner fields 0)) (number-fields-inner fields 0))
(define (process-fields record-name fields) (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) (define (guess-accessor-name field-name)
(wrap
(string->symbol (string-append (string->symbol (string-append
record-name-str "-" (symbol->string field-name)))) record-name-str "-" (id->string field-name)))))
(define (guess-mutator-name field-name) (define (guess-mutator-name field-name)
(wrap
(string->symbol (string->symbol
(string-append (string-append
record-name-str "-" (symbol->string field-name) "-set!"))) record-name-str "-" (id->string field-name) "-set!"))))
(define (f x) (define (f x)
(define (lose) (syntax-case x (immutable mutable)
(syntax-violation 'define-record-type "invalid field specifier" x)) [(immutable name)
(cond ((symbol? x) (list 'immutable x (guess-accessor-name x) #f)) (list (wrap `(immutable ,(syntax->datum #'name)))
((not (list? x)) (lose)) (guess-accessor-name #'name)
((eq? (car x) 'immutable) #f)]
(cons 'immutable [(immutable name accessor)
(case (length x) (list (wrap `(immutable ,(syntax->datum #'name))) #'accessor #f)]
((2) (list (cadr x) (guess-accessor-name (cadr x)) #f)) [(mutable name)
((3) (list (cadr x) (caddr x) #f)) (list (wrap `(mutable ,(syntax->datum #'name)))
(else (lose))))) (guess-accessor-name #'name)
((eq? (car x) 'mutable) (guess-mutator-name #'name))]
(cons 'mutable [(mutable name accessor mutator)
(case (length x) (list (wrap `(mutable ,(syntax->datum #'name))) #'accessor #'mutator)]
((2) (list (cadr x) [name
(guess-accessor-name (cadr x)) (identifier? #'name)
(guess-mutator-name (cadr x)))) (list (wrap `(immutable ,(syntax->datum #'name)))
((4) (cdr x)) (guess-accessor-name #'name)
(else (lose))))) #f)]
(else (lose)))) [else
(syntax-violation 'define-record-type "invalid field specifier" x)]))
(map f fields)) (map f fields))
(define-syntax define-record-type0 (define-syntax define-record-type0
(lambda (stx) (lambda (stx)
(define *unspecified* (cons #f #f))
(define (unspecified? obj)
(eq? *unspecified* obj))
(syntax-case stx () (syntax-case stx ()
((_ (record-name constructor-name predicate-name) record-clause ...) ((_ (record-name constructor-name predicate-name) record-clause ...)
(let loop ((fields *unspecified*) (let loop ((_fields *unspecified*)
(parent *unspecified*) (_parent *unspecified*)
(protocol *unspecified*) (_protocol *unspecified*)
(sealed *unspecified*) (_sealed *unspecified*)
(opaque *unspecified*) (_opaque *unspecified*)
(nongenerative *unspecified*) (_nongenerative *unspecified*)
(constructor *unspecified*) (_constructor *unspecified*)
(parent-rtd *unspecified*) (_parent-rtd *unspecified*)
(record-clauses (syntax->datum #'(record-clause ...)))) (record-clauses #'(record-clause ...)))
(if (null? record-clauses) (syntax-case record-clauses
(let* (fields parent protocol sealed opaque nongenerative
((fields (if (unspecified? fields) '() fields)) constructor parent-rtd)
(field-names [()
(datum->syntax (let* ((fields (if (unspecified? _fields) '() _fields))
#'record-name (field-names (list->vector (map car fields)))
(list->vector (map (lambda (x) (take x 2)) fields))))
(field-accessors (field-accessors
(fold-left (lambda (x c lst) (fold-left (lambda (x c lst)
(cons #`(define #,(datum->syntax (cons #`(define #,(cadr x)
#'record-name (caddr x))
(record-accessor record-name #,c)) (record-accessor record-name #,c))
lst)) lst))
'() fields (sequence (length fields)))) '() fields (sequence (length fields))))
(field-mutators (field-mutators
(fold-left (lambda (x c lst) (fold-left (lambda (x c lst)
(if (cadddr x) (if (caddr x)
(cons #`(define #,(datum->syntax (cons #`(define #,(caddr x)
#'record-name (cadddr x)) (record-mutator record-name
(record-mutator record-name #,c)) #,c))
lst) lst)
lst)) lst))
'() fields (sequence (length fields)))) '() fields (sequence (length fields))))
(parent-cd (cond ((not (unspecified? _parent))
(parent-cd #`(record-constructor-descriptor
(datum->syntax #,_parent))
stx (cond ((not (unspecified? parent)) ((not (unspecified? _parent-rtd))
`(record-constructor-descriptor ,parent)) (cadr _parent-rtd))
((not (unspecified? parent-rtd)) (cadr parent-rtd)) (else #f)))
(else #f)))) (parent-rtd (cond ((not (unspecified? _parent))
(parent-rtd #`(record-type-descriptor #,_parent))
(datum->syntax ((not (unspecified? _parent-rtd))
stx (cond ((not (unspecified? parent)) (car _parent-rtd))
`(record-type-descriptor ,parent)) (else #f)))
((not (unspecified? parent-rtd)) (car parent-rtd)) (protocol (if (unspecified? _protocol) #f _protocol))
(else #f)))) (uid (if (unspecified? _nongenerative) #f _nongenerative))
(sealed? (if (unspecified? _sealed) #f _sealed))
(protocol (datum->syntax (opaque? (if (unspecified? _opaque) #f _opaque)))
#'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 #`(begin
(define record-name (define record-name
(make-record-type-descriptor (make-record-type-descriptor
#,record-name-sym (quote record-name)
#,parent-rtd #,uid #,sealed? #,opaque? #,parent-rtd #,uid #,sealed? #,opaque?
#,field-names)) #,field-names))
(define constructor-name (define constructor-name
@ -182,65 +176,61 @@
(define dummy (define dummy
(let () (let ()
(register-record-type (register-record-type
#,record-name-sym (quote record-name)
record-name (make-record-constructor-descriptor record-name (make-record-constructor-descriptor
record-name #,parent-cd #,protocol)) record-name #,parent-cd #,protocol))
'dummy)) 'dummy))
(define predicate-name (record-predicate record-name)) (define predicate-name (record-predicate record-name))
#,@field-accessors #,@field-accessors
#,@field-mutators)) #,@field-mutators))]
(let ((cr (car record-clauses))) [((fields record-fields ...) . rest)
(case (car cr) (if (unspecified? _fields)
((fields) (loop (process-fields #'record-name #'(record-fields ...))
(if (unspecified? fields) _parent _protocol _sealed _opaque _nongenerative
(loop (process-fields (syntax->datum #'record-name) _constructor _parent-rtd #'rest)
(cdr cr)) (raise (make-assertion-violation)))]
parent protocol sealed opaque nongenerative [((parent parent-name) . rest)
constructor parent-rtd (cdr record-clauses)) (if (not (unspecified? _parent-rtd))
(raise (make-assertion-violation)))) (raise (make-assertion-violation))
((parent) (if (unspecified? _parent)
(if (not (unspecified? parent-rtd)) (loop _fields #'parent-name _protocol _sealed _opaque
(raise (make-assertion-violation))) _nongenerative _constructor _parent-rtd #'rest)
(if (unspecified? parent) (raise (make-assertion-violation))))]
(loop fields (cadr cr) protocol sealed opaque [((protocol expression) . rest)
nongenerative constructor parent-rtd (if (unspecified? _protocol)
(cdr record-clauses)) (loop _fields _parent #'expression _sealed _opaque
(raise (make-assertion-violation)))) _nongenerative _constructor _parent-rtd #'rest)
((protocol) (raise (make-assertion-violation)))]
(if (unspecified? protocol) [((sealed sealed?) . rest)
(loop fields parent (cadr cr) sealed opaque (if (unspecified? _sealed)
nongenerative constructor parent-rtd (loop _fields _parent _protocol #'sealed? _opaque
(cdr record-clauses)) _nongenerative _constructor _parent-rtd #'rest)
(raise (make-assertion-violation)))) (raise (make-assertion-violation)))]
((sealed) [((opaque opaque?) . rest)
(if (unspecified? sealed) (if (unspecified? _opaque)
(loop fields parent protocol (cadr cr) opaque (loop _fields _parent _protocol _sealed #'opaque?
nongenerative constructor parent-rtd _nongenerative _constructor _parent-rtd #'rest)
(cdr record-clauses)) (raise (make-assertion-violation)))]
(raise (make-assertion-violation)))) [((nongenerative) . rest)
((opaque) (if (unspecified? opaque) (if (unspecified? _nongenerative)
(loop fields parent protocol sealed (cadr cr) (loop _fields _parent _protocol _sealed _opaque
nongenerative constructor parent-rtd #`(quote #,(datum->syntax #'record-name (gensym)))
(cdr record-clauses)) _constructor _parent-rtd #'rest)
(raise (make-assertion-violation)))) (raise (make-assertion-violation)))]
((nongenerative) [((nongenerative uid) . rest)
(if (unspecified? nongenerative) (if (unspecified? _nongenerative)
(let ((uid (list 'quote (loop _fields _parent _protocol _sealed
(or (and (> (length cr) 1) (cadr cr)) _opaque #''uid _constructor
(gensym))))) _parent-rtd #'rest)
(loop fields parent protocol sealed (raise (make-assertion-violation)))]
opaque uid constructor [((parent-rtd rtd cd) . rest)
parent-rtd (cdr record-clauses))) (if (not (unspecified? _parent))
(raise (make-assertion-violation)))) (raise (make-assertion-violation))
((parent-rtd) (if (unspecified? _parent-rtd)
(if (not (unspecified? parent)) (loop _fields _parent _protocol _sealed _opaque
(raise (make-assertion-violation))) _nongenerative _constructor #'(rtd cd)
(if (unspecified? parent-rtd) #'rest)
(loop fields parent protocol sealed opaque (raise (make-assertion-violation))))]))))))
nongenerative constructor (cdr cr)
(cdr record-clauses))
(raise (make-assertion-violation))))
(else (raise (make-assertion-violation)))))))))))
(define-syntax record-type-descriptor (define-syntax record-type-descriptor
(lambda (stx) (lambda (stx)

42
test-suite/tests/r6rs-records-syntactic.test
View file

@ -19,10 +19,13 @@
(define-module (test-suite test-rnrs-records-syntactic) (define-module (test-suite test-rnrs-records-syntactic)
:use-module ((rnrs records syntactic) :version (6)) #:use-module ((rnrs records syntactic) #:version (6))
:use-module ((rnrs records procedural) :version (6)) #:use-module ((rnrs records procedural) #:version (6))
:use-module ((rnrs records inspection) :version (6)) #:use-module ((rnrs records inspection) #:version (6))
:use-module (test-suite lib)) #: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 simple-rtd)
(define-record-type (define-record-type
@ -115,3 +118,34 @@
(pass-if "record-constructor-descriptor returns rcd" (pass-if "record-constructor-descriptor returns rcd"
(procedure? (record-constructor (record-constructor-descriptor simple-rtd)))) (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))))