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

syntax/parse:

Browse Source 
dependence on scheme/match eliminated
  fail-when, etc use conditional value if syntax
  error message typos (bad tildes) fixed

svn: r16393
This commit is contained in:
Ryan Culpepper 2009-10-20 23:17:30 +00:00
parent 1ba5bd6487
commit c7d95a21c2
11 changed files with 124 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/syntax/private/stxparse/codegen-data.ss
View File

@ -1,6 +1,5 @@
#lang scheme/base
(require scheme/match
syntax/stx
(require syntax/stx
(for-template scheme/base
syntax/stx
scheme/stxparam
@ -71,9 +70,9 @@
(fce-stx fc))
(define (frontier->index-expr fc)
(match fc
[(struct fce (stx indexes))
#`#,(stx-car indexes)]))
(syntax-case fc ()
[#s(fce stx (index0 index ...))
#'index0]))
;; --------

47
collects/syntax/private/stxparse/minimatch.ss Normal file
View File

@ -0,0 +1,47 @@
#lang scheme/base
(require (for-syntax scheme/base))
(provide match)
(define-syntax-rule (match stx clause ...)
(let ([x stx]) (match-c x clause ...)))
(define-syntax match-c
(syntax-rules ()
[(match-c x)
(error 'minimatch "match failed: ~s" x)]
[(match-c x [pattern result ...] clause ...)
(let ([fail (lambda () (match-c x clause ...))])
(match-p x pattern (let () result ...) (fail)))]))
;; (match-p id Pattern SuccessExpr FailureExpr)
(define-syntax (match-p stx)
(syntax-case stx (quote cons list)
[(match-p x wildcard success failure)
(and (identifier? #'wildcard) (free-identifier=? #'wildcard #'_))
#'success]
[(match-p x (quote lit) success failure)
#'(if (equal? x (quote lit))
success
failure)]
[(match-p x (cons p1 p2) success failure)
#'(if (pair? x)
(let ([x1 (car x)]
[x2 (cdr x)])
(match-p x1 p1 (match-p x2 p2 success failure) failure))
failure)]
[(match-p x (list) success failure)
#'(match-p x (quote ()) success failure)]
[(match-p x (list p1 p ...) success failure)
#'(match-p x (cons p1 (list p ...)) success failure)]
[(match-p x var success failure)
(identifier? #'var)
#'(let ([var x]) success)]
[(match-p x s success failure)
(prefab-struct-key (syntax-e #'s))
(with-syntax ([key (prefab-struct-key (syntax-e #'s))]
[(p ...) (cdr (vector->list (struct->vector (syntax-e #'s))))])
#'(let ([xkey (prefab-struct-key x)])
(if (equal? xkey 'key)
(let ([xps (cdr (vector->list (struct->vector x)))])
(match-p xps (list p ...) success failure))
failure)))]))

24
collects/syntax/private/stxparse/parse.ss
View File

@ -1,6 +1,5 @@
#lang scheme/base
(require (for-syntax scheme/base
scheme/match
scheme/private/sc
syntax/stx
syntax/id-table
@ -12,7 +11,6 @@
"../util.ss")
scheme/stxparam
scheme/list
scheme/match
syntax/stx
"runtime.ss"
"runtime-prose.ss")
@ -106,11 +104,12 @@
[(convert-sides x (side0 . sides) (k iattrs . kargs))
(syntax-case #'side0 ()
[#s(clause:fail condition message)
#`(if (without-fails condition)
(fail x
#:expect (expectation-of-message message)
#:fce #,(done-frontier #'x))
(convert-sides x sides (k iattrs . kargs)))]
#`(let ([c (without-fails condition)])
(if c
(fail (if (syntax? c) c x)
#:expect (expectation-of-message message)
#:fce #,(frontier:add-subparse (done-frontier #'x) #'(if (syntax? c) c x)))
(convert-sides x sides (k iattrs . kargs))))]
[#s(clause:with pattern expr (def ...))
(with-syntax ([(p-iattr ...) (pattern-attrs (wash #'pattern))])
#`(let ([y (datum->syntax #f (without-fails expr))])
@ -327,11 +326,12 @@
[#s(ghost:bind _ clauses)
#`(convert-sides x clauses (clause-success () k))]
[#s(ghost:fail _ condition message)
#`(if condition
(fail x
#:expect (expectation pattern0)
#:fce fc)
k)]
#`(let ([c (without-fails condition)])
(if c
(fail (if (syntax? c) c x)
#:expect (expectation pattern0)
#:fce #,(frontier:add-subparse (wash #'fc) #'(if (syntax? c) c x)))
k))]
[#s(ghost:parse _ pattern expr)
#`(let ([y (datum->syntax #f (without-fails expr))])
(parse:S y #,(frontier:add-subparse (wash #'fc) #'y)

21
collects/syntax/private/stxparse/rep-attrs.ss
View File

@ -1,6 +1,5 @@
#lang scheme/base
(require scheme/contract/base
scheme/match
syntax/stx
syntax/id-table
"../util.ss")
@ -115,9 +114,10 @@ a list^depth of syntax objects).
(make attr (attr-name a) (attr-depth a) #f))
(define (iattr->sattr a)
(match a
[(struct attr (name depth syntax?))
(make attr (syntax-e name) depth syntax?)]))
(let ([name (attr-name a)]
[depth (attr-depth a)]
[syntax? (attr-syntax? a)])
(make attr (syntax-e name) depth syntax?)))
(define (iattrs->sattrs as)
(map iattr->sattr as))
@ -155,12 +155,13 @@ a list^depth of syntax objects).
(let ([remap-name (syntax-e (attr-name iattr))])
(hash-set! ht remap-name iattr)))
(let loop ([relsattrs relsattrs])
(match relsattrs
['() null]
[(cons sattr rest)
(let ([iattr (hash-ref ht (attr-name sattr) #f)])
(check-iattr-satisfies-sattr iattr sattr)
(cons iattr (loop rest)))]))))
(if (null? relsattrs)
null
(let ([sattr (car relsattrs)]
[rest (cdr relsattrs)])
(let ([iattr (hash-ref ht (attr-name sattr) #f)])
(check-iattr-satisfies-sattr iattr sattr)
(cons iattr (loop rest))))))))
(define (check-iattr-satisfies-sattr iattr sattr)
(unless iattr

1
collects/syntax/private/stxparse/rep-data.ss
View File

@ -1,6 +1,5 @@
#lang scheme/base
(require scheme/contract/base
scheme/match
scheme/dict
syntax/stx
syntax/id-table

26
collects/syntax/private/stxparse/rep.ss
View File

@ -2,7 +2,7 @@
(require (for-template scheme/base)
(for-template "runtime.ss")
scheme/contract/base
scheme/match
"minimatch.ss"
scheme/dict
syntax/id-table
syntax/stx
@ -425,7 +425,7 @@
(parse-pat:id/s id parser null attrs)]
[(list 'splicing-parser parser description attrs)
(parse-pat:id/h id parser null attrs)]
[#f
['#f
(when #f ;; FIXME: enable?
(unless (safe-name? id)
(wrong-syntax id "expected identifier not starting with ~ character")))
@ -442,7 +442,7 @@
(wrong-syntax #'name "expected identifier"))
#'name]
[_
(wrong-syntax stx "bad ~var form")]))
(wrong-syntax stx "bad ~~var form")]))
(define-values (scname args)
(syntax-case stx (~var)
[(~var _name)
@ -454,7 +454,7 @@
(identifier? #'sc)
(values #'sc (syntax->list #'(arg ...)))]
[_
(wrong-syntax stx "bad ~var form")]))
(wrong-syntax stx "bad ~~var form")]))
(cond [(and (epsilon? name0) (not scname))
(wrong-syntax name0 "illegal pattern variable name")]
[(and (wildcard? name0) (not scname))
@ -525,7 +525,7 @@
(wrong-syntax #'lit "expected identifier"))
(create-pat:literal #'lit)]
[_
(wrong-syntax stx "bad ~literal pattern")]))
(wrong-syntax stx "bad ~~literal pattern")]))
(define (parse-pat:describe stx decls allow-head?)
(syntax-case stx ()
@ -669,7 +669,7 @@
[()
(wrong-syntax stx "missing message expression")]
[_
(wrong-syntax stx "bad ~fail pattern")])))]))
(wrong-syntax stx "bad ~~fail pattern")])))]))
(define (parse-pat:parse stx decls)
(syntax-case stx (~parse)
@ -677,7 +677,7 @@
(let ([p (parse-single-pattern #'pattern decls)])
(create-ghost:parse p #'expr))]
[_
(wrong-syntax stx "bad ~parse pattern")]))
(wrong-syntax stx "bad ~~parse pattern")]))
(define (parse-pat:rest stx decls)
@ -687,15 +687,15 @@
(define (check-list-pattern pattern stx)
(match pattern
[(struct pat:datum (_base '()))
[#s(pat:datum _base '())
#t]
[(struct pat:head (_base _head tail))
[#s(pat:head _base _head tail)
(check-list-pattern tail stx)]
[(struct pat:dots (_base _head tail))
[#s(pat:dots _base _head tail)
(check-list-pattern tail stx)]
[(struct pat:compound (_base '#:pair (list _head tail)))
[#s(pat:compound _base '#:pair (list _head tail))
(check-list-pattern tail stx)]
[else
[_
(wrong-syntax stx "expected proper list pattern")]))
(define (parse-hpat:optional stx decls)
@ -853,7 +853,7 @@
(match chunks
[(cons (cons '#:declare decl-stx) rest)
(loop rest (add-decl decl-stx decls))]
[else (values decls chunks)]))
[_ (values decls chunks)]))
(loop chunks decls))

43
collects/syntax/private/stxparse/runtime-prose.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require scheme/contract/base
scheme/list
scheme/match
"minimatch.ss"
scheme/stxparam
syntax/stx
(for-syntax scheme/base)
@ -16,9 +16,9 @@
;; Failure reporting parameter & default
(define (default-failure-handler stx0 f)
(match (simplify-failure f)
[(struct failure (x frontier frontier-stx expected))
(report-failure stx0 x (last frontier) frontier-stx expected)]))
(match f
[#s(failure x frontier frontier-stx expectation)
(report-failure stx0 x (last frontier) frontier-stx expectation)]))
(define current-failure-handler
(make-parameter default-failure-handler))
@ -48,7 +48,7 @@
(err (format "~a~a"
msg
(cond [(zero? index) ""]
[(= index +inf.0) " after matching main pattern"]
[(= index +inf.0) "" #|" after matching main pattern"|#]
[else (format " after ~s ~a"
index
(if (= 1 index) "term" "terms"))]))
@ -60,25 +60,28 @@
;; FIXME: try different selection/simplification algorithms/heuristics
(define (simplify-failure f)
(match f
[(struct join-failures (f1 f2))
[#s(join-failures f1 f2)
(choose-error (simplify-failure f1) (simplify-failure f2))]
[(struct failure (x frontier frontier-stx expectation))
[#s(failure x frontier frontier-stx expectation)
(match expectation
[(struct expect:thing (description (and transparent? #t) chained))
(match (simplify-failure (adjust-failure chained frontier frontier-stx))
[(struct failure (_ _ _ (? ineffable?)))
;; If unfolded failure is ineffable, fall back to the one with description
f]
[new-f new-f])]
[#s(expect:thing description '#t chained)
(let ([new-f (simplify-failure (adjust-failure chained frontier frontier-stx))])
(match new-f
[#s(failure _ _ _ new-e)
(if (ineffable? new-e)
;; If unfolded failure is ineffable, fall back to the one with description
f
new-f)]
[_ new-f]))]
[_ f])]))
(define (adjust-failure f base-frontier base-frontier-stx)
(match f
[(struct join-failures (f1 f2))
[#s(join-failures f1 f2)
(make-join-failures
(adjust-failure f1 base-frontier base-frontier-stx)
(adjust-failure f2 base-frontier base-frontier-stx))]
[(struct failure (x frontier frontier-stx expectation))
[#s(failure x frontier frontier-stx expectation)
(let-values ([(frontier frontier-stx)
(combine-frontiers base-frontier base-frontier-stx
frontier frontier-stx)])
@ -125,15 +128,15 @@
(define (for-alternative e index stx)
(match e
[(struct expect:thing (description transparent? chained))
[#s(expect:thing description transparent? chained)
(format "expected ~a" description)]
[(struct expect:atom (atom))
[#s(expect:atom atom)
(format "expected the literal ~s" atom)]
[(struct expect:literal (literal))
[#s(expect:literal literal)
(format "expected the literal identifier ~s" (syntax-e literal))]
[(struct expect:message (message))
[#s(expect:message message)
(format "~a" message)]
[(struct expect:pair ())
[#s(expect:pair)
(cond [(= index 0)
"expected sequence of terms"]
[else

5
collects/syntax/private/stxparse/runtime.ss
View File

@ -1,6 +1,5 @@
#lang scheme/base
(require scheme/contract/base
scheme/match
scheme/stxparam
scheme/list
(for-syntax scheme/base
@ -180,8 +179,8 @@
(define ok? list?)
(define-struct failure (stx frontier frontier-stx expectation) #:transparent)
(define-struct join-failures (f1 f2) #:transparent)
(define-struct failure (stx frontier frontier-stx expectation) #:prefab)
(define-struct join-failures (f1 f2) #:prefab)
;; (try expr ...)
(define-syntax (try stx)

2
collects/syntax/private/stxparse/sc.ss
View File

@ -1,11 +1,9 @@
#lang scheme/base
(require (for-syntax scheme/base
scheme/match
scheme/private/sc
"rep-data.ss"
"rep.ss"
"../util.ss")
scheme/match
syntax/stx
"parse.ss"
"runtime.ss"

20
collects/syntax/scribblings/parse.scrbl
View File

@ -500,8 +500,8 @@ follows:
(code:line #:declare pattern-id (syntax-class-id expr ...))
(code:line #:with syntax-pattern expr)
(code:line #:attr attr-id expr)
(code:line #:fail-unless condition-expr message-expr)
(code:line #:fail-when condition-expr message-expr)
(code:line #:fail-unless condition-expr message-expr)
(code:line #:when condition-expr)]
@specsubform[(code:line #:declare pvar-id syntax-class-id)]
@ -536,16 +536,18 @@ bindings and binds it to the attribute named by @scheme[attr-id]. The
value of @scheme[expr] need not be syntax.
}
@specsubform[(code:line #:fail-unless condition-expr message-expr)]{
Evaluates the @scheme[condition-expr] in the context of all previous
attribute bindings. If the value is any @scheme[#f], the matching
process backtracks (with the given message); otherwise, it continues.
}
@specsubform[(code:line #:fail-when condition-expr message-expr)]{
Like @scheme[#:fail-unless] with the condition negated.
Evaluates the @scheme[condition-expr] in the context of all previous
attribute bindings. If the value is any true value (not @scheme[#f]),
the matching process backtracks (with the given message); otherwise,
it continues. If the value of the condition expression is a syntax
object, it is indicated as the cause of the error.
}
@specsubform[(code:line #:fail-unless condition-expr message-expr)]{
Like @scheme[#:fail-when] with the condition negated.
}
@specsubform[(code:line #:when condition-expr)]{

2
collects/tests/stxparse/more-tests.ss
View File

@ -179,7 +179,7 @@
(syntax-parser
[(~fail . x) 'ok])
#rx"^syntax-parser: "
#rx"bad fail pattern")
#rx"bad ~fail pattern")
(tcerr "check-list-pattern"
(syntax-parser