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

syntax/parse: added define-simple-macro form (needs docs)

Browse Source
This commit is contained in:
Ryan Culpepper 2011-03-04 17:09:50 -07:00
parent 1353d40612
commit 012746540c
4 changed files with 47 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/syntax/parse.rkt
View File

@ -5,7 +5,7 @@
"parse/private/lib.rkt"
"parse/experimental/provide.rkt")
(provide (except-out (all-from-out "parse/private/sc.rkt")
parser/rhs)
syntax-parser/template parser/rhs)
(all-from-out "parse/private/litconv.rkt")
(except-out (all-from-out "parse/private/lib.rkt")
static))

16
collects/syntax/parse/define.rkt Normal file
View File

@ -0,0 +1,16 @@
#lang racket/base
(require (for-syntax racket/base
syntax/parse
"private/rep.rkt"
"private/rep-data.rkt"
"private/sc.rkt"))
(provide define-simple-macro
(for-syntax (all-from-out syntax/parse)))
(define-syntax (define-simple-macro stx)
(syntax-parse stx
[(define-simple-macro (~and (macro:id . _) pattern) . body)
#`(define-syntax macro
(syntax-parser/template
#,((make-syntax-introducer) stx)
[pattern . body]))]))

27
collects/syntax/parse/private/parse.rkt
View File

@ -180,7 +180,9 @@ Conventions:
;; (parse:clauses x clauses ctx)
(define-syntax (parse:clauses stx)
(syntax-case stx ()
[(parse:clauses x clauses ctx)
[(parse:clauses x clauses body-mode ctx)
;; if templates? is true, expect one form after kwargs in clause, wrap it with syntax
;; otherwise, expect non-empty body sequence (defs and exprs)
(with-disappeared-uses
(with-txlifts
(lambda ()
@ -200,17 +202,26 @@ Conventions:
#:splicing? #f
#:decls decls0
#:context #'ctx)])
(unless (and (stx-list? rest) (stx-pair? rest))
(raise-syntax-error #f
"expected non-empty clause body"
#'ctx
clause))
(with-syntax ([rest rest]
[pattern pattern]
[(local-def ...) (append defs defs2)])
[(local-def ...) (append defs defs2)]
[body-expr
(case (syntax-e #'body-mode)
((one-template)
(syntax-case rest ()
[(template)
#'(syntax template)]
[_ (raise-syntax-error #f "expected exactly one template" #'ctx)]))
((body-sequence)
(syntax-case rest ()
[(e0 e ...) #'(let () e0 e ...)]
[_ (raise-syntax-error #f "expected non-empty clause body"
#'ctx clause)]))
(else
(raise-syntax-error #f "internal error: unknown body mode" #'ctx #'body-mode)))])
#`(let ()
local-def ...
(parse:S x cx pattern pr es (let () . rest)))))]))
(parse:S x cx pattern pr es body-expr))))]))
(unless (stx-list? clauses-stx)
(raise-syntax-error #f "expected sequence of clauses" #'ctx))
(define alternatives

13
collects/syntax/parse/private/sc.rkt
View File

@ -13,6 +13,7 @@
syntax-parse
syntax-parser
syntax-parser/template
(except-out (all-from-out "keywords.rkt")
~reflect
@ -126,7 +127,7 @@
[(syntax-parse stx-expr . clauses)
(quasisyntax/loc stx
(let ([x (datum->syntax #f stx-expr)])
(parse:clauses x clauses #,((make-syntax-introducer) stx))))]))
(parse:clauses x clauses body-sequence #,((make-syntax-introducer) stx))))]))
(define-syntax (syntax-parser stx)
(syntax-case stx ()
@ -134,4 +135,12 @@
(quasisyntax/loc stx
(lambda (x)
(let ([x (datum->syntax #f x)])
(parse:clauses x clauses #,((make-syntax-introducer) stx)))))]))
(parse:clauses x clauses body-sequence #,((make-syntax-introducer) stx)))))]))
(define-syntax (syntax-parser/template stx)
(syntax-case stx ()
[(syntax-parser/template ctx . clauses)
(quasisyntax/loc stx
(lambda (x)
(let ([x (datum->syntax #f x)])
(parse:clauses x clauses one-template ctx))))]))