use literal sets

collects/honu/main.rkt

@@ -17,6 +17,7 @@
          (for-template "private/literals.rkt")
          (for-syntax "private/more.ss")
          (for-syntax "private/syntax.ss")
+         (for-syntax "private/macro.ss")
          "private/macro.ss")
 
 (define test-x-class
@@ -26,7 +27,7 @@
 
 (define x (new test-x-class [tuna 5]))
 
-(define (sql1) #f)
+(define (sql1 . x) #f)
 (define (sql2) #f)
 (define (sql3) #f)
 (define (sql4) #f)
@@ -63,12 +64,13 @@
                      with-syntax
                      quote
                      #%app
-                     #%parens
+                     #%parens #%brackets #%braces
                      ...
                      map
                      syntax->list
                      identifier
                      expression
+                     statement
                      (rename-out (semicolon \;
                                             )
                                  (ellipses-comma ec)
@@ -76,6 +78,7 @@
                                  #;
                                  (honu-identifier identifier)
                                  (expression-comma expression_comma)
+                                 (honu-macro macro)
                                  (parse-an-expr parse)
                                  (... scheme:...)
                                  (honu-body:class body)
@@ -84,6 +87,7 @@
                                  (honu-+ +)
                                  (honu-scheme scheme2)
                                  (scheme-syntax scheme:syntax)
+                                 (scheme-syntax schemeSyntax)
                                  ))
          #%braces #%parens #%brackets
          x
@@ -92,6 +96,10 @@
          display
          display2
          newline
+         ;; stuff i done want
+         define
+         let
+         ;; end stuff
          else
          #%app
          quote
@@ -99,7 +107,10 @@
          foobar2000
          expression
          str
-         (for-template #%parens)
+         define-struct
+         #;
+         (for-template #%parens #%brackets #%braces)
+         ;; (for-meta 2 (rename-out (honu-syntax syntax)))
          (rename-out
            (honu-if if)
            (honu-provide provide)

collects/honu/private/honu-typed-scheme.rkt

@@ -13,6 +13,7 @@
                      "ops.ss"
                      "syntax.ss"
                      "parse.ss"
+                     "literals.ss"
                      )
          "literals.ss"
          ;; "typed-utils.ss"
@@ -501,6 +502,15 @@ if (foo){
     [(_ expr ...)
      (parse-an-expr #'(expr ...))]))
 
+(define-honu-syntax scheme-syntax
+  (lambda (body ctx)
+    (syntax-parse body
+      [(_ expr . rest)
+       (values
+         (lambda ()
+           (apply-scheme-syntax #'#'expr))
+         #'rest)])))
+
 (define-honu-syntax honu-provide
   (lambda (body ctx)
     (syntax-parse body #:literals (semicolon)
@@ -547,7 +557,7 @@ if (foo){
          #'rest)])))
 
 (define-syntax (honu-unparsed-begin stx)
-  (printf "honu unparsed begin: ~a\n" (syntax->datum stx))
+  (printf "honu unparsed begin: ~a at phase ~a\n" (syntax->datum stx) (syntax-local-phase-level))
   (syntax-case stx ()
     [(_) #'(void)]
     [(_ . body)

collects/honu/private/literals.rkt

@@ -1,6 +1,7 @@
 #lang racket
 
 (provide (all-defined-out))
+(require syntax/parse)
 
 ;; macro for defining literal tokens that can be used in macros
 (define-syntax-rule (define-literal name ...)
@@ -18,3 +19,5 @@
                 honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->=
                 honu-? honu-: honu-comma honu-. #%braces #%brackets #%parens colon
                 ellipses-comma ellipses-comma* ellipses-repeat honu-for-syntax)
+
+(define-literal-set cruft (#%parens #%brackets #%braces semicolon))

collects/honu/private/macro.rkt

@@ -13,6 +13,7 @@
                      "contexts.ss"
                      "parse.ss"
                      "syntax.ss"
+                     "literals.rkt"
                      "honu-typed-scheme.ss"
                      scheme/base
                      syntax/parse
@@ -430,7 +431,8 @@
 
 (define-honu-syntax honu-pattern
   (lambda (stx ctx)
-    (syntax-parse stx #:literals (#%parens #%brackets semicolon)
+    (syntax-parse stx #:literal-sets ([cruft #:at stx])
+      ;; #%parens #%brackets semicolon)
       [(_ name (#%parens all-attributes:identifier ...) (#%brackets xpattern ...)
           semicolon . rest)
        (define my-parens (datum->syntax #'name '#%parens #'name #'name))
@@ -445,28 +447,38 @@
                          [parens (datum->syntax #'name '#%parens #'name #'name)])
              (syntax/loc stx
                          (define-splicing-syntax-class name
-                                                       #:literals (parens)
+                                                       #:literal-sets ([cruft #:at name])
                                                        #:attributes (all-attributes ...)
                                                        final-pattern))))
          #'rest)])))
 
+(define foobar 0)
 
 (define-honu-syntax honu-macro
   (lambda (stx ctx)
     (define-syntax-class honu-macro3
-                         #:literals (#%parens #%braces)
+                         ;; #:literals (#%parens #%braces)
+                         #:literal-sets ([cruft ;;#:at stx
+                                           #:phase (syntax-local-phase-level)
+                                           ])
       [pattern (_ name (#%parens literals ...)
                   (#%braces template ...) (#%braces code ...)
                   . rest)
                #:with result
                (list
                  (with-syntax ([(fixed ...) (fix-template #'(template ...))]
+                               [first-pattern (stx-car #'(template ...))]
+                               #;
+                               [your-bracket (datum->syntax #'name '#%brackets #'name)]
+                               #;
+                               [your-braces (datum->syntax #'name '#%braces #'name)]
+                               #;
                                [your-parens (datum->syntax #'name '#%parens #'name)])
 
                    #;
                    #'(define-honu-syntax name
                        (lambda (stx ctx)
-                         (syntax-parse stx #:literals (your-parens literals ...)
+                         (syntax-parse stx #:literals (your-parens your-bracket literals ...)
                            [(fixed ... rrest (... ...))
                             (values
                               #;
@@ -481,7 +493,10 @@
                    (syntax/loc stx
                                (define-honu-syntax name
                                  (lambda (stx ctx)
-                                   (syntax-parse stx #:literals (your-parens literals ...)
+                                   (printf "Executing macro `~a' on input `~a'\n" 'name (syntax->datum stx))
+                                   (syntax-parse stx
+                                     #:literal-sets ([cruft #:at name])
+                                     #:literals (foobar literals ...)
                                      [(fixed ... rrest (... ...))
                                       (values
                                         #;
@@ -595,7 +610,7 @@
                                                          #'rrest))]))))
                                   #'rest))])
     (printf "Executing honu macro\n")
-    (syntax-parse stx #:literals (#%parens #%braces)
+    (syntax-parse stx
       [out:honu-macro1 (apply (lambda (a b) (values (lambda () a) b)) (syntax->list (attribute out.result)))]
       [out:honu-macro3 (apply (lambda (a b) (values (lambda () a) b)) (syntax->list (attribute out.result)))]
       [out:honu-macro2 (apply (lambda (a b) (values (lambda () a) b)) (syntax->list (attribute out.result)))]

collects/honu/private/more.ss

@@ -180,7 +180,7 @@
 (define-syntax-rule (honu-syntax-maker maker unparsed)
   (define-honu-syntax maker
     (lambda (stx ctx)
-      (syntax-parse stx #:literals (semicolon #%parens)
+      (syntax-parse stx #:literal-sets ([cruft #:at unparsed])
         [(_ (#%parens expr (... ...)) semicolon . rest)
          (values
            (lambda ()

collects/honu/private/parse.rkt

@@ -56,7 +56,7 @@
   #:attrs (result)
   #:description "honu-expr"
   (lambda (stx fail)
-    (printf "Honu expr from transformer ~a in context ~a\n" (syntax->datum stx) context)
+    (printf "Honu expr from transformer `~a' in context ~a transformer ~a\n" (syntax->datum stx) context (get-transformer stx))
     (cond
      [(stx-null? stx) (fail)]
      #;
@@ -336,7 +336,7 @@
                      [pattern ((~var e (ternary context))
                                (~var x1 (debug-here (format "expression top 1 ~a\n" (syntax->datum #'e))))
                                semicolon
-                               (~var x2 (debug-here "2"))
+                               (~var x2 (debug-here "expression top 2"))
                                . rest)
                               #:with result #'e.result])
 
@@ -432,6 +432,27 @@
   [pattern (~seq (~var x (expression-1 the-expression-context)))
            #:with result (apply-scheme-syntax #'x.result)])
 
+(define-splicing-syntax-class (whats-here? hm)
+  [pattern (~seq x)
+           #:when (begin (printf "Whats at `~a': `~a'\n" hm #'x)
+                         #f)])
+
+(define-syntax-class statement
+  [pattern (~var x (expression-top the-top-block-context))
+           #:with result (apply-scheme-syntax (attribute x.result))
+           #:with rest #'x.rest])
+
+#;
+(define-splicing-syntax-class statement
+  [pattern (~seq
+             (~optional (~var zz (whats-here? "statement")))
+             (~var d1 (debug-here (format "statement 1\n")))
+             (~var x (expression-top the-top-block-context))
+             (~var d2 (debug-here (format "statement 2\n")))
+             )
+           #:with result (apply-scheme-syntax #'x.result)
+           #:with rest #'x.rest])
+
 (define-splicing-syntax-class expression-comma
   #:literals (honu-comma)
   #;
@@ -454,7 +475,7 @@
 (define (parse-an-expr stx)
   (printf "Parse an expr ~a\n" (syntax->datum stx))
   (syntax-parse (with-syntax ([(s ...) stx])
-                  #'(s ... semicolon))
+                  #'(s ...))
     #;
     [(raw:raw-scheme-syntax . rest) #'raw]
     [((~var expr (expression-1 the-expression-context)) . rest) #'expr.result]
@@ -555,10 +576,6 @@
              (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
@@ -566,7 +583,6 @@
     (and (stx-pair? stx)
          (identifier? (stx-car stx))
          (let ([v (begin
-                    #;
                     (printf "Transformer is ~a. Local value is ~a\n" (stx-car stx) (syntax-local-value (stx-car stx) (lambda () #f)))
                     (syntax-local-value (stx-car stx) (lambda () #f)))])
            (and (honu-transformer? v) v))))
@@ -596,8 +612,9 @@
               (let ([v (syntax-local-value (stx-car first) (lambda () #f))])
                 (and (honu-transformer? v) v))]
              [else #f]))))
-  #;
   (printf "~a bound transformer? ~a\n" stx (bound-transformer stx))
+  (bound-transformer stx)
+  #;
   (or (bound-transformer stx)
       (special-transformer stx)))
 

collects/honu/private/syntax.ss

@@ -24,6 +24,7 @@
 #;
 (define honu-scheme-syntax (gensym))
 
+#;
 (define-syntax-rule (scheme-syntax stx)
                     (syntax-property (syntax stx) honu-scheme-syntax #t))