221 lines
7.2 KiB
Scheme
221 lines
7.2 KiB
Scheme
|
|
#lang scheme/base
|
|
(require (for-syntax scheme/base
|
|
scheme/match
|
|
scheme/private/sc
|
|
"rep.ss"
|
|
"parse.ss"
|
|
"util.ss")
|
|
scheme/match
|
|
syntax/stx
|
|
"kws.ss"
|
|
"messages.ss")
|
|
(provide define-syntax-class
|
|
define-basic-syntax-class
|
|
define-basic-syntax-class*
|
|
parse-sc
|
|
attrs-of
|
|
|
|
debug-rhs
|
|
debug-pattern
|
|
|
|
syntax-parse
|
|
syntax-parser
|
|
with-patterns
|
|
|
|
pattern
|
|
...*
|
|
|
|
fail-sc
|
|
(struct-out failed)
|
|
|
|
current-expression
|
|
current-macro-name)
|
|
|
|
(define-syntax (define-syntax-class stx)
|
|
(syntax-case stx ()
|
|
[(define-syntax-class (name arg ...) . rhss)
|
|
#`(begin (define-syntax name
|
|
(let ([the-rhs (parse-rhs (quote-syntax rhss) #t (quote-syntax #,stx))])
|
|
(make sc 'name
|
|
'(arg ...)
|
|
(rhs-attrs the-rhs)
|
|
((syntax-local-certifier) #'parser)
|
|
(rhs-description the-rhs))))
|
|
(define parser (rhs->parser name rhss (arg ...) #,stx)))]
|
|
[(define-syntax-class name . rhss)
|
|
(syntax/loc stx
|
|
(define-syntax-class (name) . rhss))]))
|
|
|
|
|
|
#;
|
|
(define-syntax (define-syntax-splice-class stx)
|
|
(syntax-case stx ()
|
|
[(define-syntax-splice-class (name arg ...) . rhss)
|
|
#`(begin (define-syntax name
|
|
(make ssc 'name
|
|
'(arg ...)
|
|
(rhs-attrs
|
|
(parse-splice-rhs (quote-syntax rhss) #t (quote-syntax #,stx)))
|
|
((syntax-local-certifier) #'parser)))
|
|
(define parser (splice-rhs->parser name rhss (arg ...) #,stx)))]
|
|
[(define-syntax-splice-class name . rhss)
|
|
(syntax/loc stx (define-syntax-splice-class (name) . rhss))]))
|
|
|
|
(define-syntax define-basic-syntax-class
|
|
(syntax-rules ()
|
|
[(define-basic-syntax-class (name arg ...)
|
|
([attr-name attr-depth] ...)
|
|
parser-expr)
|
|
(define-basic-syntax-class* (name arg ...)
|
|
([attr-name attr-depth] ...)
|
|
(let ([name parser-expr])
|
|
(let ([name
|
|
(lambda (x arg ...)
|
|
(let ([r (name x arg ...)])
|
|
(if (ok? r)
|
|
(cons x r)
|
|
r)))])
|
|
name)))]
|
|
[(define-basic-syntax-class name
|
|
([attr-name attr-depth] ...)
|
|
parser-expr)
|
|
(define-basic-syntax-class (name)
|
|
([attr-name attr-depth] ...)
|
|
parser-expr)]))
|
|
|
|
(define-syntax define-basic-syntax-class*
|
|
(syntax-rules ()
|
|
[(define-basic-syntax-class* (name arg ...)
|
|
([attr-name attr-depth] ...)
|
|
parser-expr)
|
|
(define-syntax-class (name arg ...)
|
|
(basic-syntax-class
|
|
([attr-name attr-depth] ...)
|
|
(let ([name parser-expr]) name)))]))
|
|
|
|
(define-syntax (rhs->parser stx)
|
|
(syntax-case stx ()
|
|
[(rhs->parser name rhss (arg ...) ctx)
|
|
(let ([rhs (parse-rhs #'rhss #f #'ctx)]
|
|
[sc (syntax-local-value #'name)])
|
|
(parse:rhs rhs
|
|
(sc-attrs sc)
|
|
(syntax->list #'(arg ...))))]))
|
|
|
|
(define-syntax (parse-sc stx)
|
|
(syntax-case stx ()
|
|
[(parse s x arg ...)
|
|
(let* ([stxclass (get-stxclass #'s)]
|
|
[attrs (flatten-sattrs (sc-attrs stxclass))])
|
|
(with-syntax ([parser (sc-parser-name stxclass)]
|
|
[(name ...) (map attr-name attrs)]
|
|
[(depth ...) (map attr-depth attrs)])
|
|
#'(let ([raw (parser x arg ...)])
|
|
(if (ok? raw)
|
|
(map vector '(name ...) '(depth ...) (cdr raw))
|
|
raw))))]))
|
|
|
|
(define-syntax (attrs-of stx)
|
|
(syntax-case stx ()
|
|
[(attrs-of s)
|
|
(let ([attrs (flatten-sattrs (sc-attrs (get-stxclass #'s)))])
|
|
(with-syntax ([(a ...) (map attr-name attrs)]
|
|
[(depth ...) (map attr-depth attrs)])
|
|
#'(quote ((a depth) ...))))]))
|
|
|
|
(define-syntax (debug-rhs stx)
|
|
(syntax-case stx ()
|
|
[(debug-rhs rhs)
|
|
(let ([rhs (parse-rhs #'rhs #f)])
|
|
#`(quote #,rhs))]))
|
|
|
|
(define-syntax (debug-pattern stx)
|
|
(syntax-case stx ()
|
|
[(debug-pattern p)
|
|
(let ([pattern (parse-pattern #'p)])
|
|
#`(quote #,pattern))]))
|
|
|
|
(define-syntax (syntax-parser stx)
|
|
(syntax-case stx ()
|
|
[(syntax-parser . clauses)
|
|
#`(lambda (x)
|
|
(let ([fail (syntax-patterns-fail x)])
|
|
(parameterize ((current-expression (or (current-expression) x)))
|
|
#,(parse:clauses #'clauses #'x #'fail))))]))
|
|
|
|
(define-syntax (syntax-parse stx)
|
|
(syntax-case stx ()
|
|
[(syntax-parse expr . clauses)
|
|
#`(let ([x expr])
|
|
(let ([fail (syntax-patterns-fail x)])
|
|
(parameterize ((current-expression (or (current-expression) x)))
|
|
#,(parse:clauses #'clauses #'x #'fail))))]))
|
|
|
|
(define-syntax with-patterns
|
|
(syntax-rules ()
|
|
[(with-patterns () . b)
|
|
(let () . b)]
|
|
[(with-patterns ([p x] . more) . b)
|
|
(syntax-parse x [p (with-patterns more . b)])]))
|
|
|
|
(define ((syntax-patterns-fail stx0) x expected reason frontier)
|
|
(define (err msg stx)
|
|
(raise (make-exn:fail:syntax
|
|
(if msg
|
|
(string->immutable-string (string-append "bad syntax: " msg))
|
|
(string->immutable-string "bad syntax"))
|
|
(current-continuation-marks)
|
|
(list stx))))
|
|
(define-values (stx n) (frontier->syntax frontier))
|
|
(cond #;
|
|
[(and (stx-null? x) expected)
|
|
(err (format "missing ~s" (expectation->string expected))
|
|
(datum->syntax stx x
|
|
(list (syntax-source stx)
|
|
#f
|
|
#f
|
|
(and (syntax-position stx)
|
|
(syntax-span stx)
|
|
(+ (syntax-position stx)
|
|
(syntax-span stx)
|
|
-1))
|
|
1)))]
|
|
[(empty-expectation? expected)
|
|
;; FIXME: "extra term(s) after <pattern>"
|
|
(syntax-case x ()
|
|
[(one)
|
|
(err "unexpected term" #'one)]
|
|
[(first . more)
|
|
(err "unexpected terms starting here" #'first)]
|
|
[_
|
|
(err "unexpected term" x)])]
|
|
[(and expected (expectation->string expected))
|
|
=>
|
|
(lambda (msg)
|
|
(err (format "expected ~a~a"
|
|
msg
|
|
(cond [(zero? n) ""]
|
|
[(= n +inf.0) " after matching main pattern"]
|
|
[else (format " after ~s ~a"
|
|
n
|
|
(if (= 1 n) "form" "forms"))]))
|
|
stx))]
|
|
[reason
|
|
(err (format "~a" reason) stx)]
|
|
[else
|
|
(err #f stx0)]))
|
|
|
|
(define (frontier->syntax f)
|
|
(match f
|
|
[(list x n)
|
|
(values x n)]
|
|
[(list-rest _ _ rest)
|
|
(frontier->syntax rest)]))
|
|
|
|
(define (fail-sc stx #:pattern [pattern #f] #:reason [reason #f])
|
|
(make-failed stx pattern reason))
|
|
|
|
(define (syntax-class-fail stx #:reason [reason #f])
|
|
(make-failed stx #f reason))
|