Parser bug fix.

++ on fields and arrays bug fix. svn: r10726
2008-07-12 14:29:23 +00:00 · 2008-07-12 14:29:23 +00:00 · c459978d86
commit c459978d86
parent eff5666a39
5 changed files with 116 additions and 62 deletions
--- 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 
--- 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
--- 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)))
--- 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 
--- 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")