better syntax errors for define-record-type; support parent-rtd correctly; more r6rs tests
svn: r9489
This commit is contained in:
Matthew Flatt
parent
8e23842d0c
commit
b8c425cc42
|
|
@ -55,19 +55,34 @@
|
|||
(?k ?default . ?rands))
|
||||
((?name/cps ((?tag ?val) . ?rest) ?k . ?rands)
|
||||
(?k ?val . ?rands))
|
||||
((?name/cps ((?another-tag ?val) . ?rest) ?k . ?rands)
|
||||
((?name/cps ((?another-tag . ?vals) . ?rest) ?k . ?rands)
|
||||
(?name/cps ?rest ?k . ?rands))))
|
||||
|
||||
(define-syntax ?name
|
||||
(syntax-rules (?tag)
|
||||
((?name ())
|
||||
?default)
|
||||
((?name ((?tag ?val) . ?rest))
|
||||
?val)
|
||||
((?name ((?another-tag ?val) . ?rest))
|
||||
((?name ((?another-tag . ?vals) . ?rest))
|
||||
(?name ?rest))))))))
|
||||
|
||||
(define-alist-extractor extract-parent extract-parent/cps parent no-record-type)
|
||||
(define-syntax extract-parent/sel
|
||||
(syntax-rules (parent parent-rtd)
|
||||
((_ () ?sel) #f)
|
||||
((_ ((parent ?val) . ?rest) ?sel)
|
||||
(?sel (record-type-descriptor ?val)
|
||||
(record-constructor-descriptor ?val)))
|
||||
((_ ((parent-rtd ?rtd ?cons) . ?rest) ?sel)
|
||||
(?sel ?rtd ?cons))
|
||||
((_ ((?another-tag . ?vals) . ?rest) ?sel)
|
||||
(extract-parent/sel ?rest ?sel))))
|
||||
(define-syntax sel-record-type-descriptor
|
||||
(syntax-rules ()
|
||||
[(_ ?rtd ?cons) ?rtd]))
|
||||
(define-syntax sel-record-constructor-descriptor
|
||||
(syntax-rules ()
|
||||
[(_ ?rtd ?cons) ?cons]))
|
||||
|
||||
(define-alist-extractor extract-sealed extract-sealed/cps sealed #f)
|
||||
(define-alist-extractor extract-opaque extract-opaque/cps opaque #f)
|
||||
(define-alist-extractor extract-protocol extract-protocol/cps
|
||||
|
|
@ -93,7 +108,7 @@
|
|||
?clause ...))))
|
||||
|
||||
(define-syntax define-record-type-1
|
||||
(syntax-rules (parent protocol sealed nongenerative opaque fields mutable immutable)
|
||||
(syntax-rules (parent parent-rtd protocol sealed nongenerative opaque fields mutable immutable)
|
||||
;; find PARENT clause
|
||||
((define-record-type-1 ?props
|
||||
?field-specs
|
||||
|
|
@ -102,6 +117,13 @@
|
|||
(define-record-type-1 ((parent ?parent) . ?props)
|
||||
?field-specs
|
||||
?clause ...))
|
||||
((define-record-type-1 ?props
|
||||
?field-specs
|
||||
(parent-rtd ?parent ?cons)
|
||||
?clause ...)
|
||||
(define-record-type-1 ((parent-rtd ?parent ?cons) . ?props)
|
||||
?field-specs
|
||||
?clause ...))
|
||||
|
||||
;; find PROTOCOL clause
|
||||
((define-record-type-1 ?props
|
||||
|
|
@ -192,7 +214,7 @@
|
|||
|
||||
(define $rtd
|
||||
(make-record-type-descriptor (extract-record-name/cps ?props quote)
|
||||
(extract-parent/cps ?props record-type-descriptor)
|
||||
(extract-parent/sel ?props sel-record-type-descriptor)
|
||||
(extract-nongenerative ?props)
|
||||
(extract-sealed ?props)
|
||||
(extract-opaque ?props)
|
||||
|
|
@ -201,7 +223,7 @@
|
|||
(define $constructor-descriptor
|
||||
(make-record-constructor-descriptor
|
||||
$rtd
|
||||
(extract-parent/cps ?props record-constructor-descriptor)
|
||||
(extract-parent/sel ?props sel-record-constructor-descriptor)
|
||||
(extract-protocol ?props)))
|
||||
|
||||
(extract-record-name/cps
|
||||
|
|
|
|||
|
|
@ -36,20 +36,184 @@
|
|||
(rename (r6rs private records-explicit)
|
||||
(define-record-type define-record-type/explicit)))
|
||||
|
||||
;; R5RS part of the implementation of DEFINE-RECORD-TYPE for Records SRFI
|
||||
|
||||
(define-syntax define-record-type
|
||||
(syntax-rules ()
|
||||
((define-record-type (?record-name ?constructor-name ?predicate-name)
|
||||
?clause ...)
|
||||
(define-record-type-1 ?record-name (?record-name ?constructor-name ?predicate-name)
|
||||
()
|
||||
?clause ...))
|
||||
((define-record-type ?record-name
|
||||
?clause ...)
|
||||
(define-record-type-1 ?record-name ?record-name
|
||||
()
|
||||
?clause ...))))
|
||||
;; Just check syntax, then send off to reference implementation
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name-spec clause ...)
|
||||
(with-syntax ([(name parts)
|
||||
(syntax-case #'name-spec ()
|
||||
[(name cname pname)
|
||||
(begin
|
||||
(if (not (identifier? #'name))
|
||||
(syntax-violation #f
|
||||
"expected an identifier for the record type name"
|
||||
stx
|
||||
#'name))
|
||||
(if (not (identifier? #'cname))
|
||||
(syntax-violation #f
|
||||
"expected an identifier for the record type constructor name"
|
||||
stx
|
||||
#'cname))
|
||||
(if (not (identifier? #'pname))
|
||||
(syntax-violation #f
|
||||
"expected an identifier for the record type predicate name"
|
||||
stx
|
||||
#'pname))
|
||||
#'(name (name cname pname)))]
|
||||
[name
|
||||
(identifier? #'name)
|
||||
#'(name name)]
|
||||
[_
|
||||
(syntax-violation #f
|
||||
(string-append
|
||||
"expected either an identifier for the record type name"
|
||||
" or a form (<name-id> <constructor-id> <predicate-id>)")
|
||||
stx
|
||||
#'name-spec)])])
|
||||
(let* ([clauses #'(clause ...)]
|
||||
[extract (lambda (id)
|
||||
(let loop ([clauses clauses][found #f])
|
||||
(cond
|
||||
[(null? clauses) found]
|
||||
[(syntax-case (car clauses) ()
|
||||
[(tag . body)
|
||||
(free-identifier=? #'tag id)])
|
||||
(if found
|
||||
(syntax-violation #f
|
||||
(string-append "duplicate "
|
||||
(symbol->string (syntax->datum id))
|
||||
" clause")
|
||||
stx
|
||||
(car clauses))
|
||||
(loop (cdr clauses) (car clauses)))]
|
||||
[else
|
||||
(loop (cdr clauses) found)])))]
|
||||
[kws (with-syntax ([(kw ...)
|
||||
#'(fields mutable immutable parent
|
||||
protocol sealed opaque nongenerative
|
||||
parent-rtd)])
|
||||
#'(kw ...))])
|
||||
(for-each (lambda (clause)
|
||||
(syntax-case clause ()
|
||||
[(id . _)
|
||||
(and (identifier? #'id)
|
||||
(let loop ([kws kws])
|
||||
(and (not (null? kws))
|
||||
(or (free-identifier=? #'id (car kws))
|
||||
(loop (cdr kws))))))
|
||||
'ok]
|
||||
[_
|
||||
(syntax-violation #f
|
||||
(string-append
|
||||
"expected a `mutable', `immutable', `parent',"
|
||||
" `protocol', `sealed', `opaque', `nongenerative',"
|
||||
" or `parent-rtd' clause")
|
||||
stx
|
||||
clause)]))
|
||||
clauses)
|
||||
(if (and (extract #'parent) (extract #'parent-rtd))
|
||||
(syntax-violation #f
|
||||
"cannot specify both `parent' and `parent-rtd'"
|
||||
stx))
|
||||
(syntax-case (extract #'fields) ()
|
||||
[#f 'ok]
|
||||
[(_ spec ...)
|
||||
(for-each (lambda (spec)
|
||||
(syntax-case spec (immutable mutable)
|
||||
[(immutable id acc-id)
|
||||
(begin
|
||||
(if (not (identifier? #'id))
|
||||
(syntax-violation #f
|
||||
"expected a field-name identifier"
|
||||
spec
|
||||
#'id))
|
||||
(if (not (identifier? #'acc-id))
|
||||
(syntax-violation #f
|
||||
"expected a field-accessor identifier"
|
||||
spec
|
||||
#'acc-id)))]
|
||||
[(immutable id)
|
||||
(if (not (identifier? #'id))
|
||||
(syntax-violation #f
|
||||
"expected a field-name identifier"
|
||||
spec
|
||||
#'id))]
|
||||
[(immutable . _)
|
||||
(syntax-violation #f
|
||||
"expected one or two identifiers"
|
||||
spec)]
|
||||
[(mutable id acc-id set-id)
|
||||
(begin
|
||||
(if (not (identifier? #'id))
|
||||
(syntax-violation #f
|
||||
"expected a field-name identifier"
|
||||
spec
|
||||
#'id))
|
||||
(if (not (identifier? #'acc-id))
|
||||
(syntax-violation #f
|
||||
"expected a field-accessor identifier"
|
||||
spec
|
||||
#'acc-id))
|
||||
(if (not (identifier? #'set-id))
|
||||
(syntax-violation #f
|
||||
"expected a field-mutator identifier"
|
||||
spec
|
||||
#'set-id)))]
|
||||
[(mutable id)
|
||||
(if (not (identifier? #'id))
|
||||
(syntax-violation #f
|
||||
"expected a field-name identifier"
|
||||
spec
|
||||
#'id))]
|
||||
[(mutable . _)
|
||||
(syntax-violation #f
|
||||
"expected one or three identifiers"
|
||||
spec)]
|
||||
[id (identifier? #'id) 'ok]
|
||||
[_ (syntax-violation #f
|
||||
"expected an identifier, `immutable' form, or `mutable' form for field"
|
||||
stx
|
||||
spec)]))
|
||||
#'(spec ...))])
|
||||
|
||||
(let ([p (extract #'parent)])
|
||||
(syntax-case p ()
|
||||
[#f 'ok]
|
||||
[(_ id) (identifier? #'id) 'ok]
|
||||
[_ (syntax-violation #f
|
||||
"expected a single identifier for the parent record type"
|
||||
p)]))
|
||||
|
||||
(let ([p (extract #'parent-rtd)])
|
||||
(syntax-case p ()
|
||||
[#f 'ok]
|
||||
[(_ id cons-id) 'ok]
|
||||
[_ (syntax-violation #f
|
||||
"expected two expressions for the parent record type and constructor"
|
||||
p)]))
|
||||
|
||||
(syntax-case (extract #'protocol) ()
|
||||
[#f 'ok]
|
||||
[(_ expr) 'ok])
|
||||
|
||||
(syntax-case (extract #'sealed) ()
|
||||
[#f 'ok]
|
||||
[(_ #f) 'ok]
|
||||
[(_ #t) 'ok])
|
||||
|
||||
(syntax-case (extract #'opaque) ()
|
||||
[#f 'ok]
|
||||
[(_ #f) 'ok]
|
||||
[(_ #t) 'ok])
|
||||
|
||||
(syntax-case (extract #'nongenerative) ()
|
||||
[#f 'ok]
|
||||
[(_) 'ok]
|
||||
[(_ id) (identifier? #'id) 'ok])
|
||||
|
||||
#'(define-record-type-1 name parts
|
||||
() clause ...)))])))
|
||||
|
||||
(define-syntax define-record-type-1
|
||||
(syntax-rules (fields)
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@
|
|||
(rename-out [raise-syntax-error syntax-violation]))
|
||||
|
||||
(define (r6rs:free-identifier=? a b)
|
||||
(free-identifier=? a a))
|
||||
(free-identifier=? a b))
|
||||
|
||||
(define (r6rs:datum->syntax id datum)
|
||||
(unless (identifier? id)
|
||||
|
|
|
|||
|
|
@ -5,6 +5,18 @@
|
|||
(import (rnrs)
|
||||
(tests r6rs test))
|
||||
|
||||
|
||||
(define-syntax test-cond
|
||||
(syntax-rules ()
|
||||
[(_ &c &parent (make arg ...) pred sel ...)
|
||||
(begin
|
||||
(test (pred (make arg ...)) #t)
|
||||
(let ([v (make arg ...)])
|
||||
(test (sel v) arg) ...
|
||||
'ok)
|
||||
(test ((record-predicate &parent) (make arg ...)) #t)
|
||||
(test (record-type-parent &c) &parent))]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-record-type (&cond1 make-cond1 real-cond1?)
|
||||
|
|
@ -118,7 +130,63 @@
|
|||
(test (c1-a v5) "a3")
|
||||
(test (c2-b v5) "b2")
|
||||
|
||||
(test-cond &message &condition
|
||||
(make-message-condition "message")
|
||||
message-condition?
|
||||
condition-message)
|
||||
|
||||
(test-cond &warning &condition
|
||||
(make-warning)
|
||||
warning?)
|
||||
|
||||
(test-cond &serious &condition
|
||||
(make-serious-condition)
|
||||
serious-condition?)
|
||||
|
||||
(test-cond &error &serious
|
||||
(make-error)
|
||||
error?)
|
||||
|
||||
(test-cond &violation &serious
|
||||
(make-violation)
|
||||
violation?)
|
||||
|
||||
(test-cond &assertion &violation
|
||||
(make-assertion-violation)
|
||||
assertion-violation?)
|
||||
|
||||
(test-cond &irritants &condition
|
||||
(make-irritants-condition (list 'sand 'salt 'acid))
|
||||
irritants-condition?
|
||||
condition-irritants)
|
||||
|
||||
(test-cond &who &condition
|
||||
(make-who-condition 'new-boss)
|
||||
who-condition?
|
||||
condition-who)
|
||||
|
||||
(test-cond &non-continuable &violation
|
||||
(make-non-continuable-violation)
|
||||
non-continuable-violation?)
|
||||
|
||||
(test-cond &implementation-restriction &violation
|
||||
(make-implementation-restriction-violation)
|
||||
implementation-restriction-violation?)
|
||||
|
||||
(test-cond &lexical &violation
|
||||
(make-lexical-violation)
|
||||
lexical-violation?)
|
||||
|
||||
(test-cond &syntax &violation
|
||||
(make-syntax-violation '(lambda (x) case) 'case)
|
||||
syntax-violation?
|
||||
syntax-violation-form
|
||||
syntax-violation-subform)
|
||||
|
||||
(test-cond &undefined &violation
|
||||
(make-undefined-violation)
|
||||
undefined-violation?)
|
||||
|
||||
;;
|
||||
))
|
||||
|
||||
|
|
|
|||
|
|
@ -22,6 +22,12 @@
|
|||
(fields
|
||||
(mutable rgb cpoint-rgb cpoint-rgb-set!)))
|
||||
|
||||
(define-record-type (cpoint2 make-cpoint2 cpoint2?)
|
||||
(parent-rtd (record-type-descriptor point)
|
||||
(record-constructor-descriptor point))
|
||||
(fields rgb)
|
||||
(opaque #f) (sealed #f))
|
||||
|
||||
(define (color->rgb c)
|
||||
(cons 'rgb c))
|
||||
|
||||
|
|
@ -94,6 +100,7 @@
|
|||
(test (point-y p1) 17)
|
||||
|
||||
(test (record-rtd p1) (record-type-descriptor point))
|
||||
(test point (record-type-descriptor point))
|
||||
|
||||
(test (ex1-f ex1-i1) '(1 2 3))
|
||||
|
||||
|
|
@ -107,8 +114,37 @@
|
|||
(test (ex3-thickness ex3-i1) 18)
|
||||
(test *ex3-instance* ex3-i1)
|
||||
|
||||
(test (record? p1) #t)
|
||||
(test (record? ex3-i1) #f)
|
||||
|
||||
(test (record-type-name point) 'point)
|
||||
(test (record-type-name cpoint2) 'cpoint2)
|
||||
(test (record-type-name ex1) 'ex1)
|
||||
|
||||
(test (record-type-parent point) #f)
|
||||
(test (record-type-parent cpoint2) point)
|
||||
|
||||
(test (record-type-uid point) 'point-4893d957-e00b-11d9-817f-00111175eb9e)
|
||||
(test/unspec (record-type-uid cpoint2))
|
||||
(test/unspec (record-type-uid ex1))
|
||||
|
||||
(test (record-type-generative? point) #f)
|
||||
(test (record-type-generative? cpoint2) #t)
|
||||
(test (record-type-generative? ex1) #t)
|
||||
|
||||
(test (record-type-sealed? point) #f)
|
||||
(test (record-type-sealed? ex3) #t)
|
||||
|
||||
(test (record-type-opaque? point) #f)
|
||||
(test (record-type-opaque? ex3) #t)
|
||||
|
||||
(test (record-type-field-names point) '#(x y))
|
||||
(test (record-type-field-names cpoint2) '#(rgb))
|
||||
|
||||
(test (record-field-mutable? point 0) #f)
|
||||
(test (record-field-mutable? point 1) #t)
|
||||
(test (record-field-mutable? cpoint 0) #t)
|
||||
|
||||
;;
|
||||
))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user