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

allow macros to reparse their input

Browse Source
This commit is contained in:
Jon Rafkind 2010-05-13 18:05:29 -06:00
parent 066166ce65
commit 721c815d89
6 changed files with 232 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/honu/main.rkt
View File

@ -11,6 +11,8 @@
(for-syntax "private/parse.ss")
"private/literals.ss"
"private/syntax.ss"
"private/more.ss"
(for-syntax "private/more.ss")
(for-syntax "private/syntax.ss")
"private/macro.ss")
@ -27,6 +29,7 @@
)
(honu-+ +)
(honu-* *)
(+ scheme:+)
(honu-/ /)
(honu-- -)
(honu-? ?)
@ -38,11 +41,20 @@
(for-syntax #%datum
display
with-syntax
quote
#%app
#%parens
...
map
syntax->list
(rename-out (semicolon \;
)
(parse-an-expr parse)
(... scheme:...)
(honu-syntax syntax)
(honu-+ +)
(honu-scheme scheme2)
(scheme-syntax schemeSyntax)
(scheme-syntax scheme:syntax)
))
#%braces
#%parens
@ -53,6 +65,9 @@
display2
newline
else
#%app
quote
...
foobar2000
(rename-out
(honu-if if)
@ -62,7 +77,7 @@
(honu-syntax syntax)
#;
(honu-scheme scheme2)
(scheme-syntax schemeSyntax)
(scheme-syntax scheme:syntax)
))
#;

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

@ -13,6 +13,7 @@
"ops.ss"
"parse.ss"
)
(for-template scheme/base)
"literals.ss"
;; "typed-utils.ss"
)
@ -342,7 +343,10 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
(define-honu-syntax honu-scheme
(lambda (stx ctx)
(syntax-parse stx #:literals (semicolon)
[(_ template semicolon rest ...) (values #'template #'(rest ...))])))
[(_ template semicolon rest ...)
(values (lambda () #'(lambda () template)) #'(rest ...))]
[else (raise-syntax-error 'scheme "need a semicolon probably" stx)]
)))
(define-honu-syntax honu-if
(lambda (stx ctx)
@ -483,16 +487,22 @@ if (foo){
(define-syntax (honu-unparsed-begin stx)
(printf "honu unparsed begin: ~a\n" (syntax->datum stx))
(syntax-case stx ()
[(_) #'(begin (void))]
[(_ . body) (let-values ([(code rest) (parse-block-one/2 #'body
[(_) #'(void)]
[(_ . body)
(begin
(printf "Body is ~a\n" #'body)
(let-values ([(code rest) (parse-block-one/2 #'body
the-expression-context
#;
the-top-block-context)])
;; (printf "Rest is ~a\n" (syntax->datum rest))
(with-syntax ([code code]
[(rest ...) rest])
(syntax/loc stx
(begin code (honu-unparsed-begin rest ...)))))]
(if (stx-null? #'(rest ...))
(syntax/loc stx
code)
(syntax/loc stx
(begin code (honu-unparsed-begin rest ...)))))))]
#;
[(_ . body) (let-values ([(code rest) (parse-block-one the-top-block-context
#'body

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

@ -4,7 +4,6 @@
"literals.ss"
"parse.ss"
"syntax.ss"
;; (for-template "syntax.ss")
(for-syntax "debug.ss"
"contexts.ss"
"parse.ss"
@ -396,6 +395,31 @@
(define-honu-syntax honu-macro
(lambda (stx ctx)
(define-syntax-class honu-macro3
#:literals (#%parens #%braces)
[pattern (_ name (#%parens literals ...)
(#%braces template ...) (#%braces code ...)
. rest)
#:with result
(list
(syntax/loc stx
(define-honu-syntax name
(lambda (stx ctx)
(syntax-parse stx #:literals (literals ...)
[(template ... rrest (... ...))
(values
(honu-unparsed-begin code ...)
#'(rrest (... ...)))]))))
#;
(with-syntax ([parsed (let-values ([(out rest*)
(parse-block-one/2 #'(code ...)
the-expression-context)])
out)])
(syntax/loc stx
(define-honu-syntax name
(lambda (stx ctx)
parsed))))
#'rest)])
(define-syntax-class honu-macro2
#:literals (#%parens #%braces)
[pattern (_ name (#%braces code ...)
@ -405,7 +429,13 @@
(syntax/loc stx
(define-honu-syntax name
(lambda (stx ctx)
(honu-unparsed-begin code ...))))
(values
(honu-unparsed-begin code ...)
(begin
(printf "inside ~a stx is ~a\n" 'name stx)
(syntax-parse stx #:literals (semicolon)
[(_ semicolon rrest (... ...))
#'(rrest (... ...))]))))))
#;
(with-syntax ([parsed (let-values ([(out rest*)
(parse-block-one/2 #'(code ...)
@ -485,8 +515,9 @@
#'rest))])
(printf "Executing honu macro\n")
(syntax-parse stx #:literals (#%parens #%braces)
[out:honu-macro1 (apply (lambda (a b) (values a b)) (syntax->list (attribute out.result)))]
[out:honu-macro2 (apply (lambda (a b) (values a b)) (syntax->list (attribute out.result)))]
[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)))]
#;
[(_ (#%parens honu-literal ...)

21
collects/honu/private/more.ss Normal file
View File

@ -0,0 +1,21 @@
#lang scheme
(require "honu-typed-scheme.ss"
"literals.ss"
(for-syntax syntax/parse
"literals.ss")
(for-template "honu-typed-scheme.ss"
"literals.ss"
))
(provide (all-defined-out))
(define-honu-syntax honu-syntax
(lambda (stx ctx)
(syntax-parse stx #:literals (semicolon #%parens)
[(_ (#%parens expr ...) semicolon . rest)
(values
(lambda ()
#'(honu-unparsed-begin expr ...))
#'rest)])))

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

@ -7,6 +7,7 @@
"syntax.ss")
syntax/parse
syntax/parse/experimental/splicing
"syntax.ss"
(for-syntax syntax/parse)
scheme/splicing
(for-syntax syntax/define)
@ -43,20 +44,30 @@
#:attrs (result)
#:description "honu-expr"
(lambda (stx fail)
(printf "Honu expr ~a\n" stx)
(printf "Honu expr from transformer ~a\n" (syntax->datum stx))
(cond
[(stx-null? stx) (fail)]
[(syntax-parse stx #:literals (honu-syntax)
[(honu-syntax expr ...) #'(expr ...)]
[else #f]) => (lambda (exprs)
#;
[(syntax-parse stx #:literals (honu-syntax #%parens semicolon)
[(honu-syntax (#%parens expr ...) semicolon . rest)
(printf "Parsed honu-syntax rest ~a position ~a out ~a\n"
#'rest (syntax-object-position stx #'rest)
#'(honu-unparsed-begin expr ...))
(list #'rest (syntax-object-position stx #'rest)
#'(honu-unparsed-begin expr ...))]
[else #f]
#;
[else #f => (lambda (exprs)
(printf "Ignoring honu-syntax 1!\n")
(list exprs 0 #''()))]
(list 0 #''()))]
)]
[(get-transformer stx) => (lambda (transformer)
(printf "Transforming honu macro ~a\n" (car stx))
(printf "Transforming honu macro ~a\n" (stx-car stx))
(let-values ([(used rest)
(transformer stx context)])
(printf "Result is ~a\n" used)
(list rest (syntax-object-position stx rest)
used)))]
(used))))]
[else (fail)])))
@ -67,6 +78,18 @@
(printf "Honu expr ~a\n" stx)
(cond
[(stx-null? stx) (fail)]
#;
[(syntax-parse stx #:literals (honu-syntax #%parens semicolon)
[(honu-syntax (#%parens expr ...) semicolon . rest)
(list #'rest (syntax-object-position stx #'rest)
#'(honu-unparsed-begin expr ...))]
[else #f]
#;
[else #f => (lambda (exprs)
(printf "Ignoring honu-syntax 1!\n")
(list 0 #''()))]
)]
#;
[(syntax-parse stx #:literals (honu-syntax)
[(honu-syntax expr ...) #'(expr ...)]
[else #f]) => (lambda (exprs)
@ -76,11 +99,21 @@
(printf "Transforming honu macro ~a\n" (car stx))
(let-values ([(used rest)
(transformer stx context)])
<<<<<<< HEAD
(list (syntax-object-position stx rest)
used)))]
[else (syntax-case stx ()
[(f . rest) (list 1 #'f)])])))
=======
(list rest (syntax-object-position stx rest)
(used))))]
[else (syntax-parse stx
[(f . rest) (list #'rest 1 #'f)]
[x:number (list #''() 0 #'x)]
)])))
>>>>>>> allow macros to reparse their input
#;
(define-splicing-syntax-class expr
@ -93,6 +126,8 @@
#:with call #'(e.result arg.result ...)])
(define-splicing-syntax-class (expression-last context)
#:literals (#%parens)
[pattern (~seq (#%parens (~var e (expression-1 context)))) #:with result #'e.result]
[pattern (~seq (~var e (honu-transformer context))) #:with result #'e.result]
[pattern (~seq (~var call (call context))) #:with result #'call.call]
@ -204,23 +239,24 @@
([honu-. (sl (left right) #'(field-access right left))])
))
(define-splicing-syntax-class (ternary context)
#:literals (honu-? honu-:)
[pattern (~seq (~var condition (expression-1 context))
(~optional (~seq honu-? (~var on-true (ternary context))
honu-: (~var on-false (ternary context)))))
#:with result
(cond [(attribute on-true)
#'(if condition.result on-true.result on-false.result)]
[else #'condition.result])])
(define-syntax-class (expression-top context)
#:literals (semicolon)
[pattern ((~var e (ternary context)) semicolon . rest)
#:with result #'e.result])
(define-splicing-syntax-class (ternary context)
#:literals (honu-? honu-:)
[pattern (~seq (~var condition (expression-1 context))
(~optional (~seq honu-? (~var on-true (ternary context))
honu-: (~var on-false (ternary context)))))
#:with result
(cond [(attribute on-true)
#'(if condition.result on-true.result on-false.result)]
[else #'condition.result])])
(define-syntax-class (expression-top context)
#:literals (semicolon)
[pattern ((~var e (ternary context)) semicolon . rest)
#:with result #'e.result])
(define-syntax-class raw-scheme-syntax
[pattern x #:when (syntax-property #'x honu-scheme-syntax)])
(define-values (prop:honu-transformer honu-transformer? honu-transformer-ref)
(make-struct-type-property 'honu-transformer))
@ -248,6 +284,7 @@
[(_ template rest ...) (values #'template #'(rest ...))])))
(define (fix-output stx)
#f
#|
(printf "Fix output ~a\n" (syntax->datum stx))
(when (and (stx-pair? stx) (equal? 'honu-syntax (syntax->datum (stx-car stx))))
@ -258,18 +295,21 @@
(free-identifier=? stx #'honu-scheme)
))
|#
#;
(syntax-parse stx #:literals (honu-syntax #%parens syntax)
#;
[((honu-syntax (#%parens x ...) y ...) rest ...)
#;
(printf "a1\n")
(with-syntax ([(y* ...) (fix-output #'(y ... rest ...))])
(syntax/loc stx
(x ... y* ...)))]
((honu-syntax x ...) y* ...)))]
#;
[(start ... (honu-scheme code ...) rest ...)
(with-syntax ([(rest* ...) (fix-output #'(rest ...))])
(syntax/loc stx
(start ... honu-scheme (code ...) rest* ...)))]
#;
[(honu-syntax (#%parens x ...) y ...)
#;
(printf "a2\n")
@ -286,10 +326,16 @@
[(z x ...)
#;
(printf "a3\n")
(datum->syntax stx (cons (fix-output #'z)
(fix-output #'(x ...)))
stx)
#;
(with-syntax ([z* (fix-output #'z)]
[(x* ...) (fix-output #'(x ...))])
(syntax/loc stx
(z* x* ...)))]
#;
[(honu-syntax . rest)
(raise-syntax-error 'fix-output "invalid use of honu-syntax")]
[else
@ -297,11 +343,21 @@
(printf " no change\n")
stx]))
(define (parse-an-expr stx)
(printf "Parse an expr ~a\n" (syntax->datum stx))
(syntax-parse (with-syntax ([s stx])
#'(s semicolon))
[(raw:raw-scheme-syntax . rest) #'raw]
[((~var expr (expression-1 the-expression-context)) . rest) #'expr.result]
[else (raise-syntax-error 'parse-an-expr "cant parse" stx)]
))
(define (parse-block-one/2 stx context)
(define (parse-one stx context)
;; (printf "~a\n" (syntax-class-parse function stx))
(syntax-parse stx
[(raw:raw-scheme-syntax . rest) (values #'raw #'rest)]
[function:function (values #'function.result #'function.rest)]
[(~var expr (expression-top context)) (values #'expr.result #'expr.rest)]
#;
@ -310,13 +366,44 @@
(printf "Parsing ~a\n" stx)
(cond
[(stx-null? stx) (values stx '())]
#;
[(syntax-parse stx #:literals (honu-syntax #%parens semicolon)
[(honu-syntax (#%parens expr ...) semicolon . rest)
(list #'(expr ...)
#'rest)
#;
(printf "Parsed honu-syntax rest ~a position ~a out ~a\n"
#'rest (syntax-object-position stx #'rest)
#'(honu-unparsed-begin expr ...))
#;
(list #'rest (syntax-object-position stx #'rest)
#'(honu-unparsed-begin expr ...))]
[else #f]
#;
[else #f => (lambda (exprs)
(printf "Ignoring honu-syntax 1!\n")
(list 0 #''()))]
) => (lambda (all)
(let ([to-parse (car all)]
[rest (cadr all)])
(let-values ([(out rest2)
(with-syntax ([(more ...) rest]
[(stuff ...) to-parse])
(parse-block-one/2 #'(stuff ... more ...) context))])
(values out rest2))))
]
[(get-transformer stx) => (lambda (transformer)
(printf "Parse one: execute transformer ~a\n" transformer)
(printf "Parse one: execute transformer ~a ~a\n" (stx-car stx) transformer)
#;
(printf "output of transformer is ~a\n" (let-values ([(a b) (transformer stx context)]) (list a b)))
(let-values ([(output rest)
(transformer stx context)])
(values (output) rest))
#;
(call-values (transformer stx context)
(lambda (reparse rest)
(define fixed (fix-output reparse))
;; (define fixed (fix-output reparse))
(define fixed reparse)
(printf "Transformer gave us ~a\n" (syntax->datum reparse))
#;
(values reparse rest)
@ -356,8 +443,9 @@
(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 () (stx-car stx))))])
(syntax-local-value (stx-car stx) (lambda () #f)))])
(and (honu-transformer? v) v))))
(define (special-transformer stx)
(and (stx-pair? stx)
@ -385,7 +473,8 @@
(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))
#;
(printf "~a bound transformer? ~a\n" stx (bound-transformer stx))
(or (bound-transformer stx)
(special-transformer stx)))

29
collects/honu/private/syntax.ss Normal file
View File

@ -0,0 +1,29 @@
#lang scheme
(provide (all-defined-out))
#;
(define-syntax (honu-syntax stx)
(syntax-case stx ()
[(_ expr)
#'(honu-unparsed-expr expr)
#;
(begin
(printf "honu syntax ~a\n" stx)
(raise-syntax-error 'honu-syntax "dont call this")
#'(make-honu-transformer (lambda (stx ctx)
(printf "honu syntax ~a\n" stx)
#'(expr ...))))]))
(define-syntax honu-unparsed-expr (lambda (stx) (raise-syntax-error 'honu-unparsed-expr "dont use this")))
(define honu-scheme-syntax (gensym))
(define-syntax-rule (scheme-syntax stx)
(syntax-property (syntax stx) honu-scheme-syntax #t))
#;
(define-syntax (scheme-syntax stx)
(syntax-case stx ()
[(_ x ...)
(lambda () '(syntax-property #'(x ...) honu-scheme-syntax #t))]))