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

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

@ -14,6 +14,10 @@
(define (sort-used reses)
(sort reses
(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)
(lambda (input file)
@ -38,17 +42,36 @@
[(res? result)
(fail-type->message (res-msg (!!! 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)]
[finished-options (filter (lambda (o)
(cond [(res? o) (null? (res-rest o))]
[(repeat-res? o)
(eq? (repeat-res-stop o) 'out-of-input)]))
options)]
[possible-errors (filter res-possible-error
[possible-repeat-errors
(filter (lambda (r) (and (repeat-res? r)
(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
[(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))
;(printf "choice or pair fail~n")
(!!! (fail-type->message

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

@ -113,7 +113,7 @@
name (res-id r) (res-used r)
(res-possible-error 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))))
(res-rest (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)
seq-name (or id (res-id rst))
(+ 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)))
(res-rest (repeat-res-a rst)) seq-name
(or id (res-id (repeat-res-a rst)))
@ -175,6 +175,8 @@
[id-spot? (= id-position (add1 (length seen)))]
[next-call
(lambda (old-result curr curr-name new-id tok alts)
(cond
[(res? old-result)
(let* ([old-answer (res-a old-result)]
[rest (res-rest old-result)]
[old-used (res-used old-result)]
@ -195,13 +197,14 @@
[(res? rsts) (fail-res rest (res-msg rsts))]
[(pair? rsts)
(map (lambda (rst) (next-res old-answer new-id old-used tok rst))
(correct-list rsts))]
(flatten (correct-list rsts)))]
[(choice-res? rsts)
(map (lambda (rst) (next-res old-answer new-id old-used tok rst))
(correct-list (choice-res-matches rsts)))]
(flatten (correct-list (choice-res-matches 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-error3 (format "~a" rsts))]))]
[else (error 'parser-internal-error11 (format "~a" old-result))]))])
(cond
[(null? subs) (error 'end-of-subs)]
[(null? next-preds)
@ -322,11 +325,12 @@
(letrec ([repeat->res
(lambda (rpt back)
(cond
[(pair? rpt) (map (lambda (r) (repeat->res r back)) rpt)]
[(repeat-res? rpt)
[(pair? rpt) (map (lambda (r) (repeat->res r back)) (flatten rpt))]
[(and (repeat-res? rpt) (res? (repeat-res-a rpt)))
(let ([inn (repeat-res-a rpt)]
[stop (repeat-res-stop rpt)])
#;(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 "stop ~a~n" stop)
#;(printf "choice-res? back ~a~n" (choice-res? back))
@ -364,7 +368,7 @@
(repeat->res old-res look-back)]
[(pair? 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
#;(printf "There actually was an error for ~a~n" name)
(fail-res (res-rest old-res)
@ -489,6 +493,8 @@
(cond
[(repeat-res? rest-ans)
#;(printf "building up the repeat answer for ~a~n" repeat-name)
(cond
[(res? curr-ans)
(let* ([a (res-a curr-ans)]
[rest (repeat-res-a rest-ans)]
[repeat-build
@ -508,8 +514,10 @@
#;(printf "rest is a one-element list for ~a~n" repeat-name)
(repeat-build (car 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)
(map (lambda (r) (process-rest curr-ans r)) (flatten rest-ans))]
[else (error 'parser-internal-error10 (format "~a" rest-ans))]))]
@ -527,6 +535,8 @@
[else
(let ([ans
(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
[(null? curr-input)
#;(printf "out of input for ~a~n" repeat-name)
@ -557,7 +567,7 @@
(res-rest (repeat-res-a this-res)))]
[(or (choice-res? this-res) (pair? this-res))
(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"
repeat-name
(and (choice-res? this-res)
@ -575,7 +585,7 @@
list-of-answer)]))]
[else (error 'internal-parser-error8 (format "~a" this-res))]))]))])
(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)]))))
;choice: [list [[list 'a ] -> result]] name -> result
@ -675,7 +685,7 @@
(loop (cdr in) correct (cons (res-msg (car in)) incorrect))]
[else (error 'split-list (car in))])]
[(null? in)
(values correct incorrect)])))
(values (flatten correct) (flatten incorrect))])))
(define (src-list src-s src-e)
(list (position-line src-s)