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

Corrections to parser for error recovery; correction to bug in check based on setting fields in beginner

Browse Source 
svn: r7068
This commit is contained in:
Kathy Gray 2007-08-09 18:09:09 +00:00
parent d913915068
commit 1d44d5765c
3 changed files with 87 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -120,7 +120,7 @@
(res-used (repeat-res-a r)) (res-used (repeat-res-a r))
(repeat-res-stop r) (repeat-res-stop r)
(res-first-tok (repeat-res-a r)))] (res-first-tok (repeat-res-a r)))]
[else (error 'parser-internal-error1 r)]))] [else (error 'parser-internal-error1 (format "~a" r))]))]
[my-error (sequence-error-gen name sequence-length)] [my-error (sequence-error-gen name sequence-length)]
[my-walker (seq-walker id-position name my-error)]) [my-walker (seq-walker id-position name my-error)])
(opt-lambda (input [last-src (list 1 0 1 0)] [alts 1]) (opt-lambda (input [last-src (list 1 0 1 0)] [alts 1])
@ -135,12 +135,20 @@
[ans [ans
(cond (cond
[(and (res? pre-build-ans) (res-a pre-build-ans)) (builder pre-build-ans)] [(and (res? pre-build-ans) (res-a pre-build-ans)) (builder pre-build-ans)]
[(and (pair? pre-build-ans) (null? (cdr pre-build-ans))) (builder (car pre-build-ans))]
[(pair? pre-build-ans) (map builder pre-build-ans)] [(pair? pre-build-ans) (map builder pre-build-ans)]
[else pre-build-ans])]) [else pre-build-ans])])
(hash-table-put! memo-table input ans) (hash-table-put! memo-table input ans)
#;(!!! (printf "sequence ~a returning ~n" name)) #;(!!! (printf "sequence ~a returning ~n" name))
#;(when (res? pre-build-ans) (printf "pre-build is a res~n"))
#;(when (pair? pre-build-ans) (printf "pre-build is a pair of length ~a~n"
(length pre-build-ans)))
#;(when (and (pair? pre-build-ans) (= 1 (length pre-build-ans)))
(printf "pre-build-ans a pair containing a res? ~a~n" (res? (car pre-build-ans))))
#;(when (and (pair? pre-build-ans) (= 1 (length pre-build-ans)) (res? (car pre-build-ans)))
(printf "pre-build-ans a pair containing ~a~n" (car pre-build-ans)))
#;(printf "prebuild answer is ~a~n" pre-build-ans) #;(printf "prebuild answer is ~a~n" pre-build-ans)
#;(!!! (printf "answer is ~a ~n" ans)) #;(printf "answer is ~a ~n" ans)
ans)]))))) ans)])))))
;seq-walker: int string error-gen -> [(list parser) (list alpha) parser result (U bool string) (list string) int int -> result ;seq-walker: int string error-gen -> [(list parser) (list alpha) parser result (U bool string) (list string) int int -> result
@ -158,7 +166,7 @@
(or id (res-id (repeat-res-a rst))) (or id (res-id (repeat-res-a rst)))
(+ used (res-used (repeat-res-a rst))) (+ used (res-used (repeat-res-a rst)))
(repeat-res-stop rst) tok)] (repeat-res-stop rst) tok)]
[else (error 'parser-internal-error2 rst)] [else (error 'parser-internal-error2 (format "~a" rst))]
))] ))]
[walker [walker
(lambda (subs input previous? look-back curr-id seen used alts last-src) (lambda (subs input previous? look-back curr-id seen used alts last-src)
@ -177,6 +185,10 @@
(make-src-lst (position-token-start-pos (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))) (position-token-end-pos (res-first-tok old-result)))
last-src))]) last-src))])
#;(printf "next-call ~a ~a: ~a ~a ~a ~a~n"
seq-name (length seen) old-result (res? rsts)
(and (res? rsts) (res-a rsts))
(and (res? rsts) (choice-fail? (res-possible-error rsts))))
(cond (cond
[(and (res? rsts) (res-a rsts)) [(and (res? rsts) (res-a rsts))
(next-res old-answer new-id old-used tok rsts)] (next-res old-answer new-id old-used tok rsts)]
@ -189,7 +201,7 @@
(correct-list (choice-res-matches rsts)))] (correct-list (choice-res-matches rsts)))]
[(repeat-res? rsts) [(repeat-res? rsts)
(next-res old-answer new-id old-used tok rsts)] (next-res old-answer new-id old-used tok rsts)]
[else (error 'parser-internal-error3 rsts)])))]) [else (error 'parser-internal-error3 (format "~a" rsts))])))])
(cond (cond
[(null? subs) (error 'end-of-subs)] [(null? subs) (error 'end-of-subs)]
[(null? next-preds) [(null? next-preds)
@ -247,9 +259,11 @@
(res-msg (repeat-res-a res)) #f (res-msg (repeat-res-a res)) #f
(res-first-tok (repeat-res-a res)) (res-first-tok (repeat-res-a res))
new-alts)] new-alts)]
[else (!!! (error 'parser-internal-error4 res))])) [else (!!! (error 'parser-internal-error4 (format "~a" res)))]))
lst)] (flatten lst))]
[(correct-rsts) (correct-list rsts)]) [(correct-rsts) (flatten (correct-list rsts))])
#;(printf "case ~a ~a, choice case: intermediate results are ~a~n"
seq-name (length seen) lst)
(cond (cond
[(null? correct-rsts) [(null? correct-rsts)
(let ([fails (let ([fails
@ -281,7 +295,7 @@
(values 'sub-seq (sequence-fail-expected fail) fail)] (values 'sub-seq (sequence-fail-expected fail) fail)]
[(choice-fail? fail) (values 'choice null fail)] [(choice-fail? fail) (values 'choice null fail)]
[(options-fail? fail) (values 'options null fail)] [(options-fail? fail) (values 'options null fail)]
[else (error 'parser-internal-error5 fail)])) [else (error 'parser-internal-error5 (format "~a" fail))]))
;update-src: symbol src-list src-list token -> src-list ;update-src: symbol src-list src-list token -> src-list
(define (update-src error-kind src prev-src tok) (define (update-src error-kind src prev-src tok)
@ -312,6 +326,20 @@
[(repeat-res? rpt) [(repeat-res? 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 "fail-type? stop ~a~n" (fail-type? stop))
#;(printf "stop ~a~n" stop)
#;(printf "choice-res? back ~a~n" (choice-res? back))
#;(when (choice-res? back) (printf "choice-res-errors back ~a~n"
(choice-res-errors back)))
#;(when (and (fail-type? stop)
(choice-res? back)
(choice-res-errors back))
(printf "chances ~a > ~a -> ~a ~n"
(fail-type-chance (choice-res-errors back))
(fail-type-chance stop)
(> (fail-type-chance (choice-res-errors back))
(fail-type-chance stop))))
(cond (cond
[(fail-type? stop) [(fail-type? stop)
(make-res (res-a inn) (res-rest inn) (res-msg inn) (res-id inn) (res-used inn) (make-res (res-a inn) (res-rest inn) (res-msg inn) (res-id inn) (res-used inn)
@ -460,34 +488,31 @@
(lambda (curr-ans rest-ans) (lambda (curr-ans rest-ans)
(cond (cond
[(repeat-res? rest-ans) [(repeat-res? rest-ans)
(let ([a (res-a curr-ans)] #;(printf "building up the repeat answer for ~a~n" repeat-name)
[rest (repeat-res-a rest-ans)]) (let* ([a (res-a curr-ans)]
#;(printf "building up the repeat answer for ~a~n" repeat-name) [rest (repeat-res-a rest-ans)]
(make-repeat-res [repeat-build
(cond (lambda (r)
[(res? rest) (cond
#;(printf "rest is a res for ~a~n" repeat-name) [(res? r)
(make-res (append a (res-a rest)) (res-rest rest) repeat-name #f #;(printf "rest is a res for ~a~n" repeat-name)
(+ (res-used curr-ans) (res-used rest)) (make-repeat-res
#f (res-first-tok curr-ans))] (make-res (append a (res-a r)) (res-rest r) repeat-name #f
[(and (pair? rest) (null? (cdr rest))) (+ (res-used curr-ans) (res-used r))
#;(printf "rest is a one-element list for ~a~n" repeat-name) #f (res-first-tok curr-ans))
(make-res (append a (res-a (car rest))) (repeat-res-stop rest-ans))]
(res-rest (car rest)) repeat-name #f [else
(+ (res-used curr-ans) (res-used (car rest))) (error 'parser-internal-error9 (format "~a" r))]))])
#f (res-first-tok curr-ans))] (cond
[(pair? rest) [(and (pair? rest) (null? (cdr rest)))
#;(printf "rest is a pair being sent off to correct-list for ~a~n" repeat-name) #;(printf "rest is a one-element list for ~a~n" repeat-name)
(correct-list (repeat-build (car rest))]
(map (lambda (rs) [(pair? rest)
(make-res (append a (res-a rs)) (res-rest rs) repeat-name "" (map repeat-build (flatten rest))]
(+ (res-used curr-ans) (res-used rs)) [else (repeat-build rest)]))]
#f (res-first-tok curr-ans)))
rest))])
(repeat-res-stop rest-ans)))]
[(pair? rest-ans) [(pair? rest-ans)
(map (lambda (r) (process-rest curr-ans r)) rest-ans)] (map (lambda (r) (process-rest curr-ans r)) (flatten rest-ans))]
[else (error 'here4)]))] [else (error 'parser-internal-error10 (format "~a" rest-ans))]))]
[update-src [update-src
(lambda (input prev-src) (lambda (input prev-src)
(cond (cond
@ -548,9 +573,9 @@
(loop (res-rest match) (loop (res-rest match)
(update-src (res-rest match) curr-src)))) (update-src (res-rest match) curr-src))))
list-of-answer)]))] list-of-answer)]))]
[else (error 'internal-parser-error8)]))]))]) [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 ~n" repeat-name #;ans)) #;(!!! (printf "repeat of ~a ended with ans ~a ~n" repeat-name ans))
ans)])))) ans)]))))
;choice: [list [[list 'a ] -> result]] name -> result ;choice: [list [[list 'a ] -> result]] name -> result
@ -597,8 +622,19 @@
[else (make-choice-res name corrects (fail-builder errors))])]) [else (make-choice-res name corrects (fail-builder errors))])])
#;(!!! (printf "choice ~a is returning options were ~a ~n" name choice-names)) #;(!!! (printf "choice ~a is returning options were ~a ~n" name choice-names))
#;(printf "corrects were ~a~n" corrects) #;(printf "corrects were ~a~n" corrects)
#;(printf "errors were ~a~n" errors)
(hash-table-put! memo-table input ans) ans)]))))) (hash-table-put! memo-table input ans) ans)])))))
(define (flatten lst)
(cond
[(pair? lst)
(cond
[(pair? (car lst))
(append (flatten (car lst))
(flatten (cdr lst)))]
[else (cons (car lst) (flatten (cdr lst)))])]
[else null]))
;correct-list: (list result) -> (list result) ;correct-list: (list result) -> (list result)
(define (correct-list subs) (define (correct-list subs)
(cond (cond
@ -614,7 +650,7 @@
(append (car subs) (correct-list (cdr subs)))] (append (car subs) (correct-list (cdr subs)))]
[else (correct-list (cdr subs))])] [else (correct-list (cdr subs))])]
[(null? subs) null] [(null? subs) null]
[else (error 'parser-internal-error6 subs)])) [else (error 'parser-internal-error6 (format "~a" subs))]))
(define (split-list subs) (define (split-list subs)
(let loop ([in subs] [correct null] [incorrect null]) (let loop ([in subs] [correct null] [incorrect null])

18
collects/profj/check.ss
View File

@ -470,9 +470,13 @@
(let ((member (car rest))) (let ((member (car rest)))
(cond (cond
((method? member) ((method? member)
(if (memq 'static (map modifier-kind (method-modifiers member))) (cond
(check-method member static-env level type-recs c-class #t iface?) [(memq 'static (map modifier-kind (method-modifiers member)))
(check-method member field-env level type-recs c-class #f iface?)) (check-method member static-env level type-recs c-class #t iface?)]
[(and (eq? level 'beginner) (eq? 'ctor (type-spec-name (method-type member))))
(check-method member fields level type-recs c-class #f iface?)]
[else
(check-method member field-env level type-recs c-class #f iface?)])
(loop (cdr rest) statics fields)) (loop (cdr rest) statics fields))
((initialize? member) ((initialize? member)
(if (initialize-static member) (if (initialize-static member)
@ -505,7 +509,7 @@
(add-var-to-env name type (class-field (var-init? member)) statics) (add-var-to-env name type (class-field (var-init? member)) statics)
(add-var-to-env name type (class-field (var-init? member)) fields)) (add-var-to-env name type (class-field (var-init? member)) fields))
(loop (cdr rest) statics (loop (cdr rest) statics
(add-var-to-env name type (obj-field #f #;(var-init? member)) fields))))) (add-var-to-env name type (obj-field (var-init? member)) fields)))))
((def? member) ((def? member)
(check-inner-def member level type-recs c-class field-env) (check-inner-def member level type-recs c-class field-env)
(loop (cdr rest) statics fields)) (loop (cdr rest) statics fields))
@ -527,7 +531,7 @@
(lambda (assign) (lambda (assign)
(field-set? field assign (car c-class) level #f)) assigns))) (field-set? field assign (car c-class) level #f)) assigns)))
setting-fields)))) setting-fields))))
;create-field-env: (list field-record) env string -> env ;create-field-env: (list field-record) env string -> env
(define (create-field-env fields env class) (define (create-field-env fields env class)
(cond (cond
@ -543,9 +547,9 @@
(field-record-type field) (field-record-type field)
(cond (cond
((and in-env? (not current?)) inherited-conflict) ((and in-env? (not current?)) inherited-conflict)
((and (not static?) (not final?)) (obj-field #f)) ((and (not static?) (not final?)) (obj-field #t))
((and (not static?) final?) (final-field current?)) ((and (not static?) final?) (final-field current?))
((and static? (not final?)) (class-field #f)) ((and static? (not final?)) (class-field #t))
((and static? final?) (final-class-field current?))) ((and static? final?) (final-class-field current?)))
(create-field-env (cdr fields) env class)))))) (create-field-env (cdr fields) env class))))))

4
collects/profj/comb-parsers/parser-units.scm
View File

@ -648,13 +648,13 @@
(sequence (O_PAREN (eta expression) C_PAREN) id "parened expression") (sequence (O_PAREN (eta expression) C_PAREN) id "parened expression")
(sequence (! (eta expression)) id "conditional expression") (sequence (! (eta expression)) id "conditional expression")
(sequence (MINUS (eta expression)) id "negation expression") (sequence (MINUS (eta expression)) id "negation expression")
checks) "expression unique-base")) checks) "expression"))
(define unique-end (define unique-end
(choose (field-access-end (choose (field-access-end
method-call-end method-call-end
(binary-expression-end (bin-ops (list math-ops compare-ops bool-ops)))) (binary-expression-end (bin-ops (list math-ops compare-ops bool-ops))))
"expression unique-end")) "expression"))
(define expression (define expression
(sequence (unique-base (repeat-greedy unique-end)) id "expression")) (sequence (unique-base (repeat-greedy unique-end)) id "expression"))