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

syntax/parse: refactored some parsing/checking code

Browse Source
This commit is contained in:
Ryan Culpepper 2011-05-02 20:28:51 -06:00
parent fd401ce98e
commit 0a048b67bb
2 changed files with 47 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -51,6 +51,12 @@
(-> syntax?
#:context syntax?
arity?)]
[check-stxclass-header
(-> syntax? syntax?
(list/c identifier? syntax? arity?))]
[check-stxclass-application
(-> syntax? syntax?
(cons/c identifier? arguments?))]
[check-literals-list/litset
(-> syntax? syntax?
(listof (list/c identifier? identifier?)))]
@ -728,15 +734,8 @@ A syntax class is integrable if
(values #f null #f)]
[(~var _name sc/sc+args . rest)
(let-values ([(sc argu)
(syntax-case #'sc/sc+args ()
[sc
(identifier? #'sc)
(values #'sc no-arguments)]
[(sc arg ...)
(identifier? #'sc)
(values #'sc (parse-argu (syntax->list #'(arg ...))))]
[_
(wrong-syntax stx "bad ~~var form")])])
(let ([p (check-stxclass-application #'sc/sc+args stx)])
(values (car p) (cdr p)))])
(define chunks
(parse-keyword-options/eol #'rest var-pattern-directive-table
#:no-duplicates? #t
@ -1427,19 +1426,33 @@ A syntax class is integrable if
(raise-syntax-error #f "expected identifier convention pattern"
ctx blame)]))
(define (check-sc-expr x rx)
(syntax-case x ()
[sc
(identifier? #'sc)
(make den:class rx #'sc no-arguments)]
[(sc arg ...)
(identifier? #'sc)
(make den:class rx #'sc (parse-argu (syntax->list #'(arg ...))))]
[_ (raise-syntax-error #f "expected syntax class use" ctx x)]))
(let ([x (check-stxclass-application x ctx)])
(make den:class rx (car x) (cdr x))))
(syntax-case stx ()
[(rx sc)
(let ([name-pattern (check-conventions-pattern (syntax-e #'rx) #'rx)])
(list name-pattern
(check-sc-expr #'sc name-pattern)))]))
(list name-pattern (check-sc-expr #'sc name-pattern)))]))
(define (check-stxclass-header stx ctx)
(syntax-case stx ()
[name
(identifier? #'name)
(list #'name #'() no-arity)]
[(name . formals)
(identifier? #'name)
(list #'name #'formals (parse-kw-formals #'formals #:context ctx))]
[_ (raise-syntax-error #f "expected syntax class header" stx ctx)]))
(define (check-stxclass-application stx ctx)
;; Doesn't check "operator" is actually a stxclass
(syntax-case stx ()
[op
(identifier? #'op)
(cons #'op no-arguments)]
[(op arg ...)
(identifier? #'op)
(cons #'op (parse-argu (syntax->list #'(arg ...))))]
[_ (raise-syntax-error #f "expected syntax class use" ctx stx)]))
;; bind clauses
(define (check-bind-clause-list stx ctx)

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

@ -30,19 +30,20 @@
parser/rhs)
(begin-for-syntax
(define (defstxclass stx name formals rhss splicing?)
(define (defstxclass stx header rhss splicing?)
(parameterize ((current-syntax-context stx))
(with-syntax ([name name]
[formals formals]
[rhss rhss])
(let* ([the-rhs (parse-rhs #'rhss #f splicing? #:context stx)]
[arity (parse-kw-formals #'formals #:context stx)]
(let-values ([(name formals arity)
(let ([p (check-stxclass-header header stx)])
(values (car p) (cadr p) (caddr p)))])
(let* ([the-rhs (parse-rhs rhss #f splicing? #:context stx)]
[opt-rhs+def
(and (stx-list? #'formals) (andmap identifier? (syntax->list #'formals))
(optimize-rhs the-rhs (syntax->list #'formals)))]
(and (andmap identifier? (syntax->list formals))
(optimize-rhs the-rhs (syntax->list formals)))]
[the-rhs (if opt-rhs+def (car opt-rhs+def) the-rhs)])
(with-syntax ([parser (generate-temporary
(format-symbol "parse-~a" (syntax-e #'name)))]
(with-syntax ([name name]
[formals formals]
[rhss rhss]
[parser (generate-temporary (format-symbol "parse-~a" name))]
[arity arity]
[attrs (rhs-attrs the-rhs)]
[(opt-def ...)
@ -80,21 +81,13 @@
(define-syntax (define-syntax-class stx)
(syntax-case stx ()
[(define-syntax-class name . rhss)
(identifier? #'name)
(defstxclass stx #'name #'() #'rhss #f)]
[(define-syntax-class (name . formals) . rhss)
(identifier? #'name)
(defstxclass stx #'name #'formals #'rhss #f)]))
[(dsc header . rhss)
(defstxclass stx #'header #'rhss #f)]))
(define-syntax (define-splicing-syntax-class stx)
(syntax-case stx ()
[(define-splicing-syntax-class name . rhss)
(identifier? #'name)
(defstxclass stx #'name #'() #'rhss #t)]
[(define-splicing-syntax-class (name . formals) . rhss)
(identifier? #'name)
(defstxclass stx #'name #'formals #'rhss #t)]))
[(dssc header . rhss)
(defstxclass stx #'header #'rhss #t)]))
;; ----