suzanne.soy/typed-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.

original commit: c2a53b316be90d81b1af0afd4acb4f22b5dc57c9
This commit is contained in:
Stevie Strickland 2008-06-18 12:31:08 -04:00
parent 4271f734a6
commit 9d55a9e592
1 changed files with 31 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
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)
'typechecker:ignore #t))))]))
(define-for-syntax (formal-annotation-error stx src)
(let loop ([stx stx])
(syntax-case stx ()
;; should never happen
[() (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)
(identifier? #'var)
(loop #'rest)]
[([var : ty] . rest)
(raise-syntax-error #f "not a variable" src #'var)]
[(e . rest)
(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])
[([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))]
[_
(let loop ([stx stx])
(syntax-case stx ()
;; should never happen
[() (raise-syntax-error #f "bad annotation syntax" src stx)]
[([var : ty] . rest)
(identifier? #'var)
(loop #'rest)]
[([var : ty] . rest)
(raise-syntax-error #f "not a variable" src #'var)]
[(e . rest)
(raise-syntax-error #f "expected annotated variable of the form [x : T], got something else" src #'e)]))]))
[_ (formal-annotation-error stx src)]))
(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)]
[(_ arg ty)
(syntax-property #'arg 'type-ascription #'ty)]
[(_ arg ty star)
(eq? '* (syntax-e #'star))
(syntax-property #'arg 'type-ascription #'ty)]
[(_ arg ty ddd bound)
(eq? '... (syntax-e #'ddd))
(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
(define-for-syntax (annotate-names stx)
(define-for-syntax (annotate-names stx src)
(define (label-one var ty)
(syntax-property var 'type-label ty))
(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 #'(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))]
[([var : ty] ... . [rest : rest-ty ddd bound])
(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 (lambda: stx)
(syntax-case stx (:)
[(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)))]))
(define-syntax (case-lambda: stx)
(syntax-case stx (:)
[(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] ...)))]))
(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)
(syntax-case stx (:)
[(_ ([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)
(quasisyntax/loc loc [#,v . #,e]))
(syntax->list #'(vars ...))