From 65dcf4e5007229707264707b3df7343411c30812 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Fri, 18 Aug 2006 20:10:16 +0000
Subject: [PATCH] syntax/kerncase.ss: Added kernel-syntax-case*, which allows
 additional specification of keywords beyond the MzScheme core forms.  Define
 both kernel-sytnax-case and kernel-sytnax-case* in terms of (new)
 kernel-sytnax-case-internal.

svn: r4089
---
 collects/syntax/kerncase.ss | 52 ++++++++++++++++++++++++-------------
 1 file changed, 34 insertions(+), 18 deletions(-)

diff --git a/collects/syntax/kerncase.ss b/collects/syntax/kerncase.ss
index 08792432cb..ea663a6b67 100644
--- a/collects/syntax/kerncase.ss
+++ b/collects/syntax/kerncase.ss
@@ -1,27 +1,42 @@
 
 (module kerncase mzscheme
 
+  (define-syntax kernel-syntax-case-internal
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ stxv trans? (extras ...) kernel-context clause ...)
+	 (quasisyntax/loc
+	  stx
+	  (syntax-case* stxv #,(datum->syntax-object
+				#'kernel-context
+                                (append (syntax->list #'(extras ...))
+                                        '(quote 
+                                          quote-syntax #%datum #%top
+                                          lambda case-lambda
+                                          let-values letrec-values
+                                          begin begin0 set!
+                                          with-continuation-mark
+                                          if #%app
+                                          define-values define-syntaxes define-values-for-syntax
+                                          module #%plain-module-begin require provide 
+                                          require-for-syntax require-for-template
+                                          #%variable-reference)))
+                        (if trans? module-transformer-identifier=? module-identifier=?)
+	    clause ...))])))
+  
   (define-syntax kernel-syntax-case
     (lambda (stx)
       (syntax-case stx ()
 	[(_ stxv trans? clause ...)
-	 (quasisyntax/loc
-	  stx
-	  (syntax-case* stxv #,(datum->syntax-object
-				stx
-				'(quote 
-				  quote-syntax #%datum #%top
-				  lambda case-lambda
-				  let-values letrec-values
-				  begin begin0 set!
-				  with-continuation-mark
-				  if #%app
-				  define-values define-syntaxes define-values-for-syntax
-				  module #%plain-module-begin require provide 
-				  require-for-syntax require-for-template
-				  #%variable-reference))
-			(if trans? module-transformer-identifier=? module-identifier=?)
-	    clause ...))])))
+         (quasisyntax/loc stx
+           (kernel-syntax-case-internal stxv trans? () #,stx clause ...))])))
+
+  (define-syntax kernel-syntax-case*
+    (lambda (stx)
+      (syntax-case stx ()
+	[(_ stxv trans? (extras ...) clause ...)
+         (quasisyntax/loc stx
+           (kernel-syntax-case-internal stxv trans? (extras ...) #,stx clause ...))])))
 
   (define (kernel-form-identifier-list stx)
     (map (lambda (s)
@@ -45,4 +60,5 @@
 	    #%variable-reference)))
   
   (provide kernel-syntax-case
-	  kernel-form-identifier-list))
+           kernel-syntax-case*
+           kernel-form-identifier-list))