improve error checking in the struct form of contract-out

closes #2303
This commit is contained in:
Robby Findler 2018-10-12 20:36:53 -04:00
parent 51e08c48f1
commit b97811d4db
3 changed files with 34 additions and 10 deletions

View File

@ -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

View File

@ -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)

View File

@ -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)])