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

define patterns (really syntax-classes). use different parsers depending on the context. implement provide and require

Browse Source
This commit is contained in:
Jon Rafkind 2010-05-24 22:14:49 -06:00
parent 0ec71da614
commit 9894670dbe
7 changed files with 103 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/honu/main.rkt
View File

@ -65,10 +65,13 @@
...
map
syntax->list
identifier expression
identifier
expression
(rename-out (semicolon \;
)
(ellipses-comma ec)
#;
(honu-identifier identifier)
(expression-comma expression_comma)
(parse-an-expr parse)
(... scheme:...)
@ -78,8 +81,7 @@
(honu-scheme scheme2)
(scheme-syntax scheme:syntax)
))
#%braces
#%parens
#%braces #%parens #%brackets
x
true
false
@ -96,7 +98,11 @@
(honu-provide provide)
(honu-macro-item macroItem)
(honu-macro macro)
(honu-identifier identifier)
(honu-require require)
(honu-for-syntax forSyntax)
(honu-syntax syntax)
(honu-pattern pattern)
(honu-keywords keywords)
#;
(honu-scheme scheme2)

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

@ -322,6 +322,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
(syntax/loc stx
(define-syntax id (make-honu-transformer rhs))))))
#;
(define-honu-syntax honu-provide
(lambda (stx ctx)
(syntax-parse stx
@ -355,7 +356,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
[(_ word:identifier ... semicolon . rest)
(values (lambda () (apply-scheme-syntax
#'(begin
(define-syntax word (lambda (xx) (raise-syntax-error 'word "dont use this")))
(define-syntax word (lambda (xx) (raise-syntax-error 'word "dont use this")))
...)))
#'rest)])))
@ -496,6 +497,54 @@ if (foo){
(define (display2 x y)
(printf "~a ~a" x y))
(define-syntax (honu-unparsed-expr stx)
(parse-an-expr stx))
(define-honu-syntax honu-provide
(lambda (body ctx)
(syntax-parse body #:literals (semicolon)
[(_ x:id ... semicolon . rest)
(values
(lambda ()
#'(provide x ...))
#'rest)])))
(define-honu-syntax honu-require
(lambda (body ctx)
(define-syntax-class for-syntax-form
#:literals (#%parens honu-for-syntax)
[pattern (#%parens honu-for-syntax spec)
#:with result
(datum->syntax #'spec (cons #'for-syntax (cons #'spec #'()))
#'spec #'spec)
#;
(datum->syntax body (cons #'for-syntax (cons #'spec #'()))
body body)])
(define-syntax-class normal-form
[pattern x:str #:with result #'x])
(define-syntax-class form
[pattern x:for-syntax-form #:with result #'x.result]
[pattern x:normal-form #:with result #'x.result])
(syntax-parse body #:literals (semicolon)
[(_ form:form ... semicolon . rest)
(values
(lambda ()
(datum->syntax
body
(cons #'require
#'(form.result ...))
body
body))
#'rest)])
#;
(syntax-parse body #:literals (#%parens honu-for-syntax semicolon)
[(_ (#%parens honu-for-syntax what) semicolon . rest)
(values
(lambda ()
(apply-scheme-syntax
#'(require (for-syntax what))))
#'rest)])))
(define-syntax (honu-unparsed-begin stx)
(printf "honu unparsed begin: ~a\n" (syntax->datum stx))
(syntax-case stx ()
@ -504,6 +553,8 @@ if (foo){
(begin
(printf "Body is ~a\n" #'body)
(let-values ([(code rest) (parse-block-one/2 #'body
the-top-block-context
#;
the-expression-context
#;
the-top-block-context)])
@ -550,4 +601,9 @@ if (foo){
[(_ forms ...)
(begin
(printf "Module begin ~a\n" (syntax->datum #'(forms ...)))
#'(#%plain-module-begin (honu-unparsed-begin forms ...)))]))
#'(#%plain-module-begin (honu-unparsed-begin forms ...))
#;
(with-syntax ([all (syntax-local-introduce #'(provide (all-defined-out)))])
#'(#%plain-module-begin all (honu-unparsed-begin forms ...))
#;
#'(#%plain-module-begin (provide (all-defined-out)) (honu-unparsed-begin forms ...))))]))

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

@ -16,5 +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
ellipses-comma)
honu-? honu-: honu-comma honu-. #%braces #%brackets #%parens colon
ellipses-comma honu-for-syntax)

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

@ -4,6 +4,7 @@
"literals.ss"
"parse.ss"
"syntax.ss"
syntax/parse
(for-meta -3
(only-in "literals.ss" (#%parens literal-parens)))
#;
@ -19,7 +20,7 @@
scheme/pretty
scheme/trace))
(provide honu-macro)
(provide (all-defined-out))
(define-syntax (ensure-defined stx)
(syntax-case stx ()
@ -415,6 +416,20 @@
(with-syntax ([pulled (pull #'(x ...))])
#'(unpull pulled)))]))
(define-honu-syntax honu-pattern
(lambda (stx ctx)
(syntax-parse stx #:literals (#%brackets semicolon)
[(_ name (#%brackets xpattern ...) semicolon . rest)
(define (create-pattern stuff)
(with-syntax ([(fixed ...) (fix-template stuff)])
#'(pattern (~seq fixed ...))))
(values
(lambda ()
(with-syntax ([final-pattern (create-pattern #'(xpattern ...))])
#'(define-splicing-syntax-class name final-pattern)))
#'rest)])))
(define-honu-syntax honu-macro
(lambda (stx ctx)
(define-syntax-class honu-macro3

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

@ -8,6 +8,7 @@
(for-syntax syntax/parse
syntax/stx
racket/list
"contexts.ss"
"syntax.ss"
(only-in racket (... scheme-ellipses))
"literals.ss")
@ -174,6 +175,14 @@
[(stx-pair? what) (for-each show-pattern-variables (syntax->list what))]
[else (printf "~a is *not* a pattern variable\n" what)]))
(define (make-unparsed code)
(with-syntax ([(code ...) code])
(cond
[(expression-context? ctx)
(syntax/loc stx (honu-unparsed-expr code ...))]
[else #'(honu-unparsed-begin code ...)])))
#;
(printf "Original code is ~a\n" (syntax->datum #'(expr ...)))
#;
@ -192,7 +201,10 @@
(with-syntax ([a #'(fix-template #'(honu-unparsed-begin expr ...))])
#'a)
#'(fix-template (honu-unparsed-begin expr ...))
(with-syntax ([unparsed (make-unparsed #'(expr ...))])
#'(fix-template unparsed))
;; #'(fix-template (honu-unparsed-begin expr ...))
#;
#'(fix-template (expr ...))

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

@ -426,7 +426,8 @@
stx]))
(define-splicing-syntax-class expression
[pattern (~seq (~var x (expression-1 the-expression-context))) #:with result (apply-scheme-syntax #'x.result)])
[pattern (~seq (~var x (expression-1 the-expression-context)))
#:with result (apply-scheme-syntax #'x.result)])
(define-splicing-syntax-class expression-comma
#:literals (honu-comma)

4
collects/honu/private/syntax.ss
View File

@ -15,7 +15,9 @@
(printf "honu syntax ~a\n" stx)
#'(expr ...))))]))
(define-syntax honu-unparsed-expr (lambda (stx) (raise-syntax-error 'honu-unparsed-expr "dont use this")))
#;
(define-syntax honu-unparsed-expr
(lambda (stx) (raise-syntax-error 'honu-unparsed-expr "dont use this")))
(define honu-scheme-syntax 'honu-scheme-syntax)