parent
51e08c48f1
commit
b97811d4db
|
@ -1230,6 +1230,22 @@
|
|||
(eval '(dynamic-require ''provide/contract66-m2 #f)))
|
||||
"provide/contract66-m1")
|
||||
|
||||
(contract-error-test
|
||||
'provide/contract-struct-out
|
||||
#'(begin
|
||||
(eval '(module pos racket/base
|
||||
(require racket/contract)
|
||||
(provide
|
||||
(contract-out
|
||||
[struct (b not-a) ()])
|
||||
|
||||
(struct a ())
|
||||
(struct b a ())))))
|
||||
(λ (x)
|
||||
(and (exn:fail:syntax? x)
|
||||
(regexp-match #rx"^contract-out: expected a struct name"
|
||||
(exn-message x)))))
|
||||
|
||||
(contract-error-test
|
||||
'contract-error-test8
|
||||
#'(begin
|
||||
|
|
|
@ -23,16 +23,22 @@
|
|||
|
||||
;; lookup-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...))
|
||||
(define (lookup-struct-info stx provide-stx)
|
||||
(let ([id (syntax-case stx ()
|
||||
[(a b) (syntax a)]
|
||||
[_ stx])])
|
||||
(let ([v (syntax-local-value id (λ () #f))])
|
||||
(if (struct-info? v)
|
||||
(extract-struct-info v)
|
||||
(raise-syntax-error 'provide/contract
|
||||
"expected a struct name"
|
||||
provide-stx
|
||||
id)))))
|
||||
(define id (syntax-case stx ()
|
||||
[(a b) (syntax a)]
|
||||
[_ stx]))
|
||||
(define v (syntax-local-value id (λ () #f)))
|
||||
(define error-name
|
||||
(syntax-case provide-stx ()
|
||||
[(x . y)
|
||||
(identifier? #'x)
|
||||
(syntax-e #'x)]
|
||||
[_ 'provide/contract]))
|
||||
(if (struct-info? v)
|
||||
(extract-struct-info v)
|
||||
(raise-syntax-error error-name
|
||||
"expected a struct name"
|
||||
provide-stx
|
||||
id)))
|
||||
|
||||
|
||||
(define (add-name-prop name stx)
|
||||
|
|
|
@ -684,6 +684,8 @@
|
|||
|
||||
[all-parent-struct-count/names
|
||||
(get-field-counts/struct-names struct-name provide-stx)]
|
||||
[_ (and (syntax? super-id)
|
||||
(a:lookup-struct-info super-id provide-stx))] ;; for the error check
|
||||
[parent-struct-count (if (null? all-parent-struct-count/names)
|
||||
#f
|
||||
(let ([pp (cdr all-parent-struct-count/names)])
|
||||
|
|
Loading…
Reference in New Issue
Block a user