From 2200ef17f50f1d405d7d488f65c9b610729006f2 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 30 Dec 2009 12:35:21 +0000
Subject: [PATCH] fix problem with expansion to lambda in class form; better
 certficate transparency in splicing-let forms

svn: r17436
---
 collects/scheme/private/class-internal.ss | 12 +++++++----
 collects/scheme/splicing.ss               | 25 ++++++++++++++++-------
 2 files changed, 26 insertions(+), 11 deletions(-)

diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss
index 96d51be73b..375ba373e5 100644
--- a/collects/scheme/private/class-internal.ss
+++ b/collects/scheme/private/class-internal.ss
@@ -337,7 +337,7 @@
         (local-expand
          expr
          'expression
-         (append locals expand-stop-names)
+         (append locals (list #'lambda #'λ) expand-stop-names)
          def-ctx))
       ;; Checks whether the vars sequence is well-formed
       (define (vars-ok? vars)
@@ -379,17 +379,19 @@
          #f))
       ;; -- tranform loop starts here --
       (let loop ([stx orig-stx][can-expand? #t][name name][locals null])
-        (syntax-case stx (#%plain-lambda lambda case-lambda letrec-values let-values)
+        (syntax-case stx (#%plain-lambda lambda λ case-lambda letrec-values let-values)
           [(lam vars body1 body ...)
            (or (and (free-identifier=? #'lam #'#%plain-lambda)
                     (vars-ok? (syntax vars)))
-               (and (free-identifier=? #'lam #'lambda)
+               (and (or (free-identifier=? #'lam #'lambda)
+                        (free-identifier=? #'lam #'λ))
                     (kw-vars-ok? (syntax vars))))
            (if xform?
                (with-syntax ([the-obj the-obj]
                              [the-finder the-finder]
                              [name (mk-name name)])
-                 (with-syntax ([vars (if (free-identifier=? #'lam #'lambda)
+                 (with-syntax ([vars (if (or (free-identifier=? #'lam #'lambda)
+                                             (free-identifier=? #'lam #'λ))
                                          (let loop ([vars #'vars])
                                            (cond
                                              [(identifier? vars) vars]
@@ -425,6 +427,8 @@
            (bad "ill-formed lambda expression for method" stx)]
           [(lambda . _)
            (bad "ill-formed lambda expression for method" stx)]
+          [(λ . _)
+           (bad "ill-formed lambda expression for method" stx)]
           [(case-lambda [vars body1 body ...] ...)
            (andmap vars-ok? (syntax->list (syntax (vars ...))))
            (if xform?
diff --git a/collects/scheme/splicing.ss b/collects/scheme/splicing.ss
index 00bd5a5f41..d22f905a58 100644
--- a/collects/scheme/splicing.ss
+++ b/collects/scheme/splicing.ss
@@ -187,9 +187,9 @@
 (define-syntax (expand-ssp-body stx)
   (syntax-case stx ()
     [(_ (sp-id ...) (temp-id ...) body)
-     (let ([body (local-expand #'(letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))]
-                                                   ...)
-                                   (force-expand body))
+     (let ([body (local-expand #'(letrec-syntaxes/trans ([(sp-id) (syntax-local-value (quote-syntax temp-id))]
+                                                         ...)
+                                    (force-expand body))
                                (syntax-local-context)
                                null ;; `force-expand' actually determines stopping places
                                #f)])
@@ -212,12 +212,23 @@
                       (letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))] ...)
                         expr))]))]))]))
 
+(define-syntax (letrec-syntaxes/trans stx)
+  (syntax-case stx ()
+    [(_ bindings body)
+     (syntax-property
+      #'(letrec-syntaxes bindings body)
+      'certify-mode
+      'transparent)]))
+
 (define-syntax (force-expand stx)
   (syntax-case stx ()
     [(_ stx)
      ;; Expand `stx' to reveal type of form, and then preserve it via
      ;; `quote':
-     #`(quote #,(local-expand #'stx
-                              'module
-                              (kernel-form-identifier-list)
-                              #f))]))
+     (syntax-property
+      #`(quote #,(local-expand #'stx
+                               'module
+                               (kernel-form-identifier-list)
+                               #f))
+      'certify-mode
+      'transparent)]))