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

Adding some more strictness (!!!)

Browse Source 
svn: r5748
This commit is contained in:
Kathy Gray 2007-03-07 11:37:50 +00:00
parent 4e470ecd84
commit 78a80fe13e
3 changed files with 29 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -22,6 +22,7 @@
[(and (res? result) (res-a result) (null? (res-rest result)))
(car (res-a (!!! result)))]
[(and (res? result) (res-a result) (res-possible-error result))
(printf "res fail~n")
(fail-type->message (!!! (res-possible-error result)))]
[(and (res? result) (res-a result))
(make-err
@ -30,7 +31,9 @@
(input->output-name (!!! (car (res-rest result)))) input-type)
(and src?
(make-src-lst (position-token-start-pos (!!! (car (res-rest result)))))))]
[(res? result) (fail-type->message (res-msg (!!! result)))]
[(res? result)
(printf "res fail2~n")
(fail-type->message (res-msg (!!! result)))]
[(or (choice-res? result) (pair? result))
(let* ([options (if (choice-res? result) (choice-res-matches result) result)]
[finished-options (filter (lambda (o)
@ -44,6 +47,7 @@
(cond
[(not (null? finished-options)) (car (res-a (!!! (car finished-options))))]
[(not (null? possible-errors))
(printf "choice or pair fail~n")
(!!! (fail-type->message
(res-possible-error (!!! (car (sort-used possible-errors))))))]
[else
@ -58,14 +62,19 @@
[(and (repeat-res? result) (eq? 'out-of-input (repeat-res-stop (!!! result))))
(res-a (repeat-res-a result))]
[(and (repeat-res? result) (fail-type? (repeat-res-stop (!!! result))))
(printf "repeat-fail~n")
(!!! (fail-type->message (!!! (repeat-res-stop (!!! result)))))]
[else (error 'parser (format "Internal error: recieved unexpected input ~a"
(!!! result)))])])
(cond
[(err? out)
(make-err (!!! (err-msg out))
(cons file (!!list (err-src out))))]
[else out]))))
(list (!!! file)
(!!! (first (err-src out)))
(!!! (second (err-src out)))
(!!! (third (err-src out)))
(!!! (fourth (err-src out)))))]
[else (!!! out)]))))
)
(define-unit rank-max@

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

@ -39,7 +39,7 @@
(missclass name (token-name token))))]
[make-fail
(lambda (c n k i u)
(make-terminal-fail c (if src?
(make-terminal-fail c (if (and src? i)
(make-src-lst (position-token-start-pos i)
(position-token-end-pos i))
null)
@ -57,7 +57,7 @@
(cond
[(eq? input return-name) name]
[(null? input)
(make-terminal-fail null last-src .4 0 0 'end #f)]
(fail-res null (make-terminal-fail .4 last-src name 0 0 'end #f))]
[(pred (if src? (position-token-token (car input)) (car input)))
(make-res (list (builder (car input))) (cdr input)
name (value (car input)) 1 #f (car input))]
@ -153,7 +153,7 @@
[rsts (walker next-preds rest curr-pred curr
(or new-id curr-id) (cons curr-name seen)
(+ old-used used) alts
(if src?
(if (and src? (res-first-tok old-result))
(make-src-lst (position-token-start-pos (res-first-tok old-result))
(position-token-end-pos (res-first-tok old-result)))
last-src))])
@ -170,8 +170,10 @@
(previous? input) (previous? return-name)
look-back used curr-id seen alts last-src)]
[else
#;(printf "seq-walker called: else case~n")
#;(printf "seq-walker called: else case, ~a case of ~a~n"
seq-name (curr-pred return-name))
(let ([fst (curr-pred input last-src)])
#;(printf "seq-walker predicate returned~n")
(cond
[(res? fst)
(cond
@ -241,7 +243,10 @@
(case error-kind
[(choice options) prev-src]
[(sub-seq misscase misspell end) src]
[(missclass wrong) (update-src-start src (position-token-start-pos tok))])))
[(missclass wrong)
(if tok
(update-src-start src (position-token-start-pos tok))
src)])))
;build-sequence-error: result boolean result string int [U #f string] [listof string] int int -> result
(define (sequence-error-gen name len)
@ -419,7 +424,8 @@
(list (position-line new-start)
(position-col new-start)
(position-offset new-start)
(+ (- (third src) (position-offset new-start))
(+ (- (!!! (third src))
(!!! (position-offset new-start)))
(fourth src))))
(define (update-src-end src new-end)

10
collects/combinator-parser/private-combinator/structs.scm
View File

@ -9,11 +9,11 @@
;make-src-lst: position position -> src-list
(define (make-src-lst start end)
(list (position-line start)
(position-col start)
(position-offset start)
(- (position-offset end)
(position-offset start))))
(list (!!! (position-line start))
(!!! (position-col start))
(!!! (position-offset start))
(- (!!! (position-offset end))
(!!! (position-offset start)))))
;(make-fail-type float fail-src string int int)
(define-struct fail-type (chance src name used may-use) (make-inspector))