From adbc34d59de45de0f8c48e5a629e052dfa28e264 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 25 Jul 2001 22:44:35 +0000
Subject: [PATCH] .

original commit: e8cba904a3dcf993d861601390b7ffa04b0920ee
---
 collects/mzlib/unit.ss              |  8 ++++----
 collects/mzlib/unitsig.ss           |  8 ++++----
 collects/tests/mzscheme/macrolib.ss | 29 +++++++++++++++++++++++++++++
 3 files changed, 37 insertions(+), 8 deletions(-)

diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss
index 7713944..ae307dc 100644
--- a/collects/mzlib/unit.ss
+++ b/collects/mzlib/unit.ss
@@ -694,7 +694,7 @@
 	 (let* ([badsyntax (lambda (s why)
 			     (raise-syntax-error
 			      (if (syntax-e (syntax global?))
-				  'global-define-values/invoke-unit
+				  'namespace-variable-bind/invoke-unit
 				  'define-values/invoke-unit)
 			      (format "bad syntax (~a)" why)
 			      (syntax orig)
@@ -740,7 +740,7 @@
 						 . imports))])
 	       (if (syntax-e (syntax global?))
 		   (syntax (let-values ([(tagged-export ...) invoke-unit])
-			     (global-defined-value 'tagged-export tagged-export)
+			     (namespace-variable-binding 'tagged-export tagged-export)
 			     ...
 			     (void)))
 		   (syntax (define-values (tagged-export ...) invoke-unit))))))])))
@@ -754,7 +754,7 @@
 	  [(_ exports unit) 
 	   (syntax (do-define-values/invoke-unit #f exports unit #f () orig))]))))
   
-  (define-syntax global-define-values/invoke-unit
+  (define-syntax namespace-variable-bind/invoke-unit
     (lambda (stx)
       (with-syntax ([orig stx])
 	(syntax-case stx ()
@@ -767,4 +767,4 @@
 	  exn:unit? struct:exn:unit make-exn:unit
 
 	  define-values/invoke-unit
-	  global-define-values/invoke-unit))
+	  namespace-variable-bind/invoke-unit))
diff --git a/collects/mzlib/unitsig.ss b/collects/mzlib/unitsig.ss
index 2f91d17..2222831 100644
--- a/collects/mzlib/unitsig.ss
+++ b/collects/mzlib/unitsig.ss
@@ -233,7 +233,7 @@
       (syntax-case stx ()
 	[(_ global? signame unite prefix imports orig)
 	 (let* ([formname (if (syntax-e (syntax global?))
-			      'global-define-values/invoke-unit/sig
+			      'namespace-variable-bind/invoke-unit/sig
 			      'define-values/invoke-unit/sig)]
 		[badsyntax (lambda (s why)
 			     (raise-syntax-error
@@ -253,7 +253,7 @@
 		       [im-flattened (flatten-signatures im-sigs)]
 		       [d->s (lambda (x) (datum->syntax-object (syntax orig) x (syntax orig)))])
 		   (with-syntax ([dv/iu (if (syntax-e (syntax global?))
-					    (quote-syntax global-define-values/invoke-unit)
+					    (quote-syntax namespace-variable-bind/invoke-unit)
 					    (quote-syntax define-values/invoke-unit))]
 				 [ex-flattened (d->s ex-flattened)]
 				 [ex-exploded (d->s ex-exploded)]
@@ -283,7 +283,7 @@
 	  [(_ signame unit)
 	   (syntax (do-define-values/invoke-unit/sig #f signame unit #f () orig))]))))
 
-  (define-syntax global-define-values/invoke-unit/sig
+  (define-syntax namespace-variable-bind/invoke-unit/sig
     (lambda (stx)
       (with-syntax ([orig stx])
 	(syntax-case stx ()
@@ -316,6 +316,6 @@
 	   (struct unit/sig (unit imports exports))
 	   
 	   define-values/invoke-unit/sig
-	   global-define-values/invoke-unit/sig
+	   namespace-variable-bind/invoke-unit/sig
 	   provide-signature-elements))
 
diff --git a/collects/tests/mzscheme/macrolib.ss b/collects/tests/mzscheme/macrolib.ss
index 30e2f1a..415f0b4 100644
--- a/collects/tests/mzscheme/macrolib.ss
+++ b/collects/tests/mzscheme/macrolib.ss
@@ -107,6 +107,35 @@
        (let ([=> 12]) (evcase 3 [3 => 17]))
        (let ([=> 17]) (evcase 3 [3 =>]))))
 
+(define (opt-lam-test exp expected)
+   (let ([got (eval exp)])
+     (unless (equal? got expected)
+       (printf  "FAILED test: ~a~n   expected: ~s~n        got: ~s~n"
+                exp expected got))))
+
+(define (opt-lam-test/bad exp expected)
+   (let ([got (with-handlers ([exn:syntax?
+                               (lambda (exn) (exn-message exn))])
+                (cons 'got-result (eval exp)))])
+     (unless (regexp-match expected got)
+       (printf  "FAILED test: ~a~n   expected: ~s~n        got: ~s~n"
+                exp expected got))))
+
+(test 1 (opt-lambda (start) start) 1)
+(test 1 (opt-lambda ([start 1]) start))
+(test 1 (opt-lambda ([start 2]) start) 1)
+(test '(1) (opt-lambda args args) 1)
+(test '(1) (opt-lambda (x . args) args) 2 1)
+(test '(2 1) (opt-lambda ([x 1] . args) (cons x args)) 2 1)
+(test '(1) (opt-lambda ([x 1] . args) (cons x args)))
+(test '(1 2 3) (opt-lambda ([x 1] . args) (cons x args)) 1 2 3)
+
+(syntax-test #'(opt-lambda))
+(syntax-test #'(opt-lambda 1 x))
+(syntax-test #'(opt-lambda (x [x 1]) x))
+(syntax-test #'(opt-lambda ([x 1] y) x))
+(syntax-test #'(opt-lambda (1) x))
+(syntax-test #'(opt-lambda ([2 1]) x))
 
 (report-errs)