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

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

@ -13,6 +13,7 @@
"ops.ss" "ops.ss"
"parse.ss" "parse.ss"
) )
(for-template scheme/base)
"literals.ss" "literals.ss"
;; "typed-utils.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 (define-honu-syntax honu-scheme
(lambda (stx ctx) (lambda (stx ctx)
(syntax-parse stx #:literals (semicolon) (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 (define-honu-syntax honu-if
(lambda (stx ctx) (lambda (stx ctx)
@ -483,16 +487,22 @@ if (foo){
(define-syntax (honu-unparsed-begin stx) (define-syntax (honu-unparsed-begin stx)
(printf "honu unparsed begin: ~a\n" (syntax->datum stx)) (printf "honu unparsed begin: ~a\n" (syntax->datum stx))
(syntax-case stx () (syntax-case stx ()
[(_) #'(begin (void))] [(_) #'(void)]
[(_ . body) (let-values ([(code rest) (parse-block-one/2 #'body [(_ . body)
(begin
(printf "Body is ~a\n" #'body)
(let-values ([(code rest) (parse-block-one/2 #'body
the-expression-context the-expression-context
#; #;
the-top-block-context)]) the-top-block-context)])
;; (printf "Rest is ~a\n" (syntax->datum rest)) ;; (printf "Rest is ~a\n" (syntax->datum rest))
(with-syntax ([code code] (with-syntax ([code code]
[(rest ...) rest]) [(rest ...) rest])
(if (stx-null? #'(rest ...))
(syntax/loc stx (syntax/loc stx
(begin code (honu-unparsed-begin rest ...)))))] code)
(syntax/loc stx
(begin code (honu-unparsed-begin rest ...)))))))]
#; #;
[(_ . body) (let-values ([(code rest) (parse-block-one the-top-block-context [(_ . body) (let-values ([(code rest) (parse-block-one the-top-block-context
#'body #'body

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

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

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

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