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

Fixes to v4 errors discovered in test suite;

Browse Source 
Fixes to undefined errors in parser;
Tweak to error selection in parser;
Removal of irrelevant preference in ProfJ Tool

svn: r9536
This commit is contained in:
Kathy Gray 2008-04-29 16:07:47 +00:00
parent c71192136e
commit 6a1b99a74f
6 changed files with 41 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -447,17 +447,17 @@
(cond (cond
[(and (repeat-res? look-back) [(and (repeat-res? look-back)
(fail-type? (repeat-res-stop look-back)) (fail-type? (repeat-res-stop look-back))
(> (fail-type-chance (repeat-res-stop look-back)) (>= (fail-type-chance (repeat-res-stop look-back))
(fail-type-chance fail))) (fail-type-chance fail)))
(repeat-res-stop look-back)] (repeat-res-stop look-back)]
[(and (choice-res? look-back) [(and (choice-res? look-back)
(choice-res-errors look-back) (choice-res-errors look-back)
(> (fail-type-chance (choice-res-errors look-back)) (>= (fail-type-chance (choice-res-errors look-back))
(fail-type-chance fail))) (fail-type-chance fail)))
(choice-res-errors look-back)] (choice-res-errors look-back)]
[(and (res? look-back) [(and (res? look-back)
(fail-type? (res-possible-error look-back)) (fail-type? (res-possible-error look-back))
(> (fail-type-chance (res-possible-error look-back)) (>= (fail-type-chance (res-possible-error look-back))
(fail-type-chance fail))) (fail-type-chance fail)))
(res-possible-error look-back)] (res-possible-error look-back)]
[else #f])] [else #f])]
@ -505,7 +505,7 @@
(fail-type-name (res-msg old-res)) (fail-type-name (res-msg old-res))
(and (fail-type? (res-possible-error look-back)) (fail-type-chance (res-possible-error look-back))) (and (fail-type? (res-possible-error look-back)) (fail-type-chance (res-possible-error look-back)))
(fail-type-chance (res-msg old-res))) (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 (let* ([seq-fail-maker
(lambda (fail used) (lambda (fail used)
(let-values ([(kind expected found) (get-fail-info fail)]) (let-values ([(kind expected found) (get-fail-info fail)])
@ -532,7 +532,7 @@
#;(when pos-fail #;(when pos-fail
(printf "used ~a look-back-ref used ~a ~n" (printf "used ~a look-back-ref used ~a ~n"
used (when (res? look-back-ref) (res-used look-back-ref))) 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 (if pos-fail
(make-options-fail (rank-choice (map fail-type-chance opt-fails)) (make-options-fail (rank-choice (map fail-type-chance opt-fails))
#f #f
@ -700,7 +700,7 @@
[choice-names (lambda () (map (lambda (o) (o return-name)) opt-list))]) [choice-names (lambda () (map (lambda (o) (o return-name)) opt-list))])
(opt-lambda (input [last-src (list 0 0 0 0)] [alts 1]) (opt-lambda (input [last-src (list 0 0 0 0)] [alts 1])
#;(unless (eq? input return-name) (printf "choice ~a~n" name)) #;(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))]) (let ([sub-opts (sub1 (+ alts num-choices))])
(cond (cond
[(weak-map-get memo-table input #f) (weak-map-get memo-table input)] [(weak-map-get memo-table input #f) (weak-map-get memo-table input)]

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

@ -126,12 +126,15 @@
(collapse-message (collapse-message
(add-to-message (car messages) name #f message-to-date))] (add-to-message (car messages) name #f message-to-date))]
[else [else
(let ([msg (cond
[(apply equal? (map err-src messages)) (lambda (m) (make-err m (err-src (car messages))))]
[else msg])])
(collapse-message (collapse-message
(add-to-message (add-to-message
(msg (format "An error occured in the ~a. Possible errors were: ~n ~a" (msg (format "An error occured in the ~a. Possible errors were: ~n ~a"
name name
(alternate-error-list (map err-msg messages)))) (alternate-error-list (map err-msg messages))))
name #f message-to-date))]))] name #f message-to-date)))]))]
[else [else
(fail-type->message (fail-type->message
(car winners) (car winners)
@ -223,16 +226,16 @@
(narrow-opts chance-may-use chance-used-winners)] (narrow-opts chance-may-use chance-used-winners)]
[winners (narrow-opts chance chance-may-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" #;(printf "~a ~a ~a ~a ~n"
(map fail-type-name (map !!! (!!list opts-list))) (map fail-type-name opts-list)
(map !!! (map fail-type-chance (!!list opts-list))) (map fail-type-chance opts-list)
(map !!! (map fail-type-used (!!list opts-list))) (map fail-type-used opts-list)
(map !!! (map fail-type-may-use (!!list opts-list)))) (map fail-type-may-use opts-list))
#;(printf "composite round: ~a ~a ~n" #;(printf "composite round: ~a ~a ~n"
(map fail-type-name (map !!! composite-winners)) (map fail-type-name composite-winners)
(map composite (map !!! composite-winners))) (map composite composite-winners))
#;(printf "final sorting: ~a~n" (map fail-type-name (map !!! winners))) #;(printf "final sorting: ~a~n" (map fail-type-name winners))
winners)) winners))
(define (first-n n lst) (define (first-n n lst)

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

@ -334,7 +334,7 @@
"class instantiation")) "class instantiation"))
(define (new-array type-name) (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")) id "array instantiation"))
(define field-access-end (define field-access-end
@ -362,13 +362,13 @@
(define simple-method-call (define simple-method-call
(choose (choose
((sequence ((^ identifier) O_PAREN C_PAREN) id) ((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")) "method invocation"))
(define method-call-end (define method-call-end
(choose (choose
((sequence (PERIOD (^ identifier) O_PAREN C_PAREN) id) ((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")) "method invocation"))
(define (assignment asignee op) (define (assignment asignee op)
@ -937,7 +937,7 @@
(define (statement-c interact?) (define (statement-c interact?)
(if interact? (if interact?
(choose ((return-s #t) (choose ((return-s #t)
(if-s statement #t) (if-s (eta statement) #t)
(block #t) (block #t)
(for-l (choose ((variable-declaration (array-type (value+name-type prim-type)) expression #t #f "for loop variable") (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") (comma-sep stmt-expr "initializations")) "for loop initialization")
@ -955,7 +955,7 @@
assignment-ops) assignment-ops)
) "statement") ) "statement")
(choose ((return-s #t) (choose ((return-s #t)
(if-s statement #t) (if-s (eta statement) #t)
(variable-declaration (array-type (value+name-type prim-type)) (variable-declaration (array-type (value+name-type prim-type))
(choose (expression array-init) "variable initialization") #t #t "local variable") (choose (expression array-init) "variable initialization") #t #t "local variable")
(block #t) (block #t)

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

@ -377,7 +377,7 @@
(lambda (def) (send type-recs set-composite-location (id-string (def-name def)) location)) (lambda (def) (send type-recs set-composite-location (id-string (def-name def)) location))
defs) defs)
`(file ,(path->string (build-path (string-append (symbol->string (module-name)) ".ss"))))) `(file ,(path->string (build-path (string-append (symbol->string (module-name)) ".ss")))))
(module-name))) #`(quote #,(module-name))))
(let* ((translated-defs (let* ((translated-defs
(map (lambda (d) (map (lambda (d)
(cond (cond
@ -1459,7 +1459,7 @@
null) null)
(generate-contract-defs (class-name))) (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 ;Member translation functions

10
collects/profj/tool.ss
View File

@ -400,7 +400,7 @@
[allow-test (when (eq? level 'full) [allow-test (when (eq? level 'full)
(make-object check-box% (string-constant profj-language-config-support-test-language) (make-object check-box% (string-constant profj-language-config-support-test-language)
testing-prefs (lambda (x y) update-at2)))] testing-prefs (lambda (x y) update-at2)))]
[display-testing #;[display-testing
(make-object check-box% (string-constant profj-language-config-testing-enable) (make-object check-box% (string-constant profj-language-config-testing-enable)
testing-prefs (lambda (x y) (update-dt x y)))] testing-prefs (lambda (x y) (update-dt x y)))]
[collect-coverage [collect-coverage
@ -565,8 +565,8 @@
(send allow-testing get-value)) (send allow-testing get-value))
(and (eq? level 'full) (and (eq? level 'full)
(send allow-test get-value)) (send allow-test get-value))
(send display-testing get-value) #t #;(send display-testing get-value)
(and (send display-testing get-value) (and #t #;(send display-testing get-value)
(send collect-coverage get-value)) (send collect-coverage get-value))
(get-classpath))] (get-classpath))]
[(settings) [(settings)
@ -581,8 +581,8 @@
(send allow-testing set-value (profj-settings-allow-check? settings))) (send allow-testing set-value (profj-settings-allow-check? settings)))
(when (eq? level 'full) (when (eq? level 'full)
(send allow-test set-value (profj-settings-allow-test? settings))) (send allow-test set-value (profj-settings-allow-test? settings)))
(send display-testing set-value (profj-settings-run-tests? settings)) #;(send display-testing set-value (profj-settings-run-tests? settings))
(if (send display-testing get-value) (if #t #;(send display-testing get-value)
(send collect-coverage set-value (profj-settings-coverage? settings)) (send collect-coverage set-value (profj-settings-coverage? settings))
(send collect-coverage enable #f)) (send collect-coverage enable #f))
(install-classpath (profj-settings-classpath settings))]))) (install-classpath (profj-settings-classpath settings))])))

4
collects/tests/profj/advanced-tests.ss
View File

@ -437,7 +437,7 @@ class WeeklyPlanner{
(interact-test (interact-test
'advanced 'advanced
(list "(new int[2][])[0]") (list "(new int[2][])[0]")
(list null) (list #\null)
"multi-dimension array - not all intialized") "multi-dimension array - not all intialized")
(interact-test (interact-test
@ -463,7 +463,7 @@ class WeeklyPlanner{
'advanced 'advanced
(list "int[] x = new int[2];" "boolean[] y = new boolean[2];" "char[] z = new char[2];" (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]") "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") "Array initialization checks")
(interact-test (interact-test