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

expand syntax properly. force use of syntax-parse classes

Browse Source
This commit is contained in:
Jon Rafkind 2010-05-18 14:51:34 -06:00
parent d5357f6dca
commit 1b088f7c37
5 changed files with 88 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/honu/main.rkt
View File

@ -9,6 +9,7 @@
(for-syntax "private/literals.ss")
(for-syntax "private/honu-typed-scheme.ss")
(for-syntax "private/parse.ss")
(for-syntax syntax/parse)
"private/literals.ss"
"private/syntax.ss"
"private/more.ss"
@ -23,6 +24,12 @@
(define x (new test-x-class [tuna 5]))
(define (sql1) #f)
(define (sql2) #f)
(define (sql3) #f)
(define (sql4) #f)
(define (sql5) #f)
(provide (rename-out (#%dynamic-honu-module-begin #%module-begin)
(honu-top #%top)
(semicolon \;
@ -37,7 +44,18 @@
(honu-comma |,|)
(honu-. |.|)
)
;; sql nonsense
(rename-out
(sql1 SQL_create_insert)
(sql2 foo)
(sql3 cheese)
(sql4 monkeys)
(sql5 horse))
;; end sql
#%datum
#%top-interaction
(for-syntax #%datum
display
with-syntax
@ -47,6 +65,7 @@
...
map
syntax->list
identifier expression
(rename-out (semicolon \;
)
(parse-an-expr parse)
@ -76,6 +95,7 @@
(honu-macro-item macroItem)
(honu-macro macro)
(honu-syntax syntax)
(honu-keywords keywords)
#;
(honu-scheme scheme2)
(scheme-syntax scheme:syntax)

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

@ -348,6 +348,15 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
[else (raise-syntax-error 'scheme "need a semicolon probably" stx)]
)))
(define-honu-syntax honu-keywords
(lambda (stx ctx)
(syntax-parse stx #:literals (semicolon)
[(_ word:identifier ... semicolon . rest)
(values (lambda () #'(begin
(define-syntax word (lambda (xx) (raise-syntax-error 'word "dont use this")))
...))
#'rest)])))
(define-honu-syntax honu-if
(lambda (stx ctx)
(define (parse-complete-block stx)
@ -474,6 +483,7 @@ if (foo){
#'a)]))
(define-syntax (honu-top stx)
(printf "Honu ~a\n" (syntax->datum stx))
(raise-syntax-error #f "interactive use is not yet supported"))
(define-syntax (foobar2000 stx)
@ -492,9 +502,9 @@ if (foo){
(begin
(printf "Body is ~a\n" #'body)
(let-values ([(code rest) (parse-block-one/2 #'body
the-expression-context
#;
the-top-block-context)])
the-expression-context
#;
the-top-block-context)])
;; (printf "Rest is ~a\n" (syntax->datum rest))
(with-syntax ([code code]
[(rest ...) rest])

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

@ -4,6 +4,10 @@
"literals.ss"
"parse.ss"
"syntax.ss"
(for-meta -3
(only-in "literals.ss" (#%parens literal-parens)))
#;
(for-template (only-in "literals.ss" (#%parens literal-parens)))
(for-syntax "debug.ss"
"contexts.ss"
"parse.ss"
@ -67,10 +71,18 @@
(syntax-parse stx #:literals (honu-:)
[(variable:id honu-: class:id rest ...)
(with-syntax ([(rest* ...) (fix-template #'(rest ...))])
(datum->syntax stx (cons #'(~var variable class)
#'(rest* ...))
stx)
#;
#'((~var variable class) rest* ...))]
[(one rest ...)
(with-syntax ([one* (fix-template #'one)]
[(rest* ...) (fix-template #'(rest ...))])
(datum->syntax stx (cons #'one*
#'(rest* ...))
stx)
#;
#'(one* rest* ...))]
[else stx]))
@ -411,13 +423,32 @@
. rest)
#:with result
(list
(with-syntax ([(fixed ...) (fix-template #'(template ...))])
(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 ...)
[(fixed ... rrest (... ...))
(values
#;
(with-syntax ([(real-out (... ...)) #'(code ...)])
(let ([result (honu-unparsed-begin #'(real-out (... ...)))])
(lambda () result)))
(let ([result (honu-unparsed-begin code ...)])
(lambda () result))
#'(rrest (... ...)))])))
#;
(syntax/loc stx
(define-honu-syntax name
(lambda (stx ctx)
(syntax-parse stx #:literals (literals ...)
(syntax-parse stx #:literals (your-parens literals ...)
[(fixed ... rrest (... ...))
(values
#;
(with-syntax ([(real-out (... ...)) #'(code ...)])
(let ([result (honu-unparsed-begin #'(real-out (... ...)))])
(lambda () result)))
(let ([result (honu-unparsed-begin code ...)])
(lambda () result))
#'(rrest (... ...)))])))))

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

@ -3,6 +3,7 @@
(require "honu-typed-scheme.ss"
"literals.ss"
(for-syntax syntax/parse
syntax/stx
"literals.ss")
(for-template "honu-typed-scheme.ss"
"literals.ss"
@ -16,6 +17,19 @@
[(_ (#%parens expr ...) semicolon . rest)
(values
(lambda ()
#'(honu-unparsed-begin expr ...))
(define (show-pattern-variables what)
(cond
[(syntax-pattern-variable? what) (printf "~a is a pattern variable\n") what]
[(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 ...)
#;
(with-syntax ([(out ...) (local-expand #'(expr ...) 'expression '())])
#'(honu-unparsed-begin out ...)))
#'rest)])))

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

@ -19,12 +19,14 @@
(provide (all-defined-out))
(define-syntax-class block
#:literals (#%braces)
[pattern (#%braces statement ...)
#: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)
#:literals (#%parens)
[pattern (_ name:id (#%parens args ...) body:block . rest)
#:with result #'(define (name args ...)
body.result)])
@ -133,7 +135,7 @@
[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:id) #:with result #'x]
[pattern (~seq x:identifier) #:with result #'x]
#;
[pattern (~seq (~var e (honu-expr context))) #:with result #'e.result]
)
@ -343,6 +345,9 @@
(printf " no change\n")
stx]))
(define-splicing-syntax-class expression
[pattern (~seq (~var x (expression-1 the-expression-context)))])
(define (parse-an-expr stx)
(printf "Parse an expr ~a\n" (syntax->datum stx))
(syntax-parse (with-syntax ([s stx])