diff --git a/collects/combinator-parser/private-combinator/combinator.scm b/collects/combinator-parser/private-combinator/combinator.scm index 2a4a7bad68..134a1e9616 100644 --- a/collects/combinator-parser/private-combinator/combinator.scm +++ b/collects/combinator-parser/private-combinator/combinator.scm @@ -222,7 +222,8 @@ (map (lambda (rst) (next-res old-answer new-id old-used tok rst)) (flatten (correct-list 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))))] [(repeat-res? rsts) (next-res old-answer new-id old-used tok rsts)] @@ -335,7 +336,7 @@ (map (lambda (rst) (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))) rsts)]) (fail-res input @@ -385,6 +386,21 @@ (rank-choice (map fail-type-may-use 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 (define (sequence-error-gen name len) (letrec ([repeat->res @@ -424,14 +440,16 @@ stop) (res-first-tok 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) (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))) (repeat->res (car old-res) look-back)] [(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) #;(printf "finished on repeat-res for ~a res ~n" name #;old-res) (repeat->res old-res look-back)] @@ -517,7 +535,7 @@ name used (+ used (fail-type-may-use fail) next-used) id kind (reverse seen) expected found - (and (res? prev) (res-a prev) (res-msg prev)) + prev prev-name)))] [seq-fail (seq-fail-maker fail used)] [pos-fail diff --git a/collects/combinator-parser/private-combinator/errors.scm b/collects/combinator-parser/private-combinator/errors.scm index d581242cb9..9a270f0ca5 100644 --- a/collects/combinator-parser/private-combinator/errors.scm +++ b/collects/combinator-parser/private-combinator/errors.scm @@ -56,17 +56,19 @@ (collapse-message (add-to-message (msg - (cond - [(sequence-fail-repeat? fail-type) - (format "Found a repitition of ~a; the required number are present. Expected ~a ~a next." - (sequence-fail-last-seen fail-type) a2 expected)] - [(null? show-sequence) - (format "Expected ~a ~a to begin this ~a, instead found ~a." - a2 expected id-name (input->output-name (sequence-fail-found fail-type)))] - [else - (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))])) + (let* ([poss-repeat ((sequence-fail-repeat? fail-type))] + [repeat? (and (res? poss-repeat) (res-a poss-repeat) (res-msg poss-repeat))]) + (cond + [repeat? + (format "Found a repitition of ~a; the required number are present. Expected ~a ~a next." + (sequence-fail-last-seen fail-type) a2 expected)] + [(null? show-sequence) + (format "Expected ~a ~a to begin this ~a, instead found ~a." + a2 expected id-name (input->output-name (sequence-fail-found fail-type)))] + [else + (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))] [(misscase) (collapse-message diff --git a/collects/combinator-parser/private-combinator/structs.scm b/collects/combinator-parser/private-combinator/structs.scm index 7344dc7261..c69894a66e 100644 --- a/collects/combinator-parser/private-combinator/structs.scm +++ b/collects/combinator-parser/private-combinator/structs.scm @@ -27,7 +27,7 @@ ;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) ;make-choice-res string (listof res) fail-type) (define-struct choice-res (name matches errors) #:transparent) @@ -38,6 +38,11 @@ ;(make-lazy-choice (listof res) fail-type (listof (_ -> res)) string) (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) (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))) diff --git a/collects/profj/libs/java/runtime.ss b/collects/profj/libs/java/runtime.ss index 9330984e0d..ba55f28440 100644 --- a/collects/profj/libs/java/runtime.ss +++ b/collects/profj/libs/java/runtime.ss @@ -14,7 +14,7 @@ (provide convert-to-string shift not-equal bitwise mod divide-dynamic divide-int divide-float and or cast-primitive cast-reference instanceof-array nullError check-eq? dynamic-equal? compare compare-within check-catch check-mutate check-by - compare-rand) + compare-rand check-effect) (define (check-eq? obj1 obj2) (or (eq? obj1 obj2) @@ -347,9 +347,10 @@ result-value))) ;check-effects: (-> (listof val)) (-> (listof val)) (list string) src object -> boolean - (define (check-effects tests checks info src test-obj) - (tests) - (checks)) + (define (check-effect tests checks info src test-obj) + (let ([app (lambda (thunk) (thunk))]) + (for-each app tests) + (andmap app checks))) (define (report-check-result res check-kind info values src test-obj) (when test-obj diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index 01944ffbcf..609eb222ba 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -2830,60 +2830,85 @@ ,(type-spec-dim type)) (build-src (type-spec-src type)))) - ;converted ;translate-array-access: syntax syntax src -> syntax - (define translate-array-access - (lambda (array index src) - (make-syntax #f `(send ,array access ,index) - (build-src src)))) + (define (translate-array-access array index src) + (make-syntax #f `(send ,array access ,index) + (build-src src))) - ;converted ;translate-cond: syntax syntax syntax src -> syntax - (define translate-cond - (lambda (if? then else src) - (make-syntax #f `(if ,if? ,then ,else) (build-src src)))) + (define (translate-cond if? then else src) + (make-syntax #f `(if ,if? ,then ,else) (build-src src))) - ;converted ;translate-post-expr: syntax expression symbol src src -> syntax (define (translate-post-expr expr exp op key src) - (let ([setter (cond - [(and (field-access? (access-name exp)) - (not (var-access-static? (field-access-access (access-name exp))))) - (create-set-name (id-string (field-access-field (access-name exp))) - (var-access-class (field-access-access (access-name exp))))] - [else 'set!])]) - (make-syntax #f `(begin0 - ,expr - (,setter ,expr ( ,(create-syntax #f (if (eq? op '++) 'add1 'sub1) (build-src key)) - ,expr))) - (build-src src)))) + (let* ([array? (array-access? exp)] + [memb-field? (and + (access? exp) + (field-access? (access-name exp)) + (not (var-access-static? (field-access-access (access-name exp)))))] + [set-id (gensym 'target-)] + [set-val-id (gensym 'val-)] + [op (create-syntax #f (if (eq? op '++) 'add1 'sub1) (build-src key))]) + (make-syntax + #f + (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 (define (translate-pre-expr op expr exp key src) - (let ([setter (cond - [(and (field-access? (access-name exp)) - (not (var-access-static? (field-access-access (access-name exp))))) - (create-set-name (id-string (field-access-field (access-name exp))) - (var-access-class (field-access-access (access-name exp))))] - [else 'set!])]) - (make-syntax #f - `(begin - (,setter ,expr (,(create-syntax #f (if (eq? op '++) 'add1 'sub1) (build-src key)) - ,expr)) - ,expr) - (build-src src)))) + (let* ([array? (array-access? exp)] + [memb-field? (and + (access? exp) + (field-access? (access-name exp)) + (not (var-access-static? (field-access-access (access-name exp)))))] + [set-id (gensym 'target-)] + [set-val-id (gensym 'val-)] + [op (create-syntax #f (if (eq? op '++) 'add1 'sub1) (build-src key))]) + (make-syntax + #f + (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 (,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 - (define translate-unary - (lambda (op expr key src) + (define (translate-unary op expr key src) (make-syntax #f (case op ((-) `(,(create-syntax #f '- (build-src key)) ,expr)) ((!) `(,(create-syntax #f 'not (build-src key)) ,expr)) ((~) `(,(create-syntax #f '- (build-src key)) (- ,expr) 1)) ((+) expr)) - (build-src src)))) + (build-src src))) ;translate-cast: type-spec syntax type src (define (translate-cast type expr expr-type src) @@ -3132,8 +3157,11 @@ obj@)]))))) (map (apply compose (list id-string local-access-name access-name)) ids) (map expr-types ids)))) - ,@(map (lambda (t) `(,t)) ts) - ,@(map (lambda (c) `(,c)) cs)) + (javaRuntime:check-effect (list ,@ts) (list ,@cs) + (quote ,(map checked-info test)) + (quote ,(src->list src)) + (namespace-variable-value 'current~test~object% #f + (lambda () #f)))) (build-src src)))) (require "error-messaging.ss")