From 6222942f6fa3e91306a82624c9d3a5262a345d96 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Fri, 11 Apr 2008 14:53:35 +0000 Subject: [PATCH] Corrects stupid exponential bug (m^2 in a non-trivial m); corrects small repetitions in grammar svn: r9257 --- .../private-combinator/combinator-parser.scm | 19 ++--- .../private-combinator/combinator.scm | 56 +++++++++------ .../private-combinator/errors.scm | 2 +- .../private-combinator/structs.scm | 71 +++++++++---------- collects/profj/comb-parsers/parser-units.scm | 44 ++++++------ 5 files changed, 98 insertions(+), 94 deletions(-) diff --git a/collects/combinator-parser/private-combinator/combinator-parser.scm b/collects/combinator-parser/private-combinator/combinator-parser.scm index 3face3c4bd..044b2d26b9 100644 --- a/collects/combinator-parser/private-combinator/combinator-parser.scm +++ b/collects/combinator-parser/private-combinator/combinator-parser.scm @@ -52,8 +52,12 @@ [else #f]))] [possible-errors (lambda (matches) - (filter res-possible-error - (map (lambda (a) (if (repeat-res? a) (repeat-res-a a) a)) + (map (lambda (r) + (or (and (res? r) (res-possible-error r)) + (and (repeat-res? r) (repeat-res-stop r)))) + (filter (lambda (r) + (or (and (res? r) (res-possible-error r)) + (and (repeat-res? r) (fail-type? (repeat-res-stop r))))) matches)))] [result-a (lambda (res) @@ -69,14 +73,13 @@ [(and (pair? matched) (finished? (car matched))) (result-a (car matched))] [(pair? matched) (loop (cdr matched))] [(and matched (finished? matched)) (result-a matched)] - [(or (null? matched) matched) - (loop ((if (lazy-choice? result) next-choice next-opt) result))] + [(or (null? matched) matched) (loop (next-opt result))] [else (let ([p-errors (possible-errors (lazy-opts-matches result))]) (cond [(pair? p-errors) - (let ([fails (cons (lazy-opts-errors result) - (map res-possible-error p-errors))]) + (let ([fails (cons (lazy-opts-errors result) p-errors)]) + #;(printf "~nfails ~a~n~n" fails) (fail-type->message (make-options-fail (rank-choice (map fail-type-chance fails)) #f @@ -88,7 +91,7 @@ [(null? p-errors) (fail-type->message (lazy-opts-errors result))]))])))] [(or (choice-res? result) (pair? result)) - (printf "choice-res or pair? ~a~n" result) + #;(printf "choice-res or pair? ~a~n" result) (let* ([options (if (choice-res? result) (choice-res-matches result) result)] [finished-options (filter (lambda (o) (cond [(res? o) @@ -132,8 +135,6 @@ (not (null? possible-errors))) (let ([fails (cons (choice-res-errors result) (map res-possible-error possible-errors))]) - #;(printf "we are gonna call fail-type->message ~a ~n" fails) - ;uncomment printf, stop the loop, get the error... wtf (fail-type->message (make-options-fail (rank-choice (map fail-type-chance fails)) #f diff --git a/collects/combinator-parser/private-combinator/combinator.scm b/collects/combinator-parser/private-combinator/combinator.scm index b937c25e6e..3f01dc74e7 100644 --- a/collects/combinator-parser/private-combinator/combinator.scm +++ b/collects/combinator-parser/private-combinator/combinator.scm @@ -128,7 +128,7 @@ [my-error (sequence-error-gen name sequence-length)] [my-walker (seq-walker id-position name my-error)]) (opt-lambda (input [last-src (list 1 0 1 0)] [alts 1]) - (unless (eq? input return-name) (printf "seq ~a~n" name)) + #;(unless (eq? input return-name) (printf "seq ~a~n" name)) (cond [(eq? input return-name) name] [(weak-map-get memo-table input #f) @@ -144,7 +144,7 @@ [(pair? pre-build-ans) (map builder pre-build-ans)] [else pre-build-ans])]) (weak-map-put! memo-table input ans) - (printf "sequence ~a returning ~n" name) + #;(printf "sequence ~a returning ~n" name) #;(printf "answer is ~a ~n" ans) ans)]))))) @@ -214,7 +214,7 @@ (lazy-opts-errors rsts) (map (lambda (thunk) (lambda () - (let ([ans (next-choice rsts)]) + (let ([ans (next-opt rsts)]) (and ans (next-res old-answer new-id old-used tok ans))))) (lazy-opts-thunks rsts)) (lazy-choice-name rsts))] @@ -231,14 +231,14 @@ (cond [(null? subs) (error 'end-of-subs)] [(null? next-preds) - (printf "seq-walker called: last case, ~a case of ~a ~n" + #;(printf "seq-walker called: last case, ~a case of ~a ~n" seq-name (curr-pred return-name)) (build-error (curr-pred input last-src) (lambda () (previous? input)) (previous? return-name) #f look-back look-back-ref used curr-id seen alts last-src)] [else - (printf "seq-walker called: else case, ~a case of ~a ~ath case ~n" + #;(printf "seq-walker called: else case, ~a case of ~a ~ath case ~n" seq-name (curr-pred return-name) (length seen)) (let ([fst (curr-pred input last-src)]) (cond @@ -286,7 +286,7 @@ (map (lambda (thunked) (lambda () - (let ([res (next-choice fst)]) + (let ([res (next-opt fst)]) (if res (next-c res) (begin (set-lazy-opts-thunks! opt-r null) #f))))) @@ -346,8 +346,8 @@ (rank-choice (map fail-type-used fails)) (rank-choice (map fail-type-may-use fails)) fails)))] [(and (null? correct-rsts) (lazy-choice? fst) (not (null? (lazy-opts-thunks fst)))) - (let loop ([next-res (next-choice fst)]) - (when next-res (loop (next-choice fst))))] + (let loop ([next-res (next-opt fst)]) + (when next-res (loop (next-opt fst))))] [else correct-rsts]))] [else (error 'here3)]))])))]) walker)) @@ -629,7 +629,7 @@ (make-repeat-res (make-res null null (repeat-name) "" 0 #f #f) 'out-of-input)] [else (let ([this-res (sub curr-input curr-src)]) - (printf "Repeat of ~a called it's repeated entity ~n" (repeat-name)) + #;(printf "Repeat of ~a called it's repeated entity ~n" (repeat-name)) (cond [(and (res? this-res) (res-a this-res)) #;(printf "loop again case for ~a~n" (repeat-name)) @@ -653,6 +653,20 @@ #;(printf "repeat-res case of ~a~n" repeat-name) (process-rest (repeat-res-a this-res) (res-rest (repeat-res-a this-res)))] + [(lazy-opts? this-res) + (let ([process (lambda (res) + (cond [(res? res) + (process-rest res (loop (res-rest res) (update-src (res-rest res) curr-src)))] + [(repeat-res? res) + (process-rest (repeat-res-a res) (res-rest (repeat-res-a res)))] + [else (error 'repeat-greedy-loop (format "Internal error, given ~a" res))]))]) + (update-lazy-opts this-res + (map process (lazy-opts-matches this-res)) + (map (lambda (t) + (lambda () + (let ([next-res (next-opt this-res)]) + (and next-res (process next-res))))) + (lazy-opts-thunks this-res))))] [(or (choice-res? this-res) (pair? this-res)) (let ([list-of-answer (if (choice-res? this-res) (choice-res-matches this-res) (flatten this-res))]) @@ -680,7 +694,7 @@ ans)])))) ;choice: [list [[list 'a ] -> result]] name -> result - (define (choice2 opt-list name) + (define (choice opt-list name) (let ([memo-table (make-weak-map)] [num-choices (length opt-list)] [choice-names (lambda () (map (lambda (o) (o return-name)) opt-list))]) @@ -732,12 +746,12 @@ (weak-map-put! memo-table input ans) ans)]))))) ;choice: [list [[list 'a ] -> result]] name -> result - (define (choice opt-list name) + (define (choice2 opt-list name) (let ([memo-table (make-weak-map)] [num-choices (length opt-list)] [choice-names (lambda () (map (lambda (o) (o return-name)) opt-list))]) (opt-lambda (input [last-src (list 0 0 0 0)] [alts 1]) - (unless (eq? input return-name) (printf "choice ~a~n" name)) + #;(unless (eq? input return-name) (printf "choice ~a~n" name)) #;(printf "possible options are ~a~n" choice-names) (let ([sub-opts (sub1 (+ alts num-choices))]) (cond @@ -759,10 +773,10 @@ null)] [initial-ans (make-lazy-choice null initial-fail options name)] [ans - (if (next-choice initial-ans) + (if (next-opt initial-ans) initial-ans (fail-res input (lazy-opts-errors initial-ans)))]) - (printf "choice ~a is returning options were ~a, answer is ~a ~n" name (choice-names) ans) + #;(printf "choice ~a is returning options were ~a, answer is ~a ~n" name (choice-names) ans) (weak-map-put! memo-table input ans) ans)]))))) (define (flatten lst) @@ -840,14 +854,12 @@ (- (position-offset new-end) (third src)))) (define (repeat op) - (letrec ([name (lambda () "temp") #;(lambda () (string-append "any number of " (op return-name)))] - [r* (choice (list op - (seq (list op - (opt-lambda (x [s (list 0 1 0 1)] [o 1]) (r* x s o))) - (lambda (list-args) list-args #;(cons (car list-args) (cadr list-args))) - (name)) - (seq null (lambda (x) null) return-name)) - (name))]) + (letrec ([name (lambda () (string-append "any number of " (op return-name)))] + [r* (opt-lambda (x [s (list 0 1 0 1)] [o 1]) + ((choice (list #;op + (seq (list op r*) (lambda (list-args) list-args) (name)) + (seq null (lambda (x) null) "epsilon")) + (name)) x s o))]) r*)) ) diff --git a/collects/combinator-parser/private-combinator/errors.scm b/collects/combinator-parser/private-combinator/errors.scm index b5eb110ad1..316752c9dd 100644 --- a/collects/combinator-parser/private-combinator/errors.scm +++ b/collects/combinator-parser/private-combinator/errors.scm @@ -19,7 +19,7 @@ (let* ([name (fail-type-name fail-type)] [a (a/an name)] [msg (lambda (m) (make-err m (fail-type-src fail-type)))]) - (printf "fail-type->message ~a~n" fail-type) + #;(printf "fail-type->message ~a~n" fail-type) (cond [(terminal-fail? fail-type) (collapse-message diff --git a/collects/combinator-parser/private-combinator/structs.scm b/collects/combinator-parser/private-combinator/structs.scm index a156bd6ec1..7344dc7261 100644 --- a/collects/combinator-parser/private-combinator/structs.scm +++ b/collects/combinator-parser/private-combinator/structs.scm @@ -1,9 +1,6 @@ (module structs scheme/base - (provide (except-out (all-defined-out) - set-choice-fail-messages! - set-lazy-opts-matches!) - ) + (provide (all-defined-out)) (require parser-tools/lex) @@ -41,59 +38,55 @@ ;(make-lazy-choice (listof res) fail-type (listof (_ -> res)) string) (define-struct (lazy-choice lazy-opts) (name) #:transparent) - (define (update-choice-errors failc mss) - (set-choice-fail-messages! failc (cons mss (choice-fail-messages failc))) + (define (update-lazy-errors failc mss) (set-fail-type-chance! failc (max (fail-type-chance failc) (fail-type-chance mss))) (set-fail-type-used! failc (max (fail-type-used failc) (fail-type-used mss))) - (set-fail-type-may-use! failc (max (fail-type-may-use failc) (fail-type-may-use mss)))) - (define (update-opt-errors failc mss) - (set-options-fail-opts! failc (cons mss (options-fail-opts failc))) - (set-fail-type-chance! failc (max (fail-type-chance failc) (fail-type-chance mss))) - (set-fail-type-used! failc (max (fail-type-used failc) (fail-type-used mss))) - (set-fail-type-may-use! failc (max (fail-type-may-use failc) (fail-type-may-use mss)))) - - (define (make-force thunks set-thunks matches set-matches update-errors errors) + (set-fail-type-may-use! failc (max (fail-type-may-use failc) (fail-type-may-use mss))) + (if (choice-fail? failc) + (set-choice-fail-messages! failc (cons mss (choice-fail-messages failc))) + (set-options-fail-opts! failc (cons mss (options-fail-opts failc))))) + + + (define (next-opt lc) (letrec ([next (lambda (lc update-errors) - (printf "next-opt ~a~n" lc) + #;(printf "next-opt ~a~n" lc) (cond - [(null? (thunks lc)) #f] + [(null? (lazy-opts-thunks lc)) #f] [else - (let ([curr-res ((car (thunks lc)))]) - (unless (null? (thunks lc)) (set-thunks lc (cdr (thunks lc)))) + (let ([curr-res ((car (lazy-opts-thunks lc)))]) + (unless (null? (lazy-opts-thunks lc)) + (set-lazy-opts-thunks! lc (cdr (lazy-opts-thunks lc)))) (cond - [(and (not curr-res) (not (null? (thunks lc)))) (next lc update-errors)] - [(or (and (res? curr-res) (res-a curr-res)) - (repeat-res? curr-res)) - (set-matches lc (cons curr-res (matches lc))) + [(and (not curr-res) (null? (lazy-opts-thunks lc))) curr-res] + [(and (not curr-res) (not (null? (lazy-opts-thunks lc)))) (next lc update-errors)] + [(or (and (res? curr-res) (res-a curr-res)) (repeat-res? curr-res)) + (set-lazy-opts-matches! lc (cons curr-res (lazy-opts-matches lc))) curr-res] [(lazy-opts? curr-res) (let* ([next-matches (map (lambda (m) (lambda () m)) (lazy-opts-matches curr-res))] - [new-update (if (lazy-choice? curr-res) update-choice-errors update-opt-errors)] - [remaining (map (lambda (t) (lambda () (next curr-res - (lambda (_ msg) - (new-update (errors curr-res) msg))))) + [remaining (map (lambda (t) + (lambda () + (next curr-res + (lambda (_ msg) (update-lazy-errors (lazy-opts-errors curr-res) msg))))) (lazy-opts-thunks curr-res))]) - (set-thunks lc (append next-matches remaining (thunks lc))) - (update-errors (errors lc) (lazy-opts-errors curr-res)) + (set-lazy-opts-thunks! lc (append next-matches remaining (lazy-opts-thunks lc))) + (update-errors (lazy-opts-errors lc) (lazy-opts-errors curr-res)) (next lc update-errors))] - [(and (not curr-res) (null? (thunks lc))) curr-res] [else - (update-errors (errors lc) + (update-errors (lazy-opts-errors lc) (cond [(res? curr-res) (res-msg curr-res)] [else (error 'next (format "Internal error: failure other than res ~a" curr-res))])) (next lc update-errors)]))]))]) - (lambda (lc) (next lc update-errors)))) + (next lc update-lazy-errors))) - (define next-choice - (make-force lazy-opts-thunks set-lazy-opts-thunks! - lazy-opts-matches set-lazy-opts-matches! - update-choice-errors lazy-opts-errors)) - (define next-opt - (make-force lazy-opts-thunks set-lazy-opts-thunks! - lazy-opts-matches set-lazy-opts-matches! - update-opt-errors lazy-opts-errors)) + (define (update-lazy-opts old-opts matches thunks) + (cond + [(lazy-choice? old-opts) + (make-lazy-choice matches (lazy-opts-errors old-opts) thunks (lazy-choice-name old-opts))] + [(lazy-opts? old-opts) + (make-lazy-opts matches (lazy-opts-errors old-opts) thunks)])) (define (fail-res rst msg) (make-res #f rst msg "" 0 #f #f)) diff --git a/collects/profj/comb-parsers/parser-units.scm b/collects/profj/comb-parsers/parser-units.scm index 9a255e8792..7a72b142bc 100644 --- a/collects/profj/comb-parsers/parser-units.scm +++ b/collects/profj/comb-parsers/parser-units.scm @@ -202,7 +202,7 @@ (choose (base-type name) "type")) (define (method-type base-t) - (choice (list base-t voidT) "method return")) + (choose (base-t voidT) "method return")) (define (array-type base-t) (sequence (base-t (repeat (sequence (O_BRACKET C_BRACKET) id "array type"))) id "type")) @@ -287,7 +287,7 @@ [base (sequence (type (^ identifier)) id var-name)] [decl (cond - [(and expr share-type?) (choose (s&e e base) var-name)] + [(and expr share-type?) s&e #;(choose (s&e e base) var-name)] [share-type? s] [expr (choose (e base) var-name)] [else base])]) @@ -506,10 +506,10 @@ (choose ((sequence (O_PAREN C_PAREN) id) (sequence (O_PAREN a C_PAREN) id)) "method parameter list") (sequence (O_PAREN C_PAREN) id "method parameter list"))] - [full (sequence ((repeat m) ret (^ identifier) method-parms throws (comma-sep n "thrown types")) id "method signature")] [full-no-t (sequence ((repeat m) ret (^ identifier) method-parms) id "method signature")] - [no-mods-t (sequence (ret (^ identifier) method-parms throws (comma-sep n "thrown types")) id "method signature")] - [no-mods (sequence (ret (^ identifier) method-parms) id "method signature")]) + [full (sequence ((^ full-no-t) throws (comma-sep n "thrown types")) id "method signature")] + [no-mods (sequence (ret (^ identifier) method-parms) id "method signature")] + [no-mods-t (sequence ((^ no-mods) throws (comma-sep n "thrown types")) id "method signature")]) (cond [(and m t?) (choose (full full-no-t) "method signature")] [m full-no-t] @@ -546,12 +546,11 @@ [m (sequence ((repeat modifier) interface (^ IDENTIFIER) O_BRACE body C_BRACE) id "interface definition")] [e (sequence (interface (^ IDENTIFIER) extends O_BRACE body C_BRACE) id "interface definition")] [always (sequence (interface (^ IDENTIFIER) O_BRACE body C_BRACE) id "interface definition")]) - (choice (cond - [(and modifier extends) (list m&e m e always)] - [modifier (list m always)] - [extends (list e always)] - [else (list always)]) - "interface definition"))) + (cond + [(and modifier extends) (choose (m&e m) "interface definition")] + [modifier m] + [extends (choose (e always) "interface definition")] + [else always]))) ) @@ -594,7 +593,6 @@ (define (top-member mems) (choice mems "class or interface")) - ;Note -- should enfore name to be identifier.identifier instead of name (define import-dec (let ([name (sequence (identifier (repeat-greedy (sequence (PERIOD identifier) id "import name"))) id "import name")]) @@ -608,17 +606,15 @@ [i (sequence (import body) id "program")]) (cond [(and package import) - (choice (list p&i i ) "program")] + (choose (p&i i) "program")] [package - (choice (list p body) "program")] - [import - (choice (list i body) "program")] + (choose (p body) "program")] + [import i] [else body]))) ) ;Remembered Unsupported Features - ;throws clause ;strictfp ;allowing static fields in interface @@ -664,16 +660,17 @@ (define constructor (make-constructor #f (repeat-greedy init) (value+name-type prim-type))) (define interface (interface-def #f #f - (repeat-greedy - (sequence (method-sig SEMI_COLON) id "method signature")))) + (repeat (sequence (method-sig SEMI_COLON) id "method signature")))) (define class - (class-def #f #f (implements-dec identifier) + (class-def #f #f + (implements-dec identifier) (repeat (class-body (list field method constructor))))) (define program - (make-program #f (repeat import-dec) - (repeat (top-member (list class interface))))) + (make-program #f + (repeat-greedy import-dec) + (repeat-greedy (top-member (list class interface))))) (define interact (choose (field statement expression) "interactive program")) @@ -769,7 +766,8 @@ (define program - (make-program #f (repeat-greedy import-dec) + (make-program #f + (repeat-greedy import-dec) (repeat-greedy (choose (class interface) "class or interface")))) (define interact