From 4cb749130954c821754fd976d92c02aca2013429 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Wed, 4 Aug 2010 15:52:41 -0400
Subject: [PATCH] Added opt-lambda:.

---
 .../typed-scheme/private/annotate-classes.rkt | 22 +++++++++++++++++++
 collects/typed-scheme/private/prims.rkt       | 15 +++++++++++++
 2 files changed, 37 insertions(+)

diff --git a/collects/typed-scheme/private/annotate-classes.rkt b/collects/typed-scheme/private/annotate-classes.rkt
index e9d65a8151..92c788cd74 100644
--- a/collects/typed-scheme/private/annotate-classes.rkt
+++ b/collects/typed-scheme/private/annotate-classes.rkt
@@ -63,3 +63,25 @@
                                               (~or rest:annotated-star-rest rest:annotated-dots-rest)))
            #:with ann-formals #'(n.ann-name ... . rest.ann-name)
            #:with (arg-ty ...) #'(n.ty ... . rest.formal-ty)))
+
+(define-syntax-class opt-lambda-annotated-formal
+  #:description "annotated variable, potentially with a default value"
+  #:opaque
+  #:attributes (name ty ann-name)
+  (pattern [:annotated-name])
+  (pattern [n:annotated-name val]
+           #:with name #'n.name
+           #:with ty #'n.name
+           #:with ann-name #'(n.ann-name val)))
+
+(define-syntax-class opt-lambda-annotated-formals
+  #:attributes (ann-formals (arg-ty 1))
+  #:literals (:)
+  (pattern (n:opt-lambda-annotated-formal ...)
+           #:with ann-formals #'(n.ann-name ...)
+           #:with (arg-ty ...) #'(n.ty ...))
+  (pattern (n:opt-lambda-annotated-formal ...
+            (~describe "dotted or starred type"
+                       (~or rest:annotated-star-rest rest:annotated-dots-rest)))
+           #:with ann-formals #'(n.ann-name ... . rest.ann-name)
+           #:with (arg-ty ...) #'(n.ty ... . rest.formal-ty)))
diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt
index cef82b22eb..980675b382 100644
--- a/collects/typed-scheme/private/prims.rkt
+++ b/collects/typed-scheme/private/prims.rkt
@@ -27,6 +27,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
 
 (require "../utils/utils.rkt"
          racket/base
+         mzlib/etc
 	 (for-syntax 
           syntax/parse
 	  syntax/private/util
@@ -173,6 +174,15 @@ This file defines two sorts of primitives. All of them are provided into any mod
                            'typechecker:plambda
                            #'(tvars ...))))]))
 
+(define-syntax (popt-lambda: stx)
+  (syntax-parse stx
+    [(popt-lambda: (tvars:id ...) formals . body)
+     (quasisyntax/loc stx
+       (#%expression
+        #,(syntax-property (syntax/loc stx (opt-lambda: formals . body))
+                           'typechecker:plambda
+                           #'(tvars ...))))]))
+
 (define-syntax (pdefine: stx)
   (syntax-parse stx #:literals (:)
     [(pdefine: (tvars:id ...) (nm:id . formals:annotated-formals) : ret-ty . body)
@@ -223,6 +233,11 @@ This file defines two sorts of primitives. All of them are provided into any mod
     [(case-lambda: [formals:annotated-formals . body] ...)
      (syntax/loc stx (case-lambda [formals.ann-formals . body] ...))]))
 
+(define-syntax (opt-lambda: stx)
+  (syntax-parse stx
+    [(opt-lambda: formals:opt-lambda-annotated-formals . body)
+     (syntax/loc stx (opt-lambda formals.ann-formals . body))]))
+
 (define-syntaxes (let-internal: let*: letrec:)
   (let ([mk (lambda (form)
               (lambda (stx)