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

Changes that correct another infinite loop

Browse Source 
svn: r7089
This commit is contained in:
Kathy Gray 2007-08-13 22:41:26 +00:00
parent e155deea8e
commit 3747f712a9
2 changed files with 93 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -14,6 +14,10 @@
(define (sort-used reses) (define (sort-used reses)
(sort reses (sort reses
(lambda (a b) (!!! (> (res-used a) (res-used b)))))) (lambda (a b) (!!! (> (res-used a) (res-used b))))))
(define (sort-repeats repeats)
(sort repeats
(lambda (a b) (!!! (> (res-used (repeat-res-a a))
(res-used (repeat-res-a b)))))))
(define (parser start) (define (parser start)
(lambda (input file) (lambda (input file)
@ -38,17 +42,36 @@
[(res? result) [(res? result)
(fail-type->message (res-msg (!!! result)))] (fail-type->message (res-msg (!!! result)))]
[(or (choice-res? result) (pair? result)) [(or (choice-res? result) (pair? 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) (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-errors (filter res-possible-error [possible-repeat-errors
(map (lambda (a) (if (repeat-res? a) (repeat-res-a a) a)) (filter (lambda (r) (and (repeat-res? r)
options))]) (fail-type? (repeat-res-stop r))))
options)]
[possible-errors
(filter res-possible-error
(map (lambda (a) (if (repeat-res? a) (repeat-res-a a) a))
options))])
(cond (cond
[(not (null? finished-options)) (car (res-a (!!! (car finished-options))))] [(not (null? finished-options))
(let ([first-fo (!!! (car finished-options))])
(car (cond
[(res? first-fo) (res-a first-fo)]
[(and (repeat-res? first-fo)
(res? (repeat-res-a first-fo)))
(res-a (repeat-res-a first-fo))]
[else
(error 'parser-internal-errorcp
(format "~a" first-fo))])))]
#;[(not (null? possible-repeat-errors))
(!!! (fail-type->message
(!!! (car (repeat-res-stop
(sort-repeats possible-repeat-errors))))))]
[(not (null? possible-errors)) [(not (null? possible-errors))
;(printf "choice or pair fail~n") ;(printf "choice or pair fail~n")
(!!! (fail-type->message (!!! (fail-type->message

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

@ -113,7 +113,7 @@
name (res-id r) (res-used r) name (res-id r) (res-used r)
(res-possible-error r) (res-possible-error r)
(res-first-tok r))] (res-first-tok r))]
[(repeat-res? r) [(and (repeat-res? r) (res? repeat-res-a r))
(make-res (list (build (res-a (repeat-res-a r)))) (make-res (list (build (res-a (repeat-res-a r))))
(res-rest (repeat-res-a r)) (res-rest (repeat-res-a r))
name (res-id (repeat-res-a r)) name (res-id (repeat-res-a r))
@ -160,7 +160,7 @@
(make-res (append a (res-a rst)) (res-rest rst) (make-res (append a (res-a rst)) (res-rest rst)
seq-name (or id (res-id rst)) seq-name (or id (res-id rst))
(+ used (res-used rst)) (res-possible-error rst) tok)] (+ used (res-used rst)) (res-possible-error rst) tok)]
[(repeat-res? rst) [(and (repeat-res? rst) (res? (repeat-res-a rst)))
(make-res (append a (res-a (repeat-res-a rst))) (make-res (append a (res-a (repeat-res-a rst)))
(res-rest (repeat-res-a rst)) seq-name (res-rest (repeat-res-a rst)) seq-name
(or id (res-id (repeat-res-a rst))) (or id (res-id (repeat-res-a rst)))
@ -175,33 +175,36 @@
[id-spot? (= id-position (add1 (length seen)))] [id-spot? (= id-position (add1 (length seen)))]
[next-call [next-call
(lambda (old-result curr curr-name new-id tok alts) (lambda (old-result curr curr-name new-id tok alts)
(let* ([old-answer (res-a old-result)] (cond
[rest (res-rest old-result)] [(res? old-result)
[old-used (res-used old-result)] (let* ([old-answer (res-a old-result)]
[rsts (walker next-preds rest curr-pred curr [rest (res-rest old-result)]
(or new-id curr-id) (cons curr-name seen) [old-used (res-used old-result)]
(+ old-used used) alts [rsts (walker next-preds rest curr-pred curr
(if (and src? (res-first-tok old-result)) (or new-id curr-id) (cons curr-name seen)
(make-src-lst (position-token-start-pos (res-first-tok old-result)) (+ old-used used) alts
(position-token-end-pos (res-first-tok old-result))) (if (and src? (res-first-tok old-result))
last-src))]) (make-src-lst (position-token-start-pos (res-first-tok old-result))
#;(printf "next-call ~a ~a: ~a ~a ~a ~a~n" (position-token-end-pos (res-first-tok old-result)))
seq-name (length seen) old-result (res? rsts) last-src))])
(and (res? rsts) (res-a rsts)) #;(printf "next-call ~a ~a: ~a ~a ~a ~a~n"
(and (res? rsts) (choice-fail? (res-possible-error rsts)))) seq-name (length seen) old-result (res? rsts)
(cond (and (res? rsts) (res-a rsts))
[(and (res? rsts) (res-a rsts)) (and (res? rsts) (choice-fail? (res-possible-error rsts))))
(next-res old-answer new-id old-used tok rsts)] (cond
[(res? rsts) (fail-res rest (res-msg rsts))] [(and (res? rsts) (res-a rsts))
[(pair? rsts) (next-res old-answer new-id old-used tok rsts)]
(map (lambda (rst) (next-res old-answer new-id old-used tok rst)) [(res? rsts) (fail-res rest (res-msg rsts))]
(correct-list rsts))] [(pair? rsts)
[(choice-res? rsts) (map (lambda (rst) (next-res old-answer new-id old-used tok rst))
(map (lambda (rst) (next-res old-answer new-id old-used tok rst)) (flatten (correct-list rsts)))]
(correct-list (choice-res-matches rsts)))] [(choice-res? rsts)
[(repeat-res? rsts) (map (lambda (rst) (next-res old-answer new-id old-used tok rst))
(next-res old-answer new-id old-used tok rsts)] (flatten (correct-list (choice-res-matches rsts))))]
[else (error 'parser-internal-error3 (format "~a" rsts))])))]) [(repeat-res? rsts)
(next-res old-answer new-id old-used tok rsts)]
[else (error 'parser-internal-error3 (format "~a" rsts))]))]
[else (error 'parser-internal-error11 (format "~a" old-result))]))])
(cond (cond
[(null? subs) (error 'end-of-subs)] [(null? subs) (error 'end-of-subs)]
[(null? next-preds) [(null? next-preds)
@ -322,11 +325,12 @@
(letrec ([repeat->res (letrec ([repeat->res
(lambda (rpt back) (lambda (rpt back)
(cond (cond
[(pair? rpt) (map (lambda (r) (repeat->res r back)) rpt)] [(pair? rpt) (map (lambda (r) (repeat->res r back)) (flatten rpt))]
[(repeat-res? rpt) [(and (repeat-res? rpt) (res? (repeat-res-a rpt)))
(let ([inn (repeat-res-a rpt)] (let ([inn (repeat-res-a rpt)]
[stop (repeat-res-stop rpt)]) [stop (repeat-res-stop rpt)])
#;(printf "in repeat->res for ~a~n" name) #;(printf "in repeat->res for ~a~n" name)
#;(printf "repeat-res-a res ~a~n" (res? inn))
#;(printf "fail-type? stop ~a~n" (fail-type? stop)) #;(printf "fail-type? stop ~a~n" (fail-type? stop))
#;(printf "stop ~a~n" stop) #;(printf "stop ~a~n" stop)
#;(printf "choice-res? back ~a~n" (choice-res? back)) #;(printf "choice-res? back ~a~n" (choice-res? back))
@ -364,7 +368,7 @@
(repeat->res old-res look-back)] (repeat->res old-res look-back)]
[(pair? old-res) [(pair? old-res)
#;(!!! (printf "finished on pairs of res for ~a~n" name #;old-res)) #;(!!! (printf "finished on pairs of res for ~a~n" name #;old-res))
(map (lambda (r) (repeat->res r look-back)) 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)
(fail-res (res-rest old-res) (fail-res (res-rest old-res)
@ -489,27 +493,31 @@
(cond (cond
[(repeat-res? rest-ans) [(repeat-res? rest-ans)
#;(printf "building up the repeat answer for ~a~n" repeat-name) #;(printf "building up the repeat answer for ~a~n" repeat-name)
(let* ([a (res-a curr-ans)] (cond
[rest (repeat-res-a rest-ans)] [(res? curr-ans)
[repeat-build (let* ([a (res-a curr-ans)]
(lambda (r) [rest (repeat-res-a rest-ans)]
(cond [repeat-build
[(res? r) (lambda (r)
#;(printf "rest is a res for ~a~n" repeat-name) (cond
(make-repeat-res [(res? r)
(make-res (append a (res-a r)) (res-rest r) repeat-name #f #;(printf "rest is a res for ~a~n" repeat-name)
(+ (res-used curr-ans) (res-used r)) (make-repeat-res
#f (res-first-tok curr-ans)) (make-res (append a (res-a r)) (res-rest r) repeat-name #f
(repeat-res-stop rest-ans))] (+ (res-used curr-ans) (res-used r))
[else #f (res-first-tok curr-ans))
(error 'parser-internal-error9 (format "~a" r))]))]) (repeat-res-stop rest-ans))]
(cond [else
[(and (pair? rest) (null? (cdr rest))) (error 'parser-internal-error9 (format "~a" r))]))])
#;(printf "rest is a one-element list for ~a~n" repeat-name) (cond
(repeat-build (car rest))] [(and (pair? rest) (null? (cdr rest)))
[(pair? rest) #;(printf "rest is a one-element list for ~a~n" repeat-name)
(map repeat-build (flatten rest))] (repeat-build (car rest))]
[else (repeat-build rest)]))] [(pair? rest)
#;(printf "rest is a pair for ~a ~a~n" repeat-name (length rest))
(map repeat-build (flatten rest))]
[else (repeat-build rest)]))]
[else (error 'parser-internal-error12 (format "~a" curr-ans))])]
[(pair? rest-ans) [(pair? rest-ans)
(map (lambda (r) (process-rest curr-ans r)) (flatten rest-ans))] (map (lambda (r) (process-rest curr-ans r)) (flatten rest-ans))]
[else (error 'parser-internal-error10 (format "~a" rest-ans))]))] [else (error 'parser-internal-error10 (format "~a" rest-ans))]))]
@ -527,6 +535,8 @@
[else [else
(let ([ans (let ([ans
(let loop ([curr-input input] [curr-src start-src]) (let loop ([curr-input input] [curr-src start-src])
#;(printf "length of curr-input for ~a ~a~n" repeat-name (length curr-input))
#;(printf "curr-input ~a~n" (map position-token-token curr-input))
(cond (cond
[(null? curr-input) [(null? curr-input)
#;(printf "out of input for ~a~n" repeat-name) #;(printf "out of input for ~a~n" repeat-name)
@ -557,7 +567,7 @@
(res-rest (repeat-res-a this-res)))] (res-rest (repeat-res-a this-res)))]
[(or (choice-res? this-res) (pair? this-res)) [(or (choice-res? this-res) (pair? this-res))
(let ([list-of-answer (let ([list-of-answer
(if (choice-res? this-res) (choice-res-matches this-res) this-res)]) (if (choice-res? this-res) (choice-res-matches this-res) (flatten this-res))])
#;(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)
@ -575,7 +585,7 @@
list-of-answer)]))] list-of-answer)]))]
[else (error 'internal-parser-error8 (format "~a" this-res))]))]))]) [else (error 'internal-parser-error8 (format "~a" this-res))]))]))])
(hash-table-put! memo-table input ans) (hash-table-put! memo-table input ans)
#;(!!! (printf "repeat of ~a ended with ans ~a ~n" repeat-name ans)) #;(!!! (printf "repeat of ~a ended with ans ~n" repeat-name #;ans))
ans)])))) ans)]))))
;choice: [list [[list 'a ] -> result]] name -> result ;choice: [list [[list 'a ] -> result]] name -> result
@ -675,7 +685,7 @@
(loop (cdr in) correct (cons (res-msg (car in)) incorrect))] (loop (cdr in) correct (cons (res-msg (car in)) incorrect))]
[else (error 'split-list (car in))])] [else (error 'split-list (car in))])]
[(null? in) [(null? in)
(values correct incorrect)]))) (values (flatten correct) (flatten incorrect))])))
(define (src-list src-s src-e) (define (src-list src-s src-e)
(list (position-line src-s) (list (position-line src-s)