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

honu-syntax supports commas

Browse Source
This commit is contained in:
Jon Rafkind 2010-05-19 14:56:31 -06:00
parent 1b088f7c37
commit 59db2491d0
5 changed files with 150 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/honu/main.rkt
View File

@ -68,6 +68,8 @@
identifier expression
(rename-out (semicolon \;
)
(ellipses-comma ec)
(expression-comma expression_comma)
(parse-an-expr parse)
(... scheme:...)
(honu-body:class body)

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

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

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

@ -69,9 +69,9 @@
(define-for-syntax (fix-template stx)
(syntax-parse stx #:literals (honu-:)
[(variable:id honu-: class:id rest ...)
[(variable:identifier honu-: class:identifier rest ...)
(with-syntax ([(rest* ...) (fix-template #'(rest ...))])
(datum->syntax stx (cons #'(~var variable class)
(datum->syntax stx (cons #'(~var variable class #:attr-name-separator "_")
#'(rest* ...))
stx)
#;
@ -426,6 +426,7 @@
(with-syntax ([(fixed ...) (fix-template #'(template ...))]
[your-parens (datum->syntax #'name '#%parens #'name)])
#;
#'(define-honu-syntax name
(lambda (stx ctx)
(syntax-parse stx #:literals (your-parens literals ...)
@ -438,7 +439,7 @@
(let ([result (honu-unparsed-begin code ...)])
(lambda () result))
#'(rrest (... ...)))])))
#;
(printf "Original pattern ~a" (syntax->datum #'(fixed ... rrest (... ...))))
(syntax/loc stx
(define-honu-syntax name
(lambda (stx ctx)

88
collects/honu/private/more.ss
View File

@ -2,15 +2,79 @@
(require "honu-typed-scheme.ss"
"literals.ss"
syntax/parse
(for-syntax syntax/parse
syntax/stx
racket/list
(only-in racket (... scheme-ellipses))
"literals.ss")
(for-template "honu-typed-scheme.ss"
"literals.ss"
(only-in racket ...)
))
(provide (all-defined-out))
(define (replace-commas stuff)
(syntax-parse stuff #:literals (ellipses-comma)
[((ellipses-comma z) thing blah ...)
(with-syntax ([(rest ...) (replace-commas #'(thing blah ...))])
#'(z honu-comma rest ...))]
[((ellipses-comma z)) #'z]
[(z rest ...)
(with-syntax ([z* (replace-commas #'z)]
[(rest* ...) (replace-commas #'(rest ...))])
#'(z* rest* ...))]
[else stuff]))
(define-syntax (fix-template stuff)
(define (fix stuff)
(printf "Macro fix template for ~a\n" (syntax->datum stuff))
(syntax-parse stuff #:literals (ellipses-comma)
[(any ellipses-comma rest ...)
(define (addit item)
(with-syntax ([i item])
#'(i honu-comma)))
(define (remove-last list)
(take list (sub1 (length list))))
(define (add-commas stuff)
(remove-last (apply append (map syntax->list (map addit (syntax->list stuff))))))
(with-syntax ([(any* ...) (add-commas #'any)]
[(rest* ...) (fix #'(rest ...))])
#'(any* ... rest* ...))]
[(one rest ...)
(with-syntax ([one* (fix #'one)]
[(rest* ...) (fix #'(rest ...))])
(datum->syntax stuff (cons #'one*
#'(rest* ...))
stuff)
#;
#'(one* rest* ...))]
[else stuff]))
(define (replace stuff)
(syntax-parse stuff #:literals (ellipses-comma)
[(a ellipses-comma rest ...)
(with-syntax ([a* (replace #'a)]
[(rest* ...) (replace #'(rest ...))])
#'((ellipses-comma a*) (... ...) rest* ...))]
[(z rest ...)
(with-syntax ([z* (replace #'z)]
[(rest* ...) (replace #'(rest ...))])
#'(z* rest* ...))]
[else stuff]))
(printf "Do fix template for ~a\n" (syntax->datum stuff))
(syntax-parse stuff
[(_ blah)
(let ([replaced (replace #'blah)])
(printf "Replaced ~a\n" (syntax->datum replaced))
(with-syntax ([out2 replaced])
(let ([x #'(replace-commas #'out2)])
(printf "Final syntax ~a\n" (syntax->datum x))
x)))]
#;
[(_ blah ...) (fix #'(blah ...))]))
(define-honu-syntax honu-syntax
(lambda (stx ctx)
(syntax-parse stx #:literals (semicolon #%parens)
@ -23,13 +87,35 @@
[(stx-pair? what) (for-each show-pattern-variables (syntax->list what))]
[else (printf "~a is *not* a pattern variable\n" what)]))
#;
(printf "Original code is ~a\n" (syntax->datum #'(expr ...)))
#;
(printf "Expanded is ~a\n" (syntax->datum (expand-syntax-once #'(expr ...))))
#;
(for-each show-pattern-variables (syntax->list #'(expr ...)))
;; outer is relative phase 1, inner is relative phase 0
#|
#'#'(honu-unparsed-begin expr ...)
|#
#;
(syntax (fix-template (syntax (honu-unparsed-begin expr ...))))
#;
(with-syntax ([a #'(fix-template #'(honu-unparsed-begin expr ...))])
#'a)
#'(fix-template (honu-unparsed-begin expr ...))
#;
(let ([x #'(fix-template (honu-unparsed-begin expr ...))])
(printf "Final syntax ~a\n" (syntax->datum x))
x)
#;
#'(fix-template 1 2 3)
#;
(with-syntax ([(out ...) (local-expand #'(expr ...) 'expression '())])
#'(honu-unparsed-begin out ...)))
#'rest)])))

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

@ -14,10 +14,19 @@
syntax/name
syntax/stx
(for-syntax "util.ss")
(for-syntax syntax/private/stxparse/runtime-prose
syntax/private/stxparse/runtime
)
(for-template scheme/base))
(provide (all-defined-out))
(begin-for-syntax
(current-failure-handler
(lambda (_ f)
(printf "Failure is ~a\n" (failure->sexpr (simplify-failure f)))
(error 'failed "whatever"))))
(define-syntax-class block
#:literals (#%braces)
[pattern (#%braces statement ...)
@ -110,10 +119,17 @@
=======
(list rest (syntax-object-position stx rest)
(used))))]
#;
[x:identifier (list #''() 0 #'x)]
#;
[else (fail)]
[else (syntax-parse stx
[x:identifier (list #''() 1 #'x)]
#;
[(f . rest) (list #'rest 1 #'f)]
[x:number (list #''() 0 #'x)]
#;
[x:number (list #''() 1 #'x)]
[else (fail)]
)])))
>>>>>>> allow macros to reparse their input
@ -122,20 +138,42 @@
[pattern (~seq f ...) #:with result])
(define-splicing-syntax-class (call context)
#:literals (honu-comma)
[pattern (~seq (~var e (honu-expr context)) (#%parens (~seq (~var arg (ternary context))
#:literals (honu-comma #%parens)
#;
[pattern (~seq (~var e identifier)
(x (~var arg (expression-1 context)) ...)
#;
(#%parens (~var arg (expression-1 context)) ...))
#:with call
(begin
(printf "Resulting call is ~a\n" (syntax->datum #'(e arg.result ...)))
#'(e arg.result ...))]
[pattern (~seq (~var e honu-identifier
#;
(honu-expr context))
(x
;; #%parens
(~seq (~var arg (ternary context))
(~optional honu-comma)) ...))
#:with call #'(e.result arg.result ...)])
#:with call
(begin
(printf "Resulting call is ~a\n" (syntax->datum #'(e arg.result ...)))
#'(e arg.result ...))])
(define-splicing-syntax-class honu-identifier
[pattern (~seq x:identifier) #:when (not (free-identifier=? #'honu-comma #'x))])
(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]
[pattern (~seq x:number) #:with result #'x]
[pattern (~seq x:str) #:with result #'x]
[pattern (~seq x:identifier) #:with result #'x]
[pattern (~seq x:honu-identifier) #:with result #'x]
#;
[pattern (~seq (~var e (honu-expr context))) #:with result #'e.result]
)
@ -348,6 +386,10 @@
(define-splicing-syntax-class expression
[pattern (~seq (~var x (expression-1 the-expression-context)))])
(define-splicing-syntax-class expression-comma
#:literals (honu-comma)
[pattern ((~seq (~var expr (expression-1 the-expression-context)) (~optional comma)) ...)])
(define (parse-an-expr stx)
(printf "Parse an expr ~a\n" (syntax->datum stx))
(syntax-parse (with-syntax ([s stx])
@ -363,6 +405,11 @@
(define (parse-block-one/2 stx context)
(define (parse-one stx context)
#;
(let-values ([(a b) (debug-parse #'(SQL_create_insert) ((~seq x:expression)))])
(printf "debug parse for ~a is ~a and ~a\n" 'SQL_create_insert a b))
(let-values ([(a b) (debug-parse stx ((~seq (~var x (expression-top context)))))])
(printf "debug parse for ~a is ~a and ~a\n" (syntax->datum stx) a b))
;; (printf "~a\n" (syntax-class-parse function stx))
(syntax-parse stx