suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

parse transformers

Browse Source
This commit is contained in:
jon 2010-04-21 18:15:58 -06:00 committed by Jon Rafkind
parent e052c33998
commit 72f83d19a9
5 changed files with 72 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/honu/main.rkt
View File

@ -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)
))
#;

17
collects/honu/private/honu-typed-scheme.rkt
View File

@ -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)

3
collects/honu/private/literals.rkt
View File

@ -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)

7
collects/honu/private/macro.rkt
View File

@ -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))

36
collects/honu/private/parse.rkt
View File

@ -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-:)