From 35c37dd664a4fe79e1db0df256893d4a96e6b44f Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Mon, 1 Oct 2007 09:00:32 +0000 Subject: [PATCH] Modification to force a filter predicate in combintor.scm Correction to annotate profj modules for error trace svn: r7426 --- .../private-combinator/combinator-parser.scm | 15 ++++++++---- .../private-combinator/combinator.scm | 23 +++++++++++++------ collects/profj/tool.ss | 6 +++-- 3 files changed, 30 insertions(+), 14 deletions(-) diff --git a/collects/combinator-parser/private-combinator/combinator-parser.scm b/collects/combinator-parser/private-combinator/combinator-parser.scm index 3ed6351e06..4a9e152c93 100644 --- a/collects/combinator-parser/private-combinator/combinator-parser.scm +++ b/collects/combinator-parser/private-combinator/combinator-parser.scm @@ -45,9 +45,11 @@ #;(printf "choice-res or pair? ~a~n" (choice-res? result)) (let* ([options (if (choice-res? result) (choice-res-matches result) result)] [finished-options (filter (lambda (o) - (cond [(res? o) (null? (res-rest o))] - [(repeat-res? o) - (eq? (repeat-res-stop o) 'out-of-input)])) + (!!! (cond [(res? o) + (and (not (null? (res-a o))) + (null? (res-rest o)))] + [(repeat-res? o) + (eq? (repeat-res-stop o) 'out-of-input)]))) options)] [possible-repeat-errors (filter (lambda (r) (and (repeat-res? r) @@ -57,8 +59,10 @@ (filter res-possible-error (map (lambda (a) (if (repeat-res? a) (repeat-res-a a) a)) options))]) + #;(printf "length finished-options ~a~n" finished-options) (cond - [(not (null? finished-options)) + [(not (null? finished-options)) + #;(printf "finished an option~n") (let ([first-fo (!!! (car finished-options))]) (car (cond [(res? first-fo) (res-a first-fo)] @@ -69,10 +73,12 @@ (error 'parser-internal-errorcp (format "~a" first-fo))])))] #;[(not (null? possible-repeat-errors)) + (printf "possible-repeat error~n") (!!! (fail-type->message (!!! (car (repeat-res-stop (sort-repeats possible-repeat-errors))))))] [(and (choice-res? result) (fail-type? (choice-res-errors result))) + #;(printf "choice res and choice res errors ~n") (cond [(and (null? possible-repeat-errors) (null? possible-errors)) (!!! (fail-type->message (choice-res-errors result)))] @@ -117,7 +123,6 @@ (!!! result)))])]) (cond [(err? out) - #;(printf "returning error") (make-err (!!! (err-msg out)) (if (err-src out) (list (!!! file) diff --git a/collects/combinator-parser/private-combinator/combinator.scm b/collects/combinator-parser/private-combinator/combinator.scm index 9f2cd0d143..47f93f9338 100644 --- a/collects/combinator-parser/private-combinator/combinator.scm +++ b/collects/combinator-parser/private-combinator/combinator.scm @@ -395,6 +395,7 @@ (map (lambda (r) (repeat->res r look-back)) (flatten old-res))] [else #;(printf "There actually was an error for ~a~n" name) + #;(printf "length seen ~a length rest ~a~n" (length seen) (length (res-rest old-res))) (fail-res (res-rest old-res) (let*-values ([(fail) (res-msg old-res)] [(possible-fail) @@ -481,6 +482,7 @@ (res? look-back-ref)) (- used (res-used look-back-ref)) used)))] [opt-fails (list seq-fail pos-fail)]) + #;(printf "pos-fail? ~a~n" (and pos-fail #t)) #;(printf "seq-fail ~a~n" seq-fail) #;(when pos-fail (printf "used ~a look-back-ref used ~a ~n" @@ -538,7 +540,7 @@ (lambda (r) (cond [(res? r) - #;(printf "rest is a res for ~a~n" repeat-name) + #;(printf "rest is a res for ~a, res-a is ~a ~n" a repeat-name) (make-repeat-res (make-res (append a (res-a r)) (res-rest r) repeat-name #f (+ (res-used curr-ans) (res-used r)) @@ -578,6 +580,8 @@ [(null? curr-input) #;(printf "out of input for ~a~n" repeat-name) (make-repeat-res (make-res null null repeat-name "" 0 #f #f) 'out-of-input)] + #;[(weak-map-get memo-table curr-input #f) + (weak-map-get memo-table curr-input)] [else (let ([this-res (sub curr-input curr-src)]) #;(printf "Repeat of ~a called it's repeated entity ~n" repeat-name) @@ -596,8 +600,10 @@ [(options-fail? (res-msg this-res)) 'options] [else 'terminal]) (fail-type-chance (res-msg this-res))) - (make-repeat-res (make-res null curr-input repeat-name "" 0 #f #f) - (res-msg this-res))] + (let ([fail (make-repeat-res (make-res null curr-input repeat-name "" 0 #f #f) + (res-msg this-res))]) + #;(weak-map-put! memo-table curr-input fail) + fail)] [(repeat-res? this-res) #;(printf "repeat-res case of ~a~n" repeat-name) (process-rest (repeat-res-a this-res) @@ -608,14 +614,17 @@ #;(printf "repeat call of ~a, choice-res ~a~n" repeat-name (and (choice-res? this-res) - (length (choice-res-matches this-res)))) + (length list-of-answer))) (cond [(null? (cdr list-of-answer)) - (process-rest (car list-of-answer) (loop (res-rest (car list-of-answer)) - (update-src (res-rest (car list-of-answer)) - curr-src)))] + (process-rest (car list-of-answer) + (loop (res-rest (car list-of-answer)) + (update-src (res-rest (car list-of-answer)) + curr-src)))] [else (map (lambda (match) + #;(printf "calling repeat loop again, res-rest match ~a~n" + (length (res-rest match))) (process-rest match (loop (res-rest match) (update-src (res-rest match) curr-src)))) diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index c06d48d680..946ff57f2a 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -1,6 +1,7 @@ (module tool mzscheme (require (lib "tool.ss" "drscheme") (lib "contract.ss") (lib "mred.ss" "mred") (lib "framework.ss" "framework") + (lib "errortrace-lib.ss" "errortrace") (prefix u: (lib "unit.ss")) (lib "file.ss") (lib "include-bitmap.ss" "mrlib") (lib "etc.ss") @@ -826,8 +827,9 @@ (else (let-values (((name syn) (get-module-name (expand (car mods))))) (set! name-to-require name) - (syntax-as-top (eval (compile syn)) - #;(old-current-eval (compile syn))) + (syntax-as-top #;(eval (annotate-top (compile syn))) + (old-current-eval + (errortrace-annotate syn))) (loop (cdr mods) extras #t))))))))) ((parse-java-interactions ex loc) (let ((exp (syntax-object->datum (syntax ex))))