Modification to force a filter predicate in combintor.scm
Correction to annotate profj modules for error trace svn: r7426
This commit is contained in:
Kathy Gray
parent
42c7a07fae
commit
35c37dd664
|
|
@ -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))
|
||||
#;(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)
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user