parse transformers

collects/honu/main.rkt

@@ -1,14 +1,24 @@
 #lang scheme/base
 
+(require scheme/class)
+
 (require "private/honu-typed-scheme.ss"
          ;; "private/honu.ss"
          "private/parse.ss"
          "private/literals.ss"
          "private/macro.ss")
 
+(define test-x-class
+  (class object%
+    (init-field tuna)
+    (super-new)))
+
+(define x (new test-x-class [tuna 5]))
+
 (provide (rename-out (#%dynamic-honu-module-begin #%module-begin)
                      (honu-top #%top)
-                     (semicolon \;)
+                     (semicolon \;
+                                )
                      (honu-+ +)
                      (honu-* *)
                      (honu-/ /)
@@ -16,8 +26,11 @@
                      (honu-? ?)
                      (honu-: :)
                      (honu-comma |,|)
+                     (honu-. |.|)
                      )
          #%datum
+         #%braces
+         x
          true
          false
          display
@@ -26,6 +39,9 @@
          else
          (rename-out
            (honu-if if)
+           (honu-provide provide)
+           (honu-macro-item macroItem)
+           (honu-macro macro)
            ))
 
 #;

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

@@ -320,6 +320,23 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
 
 |#
 
+(define-honu-syntax honu-provide
+  (lambda (stx ctx)
+    (syntax-parse stx
+      #:literals (semicolon)
+      [(_ something:id semicolon . rest)
+       (values #'(provide something)
+               #'rest)])))
+
+(define-honu-syntax honu-macro-item
+  (lambda (stx ctx)
+    (syntax-parse stx
+      #:literals (#%braces)
+      [(_ name:id (#%braces literals (#%braces literal ...)
+                   items ...) . rest)
+       (values #'(define-syntax-class name [pattern x])
+               #'rest)])))
+
 (define-honu-syntax honu-if
   (lambda (stx ctx)
     (define (parse-complete-block stx)

collects/honu/private/literals.rkt

@@ -16,5 +16,4 @@
                 honu-= honu-+= honu--= honu-*= honu-/= honu-%=
                 honu-&= honu-^= honu-\|= honu-<<= honu->>= honu->>>=
                 honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->=
-                honu-? honu-: honu-comma)
+                honu-? honu-: honu-comma honu-. #%braces)
-

collects/honu/private/macro.rkt

@@ -1,6 +1,6 @@
 #lang scheme/base
 
-(require "honu.ss"
+(require "honu-typed-scheme.ss"
          (for-syntax "debug.ss"
                      "contexts.ss"
                      scheme/base
@@ -364,6 +364,7 @@
 
 (define-honu-syntax honu-macro
   (lambda (stx ctx)
+    (printf "Executing honu macro\n")
     (syntax-case stx (#%parens #%braces)
       [(_ (#%parens honu-literal ...)
           (#%braces (#%braces name pattern ...))
@@ -422,7 +423,9 @@
                          out (... ...) rrest)
                       #;
                       #'rrest))])))
-          #'rest))])))
+          #'rest))]
+      [else (raise-syntax-error 'honu-macro "fail!")]
+      )))
 
 ;; (my-syntax guz (_ display (#%parens x ...)) (+ x ...))
 ;; (guz display (#%parens 1 2 3 4))

collects/honu/private/parse.rkt

@@ -2,9 +2,11 @@
 
 (require "contexts.ss"
          "util.ss"
-         (for-template "literals.ss")
+         (for-template "literals.ss"
+                       "language.ss")
          syntax/parse
          syntax/parse/experimental/splicing
+         (for-syntax syntax/parse)
          scheme/splicing
          syntax/stx
          (for-syntax "util.ss")
@@ -14,7 +16,8 @@
 
 (define-syntax-class block
   [pattern (#%braces statement ...)
-           #:with result (parse-block-one/2 #'(statement ...) the-block-context)])
+           #:with result (let-values ([(body rest) (parse-block-one/2 #'(statement ...) the-block-context)])
+                           body)])
 
 (define-syntax-class function
   [pattern (type:id name:id (#%parens args ...) body:block . rest)
@@ -33,6 +36,21 @@
        ;; [(equal? start end) count]
        [else (loop (stx-cdr start) (add1 count))]))))
 
+(define-primitive-splicing-syntax-class (honu-transformer context)
+  #:attrs (result)
+  #:description "honu-expr"
+  (lambda (stx fail)
+    (cond
+     [(stx-null? stx) (fail)]
+     [(get-transformer stx) => (lambda (transformer)
+                                 (printf "Transforming honu macro ~a\n" (car stx))
+                                 (let-values ([(used rest)
+                                               (transformer stx context)])
+                                   (list rest (syntax-object-position stx rest)
+                                         used)))]
+     
+     [else (fail)])))
+
 (define-primitive-splicing-syntax-class (honu-expr context)
   #:attributes (result)
   #:description "honu-expr"
@@ -40,6 +58,7 @@
     (cond
      [(stx-null? stx) (fail)]
      [(get-transformer stx) => (lambda (transformer)
+                                 (printf "Transforming honu macro ~a\n" (car stx))
                                  (let-values ([(used rest)
                                                (transformer stx context)])
                                    (list (syntax-object-position stx rest)
@@ -59,8 +78,12 @@
            #:with call #'(e.result arg.result ...)])
 
 (define-splicing-syntax-class (expression-last context)
+  [pattern (~seq (~var e (honu-transformer context))) #:with result #'e.result]
+
   [pattern (~seq (~var call (call context))) #:with result #'call.call]
   [pattern (~seq x:number) #:with result #'x]
+  [pattern (~seq x:id) #:with result #'x]
+  #;
   [pattern (~seq (~var e (honu-expr context))) #:with result #'e.result]
   )
 
@@ -79,6 +102,8 @@
                     [else
                      #'left.result])))))
 
+
+
 ;;   (infix-operators ([honu-* ...]
 ;;                     [honu-- ...])
 ;;                    ([honu-+ ...]
@@ -98,7 +123,8 @@
   (syntax-case stx ()
                [(_ first last operator-stuff ...)
                 (with-syntax ([(name ...) (generate-temporaries #'(operator-stuff ...))])
-                             (with-syntax ([(result ...) (create-stuff (cons #'first
+                             (with-syntax ([(result ...)
+                                            (create-stuff (cons #'first
                                                                              (append
                                                                               (drop-last (syntax->list #'(name ...)))
                                                                               (list #'last)))
@@ -136,7 +162,9 @@
                                        [honu-- (sl (left right) #'(- left right))])
                                       ([honu-* (sl (left right) #'(* left right))]
                                        [honu-% (sl (left right) #'(modulo left right))]
-                                       [honu-/ (sl (left right) #'(/ left right))])))
+                                       [honu-/ (sl (left right) #'(/ left right))])
+                                      ([honu-. (sl (left right) #'(field-access right left))])
+                                      ))
 
     (define-splicing-syntax-class (ternary context)
       #:literals (honu-? honu-:)