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

change syntax-parse clause parsing code

Browse Source
This commit is contained in:
Ryan Culpepper 2013-02-27 17:42:49 -05:00
parent 616ca51f75
commit 91cbbbbde2
2 changed files with 30 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -368,6 +368,7 @@ Conventions:
(not (assq '#:disable-colon-notation chunks))) (not (assq '#:disable-colon-notation chunks)))
(define-values (decls0 defs) (define-values (decls0 defs)
(get-decls+defs chunks #t #:context #'ctx)) (get-decls+defs chunks #t #:context #'ctx))
;; for-clause : stx -> (values pattern stx (listof stx))
(define (for-clause clause) (define (for-clause clause)
(syntax-case clause () (syntax-case clause ()
[[p . rest] [[p . rest]
@ -377,10 +378,7 @@ Conventions:
#:splicing? #f #:splicing? #f
#:decls decls0 #:decls decls0
#:context #'ctx))]) #:context #'ctx))])
(with-syntax ([rest rest] (let ([body-expr
[pattern pattern]
[(local-def ...) (append defs defs2)]
[body-expr
(case (syntax-e #'body-mode) (case (syntax-e #'body-mode)
((one-template) ((one-template)
(syntax-case rest () (syntax-case rest ()
@ -394,26 +392,30 @@ Conventions:
#'ctx clause)])) #'ctx clause)]))
(else (else
(raise-syntax-error #f "internal error: unknown body mode" #'ctx #'body-mode)))]) (raise-syntax-error #f "internal error: unknown body mode" #'ctx #'body-mode)))])
#`(let () (values pattern body-expr defs2)))]))
local-def ...
(parse:S x cx pattern pr es body-expr))))]))
(unless (stx-list? clauses-stx) (unless (stx-list? clauses-stx)
(raise-syntax-error #f "expected sequence of clauses" #'ctx)) (raise-syntax-error #f "expected sequence of clauses" #'ctx))
(define alternatives (define-values (patterns body-exprs defs2s)
(if (stx-pair? clauses-stx) (for/lists (patterns body-exprs defs2s) ([clause (in-list (stx->list clauses-stx))])
(map for-clause (stx->list clauses-stx)) (for-clause clause)))
(list #`(fail (failure pr es))))) (with-syntax ([(def ...) (apply append (get-txlifts-as-definitions) defs defs2s)])
(with-syntax ([(def ...) (append (get-txlifts-as-definitions) defs)]
[(alternative ...) alternatives])
#`(let* ([ctx0 #,context] #`(let* ([ctx0 #,context]
[pr (ps-empty x ctx0)] [pr (ps-empty x ctx0)]
[es #f] [es #f]
[cx x] [cx x]
[fh0 (syntax-patterns-fail ctx0)]) [fh0 (syntax-patterns-fail ctx0)])
def ...
(parameterize ((current-syntax-context ctx0)) (parameterize ((current-syntax-context ctx0))
(with ([fail-handler fh0] (with ([fail-handler fh0]
[cut-prompt fh0]) [cut-prompt fh0])
(try alternative ...))))))))])) #,(cond [(pair? patterns)
(with-syntax ([(alternative ...)
(for/list ([pattern (in-list patterns)]
[body-expr (in-list body-exprs)])
#`(parse:S x cx #,pattern pr es #,body-expr))])
#`(try alternative ...))]
[else
#`(fail (failure pr es))]))))))))]))
;; ---- ;; ----

1
collects/syntax/parse/private/rep.rkt
View File

@ -271,6 +271,7 @@
(values entry null)] (values entry null)]
[(den:class name class argu) [(den:class name class argu)
;; FIXME: integrable syntax classes? ;; FIXME: integrable syntax classes?
;; FIXME: what if no-arity, no-args?
(cond [(identifier? name) (cond [(identifier? name)
(let* ([pos-count (length (arguments-pargs argu))] (let* ([pos-count (length (arguments-pargs argu))]
[kws (arguments-kws argu)] [kws (arguments-kws argu)]