suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Modification to force a filter predicate in combintor.scm

Browse Source 
Correction to annotate profj modules for error trace

svn: r7426
This commit is contained in:
Kathy Gray 2007-10-01 09:00:32 +00:00
parent 42c7a07fae
commit 35c37dd664
3 changed files with 30 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/combinator-parser/private-combinator/combinator-parser.scm
View File

@ -45,9 +45,11 @@
#;(printf "choice-res or pair? ~a~n" (choice-res? result)) #;(printf "choice-res or pair? ~a~n" (choice-res? result))
(let* ([options (if (choice-res? result) (choice-res-matches result) result)] (let* ([options (if (choice-res? result) (choice-res-matches result) result)]
[finished-options (filter (lambda (o) [finished-options (filter (lambda (o)
(cond [(res? o) (null? (res-rest o))] (!!! (cond [(res? o)
(and (not (null? (res-a o)))
(null? (res-rest o)))]
[(repeat-res? o) [(repeat-res? o)
(eq? (repeat-res-stop o) 'out-of-input)])) (eq? (repeat-res-stop o) 'out-of-input)])))
options)] options)]
[possible-repeat-errors [possible-repeat-errors
(filter (lambda (r) (and (repeat-res? r) (filter (lambda (r) (and (repeat-res? r)
@ -57,8 +59,10 @@
(filter res-possible-error (filter res-possible-error
(map (lambda (a) (if (repeat-res? a) (repeat-res-a a) a)) (map (lambda (a) (if (repeat-res? a) (repeat-res-a a) a))
options))]) options))])
#;(printf "length finished-options ~a~n" finished-options)
(cond (cond
[(not (null? finished-options)) [(not (null? finished-options))
#;(printf "finished an option~n")
(let ([first-fo (!!! (car finished-options))]) (let ([first-fo (!!! (car finished-options))])
(car (cond (car (cond
[(res? first-fo) (res-a first-fo)] [(res? first-fo) (res-a first-fo)]
@ -69,10 +73,12 @@
(error 'parser-internal-errorcp (error 'parser-internal-errorcp
(format "~a" first-fo))])))] (format "~a" first-fo))])))]
#;[(not (null? possible-repeat-errors)) #;[(not (null? possible-repeat-errors))
(printf "possible-repeat error~n")
(!!! (fail-type->message (!!! (fail-type->message
(!!! (car (repeat-res-stop (!!! (car (repeat-res-stop
(sort-repeats possible-repeat-errors))))))] (sort-repeats possible-repeat-errors))))))]
[(and (choice-res? result) (fail-type? (choice-res-errors result))) [(and (choice-res? result) (fail-type? (choice-res-errors result)))
#;(printf "choice res and choice res errors ~n")
(cond (cond
[(and (null? possible-repeat-errors) [(and (null? possible-repeat-errors)
(null? possible-errors)) (!!! (fail-type->message (choice-res-errors result)))] (null? possible-errors)) (!!! (fail-type->message (choice-res-errors result)))]
@ -117,7 +123,6 @@
(!!! result)))])]) (!!! result)))])])
(cond (cond
[(err? out) [(err? out)
#;(printf "returning error")
(make-err (!!! (err-msg out)) (make-err (!!! (err-msg out))
(if (err-src out) (if (err-src out)
(list (!!! file) (list (!!! file)

19
collects/combinator-parser/private-combinator/combinator.scm
View File

@ -395,6 +395,7 @@
(map (lambda (r) (repeat->res r look-back)) (flatten old-res))] (map (lambda (r) (repeat->res r look-back)) (flatten old-res))]
[else [else
#;(printf "There actually was an error for ~a~n" name) #;(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) (fail-res (res-rest old-res)
(let*-values ([(fail) (res-msg old-res)] (let*-values ([(fail) (res-msg old-res)]
[(possible-fail) [(possible-fail)
@ -481,6 +482,7 @@
(res? look-back-ref)) (res? look-back-ref))
(- used (res-used look-back-ref)) used)))] (- used (res-used look-back-ref)) used)))]
[opt-fails (list seq-fail pos-fail)]) [opt-fails (list seq-fail pos-fail)])
#;(printf "pos-fail? ~a~n" (and pos-fail #t))
#;(printf "seq-fail ~a~n" seq-fail) #;(printf "seq-fail ~a~n" seq-fail)
#;(when pos-fail #;(when pos-fail
(printf "used ~a look-back-ref used ~a ~n" (printf "used ~a look-back-ref used ~a ~n"
@ -538,7 +540,7 @@
(lambda (r) (lambda (r)
(cond (cond
[(res? r) [(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-repeat-res
(make-res (append a (res-a r)) (res-rest r) repeat-name #f (make-res (append a (res-a r)) (res-rest r) repeat-name #f
(+ (res-used curr-ans) (res-used r)) (+ (res-used curr-ans) (res-used r))
@ -578,6 +580,8 @@
[(null? curr-input) [(null? curr-input)
#;(printf "out of input for ~a~n" repeat-name) #;(printf "out of input for ~a~n" repeat-name)
(make-repeat-res (make-res null null repeat-name "" 0 #f #f) 'out-of-input)] (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 [else
(let ([this-res (sub curr-input curr-src)]) (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)
@ -596,8 +600,10 @@
[(options-fail? (res-msg this-res)) 'options] [(options-fail? (res-msg this-res)) 'options]
[else 'terminal]) [else 'terminal])
(fail-type-chance (res-msg this-res))) (fail-type-chance (res-msg this-res)))
(make-repeat-res (make-res null curr-input repeat-name "" 0 #f #f) (let ([fail (make-repeat-res (make-res null curr-input repeat-name "" 0 #f #f)
(res-msg this-res))] (res-msg this-res))])
#;(weak-map-put! memo-table curr-input fail)
fail)]
[(repeat-res? this-res) [(repeat-res? this-res)
#;(printf "repeat-res case of ~a~n" repeat-name) #;(printf "repeat-res case of ~a~n" repeat-name)
(process-rest (repeat-res-a this-res) (process-rest (repeat-res-a this-res)
@ -608,14 +614,17 @@
#;(printf "repeat call of ~a, choice-res ~a~n" #;(printf "repeat call of ~a, choice-res ~a~n"
repeat-name repeat-name
(and (choice-res? this-res) (and (choice-res? this-res)
(length (choice-res-matches this-res)))) (length list-of-answer)))
(cond (cond
[(null? (cdr list-of-answer)) [(null? (cdr list-of-answer))
(process-rest (car list-of-answer) (loop (res-rest (car list-of-answer)) (process-rest (car list-of-answer)
(loop (res-rest (car list-of-answer))
(update-src (res-rest (car list-of-answer)) (update-src (res-rest (car list-of-answer))
curr-src)))] curr-src)))]
[else [else
(map (lambda (match) (map (lambda (match)
#;(printf "calling repeat loop again, res-rest match ~a~n"
(length (res-rest match)))
(process-rest match (process-rest match
(loop (res-rest match) (loop (res-rest match)
(update-src (res-rest match) curr-src)))) (update-src (res-rest match) curr-src))))

6
collects/profj/tool.ss
View File

@ -1,6 +1,7 @@
(module tool mzscheme (module tool mzscheme
(require (lib "tool.ss" "drscheme") (lib "contract.ss") (require (lib "tool.ss" "drscheme") (lib "contract.ss")
(lib "mred.ss" "mred") (lib "framework.ss" "framework") (lib "mred.ss" "mred") (lib "framework.ss" "framework")
(lib "errortrace-lib.ss" "errortrace")
(prefix u: (lib "unit.ss")) (prefix u: (lib "unit.ss"))
(lib "file.ss") (lib "file.ss")
(lib "include-bitmap.ss" "mrlib") (lib "etc.ss") (lib "include-bitmap.ss" "mrlib") (lib "etc.ss")
@ -826,8 +827,9 @@
(else (else
(let-values (((name syn) (get-module-name (expand (car mods))))) (let-values (((name syn) (get-module-name (expand (car mods)))))
(set! name-to-require name) (set! name-to-require name)
(syntax-as-top (eval (compile syn)) (syntax-as-top #;(eval (annotate-top (compile syn)))
#;(old-current-eval (compile syn))) (old-current-eval
(errortrace-annotate syn)))
(loop (cdr mods) extras #t))))))))) (loop (cdr mods) extras #t)))))))))
((parse-java-interactions ex loc) ((parse-java-interactions ex loc)
(let ((exp (syntax-object->datum (syntax ex)))) (let ((exp (syntax-object->datum (syntax ex))))