From c6b723bbd8481ad35a7d92e80ee0a98226a4e7b6 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Tue, 7 Aug 2007 17:47:37 +0000 Subject: [PATCH] Bug fixes (more on the way) svn: r7046 --- .../private-combinator/combinator.scm | 25 ++++++++++--------- collects/profj/comb-parsers/parser-units.scm | 22 ++++++++-------- 2 files changed, 24 insertions(+), 23 deletions(-) diff --git a/collects/combinator-parser/private-combinator/combinator.scm b/collects/combinator-parser/private-combinator/combinator.scm index a5b17979d7..0a701c9843 100644 --- a/collects/combinator-parser/private-combinator/combinator.scm +++ b/collects/combinator-parser/private-combinator/combinator.scm @@ -61,10 +61,10 @@ [(null? input) (printf "null given~n")] [else (let ([token (!!! ((!!! position-token-token) (!!! (car input))))]) - #;(!!! (printf "Look at token ~a~n" token)) + (!!! (printf "Look at token ~a~n" token)) #;(!!! (printf "calling token-name: ~a~n" ((!!! token-name) token))) #;(!!! (printf "calling pred: ~a~n" (pred token))) - #;(!!! (printf "called pred~n")) + (!!! (printf "called pred~n")) #;(!!! (printf "car of input ~a~n" (position-token-token (car input)))))])) (cond [(eq? input return-name) name] @@ -188,11 +188,12 @@ (correct-list (choice-res-matches rsts)))] [(repeat-res? rsts) (next-res old-answer new-id old-used tok rsts)] - [else (printf "~a~n" rsts) (error 'here2)])))]) + [else (error 'parser-internal-error3 rsts)])))]) (cond [(null? subs) (error 'end-of-subs)] [(null? next-preds) - #;(printf "seq-warker called: last case, ~a ~n" seq-name) + #;(printf "seq-warker called: last case, ~a case of ~a ~n" + seq-name (curr-pred return-name)) (build-error (curr-pred input last-src) (previous? input) (previous? return-name) #f look-back used curr-id seen alts last-src)] @@ -247,7 +248,7 @@ (res-msg (repeat-res-a res)) #f (res-first-tok (repeat-res-a res)) new-alts)] - [else (!!! (printf "~a~n" res))(error 'stop) ])) (correct-list lst))] + [else (!!! (error 'parser-internal-error4 res))])) (correct-list lst))] [(correct-rsts) (correct-list rsts)]) #;(printf "rsts =~a~n" rsts) #;(printf "correct-rsts ~a~n" (map res-a correct-rsts)) @@ -282,7 +283,7 @@ (values 'sub-seq (sequence-fail-expected fail) fail)] [(choice-fail? fail) (values 'choice null fail)] [(options-fail? fail) (values 'options null fail)] - [else (printf "~a~n" fail) (error 'stop3)])) + [else (error 'parser-internal-error5 fail)])) ;update-src: symbol src-list src-list token -> src-list (define (update-src error-kind src prev-src tok) @@ -344,17 +345,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) + #;[(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) + #;[(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])] @@ -601,7 +602,7 @@ (apply append (cons (correct-list (car subs)) (correct-list (cdr subs))))] [else (correct-list (cdr subs))])] [(null? subs) null] - [else (printf "subs~a~n" subs) (error 'stop5)])) + [else (error 'parser-internal-error6 subs)])) (define (split-list subs) (let loop ([in subs] [correct null] [incorrect null]) diff --git a/collects/profj/comb-parsers/parser-units.scm b/collects/profj/comb-parsers/parser-units.scm index 9d2a3f4c5b..6e9aa8763b 100644 --- a/collects/profj/comb-parsers/parser-units.scm +++ b/collects/profj/comb-parsers/parser-units.scm @@ -230,31 +230,31 @@ (export java-ops^) (define math-ops - (choose (PLUS MINUS TIMES DIVIDE %) "binary operation")) + (choose (PLUS MINUS TIMES DIVIDE %) "binary operater")) (define shift-ops - (choose (<< >> >>>) "shift operation")) + (choose (<< >> >>>) "shift operater")) (define compare-ops - (choose (== GT LT LTEQ GTEQ !=) "binary operation")) + (choose (== GT LT LTEQ GTEQ !=) "binary operater")) (define bool-ops - (choose (&& OR) "binary operation")) + (choose (&& OR) "binary operater")) (define bit-ops - (choose (^T PIPE &) "binary operation")) + (choose (^T PIPE &) "binary operater")) (define assignment-ops (choose (EQUAL OREQUAL += -= *= /= &= ^= %= <<= >>= >>>=) "assignment")) (define (bin-ops ops) - (choice ops "binary operation")) + (choice ops "binary operater")) (define un-assignment - (choose (++ --) "unary operation")) + (choose (++ --) "unary operater")) (define un-op - (choose (~ + -) "unary operation")) + (choose (~ PLUS MINUS) "unary operater")) ) @@ -361,7 +361,7 @@ (sequence (new type-name init) "array initialization"))) (define (binary-expression-end op) - (sequence ((^ op) expression) id "binary expression")) + (sequence (op expression) id "binary expression")) (define if-expr-end (sequence (? (eta expression) : (eta expression)) id "conditional expression")) @@ -648,13 +648,13 @@ (sequence (O_PAREN (eta expression) C_PAREN) id) (sequence (! (eta expression)) id "conditional expression") (sequence (MINUS (eta expression)) id "negation expression") - checks) "expression -unique base")) + checks) "expression")) (define unique-end (choose (field-access-end method-call-end (binary-expression-end (bin-ops (list math-ops compare-ops bool-ops)))) - "expression -unique end")) + "expression")) (define expression (sequence (unique-base (repeat-greedy unique-end)) id "expression"))