implement syntax-rules in honu using syntax/parse for now

svn: r16332

collects/honu/main.ss

@@ -7,6 +7,8 @@
              syntax/define
              syntax/context
              syntax/name
+             syntax/parse
+             scheme/pretty
              "private/ops.ss"
              "private/util.ss"
              "private/contexts.ss"
@@ -1907,6 +1909,64 @@
 	     (h-return expr))
            (stx-cdr after-expr))))))
 
+  (define-for-syntax (extract-conventions pattern)
+    (let loop ([out '()]
+               [in pattern])
+      (syntax-case in (:)
+        [(any : attribute rest ...)
+         (loop (cons #'(any expr) out)
+               #'(rest ...))
+         #;
+         (loop (cons #'(any attribute) out)
+               #'(rest ...))]
+        [(foo rest1 rest ...)
+         (loop out #'(rest1 rest ...))]
+        [(foo) out])))
+
+  (define-for-syntax (extract-patterns pattern)
+    (let loop ([out '()]
+               [in pattern])
+      (syntax-case in (:)
+        [(any : attribute rest ...)
+         (loop (cons #'any out)
+                #'(rest ...))]
+        [(foo rest1 rest ...)
+         (loop (cons #'foo out)
+               #'(rest1 rest ...))]
+        [(foo) (reverse (cons #'foo out))])))
+
+  (define-honu-syntax honu-macro
+    (lambda (stx ctx)
+      (syntax-case stx (#%braces)
+        [(_ (#%parens honu-literal ...)
+            (#%braces (#%braces name pattern ...))
+            (#%braces (#%braces template ...))
+            . rest)
+         (with-syntax ([(conventions ...)
+                        (extract-conventions #'(pattern ...))]
+                       [(raw-patterns ...)
+                        (extract-patterns #'(pattern ...))])
+           (values
+             #'(begin
+                 (define honu-literal (lambda () (error 'honu-literal "you suck")))
+                 ...
+                 (define-honu-syntax name
+                                     (lambda (stx ctx)
+                                       (define-conventions honu-conventions conventions ...)
+                                       #;
+                                       (printf "Hello from ~a transformer. Syntax is ~a\n" 'name (syntax->datum stx))
+                                       (syntax-parse stx
+                                                     #:literals (honu-literal ...)
+                                                     #:conventions (honu-conventions)
+                                                     [(name raw-patterns ... . rrest)
+                                                      (values
+                                                        #'(honu-unparsed-block
+                                                            #f obj 'obj #f ctx
+                                                            template ...)
+                                                        #'rrest)]))))
+             #'rest))])
+      ))
+
   (define-honu-syntax honu-if
     (lambda (stx ctx)
       (define (get-block-or-statement kw rest)
@@ -2042,8 +2102,10 @@
 
   (define-syntax (#%dynamic-honu-module-begin stx)
     ;; (printf "honu raw sexp ~a\n" (syntax->datum stx))
-    #`(#%plain-module-begin
+    (let ([result #`(#%plain-module-begin
-	(honu-unparsed-begin #,@(stx-cdr stx))))
+                     (honu-unparsed-begin #,@(stx-cdr stx)))])
+      ;; (pretty-print (syntax->datum (expand result)))
+      result))
   
   (define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx))
   
@@ -2095,6 +2157,7 @@
            (rename-out (set! =)
                        (honu-return return)
                        (honu-if if)
+                       (honu-macro macro)
                        (honu-time time)
                        (honu-class class)
                        (honu+ +)