From 9d55a9e5924e74f70b7689aaa1cf952768f9a5c0 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Wed, 18 Jun 2008 12:31:08 -0400
Subject: [PATCH]  * Enforce the use of a '*' in list-like rest args.  *
 Abstract out annotation errors so that we can report it in the other case   
 where it's useful.

original commit: c2a53b316be90d81b1af0afd4acb4f22b5dc57c9
---
 collects/typed-scheme/private/prims.ss | 50 ++++++++++++++++----------
 1 file changed, 31 insertions(+), 19 deletions(-)

diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss
index 80facd1e..929430bf 100644
--- a/collects/typed-scheme/private/prims.ss
+++ b/collects/typed-scheme/private/prims.ss
@@ -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 ...))