From f980cf9462d86de4dffba22b2c44ed5e53d77aa4 Mon Sep 17 00:00:00 2001
From: Jon Rafkind <rafkind@racket-lang.org>
Date: Sat, 30 Jan 2010 01:42:14 +0000
Subject: [PATCH] use new syntax-parse primitive to enable macro invocation
 during expression parsing

svn: r17891
---
 collects/honu/main.ss                      |  1 +
 collects/honu/private/honu-typed-scheme.ss | 44 +++++++++++++++++++---
 2 files changed, 40 insertions(+), 5 deletions(-)

diff --git a/collects/honu/main.ss b/collects/honu/main.ss
index ae632c9d99..c45f275fa8 100644
--- a/collects/honu/main.ss
+++ b/collects/honu/main.ss
@@ -1,6 +1,7 @@
 #lang scheme/base
 
 (require "private/honu-typed-scheme.ss"
+         ;; "private/honu.ss"
          "private/macro.ss")
 
 (provide (rename-out (#%dynamic-honu-module-begin #%module-begin)
diff --git a/collects/honu/private/honu-typed-scheme.ss b/collects/honu/private/honu-typed-scheme.ss
index f82899e3f0..62c9ba0d6f 100644
--- a/collects/honu/private/honu-typed-scheme.ss
+++ b/collects/honu/private/honu-typed-scheme.ss
@@ -6,6 +6,7 @@
                      syntax/name
                      syntax/define
                      syntax/parse
+                     syntax/parse/experimental
                      scheme/splicing
                      "contexts.ss"
                      "util.ss"
@@ -67,6 +68,7 @@
              (and (positive? (string-length str))
                   (memq (string-ref str 0) sym-chars)))))))
 
+;; returns a transformer or #f
 (define (get-transformer stx)
   ;; if its an identifier and bound to a transformer return it
   (define (bound-transformer stx)
@@ -366,16 +368,46 @@ x(2)
                          [pattern (type:id name:id (#%parens args ...) body:block . rest)
                                   #:with result #'(define (name args ...)
                                                     body.result)])
-    (define-syntax-class expr
-                         [pattern f])
+
+    (define (syntax-object-position mstart end)
+      (if (stx-null? end)
+          (length (syntax->list mstart))
+        (let loop ([start mstart]
+                   [count 0])
+          ;; (printf "Checking ~a vs ~a\n" start end)
+          (cond
+           [(stx-null? start) (raise-syntax-error 'honu-macro "the `rest' syntax returned by a honu macro did not return objects at the same syntactic nesting level as the head of the pattern. this is probably because it returned syntax from some inner nesting level such as (if (x + 1 2) more-stuff) where `rest' was (+ 1 2) instead of `more-stuff'" end mstart)]
+           [(eq? (stx-car start) (stx-car end)) count]
+           ;; [(equal? start end) count]
+           [else (loop (stx-cdr start) (add1 count))]))))
+
+    (define-primitive-splicing-syntax-class (expr)
+      #:attrs (result)
+      #:description "expr"
+      (lambda (stx fail)
+        (cond
+          [(stx-null? stx) (fail)]
+          [(get-transformer stx) => (lambda (transformer)
+                                      (let-values ([(used rest)
+                                                    (transformer stx context)])
+                                        (list rest (syntax-object-position stx rest)
+                                              used)))]
+
+          [else (syntax-case stx ()
+                  [(f . rest) (list #'rest 1 #'f)])])))
+
+    #;
+    (define-splicing-syntax-class expr
+                         [pattern (~seq f ...) #:with result])
 
     (define-splicing-syntax-class call
                                   #:literals (honu-comma)
                          [pattern (~seq e:expr (#%parens (~seq arg:ternary (~optional honu-comma)) ...))
-                                  #:with call #'(e arg.result ...)])
+                                  #:with call #'(e.result arg.result ...)])
     (define-splicing-syntax-class expression-last
                          [pattern (~seq call:call) #:with result #'call.call]
                          [pattern (~seq x:number) #:with result #'x]
+                         [pattern (~seq e:expr) #:with result #'e.result]
                          )
 
     (define-syntax-rule (define-infix-operator name next [operator reducer] ...)
@@ -524,7 +556,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
   (lambda (stx ctx)
     (define (parse-complete-block stx)
       ;; (printf "Parsing complete block ~a\n" (syntax->datum stx))
-      (with-syntax ([(exprs ...) (parse-block stx ctx)])
+      (with-syntax ([(exprs ...) (parse-block stx the-expression-block-context)])
         #'(begin exprs ...))
       #;
       (let-values ([(a b)
@@ -556,7 +588,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
       [(_ condition:paren-expr on-true:block else on-false:block . rest)
        ;; (printf "used if with else\n")
        (let ([result #'(if condition.expr on-true.line on-false.line)])
-         (expression-result ctx result #'rest))]
+         (expression-result ctx result (syntax/loc #'rest rest)))]
       [(_ condition:paren-expr on-true:block . rest)
        ;; (printf "used if with no else\n")
        (let ([result #'(when condition.expr on-true.line)])
@@ -656,6 +688,8 @@ if (foo){
   (syntax-case stx ()
     [(_) #'(begin (void))]
     [(_ . body) (let-values ([(code rest) (parse-block-one/2 #'body
+                                                             the-expression-context
+                                                             #;
                                                              the-top-block-context)])
                   ;; (printf "Rest is ~a\n" (syntax->datum rest))
                   (with-syntax ([code code]