From fba51484af8a8fca3986aab9948668892fac0f1d Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Wed, 8 Aug 2007 14:49:47 +0000 Subject: [PATCH] Assorted corrections svn: r7056 --- .../private-combinator/combinator.scm | 18 ++++---- .../private-combinator/errors.scm | 43 +++++++++++++------ .../private-combinator/parser-sigs.ss | 2 +- collects/profj/comb-parsers/parser-units.scm | 6 +-- 4 files changed, 45 insertions(+), 24 deletions(-) diff --git a/collects/combinator-parser/private-combinator/combinator.scm b/collects/combinator-parser/private-combinator/combinator.scm index a9e583f5e9..6319f36c75 100644 --- a/collects/combinator-parser/private-combinator/combinator.scm +++ b/collects/combinator-parser/private-combinator/combinator.scm @@ -127,7 +127,7 @@ #;(!!! (printf "seq ~a~n" name)) (cond [(eq? input return-name) name] - #;[(hash-table-get memo-table input #f) (hash-table-get memo-table input)] + [(hash-table-get memo-table input #f) (hash-table-get memo-table input)] [(null? sub-list) (builder (make-res null input name #f 0 #f #f))] [else @@ -261,7 +261,9 @@ rsts)]) (fail-res input (make-options-fail - (rank-choice (map fail-type-chance fails)) #f seq-name + (rank-choice (map fail-type-chance fails)) + last-src + seq-name (rank-choice (map fail-type-used fails)) (rank-choice (map fail-type-may-use fails)) fails)))] [else correct-rsts]))] @@ -427,8 +429,8 @@ (define (compute-chance expected-length seen-length used-toks num-alts may-use sub-chance) (let* ([revised-expectation (+ (- used-toks seen-length) expected-length)] [possible-expectation (+ revised-expectation (max 0 (sub1 may-use)))] - [probability-with-sub (* (/ (+ may-use used-toks) possible-expectation) (/ 1 num-alts))] - #;[probability-with-sub (* (/ (add1 used-toks) revised-expectation) (/ 1 num-alts))] + #;[probability-with-sub (* (/ (+ may-use used-toks) possible-expectation) (/ 1 num-alts))] + [probability-with-sub (* (/ (add1 used-toks) revised-expectation) (/ 1 num-alts))] [probability-without-sub (* (/ used-toks revised-expectation) (/ 1 num-alts))] [expected-sub probability-with-sub] [expected-no-sub probability-without-sub] @@ -441,8 +443,8 @@ (* (/ 1 num-alts) (/ 1 expected-length) sub-chance))) (cond [(and (zero? used-toks) (zero? may-use)) - (* (/ 1 expected-length) (/ 1 num-alts) sub-chance)] - [(zero? used-toks) probability-with-sub] + sub-chance #;(* (/ 1 expected-length) (/ 1 num-alts) sub-chance)] + [(zero? used-toks) sub-chance #;probability-with-sub] [else #;(printf "compute-chance: args ~a ~a ~a ~a ~a ~a~n" expected-length seen-length used-toks num-alts may-use sub-chance) @@ -497,7 +499,7 @@ (opt-lambda (input [start-src (list 1 0 1 0)] [alts 1]) (cond [(eq? input return-name) repeat-name] - #;[(hash-table-get memo-table input #f) (hash-table-get memo-table input)] + [(hash-table-get memo-table input #f) (hash-table-get memo-table input)] [else (let ([ans (let loop ([curr-input input] [curr-src start-src]) @@ -562,7 +564,7 @@ #;(!!! (printf "possible options are ~a~n" choice-names)) (let ([sub-opts (sub1 (+ alts num-choices))]) (cond - #;[(hash-table-get memo-table input #f) (hash-table-get memo-table input)] + [(hash-table-get memo-table input #f) (hash-table-get memo-table input)] [(eq? input return-name) name] [else #;(!!! (printf "choice ~a~n" name)) diff --git a/collects/combinator-parser/private-combinator/errors.scm b/collects/combinator-parser/private-combinator/errors.scm index d1d8572298..bc2a7a4bf9 100644 --- a/collects/combinator-parser/private-combinator/errors.scm +++ b/collects/combinator-parser/private-combinator/errors.scm @@ -126,12 +126,17 @@ [(and (> (length winners) 1) (<= (length winners) max-choice-depth)) (let ([messages (map (lambda (f) (fail-type->message f null)) winners)]) - (collapse-message - (add-to-message - (msg (format "An error occured in the ~a. Possible errors were: ~n ~a" - name - (alternate-error-list (map err-msg messages)))) - name #f message-to-date)))] + (cond + [(identical-messages? messages) + (collapse-message + (add-to-message (car messages) name #f message-to-date))] + [else + (collapse-message + (add-to-message + (msg (format "An error occured in the ~a. Possible errors were: ~n ~a" + name + (alternate-error-list (map err-msg messages)))) + name #f message-to-date))]))] [else (fail-type->message (car winners) @@ -169,12 +174,21 @@ (> (length no-dup-names) 1) (> (length winners) 1)) (let ([messages (map (lambda (f) (fail-type->message f null)) winners)]) - (collapse-message - (add-to-message - (msg (format "An error occured in this ~a, expected one of ~a. Possible errors were:~n~a" - name (nice-list no-dup-names) - (alternate-error-list (map err-msg messages)))) - name #f message-to-date)))] + (cond + [(identical-messages? messages) + (collapse-message + (add-to-message (car messages) #f #f + (add-to-message + (msg (format "An error occured in this ~a, expected one of ~a." + name (nice-list no-dup-names)) + name #f message-to-date))))] + [else + (collapse-message + (add-to-message + (msg (format "An error occured in this ~a, expected one of ~a. Possible errors were:~n~a" + name (nice-list no-dup-names) + (alternate-error-list (map err-msg messages)))) + name #f message-to-date))]))] [(and (> (length no-dup-names) max-choice-depth) (> (length winners) 1)) (collapse-message @@ -287,6 +301,11 @@ (string-append (string-downcase (substring string 0 1)) (substring string 1 (string-length string)))) + (define (identical-messages? msgs) + (andmap (lambda (err) (equal? (err-msg (car msgs)) + (err-msg err))) + (cdr msgs))) + (define (remove-dups l n) (cond [(null? l) null] diff --git a/collects/combinator-parser/private-combinator/parser-sigs.ss b/collects/combinator-parser/private-combinator/parser-sigs.ss index 27f9377c0f..09cea5d405 100644 --- a/collects/combinator-parser/private-combinator/parser-sigs.ss +++ b/collects/combinator-parser/private-combinator/parser-sigs.ss @@ -166,7 +166,7 @@ (define-syntaxes (eta) (values (syntax-rules () [(_ f) - (opt-lambda (x [c 1]) (f x c))]))) + (opt-lambda (x [s (list 0 1 0 1)] [o 1]) (f x s o))]))) )) (define-signature parser^ (parser)) diff --git a/collects/profj/comb-parsers/parser-units.scm b/collects/profj/comb-parsers/parser-units.scm index ab56c98f9a..db9305281a 100644 --- a/collects/profj/comb-parsers/parser-units.scm +++ b/collects/profj/comb-parsers/parser-units.scm @@ -206,7 +206,7 @@ (choice (list base-t voidT) "method return")) (define (array-type base-t) - (sequence (base-t (repeat (sequence (O_BRACKET C_BRACKET) id "array type"))) "type")) + (sequence (base-t (repeat (sequence (O_BRACKET C_BRACKET) id "array type"))) id "type")) ) @@ -440,8 +440,8 @@ (sequence (super O_PAREN (comma-sep expression "arguments") C_PAREN SEMI_COLON) id)) "super constructor call")) (define (block repeat?) - (sequence (O_BRACE (if repeat? (repeat-greedy (eta statement)) (eta statement)) C_BRACE) - id "block statement")) + (let ([body (if repeat? (repeat-greedy statement) statement)]) + (sequence (O_BRACE body C_BRACE) id "block statement"))) (define expression-stmt (sequence (expression SEMI_COLON) id "statement"))