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

Parser bug fix.

Browse Source 
++ on fields and arrays bug fix.

svn: r10726
This commit is contained in:
Kathy Gray 2008-07-12 14:29:23 +00:00
parent eff5666a39
commit c459978d86
5 changed files with 116 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -222,7 +222,8 @@
(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)))] (flatten (correct-list rsts)))]
[(choice-res? 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
(update-possible-fail rst rsts)))
(flatten (correct-list (choice-res-matches rsts))))] (flatten (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)]
@ -335,7 +336,7 @@
(map (map
(lambda (rst) (lambda (rst)
(res-msg (res-msg
(build-error rst (previous? input) (previous? return-name) (build-error rst (lambda () (previous? input)) (previous? return-name)
(car next-preds) look-back look-back-ref used curr-id seen alts last-src))) (car next-preds) look-back look-back-ref used curr-id seen alts last-src)))
rsts)]) rsts)])
(fail-res input (fail-res input
@ -385,6 +386,21 @@
(rank-choice (map fail-type-may-use fails)) (rank-choice (map fail-type-may-use fails))
fails)) fails))
;update-possible-rail result result -> result
(define (update-possible-fail res back)
#;(printf "update-possible-fail ~a, ~a~n" res back)
(cond
[(and (res? res) (not (res-possible-error res)))
(cond
[(res? back)
(make-res (res-a res) (res-rest res) (res-msg res) (res-id res) (res-used res)
(res-possible-error back) (res-first-tok res))]
[(choice-res? back)
(make-res (res-a res) (res-rest res) (res-msg res) (res-id res) (res-used res)
(choice-res-errors back) (res-first-tok res))]
[else res])]
[else res]))
;build-sequence-error: result boolean result string int [U #f string] [listof string] int int -> result ;build-sequence-error: result boolean result string int [U #f string] [listof string] int int -> result
(define (sequence-error-gen name len) (define (sequence-error-gen name len)
(letrec ([repeat->res (letrec ([repeat->res
@ -424,14 +440,16 @@
stop) stop)
(res-first-tok inn))] (res-first-tok inn))]
[else inn]))] [else inn]))]
[else rpt]))]) [else rpt]))]
)
(lambda (old-res prev prev-name next-pred look-back look-back-ref used id seen alts last-src) (lambda (old-res prev prev-name next-pred look-back look-back-ref used id seen alts last-src)
(cond (cond
[(and (pair? old-res) (null? (cdr old-res)) (res? (car old-res))) (car old-res)] [(and (pair? old-res) (null? (cdr old-res)) (res? (car old-res)))
(update-possible-fail (car old-res) look-back)]
[(and (pair? old-res) (null? (cdr old-res)) (repeat-res? (car old-res))) [(and (pair? old-res) (null? (cdr old-res)) (repeat-res? (car old-res)))
(repeat->res (car old-res) look-back)] (repeat->res (car old-res) look-back)]
[(or (and (res? old-res) (res-a old-res)) (choice-res? old-res) (lazy-opts? old-res)) [(or (and (res? old-res) (res-a old-res)) (choice-res? old-res) (lazy-opts? old-res))
old-res] (update-possible-fail old-res look-back)]
[(repeat-res? old-res) [(repeat-res? old-res)
#;(printf "finished on repeat-res for ~a res ~n" name #;old-res) #;(printf "finished on repeat-res for ~a res ~n" name #;old-res)
(repeat->res old-res look-back)] (repeat->res old-res look-back)]
@ -517,7 +535,7 @@
name used name used
(+ used (fail-type-may-use fail) next-used) (+ used (fail-type-may-use fail) next-used)
id kind (reverse seen) expected found id kind (reverse seen) expected found
(and (res? prev) (res-a prev) (res-msg prev)) prev
prev-name)))] prev-name)))]
[seq-fail (seq-fail-maker fail used)] [seq-fail (seq-fail-maker fail used)]
[pos-fail [pos-fail

24
collects/combinator-parser/private-combinator/errors.scm
View File

@ -56,17 +56,19 @@
(collapse-message (collapse-message
(add-to-message (add-to-message
(msg (msg
(cond (let* ([poss-repeat ((sequence-fail-repeat? fail-type))]
[(sequence-fail-repeat? fail-type) [repeat? (and (res? poss-repeat) (res-a poss-repeat) (res-msg poss-repeat))])
(format "Found a repitition of ~a; the required number are present. Expected ~a ~a next." (cond
(sequence-fail-last-seen fail-type) a2 expected)] [repeat?
[(null? show-sequence) (format "Found a repitition of ~a; the required number are present. Expected ~a ~a next."
(format "Expected ~a ~a to begin this ~a, instead found ~a." (sequence-fail-last-seen fail-type) a2 expected)]
a2 expected id-name (input->output-name (sequence-fail-found fail-type)))] [(null? show-sequence)
[else (format "Expected ~a ~a to begin this ~a, instead found ~a."
(format "Expected ~a ~a to continue this ~a. Instead, found ~a after ~a." a2 expected id-name (input->output-name (sequence-fail-found fail-type)))]
a2 expected id-name (input->output-name (sequence-fail-found fail-type)) [else
(format-seen show-sequence))])) (format "Expected ~a ~a to continue this ~a. Instead, found ~a after ~a."
a2 expected id-name (input->output-name (sequence-fail-found fail-type))
(format-seen show-sequence))])))
name curr-id message-to-date))] name curr-id message-to-date))]
[(misscase) [(misscase)
(collapse-message (collapse-message

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

@ -27,7 +27,7 @@
;result = res | choice-res | repeat-res | (listof (U res choice-res)) ;result = res | choice-res | repeat-res | (listof (U res choice-res))
;(make-res (U #f (listof 'b)) (listof 'a) (U string fail-type) (U string 'a) int) [U #f fail-type] token ;(make-res parse-build (listof 'a) (U string fail-type) (U string 'a) int) [U #f fail-type] token
(define-struct res (a rest msg id used possible-error first-tok) #:transparent) (define-struct res (a rest msg id used possible-error first-tok) #:transparent)
;make-choice-res string (listof res) fail-type) ;make-choice-res string (listof res) fail-type)
(define-struct choice-res (name matches errors) #:transparent) (define-struct choice-res (name matches errors) #:transparent)
@ -38,6 +38,11 @@
;(make-lazy-choice (listof res) fail-type (listof (_ -> res)) string) ;(make-lazy-choice (listof res) fail-type (listof (_ -> res)) string)
(define-struct (lazy-choice lazy-opts) (name) #:transparent) (define-struct (lazy-choice lazy-opts) (name) #:transparent)
;parse-build = answer | none
;(make-answer 'b)
(define-struct answer (ast))
(define-struct none ())
(define (update-lazy-errors failc mss) (define (update-lazy-errors failc mss)
(set-fail-type-chance! failc (max (fail-type-chance failc) (fail-type-chance mss))) (set-fail-type-chance! failc (max (fail-type-chance failc) (fail-type-chance mss)))
(set-fail-type-used! failc (max (fail-type-used failc) (fail-type-used mss))) (set-fail-type-used! failc (max (fail-type-used failc) (fail-type-used mss)))

9
collects/profj/libs/java/runtime.ss
View File

@ -14,7 +14,7 @@
(provide convert-to-string shift not-equal bitwise mod divide-dynamic divide-int (provide convert-to-string shift not-equal bitwise mod divide-dynamic divide-int
divide-float and or cast-primitive cast-reference instanceof-array nullError divide-float and or cast-primitive cast-reference instanceof-array nullError
check-eq? dynamic-equal? compare compare-within check-catch check-mutate check-by check-eq? dynamic-equal? compare compare-within check-catch check-mutate check-by
compare-rand) compare-rand check-effect)
(define (check-eq? obj1 obj2) (define (check-eq? obj1 obj2)
(or (eq? obj1 obj2) (or (eq? obj1 obj2)
@ -347,9 +347,10 @@
result-value))) result-value)))
;check-effects: (-> (listof val)) (-> (listof val)) (list string) src object -> boolean ;check-effects: (-> (listof val)) (-> (listof val)) (list string) src object -> boolean
(define (check-effects tests checks info src test-obj) (define (check-effect tests checks info src test-obj)
(tests) (let ([app (lambda (thunk) (thunk))])
(checks)) (for-each app tests)
(andmap app checks)))
(define (report-check-result res check-kind info values src test-obj) (define (report-check-result res check-kind info values src test-obj)
(when test-obj (when test-obj

108
collects/profj/to-scheme.ss
View File

@ -2830,60 +2830,85 @@
,(type-spec-dim type)) ,(type-spec-dim type))
(build-src (type-spec-src type)))) (build-src (type-spec-src type))))
;converted
;translate-array-access: syntax syntax src -> syntax ;translate-array-access: syntax syntax src -> syntax
(define translate-array-access (define (translate-array-access array index src)
(lambda (array index src) (make-syntax #f `(send ,array access ,index)
(make-syntax #f `(send ,array access ,index) (build-src src)))
(build-src src))))
;converted
;translate-cond: syntax syntax syntax src -> syntax ;translate-cond: syntax syntax syntax src -> syntax
(define translate-cond (define (translate-cond if? then else src)
(lambda (if? then else src) (make-syntax #f `(if ,if? ,then ,else) (build-src src)))
(make-syntax #f `(if ,if? ,then ,else) (build-src src))))
;converted
;translate-post-expr: syntax expression symbol src src -> syntax ;translate-post-expr: syntax expression symbol src src -> syntax
(define (translate-post-expr expr exp op key src) (define (translate-post-expr expr exp op key src)
(let ([setter (cond (let* ([array? (array-access? exp)]
[(and (field-access? (access-name exp)) [memb-field? (and
(not (var-access-static? (field-access-access (access-name exp))))) (access? exp)
(create-set-name (id-string (field-access-field (access-name exp))) (field-access? (access-name exp))
(var-access-class (field-access-access (access-name exp))))] (not (var-access-static? (field-access-access (access-name exp)))))]
[else 'set!])]) [set-id (gensym 'target-)]
(make-syntax #f `(begin0 [set-val-id (gensym 'val-)]
,expr [op (create-syntax #f (if (eq? op '++) 'add1 'sub1) (build-src key))])
(,setter ,expr ( ,(create-syntax #f (if (eq? op '++) 'add1 'sub1) (build-src key)) (make-syntax
,expr))) #f
(build-src src)))) (cond
[memb-field?
(let ([field-name (id-string (field-access-field (access-name exp)))]
[class-name (var-access-class (field-access-access (access-name exp)))])
`(let* ([,set-id ,(translate-expression (field-access-object (access-name exp)))]
[,set-val-id (,(create-get-name field-name class-name)
,set-id)])
(,(create-set-name field-name class-name) ,set-id (,op ,set-val-id))
,set-val-id))]
[array?
(let ([index-id (gensym 'index-)])
`(let* ([,set-id ,(translate-expression (array-access-name exp))]
[,index-id ,(translate-expression (array-access-index exp))]
[,set-val-id (send ,set-id access ,index-id)])
(send ,set-id set ,index-id (,op ,set-val-id))
,set-val-id))]
[else `(begin0 ,expr (set! ,expr (,op ,expr)))])
(build-src src))))
;converted
;translate-pre-expr: symbol syntax src src -> syntax ;translate-pre-expr: symbol syntax src src -> syntax
(define (translate-pre-expr op expr exp key src) (define (translate-pre-expr op expr exp key src)
(let ([setter (cond (let* ([array? (array-access? exp)]
[(and (field-access? (access-name exp)) [memb-field? (and
(not (var-access-static? (field-access-access (access-name exp))))) (access? exp)
(create-set-name (id-string (field-access-field (access-name exp))) (field-access? (access-name exp))
(var-access-class (field-access-access (access-name exp))))] (not (var-access-static? (field-access-access (access-name exp)))))]
[else 'set!])]) [set-id (gensym 'target-)]
(make-syntax #f [set-val-id (gensym 'val-)]
`(begin [op (create-syntax #f (if (eq? op '++) 'add1 'sub1) (build-src key))])
(,setter ,expr (,(create-syntax #f (if (eq? op '++) 'add1 'sub1) (build-src key)) (make-syntax
,expr)) #f
,expr) (cond
(build-src src)))) [memb-field?
(let ([field-name (id-string (field-access-field (access-name exp)))]
[class-name (var-access-class (field-access-access (access-name exp)))])
`(let* ([,set-id ,(translate-expression (field-access-object (access-name exp)))]
[,set-val-id (,op (,(create-get-name field-name class-name)
,set-id))])
(,(create-set-name field-name class-name) ,set-id ,set-val-id)
,set-val-id))]
[array?
(let ([index-id (gensym 'index-)])
`(let* ([,set-id ,(translate-expression (array-access-name exp))]
[,index-id ,(translate-expression (array-access-index exp))]
[,set-val-id (,op (send ,set-id access ,index-id))])
(send ,set-id set ,index-id ,set-val-id)
,set-val-id))]
[else `(begin (set! ,expr (,op ,expr)) ,expr)])
(build-src src))))
;converted
;translate-unary: symbol syntax src src -> syntax ;translate-unary: symbol syntax src src -> syntax
(define translate-unary (define (translate-unary op expr key src)
(lambda (op expr key src)
(make-syntax #f (case op (make-syntax #f (case op
((-) `(,(create-syntax #f '- (build-src key)) ,expr)) ((-) `(,(create-syntax #f '- (build-src key)) ,expr))
((!) `(,(create-syntax #f 'not (build-src key)) ,expr)) ((!) `(,(create-syntax #f 'not (build-src key)) ,expr))
((~) `(,(create-syntax #f '- (build-src key)) (- ,expr) 1)) ((~) `(,(create-syntax #f '- (build-src key)) (- ,expr) 1))
((+) expr)) ((+) expr))
(build-src src)))) (build-src src)))
;translate-cast: type-spec syntax type src ;translate-cast: type-spec syntax type src
(define (translate-cast type expr expr-type src) (define (translate-cast type expr expr-type src)
@ -3132,8 +3157,11 @@
obj@)]))))) obj@)])))))
(map (apply compose (list id-string local-access-name access-name)) ids) (map (apply compose (list id-string local-access-name access-name)) ids)
(map expr-types ids)))) (map expr-types ids))))
,@(map (lambda (t) `(,t)) ts) (javaRuntime:check-effect (list ,@ts) (list ,@cs)
,@(map (lambda (c) `(,c)) cs)) (quote ,(map checked-info test))
(quote ,(src->list src))
(namespace-variable-value 'current~test~object% #f
(lambda () #f))))
(build-src src)))) (build-src src))))
(require "error-messaging.ss") (require "error-messaging.ss")