From 973000adbb94ee64a131e3c298083d3aec30d116 Mon Sep 17 00:00:00 2001
From: Jon Rafkind <rafkind@racket-lang.org>
Date: Mon, 21 Nov 2011 14:05:27 -0700
Subject: [PATCH] [honu] delay parsing of function bodies

---
 collects/honu/core/private/compile.rkt | 12 ++++++++++-
 collects/honu/core/private/parse2.rkt  | 28 ++++++++++++++++++++++++++
 collects/tests/honu/function.honu      | 13 ++++--------
 3 files changed, 43 insertions(+), 10 deletions(-)

diff --git a/collects/honu/core/private/compile.rkt b/collects/honu/core/private/compile.rkt
index fba2b1cc1d..3d5847f8dc 100644
--- a/collects/honu/core/private/compile.rkt
+++ b/collects/honu/core/private/compile.rkt
@@ -3,7 +3,8 @@
 (require syntax/parse
          "literals.rkt")
 
-(provide honu->racket)
+(provide (all-defined-out))
+
 (define (honu->racket forms)
   (define-literal-set literals (%racket))
   (syntax-parse forms #:literal-sets (literals)
@@ -16,3 +17,12 @@
     [x #'x]
     [() forms]))
 
+(define (strip-stops code)
+  (define-syntax-class stopper #:literal-sets (cruft)
+    #;
+    [pattern semicolon]
+    [pattern honu-comma]
+    [pattern colon])
+  (syntax-parse code
+    [(x:stopper rest ...) (strip-stops #'(rest ...))]
+    [else code]))
diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt
index df504575a4..350951af93 100644
--- a/collects/honu/core/private/parse2.rkt
+++ b/collects/honu/core/private/parse2.rkt
@@ -113,6 +113,7 @@
       [() (reverse out)])))
 
 ;; removes syntax that causes expression parsing to stop
+#;
 (define (strip-stops code)
   (define-syntax-class stopper #:literal-sets (cruft)
     #;
@@ -152,6 +153,16 @@
   (debug 2 "Comma? ~a ~a\n" what is)
   is)
 
+#;
+(define-syntax (parse-more stx)
+  (syntax-parse stx
+    [(_ stuff ...)
+     (define-values (parsed unparsed)
+                    (parse (strip-stops #'(stuff ...))))
+     (with-syntax ([(parsed-out ...) (honu->racket parsed)]
+                   [(unparsed-out ...) unparsed])
+       #'(begin parsed-out ... (parse-stuff unparsed-out ...)))]))
+
 (provide honu-function)
 (define-splicing-syntax-class honu-function #:literal-sets (cruft)
   [pattern (~seq function:identifier (#%parens args ...) (#%braces code ...))
@@ -159,6 +170,23 @@
            (with-syntax ([(parsed-arguments ...)
                           (parse-arguments #'(args ...))])
              #'(define (function parsed-arguments ...)
+                 (define-syntax (parse-more stx)
+                   (syntax-parse stx
+                     [(_ stuff (... ...))
+                      (define-values (parsed unparsed)
+                                     (parse (strip-stops #'(stuff (... ...)))))
+                      (debug "Parse more: ~a unparsed ~a\n" parsed unparsed)
+                      (define output (if parsed
+                                       (honu->racket parsed)
+                                       #'(begin)))
+                      (debug "Output ~a\n" output)
+                      (with-syntax ([output output]
+                                    [(unparsed-out (... ...)) unparsed])
+                        (if (null? (syntax->datum #'(unparsed-out (... ...))))
+                          #'output
+                          #'(begin output (parse-more unparsed-out (... ...)))))]))
+                 (parse-more code ...)
+                 #;
                  (let-syntax ([parse-more (lambda (stx)
                                             ;; this adds an extra mark, you might not
                                             ;; want that
diff --git a/collects/tests/honu/function.honu b/collects/tests/honu/function.honu
index e7878dab2a..307a30c441 100644
--- a/collects/tests/honu/function.honu
+++ b/collects/tests/honu/function.honu
@@ -1,11 +1,6 @@
 #lang honu
 
-/*
-provide function;
-macro function ()
-  { _ name:identifier (args:identifier ...) { body ... } }
-  { #sx scheme:syntax #sx(define (name_result args_result ...)
-                         (honu-unparsed-begin body ...)) }
-  { _ (args:identifier ...) { body ... }}
-  { #sx scheme:syntax #sx(lambda (args_result ...) (honu-unparsed-begin body ...)) }
-  */
+
+foo(){
+  1 + 2
+}