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

syntax/parse:

Browse Source 
fixed docs bug in ...+
  fixed bug in rep constraint messages

svn: r17938
This commit is contained in:
Ryan Culpepper 2010-02-02 07:22:35 +00:00
parent cb7600607b
commit 82e1e3308f
5 changed files with 80 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -617,21 +617,23 @@
(define-syntax expectation-of-message/too-few
(syntax-rules ()
[(emtf #f #f)
(collect-error "repetition constraint violated")]
(expectation-of-message "repetition constraint violated")]
[(emtf #f name)
(collect-error (format "missing required occurrence of ~a" name))]
(expectation-of-message
(format "missing required occurrence of ~a" name))]
[(emtf msg _)
(collect-error msg)]))
(expectation-of-message msg)]))
(define-syntax expectation-of-message/too-many
(syntax-rules ()
[(emtm #f #f)
(collect-error (format "repetition constraint violated"))]
(expectation-of-message
(format "repetition constraint violated"))]
[(emtm #f name)
(collect-error (format "too many occurrences of ~a" name))]
(expectation-of-message
(format "too many occurrences of ~a" name))]
[(emtm msg _)
(collect-error msg)]))
(expectation-of-message msg)]))
;;
@ -648,9 +650,9 @@
(let ([b (syntax-local-value #'tmp)])
(syntax-case stx ()
[(ce thing)
(begin (set-box! b (cons #''thing (unbox b)))
(begin (set-box! b (cons #'thing (unbox b)))
#'thing)]
[(ce)
(with-syntax ([(thing ...) (reverse (unbox b))])
#'(list thing ...))])))))
#'(list #'thing ...))])))))
body))))

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

@ -143,7 +143,8 @@
(for-alternative alt index stx))
";" "or")))]
[(eq? e 'ineffable)
#f]))
#f]
[else (error 'prose-for-expectation "unexpected: ~e" e)]))
(define (for-alternative e index stx)
(match e
@ -188,3 +189,50 @@
[(a . b) (cons #'a (improper-stx->list #'b))]
[() null]
[rest (list #'rest)]))
;; Ad-hoc interpretation of error message expressions
(provide interpret-error-expression)
;; Recognize application of 'format' procedure
(define (interpret-error-expression e)
(define vars '(X Y Z))
;; minieval : syntax -> (or syntax datum)
;; Returns syntax on NON-evalable stuff, datum otherwise
(define (minieval x)
(syntax-case x (format quote datum literal)
[(format str arg ...)
(string? (syntax-e #'str))
(let ([args (map minieval (syntax->list #'(arg ...)))])
(define args*
(cond [(<= (length (filter syntax? args)) (length vars))
(for/list ([arg args])
(if (syntax? arg)
(begin0 (car vars) (set! vars (cdr vars)))
arg))]
[else
(let ([counter 1])
(for/list ([arg args])
(if (syntax? arg)
(begin0 (format "Q~a" counter)
(set! counter (add1 counter)))
arg)))]))
(apply format (syntax-e #'str) args*))]
[(quote (datum d))
(format "expected the literal ~a" (syntax->datum #'d))]
[(quote (literal lit))
(format "expected the literal identifier ~s" (syntax-e #'lit))]
[(quote thing)
(syntax->datum #'thing)]
[d
(let ([d (syntax->datum #'d)])
(or (string? d) (number? d) (boolean? d)))
(syntax->datum #'d)]
[_
x]))
(let ([ie (minieval e)])
(if (syntax? ie)
(syntax->datum ie)
ie)))

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

@ -5,6 +5,7 @@
unstable/struct
"rep-data.ss"
"rep.ss")
scheme/list
syntax/stx
"parse.ss"
"runtime.ss"
@ -172,7 +173,9 @@
[(_ s)
(parameterize ((current-syntax-context stx))
(with-syntax ([p (stxclass-parser-name (get-stxclass #'s))])
#'(parser-errors p)))]))
#'(remove-duplicates
(map interpret-error-expression
(parser-errors p)))))]))
(define-syntax (debug-rhs stx)
(syntax-case stx ()

22
collects/syntax/scribblings/parse-patterns.scrbl
View File

@ -4,14 +4,22 @@
scribble/decode
scribble/eval
scheme/sandbox
(for-syntax scheme/base)
(for-label scheme/base
scheme/contract
syntax/parse
(rename-in syntax/parse [...+ DOTSPLUS])
syntax/kerncase))
@(define ellipses @scheme[...])
@(define-syntax-rule (define-dotsplus-names dotsplus def-dotsplus)
(begin (require (for-label (only-in syntax/parse ...+)))
(define dotsplus (scheme ...+))
(define def-dotsplus (defhere ...+))))
@(define-dotsplus-names dotsplus def-dotsplus)
@(define-syntax-rule (defhere id) (defidentifier #'id #:form? #t))
@(define ellipses @scheme[...])
@(define Spattern "single-term pattern")
@(define Lpattern "list pattern")
@(define Hpattern "head pattern")
@ -84,7 +92,7 @@ When a special form in this manual refers to @svar[syntax-pattern]
means specifically @tech{@Spattern}.
@schemegrammar*[#:literals (_ ~var ~literal ~or ~and ~not ~rest ~datum
~describe ~seq ~optional ~rep ~once
~describe ~seq ~optional ~rep ~once ~between
~! ~bind ~fail ~parse)
[S-pattern
pvar-id
@ -98,7 +106,7 @@ means specifically @tech{@Spattern}.
(H-pattern . S-pattern)
(A-pattern . S-pattern)
(EH-pattern #,ellipses . S-pattern)
(H-pattern @#,(scheme ...+) . S-pattern)
(H-pattern @#,dotsplus . S-pattern)
(@#,ref[~and s] proper-S/A-pattern ...+)
(@#,ref[~or s] S-pattern ...+)
(~not S-pattern)
@ -113,7 +121,7 @@ means specifically @tech{@Spattern}.
(A-pattern . L-pattern)
(H-pattern . L-pattern)
(EH-pattern #,ellipses . L-pattern)
(H-pattern @#,(scheme ...+) . L-pattern)
(H-pattern @#,dotsplus . L-pattern)
(~rest L-pattern)]
[H-pattern
pvar-id:splicing-syntax-class-id
@ -413,14 +421,14 @@ the whole sequence pattern.
See @tech{@EHpatterns} for more information.
}
@specsubform[(H-pattern @#,defhere[...+] . S-pattern)]{
@specsubform[(H-pattern @#,def-dotsplus . S-pattern)]{
Like an ellipses (@ellipses) pattern, but requires at one occurrence
of the head pattern to be present.
That is, the following patterns are equivalent:
@itemize[
@item[@scheme[(H ...+ . S)]]
@item[@scheme[(H @#,dotsplus . S)]]
@item[@scheme[((~between H 1 +inf.0) ... . S)]]
]

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

@ -6,7 +6,7 @@
scheme/sandbox
(for-label scheme/base
scheme/contract
syntax/parse
(except-in syntax/parse ...+)
syntax/kerncase))
@(define ellipses @scheme[...])