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

* Enforce the use of a '*' in list-like rest args.

Browse Source 
* Abstract out annotation errors so that we can report it in the other case
   where it's useful.
This commit is contained in:
Stevie Strickland 2008-06-18 12:31:08 -04:00
parent 2b4f1691fa
commit c2a53b316b
1 changed files with 31 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
collects/typed-scheme/private/prims.ss
View File

@ -93,26 +93,32 @@ This file defines two sorts of primitives. All of them are provided into any mod
#,(syntax-property #'(require/contract pred pred-cnt lib) #,(syntax-property #'(require/contract pred pred-cnt lib)
'typechecker:ignore #t))))])) 'typechecker:ignore #t))))]))
(define-for-syntax (types-of-formals stx src) (define-for-syntax (formal-annotation-error stx src)
(syntax-case stx (:)
[([var : ty] ...) (quasisyntax/loc stx (ty ...))]
[([var : ty] ... . [rest : rest-ty])
(syntax/loc stx (ty ... rest-ty *))]
[([var : ty] ... . [rest : rest-ty ddd bound])
(eq? '... (syntax-e #'ddd))
(syntax/loc stx (ty ... rest-ty ddd bound))]
[_
(let loop ([stx stx]) (let loop ([stx stx])
(syntax-case stx () (syntax-case stx ()
;; should never happen ;; should never happen
[() (raise-syntax-error #f "bad annotation syntax" src stx)] [() (raise-syntax-error #f "bad annotation syntax" src stx)]
[[var : ty]
(identifier? #'var)
(raise-syntax-error #f "expected dotted or starred type" src #'ty)]
[([var : ty] . rest) [([var : ty] . rest)
(identifier? #'var) (identifier? #'var)
(loop #'rest)] (loop #'rest)]
[([var : ty] . rest) [([var : ty] . rest)
(raise-syntax-error #f "not a variable" src #'var)] (raise-syntax-error #f "not a variable" src #'var)]
[(e . rest) [(e . rest)
(raise-syntax-error #f "expected annotated variable of the form [x : T], got something else" src #'e)]))])) (raise-syntax-error #f "expected annotated variable of the form [x : T], got something else" src #'e)])))
(define-for-syntax (types-of-formals stx src)
(syntax-case stx (:)
[([var : ty] ...) (quasisyntax/loc stx (ty ...))]
[([var : ty] ... . [rest : rest-ty star])
(eq? '* (syntax-e #'star))
(syntax/loc stx (ty ... rest-ty *))]
[([var : ty] ... . [rest : rest-ty ddd bound])
(eq? '... (syntax-e #'ddd))
(syntax/loc stx (ty ... rest-ty ddd bound))]
[_ (formal-annotation-error stx src)]))
(define-syntax (plambda: stx) (define-syntax (plambda: stx)
@ -144,6 +150,9 @@ This file defines two sorts of primitives. All of them are provided into any mod
(syntax-property #'arg 'type-ascription #'ty)] (syntax-property #'arg 'type-ascription #'ty)]
[(_ arg ty) [(_ arg ty)
(syntax-property #'arg 'type-ascription #'ty)] (syntax-property #'arg 'type-ascription #'ty)]
[(_ arg ty star)
(eq? '* (syntax-e #'star))
(syntax-property #'arg 'type-ascription #'ty)]
[(_ arg ty ddd bound) [(_ arg ty ddd bound)
(eq? '... (syntax-e #'ddd)) (eq? '... (syntax-e #'ddd))
(syntax-property (syntax-property #'arg 'type-ascription #'ty) (syntax-property (syntax-property #'arg 'type-ascription #'ty)
@ -200,7 +209,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
;; helper function for annoating the bound names ;; helper function for annoating the bound names
(define-for-syntax (annotate-names stx) (define-for-syntax (annotate-names stx src)
(define (label-one var ty) (define (label-one var ty)
(syntax-property var 'type-label ty)) (syntax-property var 'type-label ty))
(define (label vars tys) (define (label vars tys)
@ -215,24 +224,27 @@ This file defines two sorts of primitives. All of them are provided into any mod
[[var : ty] (label-one #'var #'ty)] [[var : ty] (label-one #'var #'ty)]
[([var : ty] ...) [([var : ty] ...)
(label #'(var ...) #'(ty ...))] (label #'(var ...) #'(ty ...))]
[([var : ty] ... . [rest : rest-ty]) [([var : ty] ... . [rest : rest-ty star])
(eq? '* (syntax-e #'star))
(append (label #'(var ...) #'(ty ...)) (label-one #'rest #'rest-ty))] (append (label #'(var ...) #'(ty ...)) (label-one #'rest #'rest-ty))]
[([var : ty] ... . [rest : rest-ty ddd bound]) [([var : ty] ... . [rest : rest-ty ddd bound])
(eq? '... (syntax-e #'ddd)) (eq? '... (syntax-e #'ddd))
(append (label #'(var ...) #'(ty ...)) (label-dotted #'rest #'rest-ty #'bound))])) (append (label #'(var ...) #'(ty ...)) (label-dotted #'rest #'rest-ty #'bound))]
[_ (formal-annotation-error stx src)]))
(define-syntax-rule (λ: . args) (lambda: . args)) (define-syntax-rule (λ: . args) (lambda: . args))
(define-syntax (lambda: stx) (define-syntax (lambda: stx)
(syntax-case stx (:) (syntax-case stx (:)
[(lambda: formals . body) [(lambda: formals . body)
(with-syntax ([labeled-formals (annotate-names #'formals)]) (with-syntax ([labeled-formals (annotate-names #'formals stx)])
(syntax/loc stx (lambda labeled-formals . body)))])) (syntax/loc stx (lambda labeled-formals . body)))]))
(define-syntax (case-lambda: stx) (define-syntax (case-lambda: stx)
(syntax-case stx (:) (syntax-case stx (:)
[(case-lambda: [formals . body] ...) [(case-lambda: [formals . body] ...)
(with-syntax ([(lab-formals ...) (map annotate-names (syntax->list #'(formals ...)))]) (with-syntax ([(lab-formals ...) (map (lambda (s) (annotate-names s stx))
(syntax->list #'(formals ...)))])
(syntax/loc stx (case-lambda [lab-formals . body] ...)))])) (syntax/loc stx (case-lambda [lab-formals . body] ...)))]))
(define-syntaxes (let-internal: let*: letrec:) (define-syntaxes (let-internal: let*: letrec:)
@ -240,7 +252,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
(lambda (stx) (lambda (stx)
(syntax-case stx (:) (syntax-case stx (:)
[(_ ([nm : ty . exprs] ...) . body) [(_ ([nm : ty . exprs] ...) . body)
(with-syntax* ([(vars ...) (annotate-names #'([nm : ty] ...))] (with-syntax* ([(vars ...) (annotate-names #'([nm : ty] ...) stx)]
[bindings (map (lambda (v e loc) [bindings (map (lambda (v e loc)
(quasisyntax/loc loc [#,v . #,e])) (quasisyntax/loc loc [#,v . #,e]))
(syntax->list #'(vars ...)) (syntax->list #'(vars ...))