syntax/parse: refactored some parsing/checking code
This commit is contained in:
parent
fd401ce98e
commit
0a048b67bb
|
@ -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)
|
||||
|
|
|
@ -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)]))
|
||||
|
||||
;; ----
|
||||
|
||||
|
|
Loading…
Reference in New Issue
Block a user