fixing syntax issues

svn: r9021

collects/web-server/lang/anormal.ss

@@ -141,12 +141,10 @@
         (ctxt stx)]
        [id (identifier? #'id)
            (ctxt #'id)]
-       ; XXX Shouldn't be here
        [(letrec-syntaxes+values ([(sv ...) se] ...)
           ([(vv ...) ve] ...)
           be ...)
-        (anormal ctxt
+        (anormal ctxt (elim-letrec-term stx))]
-                 (elim-letrec-term stx))]
        [(#%expression d)
         (anormal
          (ccompose ctxt

collects/web-server/lang/elim-letrec.ss

@@ -88,32 +88,12 @@
          (if (bound-identifier-member? #'id ids)
              (syntax/loc stx (#%plain-app unbox id))
              #'id)]
-     ; XXX These two cases shouldn't be here.
      [(letrec-syntaxes+values ([(sv ...) se] ...)
         ([(vv ...) ve] ...)
         be ...)
-      (let ([new-ids (apply append ids (map syntax->list (syntax->list #'((vv ...) ...))))])
+      ((elim-letrec ids)
-        (with-syntax ([((nvv ...) ...) (map (compose generate-temporaries syntax->list) (syntax->list #'((vv ...) ...)))]
+       (syntax/loc stx
-                      [((nvv-box ...) ...) (map (lambda (nvs)
+         (letrec-values ([(vv ...) ve] ...) be ...)))]
-                                                  (map (lambda (x) (syntax/loc x (#%plain-app box the-undef)))
-                                                       (syntax->list nvs)))
-                                                (syntax->list #`((vv ...) ...)))]
-                      [(se ...) (map (elim-letrec new-ids) (syntax->list #'(se ...)))]
-                      [(ve ...) (map (elim-letrec new-ids) (syntax->list #'(ve ...)))]
-                      [(be ...) (map (elim-letrec new-ids) (syntax->list #'(be ...)))])
-          ; XXX Optimize special case of one nv
-          (syntax/loc stx
-            (let-values ([(vv ...)
-                          (#%plain-app values nvv-box ...)] ...)
-              ; This is okay, because we've already expanded the syntax.
-              (let-syntaxes 
-               ([(sv ...) se] ...)
-               (begin (#%plain-app call-with-values
-                                   (#%plain-lambda () ve)
-                                   (#%plain-lambda (nvv ...)
-                                                   (#%plain-app set-box! vv nvv) ...))
-                      ...
-                      be ...))))))]     
      [(#%expression d)
       (quasisyntax/loc stx (#%expression #,((elim-letrec ids) #'d)))]
      [_

collects/web-server/lang/freevars.ss

@@ -72,15 +72,10 @@
             [else 
              #;(printf "Not including id ~S with binding ~S in freevars~n" (syntax->datum #'id) i-bdg)
              empty]))]
-    ; XXX Shouldn't be here
     [(letrec-syntaxes+values ([(sv ...) se] ...)
        ([(vv ...) ve] ...)
        be ...)
-     (set-diff (union* (free-vars* (syntax->list #'(se ...)))
+     (free-vars #'(letrec-values ([(vv ...) ve] ...) be ...))]
-                       (free-vars* (syntax->list #'(ve ...)))
-                       (free-vars* (syntax->list #'(be ...))))
-               (append (apply append (map syntax->list (syntax->list #'((sv ...) ...))))
-                       (apply append (map syntax->list (syntax->list #'((vv ...) ...))))))]
     [(#%expression d)
      (free-vars #'d)]
     [_

collects/web-server/lang/util.ss

@@ -3,7 +3,7 @@
          syntax/kerncase
          mzlib/pretty
          mzlib/list)
-(provide (except-out (all-defined-out) template))
+(provide (all-defined-out))
 
 (define transformer? (make-parameter #f))
 
@@ -55,19 +55,9 @@
          (list (quasisyntax/loc stx
                  (define-values (v ...) #,nve)))))]
      [(define-syntaxes (v ...) ve)
-      (parameterize ([transformer? #t])
+      (list stx)]      
-        (let-values ([(nve defs) (inner #'ve)])
-          (append 
-           defs
-           (list (quasisyntax/loc stx
-                   (define-syntaxes (v ...) #,nve))))))]      
      [(define-values-for-syntax (v ...) ve)
-      (parameterize ([transformer? #t])
+      (list stx)]
-        (let-values ([(nve defs) (inner #'ve)])
-          (append 
-           defs
-           (list (quasisyntax/loc stx
-                   (define-values-for-syntax (v ...) #,nve))))))]
      [(#%require spec ...)
       (list stx)]
      [expr
@@ -107,68 +97,3 @@
    (lambda (an-id)
      (bound-identifier=? id an-id))
    ids))
-
-;; Kernel Case Template
-(define (template stx)  
-  (recertify
-   stx
-   (kernel-syntax-case 
-       stx (transformer?)
-     [(begin be ...)
-      (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
-        (syntax/loc stx
-          (begin be ...)))]
-     [(begin0 be ...)
-      (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
-        (syntax/loc stx
-          (begin0 be ...)))]
-     [(set! v ve)
-      (with-syntax ([ve (template #'ve)])
-        (syntax/loc stx
-          (set! v ve)))]
-     [(let-values ([(v ...) ve] ...) be ...)
-      (with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))]
-                    [(be ...) (map template (syntax->list #'(be ...)))])
-        (syntax/loc stx
-          (let-values ([(v ...) ve] ...) be ...)))]
-     [(letrec-values ([(v ...) ve] ...) be ...)
-      (with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))]
-                    [(be ...) (map template (syntax->list #'(be ...)))])
-        (syntax/loc stx
-          (letrec-values ([(v ...) ve] ...) be ...)))]
-     [(#%plain-lambda formals be ...)
-      (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
-        (syntax/loc stx
-          (#%plain-lambda formals be ...)))]
-     [(case-lambda [formals be ...] ...)
-      (with-syntax ([((be ...) ...) (map template (syntax->list #'((be ...) ...)))])
-        (syntax/loc stx
-          (case-lambda [formals be ...] ...)))]
-     [(if te ce ae)
-      (with-syntax ([te (template #'te)]
-                    [ce (template #'ce)]
-                    [ae (template #'ae)])
-        (syntax/loc stx
-          (if te ce ae)))]
-     [(quote datum)
-      stx]
-     [(quote-syntax datum)
-      stx]     
-     [(with-continuation-mark ke me be)
-      (with-syntax ([ke (template #'ke)]
-                    [me (template #'me)]
-                    [be (template #'be)])
-        (syntax/loc stx
-          (with-continuation-mark ke me be)))]
-     [(#%plain-app e ...)
-      (with-syntax ([(e ...) (map template (syntax->list #'(e ...)))])
-        (syntax/loc stx
-          (#%plain-app e ...)))]
-     [(#%top . v)
-      stx]
-     [(#%variable-reference . v)
-      stx]       
-     [id (identifier? #'id)
-         stx]     
-     [_
-      (raise-syntax-error 'kerncase "Dropped through:" stx)])))

collects/web-server/tests/lang-test.ss

@@ -272,7 +272,34 @@
          (check = 4 (test-m06.1 `(dispatch ,the-dispatch (list ,second-key 3))))
          (check-true (zero? (test-m06.1 `(dispatch ,the-dispatch (list ,second-key -1)))))
          (check = -7 (test-m06.1 `(dispatch ,the-dispatch (list ,third-key 0))))
-         (check-true (zero? (test-m06.1 `(dispatch ,the-dispatch (list ,third-key 7)))))))))
+         (check-true (zero? (test-m06.1 `(dispatch ,the-dispatch (list ,third-key 7))))))))
+    
+    (test-case
+     "curried with send/suspend and serializaztion (keyword args)"
+     
+     (let-values ([(test-m06.2)
+                   (make-module-eval
+                    (module m06.2 (lib "lang.ss" "web-server")
+                      (provide start)
+                      (define (gn #:page which)
+                        (cadr
+                         (send/suspend
+                          (lambda (k)
+                            (let ([ignore (printf "Please send the ~a number.~n" which)])
+                              k)))))
+                      
+                      (define (start ignore)
+                        (let ([result (+ (gn #:page "first") (gn #:page "second"))])
+                          (let ([ignore (printf "The answer is: ~s~n" result)])
+                            result)))))])
+       (let* ([first-key (test-m06.2 '(dispatch-start start 'foo))]
+              [second-key (test-m06.2 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) 1)))]
+              [third-key (test-m06.2 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) -7)))])
+         (check = 3 (test-m06.2 `(abort/cc (lambda () (dispatch ,the-dispatch (list ,second-key 2))))))
+         (check = 4 (test-m06.2 `(dispatch ,the-dispatch (list ,second-key 3))))
+         (check-true (zero? (test-m06.2 `(dispatch ,the-dispatch (list ,second-key -1)))))
+         (check = -7 (test-m06.2 `(dispatch ,the-dispatch (list ,third-key 0))))
+         (check-true (zero? (test-m06.2 `(dispatch ,the-dispatch (list ,third-key 7)))))))))
    
    (test-suite
     "Test the certification process"

collects/web-server/tests/lang/anormal-test.ss

@@ -45,7 +45,7 @@
 ;; w-alpha=/env: env target-expr target-expr -> boolean
 ;; are two target vars or vals alpha-equivalent?
 (define (w-alpha=/env env1 env2 expr1 expr2)
-  (syntax-case expr1 (#%top #%plain-lambda quote)
+  (syntax-case expr1 (#%top #%plain-lambda quote #%expression)
     [(#%top . var1)
      (syntax-case expr2 (#%top)
        [(#%top . var2)
@@ -69,6 +69,11 @@
                 (extend env2 (syntax->symbols (formals-list #'formals2)) syms)
                 #'body1 #'body2)))]
        [_else #f])]
+    [(#%expression e1)
+     (syntax-case expr2 (#%expression)
+       [(#%expression e2)
+        (w-alpha=/env env1 env2 #'e1 #'e2)]
+       [_else #f])]
     [x1 (symbol? (syntax->datum #'x1))
         (syntax-case expr2 ()
           [x2 (symbol? (syntax->datum #'x2))