diff --git a/collects/combinator-parser/private-combinator/combinator.scm b/collects/combinator-parser/private-combinator/combinator.scm index 3f01dc74e7..2a4a7bad68 100644 --- a/collects/combinator-parser/private-combinator/combinator.scm +++ b/collects/combinator-parser/private-combinator/combinator.scm @@ -447,18 +447,18 @@ (cond [(and (repeat-res? look-back) (fail-type? (repeat-res-stop look-back)) - (> (fail-type-chance (repeat-res-stop look-back)) - (fail-type-chance fail))) + (>= (fail-type-chance (repeat-res-stop look-back)) + (fail-type-chance fail))) (repeat-res-stop look-back)] [(and (choice-res? look-back) (choice-res-errors look-back) - (> (fail-type-chance (choice-res-errors look-back)) - (fail-type-chance fail))) + (>= (fail-type-chance (choice-res-errors look-back)) + (fail-type-chance fail))) (choice-res-errors look-back)] [(and (res? look-back) (fail-type? (res-possible-error look-back)) - (> (fail-type-chance (res-possible-error look-back)) - (fail-type-chance fail))) + (>= (fail-type-chance (res-possible-error look-back)) + (fail-type-chance fail))) (res-possible-error look-back)] [else #f])] [(next-ok?) @@ -505,7 +505,7 @@ (fail-type-name (res-msg old-res)) (and (fail-type? (res-possible-error look-back)) (fail-type-chance (res-possible-error look-back))) (fail-type-chance (res-msg old-res))) - #;(printf "lookback ~a~n" (res-possible-error look-back))) + (printf "lookback ~a~n" (res-possible-error look-back))) (let* ([seq-fail-maker (lambda (fail used) (let-values ([(kind expected found) (get-fail-info fail)]) @@ -532,7 +532,7 @@ #;(when pos-fail (printf "used ~a look-back-ref used ~a ~n" used (when (res? look-back-ref) (res-used look-back-ref))) - #;(printf "opt-fails ~a~n" opt-fails)) + (printf "opt-fails ~a~n" opt-fails)) (if pos-fail (make-options-fail (rank-choice (map fail-type-chance opt-fails)) #f @@ -700,7 +700,7 @@ [choice-names (lambda () (map (lambda (o) (o return-name)) opt-list))]) (opt-lambda (input [last-src (list 0 0 0 0)] [alts 1]) #;(unless (eq? input return-name) (printf "choice ~a~n" name)) - #;(printf "possible options are ~a~n" choice-names) + #;(printf "possible options are ~a~n" (choice-names)) (let ([sub-opts (sub1 (+ alts num-choices))]) (cond [(weak-map-get memo-table input #f) (weak-map-get memo-table input)] diff --git a/collects/combinator-parser/private-combinator/errors.scm b/collects/combinator-parser/private-combinator/errors.scm index 316752c9dd..d581242cb9 100644 --- a/collects/combinator-parser/private-combinator/errors.scm +++ b/collects/combinator-parser/private-combinator/errors.scm @@ -126,12 +126,15 @@ (collapse-message (add-to-message (car messages) name #f message-to-date))] [else - (collapse-message - (add-to-message - (msg (format "An error occured in the ~a. Possible errors were: ~n ~a" - name - (alternate-error-list (map err-msg messages)))) - name #f message-to-date))]))] + (let ([msg (cond + [(apply equal? (map err-src messages)) (lambda (m) (make-err m (err-src (car messages))))] + [else msg])]) + (collapse-message + (add-to-message + (msg (format "An error occured in the ~a. Possible errors were: ~n ~a" + name + (alternate-error-list (map err-msg messages)))) + name #f message-to-date)))]))] [else (fail-type->message (car winners) @@ -223,16 +226,16 @@ (narrow-opts chance-may-use chance-used-winners)] [winners (narrow-opts chance chance-may-winners)]) - #;(printf "all options: ~a~n" (!!list opts-list)) + #;(printf "all options: ~a~n" opts-list) #;(printf "~a ~a ~a ~a ~n" - (map fail-type-name (map !!! (!!list opts-list))) - (map !!! (map fail-type-chance (!!list opts-list))) - (map !!! (map fail-type-used (!!list opts-list))) - (map !!! (map fail-type-may-use (!!list opts-list)))) + (map fail-type-name opts-list) + (map fail-type-chance opts-list) + (map fail-type-used opts-list) + (map fail-type-may-use opts-list)) #;(printf "composite round: ~a ~a ~n" - (map fail-type-name (map !!! composite-winners)) - (map composite (map !!! composite-winners))) - #;(printf "final sorting: ~a~n" (map fail-type-name (map !!! winners))) + (map fail-type-name composite-winners) + (map composite composite-winners)) + #;(printf "final sorting: ~a~n" (map fail-type-name winners)) winners)) (define (first-n n lst) diff --git a/collects/profj/comb-parsers/parser-units.scm b/collects/profj/comb-parsers/parser-units.scm index 2b5eadfcc8..b440b3464f 100644 --- a/collects/profj/comb-parsers/parser-units.scm +++ b/collects/profj/comb-parsers/parser-units.scm @@ -334,7 +334,7 @@ "class instantiation")) (define (new-array type-name) - (sequence (new type-name O_BRACKET expression C_BRACKET (repeat (sequence (O_BRACKET expression C_BRACKET) id))) + (sequence (new type-name O_BRACKET (eta expression) C_BRACKET (repeat (sequence (O_BRACKET (eta expression) C_BRACKET) id))) id "array instantiation")) (define field-access-end @@ -346,7 +346,7 @@ (define (array-init-maker contents) (sequence (O_BRACE (comma-sep contents "array elements") C_BRACE) id "array initializations")) - (define array-init + (define array-init (letrec ([base-init (array-init-maker (eta expression))] [simple-init (array-init-maker (choose ((eta expression) base-init (eta init)) "array initializations"))] @@ -362,13 +362,13 @@ (define simple-method-call (choose ((sequence ((^ identifier) O_PAREN C_PAREN) id) - (sequence ((^ identifier) O_PAREN (comma-sep (eta expression) "arguments sm") C_PAREN) id)) + (sequence ((^ identifier) O_PAREN (comma-sep (eta expression) "arguments") C_PAREN) id)) "method invocation")) (define method-call-end (choose ((sequence (PERIOD (^ identifier) O_PAREN C_PAREN) id) - (sequence (PERIOD (^ identifier) O_PAREN (comma-sep (eta expression) "arguments me") C_PAREN) id)) + (sequence (PERIOD (^ identifier) O_PAREN (comma-sep (eta expression) "arguments") C_PAREN) id)) "method invocation")) (define (assignment asignee op) @@ -937,7 +937,7 @@ (define (statement-c interact?) (if interact? (choose ((return-s #t) - (if-s statement #t) + (if-s (eta statement) #t) (block #t) (for-l (choose ((variable-declaration (array-type (value+name-type prim-type)) expression #t #f "for loop variable") (comma-sep stmt-expr "initializations")) "for loop initialization") @@ -955,7 +955,7 @@ assignment-ops) ) "statement") (choose ((return-s #t) - (if-s statement #t) + (if-s (eta statement) #t) (variable-declaration (array-type (value+name-type prim-type)) (choose (expression array-init) "variable initialization") #t #t "local variable") (block #t) diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index d0b32d1b46..f25663e9cc 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -377,7 +377,7 @@ (lambda (def) (send type-recs set-composite-location (id-string (def-name def)) location)) defs) `(file ,(path->string (build-path (string-append (symbol->string (module-name)) ".ss"))))) - (module-name))) + #`(quote #,(module-name)))) (let* ((translated-defs (map (lambda (d) (cond @@ -1459,7 +1459,7 @@ null) (generate-contract-defs (class-name))) ) - (make-syntax #f `(module ,name mzscheme (require ,(module-name)) ,provides) #f))))) + (make-syntax #f `(module ,name mzscheme (require ,(module-require)) ,provides) #f))))) ;----------------------------------------------------------------------------------------------------------------- ;Member translation functions diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index 7026b25202..8a0989d980 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -400,7 +400,7 @@ [allow-test (when (eq? level 'full) (make-object check-box% (string-constant profj-language-config-support-test-language) testing-prefs (lambda (x y) update-at2)))] - [display-testing + #;[display-testing (make-object check-box% (string-constant profj-language-config-testing-enable) testing-prefs (lambda (x y) (update-dt x y)))] [collect-coverage @@ -565,8 +565,8 @@ (send allow-testing get-value)) (and (eq? level 'full) (send allow-test get-value)) - (send display-testing get-value) - (and (send display-testing get-value) + #t #;(send display-testing get-value) + (and #t #;(send display-testing get-value) (send collect-coverage get-value)) (get-classpath))] [(settings) @@ -581,8 +581,8 @@ (send allow-testing set-value (profj-settings-allow-check? settings))) (when (eq? level 'full) (send allow-test set-value (profj-settings-allow-test? settings))) - (send display-testing set-value (profj-settings-run-tests? settings)) - (if (send display-testing get-value) + #;(send display-testing set-value (profj-settings-run-tests? settings)) + (if #t #;(send display-testing get-value) (send collect-coverage set-value (profj-settings-coverage? settings)) (send collect-coverage enable #f)) (install-classpath (profj-settings-classpath settings))]))) diff --git a/collects/tests/profj/advanced-tests.ss b/collects/tests/profj/advanced-tests.ss index 5ad84ffd8d..f3aa86c02b 100644 --- a/collects/tests/profj/advanced-tests.ss +++ b/collects/tests/profj/advanced-tests.ss @@ -437,7 +437,7 @@ class WeeklyPlanner{ (interact-test 'advanced (list "(new int[2][])[0]") - (list null) + (list #\null) "multi-dimension array - not all intialized") (interact-test @@ -463,7 +463,7 @@ class WeeklyPlanner{ 'advanced (list "int[] x = new int[2];" "boolean[] y = new boolean[2];" "char[] z = new char[2];" "Object[] o = new Object[2];" "x[0]" "y[0]" "z[0]" "o[0]") - (list '(void) '(void) '(void) '(void) 0 #f #\null null) + (list '(void) '(void) '(void) '(void) 0 #f #\null #\null) "Array initialization checks") (interact-test