suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adjusted the syntax checking to allow the new syntax of ->i (but still has the old ->d semantics)

Browse Source
This commit is contained in:
Robby Findler 2010-07-12 16:41:08 -05:00
parent f5a190bf80
commit 1fd82ee28e
1 changed files with 25 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
collects/racket/contract/private/arr-i.rkt
View File

@ -70,10 +70,11 @@
[_ [_
(raise-syntax-error #f "bad syntax" stx)]))) (raise-syntax-error #f "bad syntax" stx)])))
;; verify-->d-structure : syntax syntax -> syntax ;; verify-->i-structure : syntax syntax -> syntax
;; returns the second argument when it has the proper shape for the first two arguments to ->d* ;; returns the second argument when it has the proper shape for the first two arguments to ->i
;; otherwise, raises a syntax error. ;; otherwise, raises a syntax error.
(define-for-syntax (verify-->d-structure stx doms) ;; also: drops the extra identifiers in the ->i.
(define-for-syntax (verify-->i-structure stx doms)
(syntax-case doms () (syntax-case doms ()
[((regular ...) (kwd ...)) [((regular ...) (kwd ...))
(let ([check-pair-shape (let ([check-pair-shape
@ -81,19 +82,27 @@
(syntax-case reg () (syntax-case reg ()
[(id dom) [(id dom)
(identifier? #'id) (identifier? #'id)
(void)] reg]
[(a b) [(a b)
(raise-syntax-error #f "expected an identifier" stx #'a)] (raise-syntax-error #f "expected an identifier" stx #'a)]
[(id (id2 ...) dom)
(and (identifier? #'id)
(andmap identifier? (syntax->list #'(id2 ...))))
#'(id dom)]
[(id ids dom)
(unless (identifier? #'id)
(raise-syntax-error #f "expected an identifier" stx #'id))
(raise-syntax-error #f "expected an sequence of identifiers" stx #'ids)]
[_ [_
(raise-syntax-error #f "expected an identifier and a contract-expr" stx reg)]))]) (raise-syntax-error #f "expected an identifier and a contract-expr" stx reg)]))])
(for-each check-pair-shape (syntax->list #'(regular ...))) (list (map check-pair-shape (syntax->list #'(regular ...)))
(for-each (map
(λ (kwd) (λ (kwd)
(syntax-case kwd () (syntax-case kwd ()
[(kwd ps) [(kwd ps)
(check-pair-shape #'ps)])) #`(kwd #,(check-pair-shape #'ps))]))
(syntax->list #'(kwd ...))))]) (syntax->list #'(kwd ...)))))]))
doms)
(define-for-syntax (make-this-transformer this-arg) (define-for-syntax (make-this-transformer this-arg)
(with-syntax ([this-arg this-arg]) (with-syntax ([this-arg this-arg])
@ -117,9 +126,9 @@
leftover) leftover)
(let-values ([(raw-optional-doms id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)]) (let-values ([(raw-optional-doms id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)])
(with-syntax ([(([mandatory-regular-id mandatory-doms] ... ) ([mandatory-kwd (mandatory-kwd-id mandatory-kwd-dom)] ...)) (with-syntax ([(([mandatory-regular-id mandatory-doms] ... ) ([mandatory-kwd (mandatory-kwd-id mandatory-kwd-dom)] ...))
(verify-->d-structure stx (split-doms stx '->d #'(raw-mandatory-doms ...)))] (verify-->i-structure stx (split-doms stx '->i #'(raw-mandatory-doms ...)))]
[(([optional-regular-id optional-doms] ... ) ([optional-kwd (optional-kwd-id optional-kwd-dom)] ...)) [(([optional-regular-id optional-doms] ... ) ([optional-kwd (optional-kwd-id optional-kwd-dom)] ...))
(verify-->d-structure stx (split-doms stx '->d raw-optional-doms))]) (verify-->i-structure stx (split-doms stx '->i raw-optional-doms))])
(with-syntax ([((kwd kwd-id) ...) (with-syntax ([((kwd kwd-id) ...)
(sort-keywords (sort-keywords
stx stx
@ -160,7 +169,7 @@
(syntax->list #'(rng-params ...))) (syntax->list #'(rng-params ...)))
=> =>
(λ (id) (λ (id)
(raise-syntax-error '->d (raise-syntax-error '->i
"expected all of the identifiers to be underscores, or none of them to be" "expected all of the identifiers to be underscores, or none of them to be"
stx stx
id))] id))]
@ -493,7 +502,7 @@
(begin0 (begin0
(string->symbol (format "~a~a" counting-id ids)) (string->symbol (format "~a~a" counting-id ids))
(set! ids (+ ids 1)))]))]) (set! ids (+ ids 1)))]))])
`(->d (,@(map (λ (x) `(,(next-id) ...)) (->d-mandatory-dom-ctcs ctc)) `(->i (,@(map (λ (x) `(,(next-id) ...)) (->d-mandatory-dom-ctcs ctc))
,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-mandatory-keywords ctc)))) ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-mandatory-keywords ctc))))
(,@(map (λ (x) `(,(next-id) ...)) (->d-optional-dom-ctcs ctc)) (,@(map (λ (x) `(,(next-id) ...)) (->d-optional-dom-ctcs ctc))
,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-optional-keywords ctc)))) ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-optional-keywords ctc))))