From 72f83d19a9dd7cf109fc0200f775a7b9ad5dd66c Mon Sep 17 00:00:00 2001 From: jon Date: Wed, 21 Apr 2010 18:15:58 -0600 Subject: [PATCH] parse transformers --- collects/honu/main.rkt | 18 ++++++++++- collects/honu/private/honu-typed-scheme.rkt | 17 ++++++++++ collects/honu/private/literals.rkt | 3 +- collects/honu/private/macro.rkt | 7 ++-- collects/honu/private/parse.rkt | 36 ++++++++++++++++++--- 5 files changed, 72 insertions(+), 9 deletions(-) diff --git a/collects/honu/main.rkt b/collects/honu/main.rkt index 432aa38935..784a192f3a 100644 --- a/collects/honu/main.rkt +++ b/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) )) #; diff --git a/collects/honu/private/honu-typed-scheme.rkt b/collects/honu/private/honu-typed-scheme.rkt index 5433eb4d4c..6679875332 100644 --- a/collects/honu/private/honu-typed-scheme.rkt +++ b/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) diff --git a/collects/honu/private/literals.rkt b/collects/honu/private/literals.rkt index 79b738ec32..d1fd426e24 100644 --- a/collects/honu/private/literals.rkt +++ b/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) diff --git a/collects/honu/private/macro.rkt b/collects/honu/private/macro.rkt index 9003b17776..23ebf955a9 100644 --- a/collects/honu/private/macro.rkt +++ b/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)) diff --git a/collects/honu/private/parse.rkt b/collects/honu/private/parse.rkt index 47fb65f7fc..fec363058c 100644 --- a/collects/honu/private/parse.rkt +++ b/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-:)