diff --git a/collects/combinator-parser/private-combinator/combinator.scm b/collects/combinator-parser/private-combinator/combinator.scm index 134a1e9616..7f1fef505f 100644 --- a/collects/combinator-parser/private-combinator/combinator.scm +++ b/collects/combinator-parser/private-combinator/combinator.scm @@ -342,7 +342,9 @@ (fail-res input (make-options-fail (rank-choice (map fail-type-chance fails)) - last-src + (if (equal? last-src (list 1 0 1 0)) + (map fail-type-src fails) + last-src) seq-name (rank-choice (map fail-type-used fails)) (rank-choice (map fail-type-may-use fails)) fails)))] @@ -465,17 +467,17 @@ (cond [(and (repeat-res? look-back) (fail-type? (repeat-res-stop look-back)) - (>= (fail-type-chance (repeat-res-stop look-back)) + (> (fail-type-chance (repeat-res-stop look-back)) (fail-type-chance fail))) (repeat-res-stop look-back)] [(and (choice-res? look-back) (choice-res-errors look-back) - (>= (fail-type-chance (choice-res-errors look-back)) + (> (fail-type-chance (choice-res-errors look-back)) (fail-type-chance fail))) (choice-res-errors look-back)] [(and (res? look-back) (fail-type? (res-possible-error look-back)) - (>= (fail-type-chance (res-possible-error look-back)) + (> (fail-type-chance (res-possible-error look-back)) (fail-type-chance fail))) (res-possible-error look-back)] [else #f])] @@ -553,7 +555,7 @@ (printf "opt-fails ~a~n" opt-fails)) (if pos-fail (make-options-fail (rank-choice (map fail-type-chance opt-fails)) - #f + (map fail-type-src opt-fails) name (rank-choice (map fail-type-used opt-fails)) (rank-choice (map fail-type-may-use opt-fails)) diff --git a/collects/combinator-parser/private-combinator/errors.scm b/collects/combinator-parser/private-combinator/errors.scm index 9a270f0ca5..0660b5ec51 100644 --- a/collects/combinator-parser/private-combinator/errors.scm +++ b/collects/combinator-parser/private-combinator/errors.scm @@ -18,7 +18,12 @@ (define (fail-type->message fail-type message-to-date) (let* ([name (fail-type-name fail-type)] [a (a/an name)] - [msg (lambda (m) (make-err m (fail-type-src fail-type)))]) + [msg (lambda (m) + (make-err m + (if (and (list? (fail-type-src fail-type)) + (list? (car (fail-type-src fail-type)))) + (car (fail-type-src fail-type)) + (fail-type-src fail-type))))]) #;(printf "fail-type->message ~a~n" fail-type) (cond [(terminal-fail? fail-type) diff --git a/collects/profj/comb-parsers/parser-units.scm b/collects/profj/comb-parsers/parser-units.scm index 647518c71c..7b2e06a2fb 100644 --- a/collects/profj/comb-parsers/parser-units.scm +++ b/collects/profj/comb-parsers/parser-units.scm @@ -280,6 +280,7 @@ (define (variable-declaration type expr share-type? end? name) (let* ([var-name (string-append name " declaration")] + [no-share (sequence (type (^ identifier)) id var-name)] [init (sequence ((^ identifier) EQUAL expr) id var-name)] [f (choose (identifier init) var-name)] [s&e (sequence (type (comma-sep f name)) id var-name)] @@ -293,6 +294,9 @@ [expr (choose (e base) var-name)] [else base])]) (cond + [(and end? (not share-type?) expr) + (sequence ((^ no-share) (choose (SEMI_COLON (sequence (EQUAL expr SEMI_COLON) id (string-append name " initialization"))))) + id var-name)] [end? (sequence (decl SEMI_COLON) id (string-append name " definition"))] [else decl]))) ) diff --git a/collects/profj/libs/java/runtime.ss b/collects/profj/libs/java/runtime.ss index ba55f28440..d9163cef8b 100644 --- a/collects/profj/libs/java/runtime.ss +++ b/collects/profj/libs/java/runtime.ss @@ -315,8 +315,7 @@ (ormap (lambda (e-v) (java-equal? test-val e-v null null 0.001 #t)) expected-vals))] [res-list (list range test-val)]) - (if - (in-check-mutate?) + (if (in-check-mutate?) (stored-checks (cons (list (and (not fail?) result) 'check-rand info res-list src test-obj) (stored-checks))) (report-check-result (and (not fail?) result) 'check-rand info res-list src test-obj)) @@ -362,11 +361,11 @@ src)))) (define (compose-message test-obj check-kind info values mutate-message) - (letrec ((test-format (construct-info-msg info)) - (eval-exception-raised? #f) - (comp-exception-raised? #f) - (exception-not-error? #f) - (formatted-values (map (lambda (v) + (letrec ([test-format (construct-info-msg info)] + [eval-exception-raised? #f] + [comp-exception-raised? #f] + [exception-not-error? #f] + [formatted-values (map (lambda (v) (cond [(and (pair? v) (eq? (car v) exception)) (if (equal? (cadddr v) "eval") @@ -374,18 +373,22 @@ (set! comp-exception-raised? #t)) (set! exception-not-error? (cadr v)) (send test-obj format-value (caddr v))] - [else (send test-obj format-value v)])) values)) - (expected-format + [(pair? v) + (map (lambda (v) (send test-obj format-value v)) v)] + [else (send test-obj format-value v)])) values)] + [expected-format (case check-kind ((check-expect check-by) "to produce ") ((check-rand) "to produce one of ") - ((check-catch) "to throw an instance of ")))) + ((check-catch) "to throw an instance of "))]) (cond [(not (eq? 'check-by check-kind)) (append (list (if mutate-message mutate-message "check expected ") test-format - expected-format - (first formatted-values)) + expected-format) + (if (eq? 'check-rand check-kind) + (list-format (first formatted-values)) + (list (first formatted-values))) (case check-kind ((check-expect) (append (if (= (length formatted-values) 3) @@ -427,6 +430,20 @@ " to compare to " (first formatted-values) " using " (third formatted-values) ". This value did not match the expectation.")]))) + + (define (list-format l) + (cond + [(= (length l) 1) l] + [(= (length l) 2) (list (car l) "or" (cadr l))] + [else + (letrec ([ins + (lambda (l) + (cond + [(null? l) l] + [(null? (cdr l)) (list " or" (car l))] + [else + (cons (car l) (cons "," (ins (cdr l))))]))]) + (ins l))])) ;construct-info-msg (list symbol string ...) -> string (define (construct-info-msg info)