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

From :svn merge r3228:3451. Branch to add additional testing extensions for

Browse Source 
full Java

svn: r3452
This commit is contained in:
Kathy Gray 2006-06-23 20:33:19 +00:00
parent b1251209df
commit b1b2919d1b
19 changed files with 915 additions and 152 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/profj/ast.ss
View File

@ -45,12 +45,18 @@
;;(make-interface-def header (list member) src src string symbol (list req) symbol)
(p-define-struct (interface-def def) ())
;(make-test-def test-header (list member) src src string symbol (list req) symbol)
(p-define-struct (test-def def) ())
;;(make-req string (list string))
(p-define-struct req (class path))
;;(make-header id (list modifier) (list name) (list name) (list gj-info) src)
(p-define-struct header (id modifiers extends implements type-parms src))
;;(make-test-header id (list modifier) (list name) (list name) (list gj-info) src (list name))
(p-define-struct (test-header header) (tests))
;;(make-modifier symbol src)
(p-define-struct modifier (kind src))
@ -89,6 +95,9 @@
;;(make-method (list modifier) type-spec null id (list var-decl) (list name) Statement bool method-record src)
(p-define-struct method (modifiers type type-parms name parms throws body all-tail? rec src))
;;(make-test-method (list modifier) type-spec null id (list var-decl) (list name) Statement bool method-record src)
(p-define-struct (test-method method) ())
;;(make-initialize bool block src)
(p-define-struct initialize (static block src))
@ -282,8 +291,16 @@
(p-define-struct (assignment expr) (left op right key-src))
;Op -> = *= /= %= += -= <<= >>= >>>= &= ^= or=
;(make-check (U #f type) src Expression Expression (U #f Expression) src)
(p-define-struct (check expr) (test actual range ta-src))
(p-define-struct (check expr) ())
;(make-check-expect (U #f type) src Expression Expression (U #f Expression) src)
(p-define-struct (check-expect check) (test actual range ta-src))
;(make-check-catch (U #f type) src Expression type-spec)
(p-define-struct (check-catch check) (test exn))
;(make-check-mutate (U #f type) src Expression Expression src)
(p-define-struct (check-mutate check) (mutate check op-src))
)

247
collects/profj/build-info.ss
View File

@ -74,10 +74,14 @@
(list (id-string (name-id (package-name prog)))))
null))
(lang-pack `("java" "lang"))
(test-pack `("java" "tester"))
(lang (filter (lambda (class)
(not (forbidden-lang-class? class level)))
(send type-recs get-package-contents lang-pack
(lambda () (error 'type-recs "Internal error: Type record not set with lang")))))
(tester (when (testcase-ext?)
(send type-recs get-package-contents test-pack
(lambda () null))))
(defs (let loop ((cur-defs (package-defs prog)))
(cond
((null? cur-defs) null)
@ -88,7 +92,7 @@
(loop (cdr cur-defs))))))
(current-loc (cond
((not (null? defs)) (def-file (car defs)))
((not (null? (package-imports prog)))
((not (null? (package-imports prog)))
(import-file (car (package-imports prog)))))))
(set-package-defs! prog defs)
@ -97,6 +101,10 @@
(for-each (lambda (class) (send type-recs add-class-req (cons class lang-pack) #f current-loc)) lang)
(send type-recs add-class-req (list 'array) #f current-loc)
{when (testcase-ext?)
(for-each (lambda (class) (send type-recs add-to-env class test-pack current-loc)) tester)
(for-each (lambda (class) (send type-recs add-class-req (cons class test-pack) #f current-loc)) tester)}
;Set location for type error messages
(build-info-location current-loc)
@ -402,34 +410,48 @@
;load-lang: type-records -> void (adds lang to type-recs)
(define (load-lang type-recs)
(let* ((lang `("java" "lang"))
(dir (find-directory lang (lambda () (error 'load-lang "Internal-error: Lang not accessible"))))
(class-list (map (lambda (fn) (substring fn 0 (- (string-length fn) 6)))
(map path->string
(filter (lambda (f) (equal? (filename-extension f) #"jinfo"))
(directory-list (build-path (dir-path-path dir) "compiled"))))))
(array (datum->syntax-object #f `(lib "array.ss" "profj" "libs" "java" "lang") #f)))
;(printf "class-list ~a~n" class-list)
(send type-recs add-package-contents lang class-list)
(for-each (lambda (c) (import-class c lang dir #f type-recs 'full #f #f)) class-list)
(send type-recs add-require-syntax (list 'array) (list array array))
;Add lang to interactions environment
(for-each (lambda (class) (send type-recs add-to-env class lang 'interactions)) class-list)
(send type-recs set-location! 'interactions)
(for-each (lambda (class) (send type-recs add-class-req (cons class lang) #f 'interactions)) class-list)
(send type-recs add-class-req (list 'array) #f 'interactions)
))
(test '("java" "tester"))
(lang-dir (find-directory lang (lambda () (error 'load-lang "Internal-error: Lang not accessible"))))
(test-dir (when (testcase-ext?)
(find-directory test (lambda () (error 'load-lang "Internal-error: Test not accessible")))))
(get-classes
(lambda (base-dir)
(map (lambda (fn) (substring fn 0 (- (string-length fn) 6)))
(map path->string
(filter (lambda (f) (equal? (filename-extension f) #"jinfo"))
(directory-list (build-path (dir-path-path base-dir) "compiled")))))))
(lang-classes (get-classes lang-dir))
(test-classes (when (testcase-ext?) (get-classes test-dir)))
(array (datum->syntax-object #f `(lib "array.ss" "profj" "libs" "java" "lang") #f))
(add
(lambda (path classes dir array?)
#;(printf "class-list ~a~n" classes)
(send type-recs add-package-contents path classes)
(for-each (lambda (c) (import-class c path dir #f type-recs 'full #f #f)) classes)
(when array? (send type-recs add-require-syntax (list 'array) (list array array)))
;Add lang to interactions environment
(for-each (lambda (class) (send type-recs add-to-env class path 'interactions)) classes)
(send type-recs set-location! 'interactions)
(for-each (lambda (class) (send type-recs add-class-req (cons class path) #f 'interactions))
classes)
(when array? (send type-recs add-class-req (list 'array) #f 'interactions)))))
(add lang lang-classes lang-dir #t)
(when (testcase-ext?) (add test test-classes test-dir #f))))
;------------------------------------------------------------------------------------
;Functions for processing classes and interfaces
;; process-class/iface: (U class-def interface-def) (list string) type-records bool bool symbol -> class-record
;; process-class/iface: (U class-def interface-def test-def) (list string) type-records bool bool symbol -> class-record
(define (process-class/iface ci package-name type-recs look-in-table put-in-table level)
(cond
((interface-def? ci)
(process-interface ci package-name type-recs look-in-table put-in-table level))
((class-def? ci)
(process-class ci package-name type-recs look-in-table put-in-table level))))
[(interface-def? ci)
(process-interface ci package-name type-recs look-in-table put-in-table level)]
[(class-def? ci)
(process-class ci package-name type-recs look-in-table put-in-table level)]
[(test-def? ci)
(process-test ci package-name type-recs look-in-table put-in-table level)]))
;;get-parent-record: (list string) name (list string) type-records (list string) -> record
(define (get-parent-record name n child-name level type-recs)
@ -535,9 +557,9 @@
(let*-values (((old-methods) (class-record-methods super-record))
((f m i)
(if (memq 'strictfp test-mods)
(process-members members old-methods cname type-recs level
(process-members members old-methods cname type-recs level #f
(find-strictfp modifiers))
(process-members members old-methods cname type-recs level)))
(process-members members old-methods cname type-recs level #f)))
((ctor?) (has-ctor? m)))
(unless ctor?
@ -744,7 +766,7 @@
(let-values (((f m i) (process-members members (apply append
(map class-record-methods super-records))
iname type-recs level)))
iname type-recs level #f)))
(valid-field-names? f members m level type-recs)
(valid-method-sigs? m members level type-recs)
@ -776,6 +798,116 @@
(get-record (send type-recs get-class-record iname #f build-record) type-recs)
(build-record)))))
;process-test: def-test (list string) type-records boolean? boolean? symbol -> class-record
(define (process-test test package-name type-recs look-in-table? put-in-table? level)
(let* ((info (def-header test))
(test-base '("TestBase" "java" "tester"))
(tname (cons (id-string (header-id info)) package-name)))
(send type-recs set-location! (def-file test))
(let ((build-record
(lambda ()
(when put-in-table? (send type-recs add-to-records tname 'in-progress))
(let* ((super (if (null? (header-extends info)) null (car (header-extends info))))
(super-name (if (null? super)
test-base
(if (null? (name-path super))
(cons (id-string (name-id super))
(send type-recs lookup-path (id-string (name-id super)) (lambda () null)))
(name->list super))))
(super-record (get-parent-record super-name super tname level type-recs))
(members (def-members test))
(super-req ((lambda (name-list)
(if (= (length name-list) 1)
(make-req (car name-list)
(send type-recs lookup-path (car name-list) (lambda () null)))
(make-req (car name-list) (cdr name-list))))
super-name))
(old-loc (send type-recs get-location)))
(send type-recs set-location! (def-file test))
(set-def-uses! test
(remove-dup-reqs
(cons super-req (get-method-reqs (class-record-methods super-record)))))
(unless (and (class-record-class? super-record)
(or (equal? super-name test-base)
(member test-base (class-record-parents super-record))))
(test-extension-error (class-record-class? super-record)
(header-id info)
super
(name-src super)))
(let*-values (((old-methods) (class-record-methods super-record))
((f m i)
(process-members members old-methods tname type-recs level #t))
((ctor?) (has-ctor? m)))
(if ctor?
(unless (= 0 (length (filter (lambda (m)
(and (eq? 'ctor (method-record-rtype m))
(null? (method-record-atypes m))
(not (memq 'private (method-record-modifiers m)))
(not (memq 'protected (method-record-modifiers m)))))
m)))
(test-not-visible-ctor-error (header-id info) (def-src test)))
(add-ctor test
(lambda (rec) (set! m (cons rec m))) old-methods (header-id info) level))
(valid-field-names? (if (memq level '(beginner intermediate advanced))
(append f (class-record-fields super-record)) f)
members m level type-recs)
(valid-method-sigs? m members level type-recs)
(and (class-fully-implemented? super-record super null null
m type-recs level)
(no-abstract-methods m members level type-recs))
(valid-inherited-methods? (cons super-record null)
(cons (if (null? super)
(make-name (make-id "Test" #f)
(list (make-id "java" #f)
(make-id "test" #f)) #f)
super) null)
level
type-recs)
(check-current-methods (cons super-record null)
m
members
level
type-recs)
(let ((record
(make-class-record
tname (header-modifiers info) #t #t
(append f (filter class-specific-field? (class-record-fields super-record)))
(append m (filter (lambda (meth)
(class-specific-method? meth m))
(class-record-methods super-record)))
(append i (filter (lambda (i-r)
(not (memq 'private (inner-record-modifiers i-r))))
(class-record-inners super-record)))
(cons super-name (class-record-parents super-record))
null)))
(when put-in-table?
(send type-recs add-class-record record)
(send type-recs add-test-class (car tname))
)
(for-each (lambda (member)
(when (def? member)
(process-class/iface member package-name type-recs #f put-in-table? level)))
members)
(send type-recs set-location! old-loc)
record))))))
(cond
((class-record? (send type-recs get-class-record tname)) =>
(lambda (rec) rec))
(look-in-table?
(get-record (send type-recs get-class-record tname #f build-record) type-recs))
(else (build-record))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Code to check for conflicts in method/field/class naming (including types)
@ -878,7 +1010,7 @@
(find-member member-record (cdr members) level type-recs))))
(else
(find-member member-record (cdr members) level type-recs))))
;valid-method-sigs? (list method-record) (list member) symbol type-records -> bool
(define (valid-method-sigs? methods members level type-recs)
(or (null? methods)
@ -1187,9 +1319,9 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Methods to process fields and methods
;; process-members: (list members) (list method-record) (list string) type-records symbol ->
;; process-members: (list members) (list method-record) (list string) type-records symbol boolean->
;; (values (list field-record) (list method-record) (list inner-record))
(define (process-members members inherited-methods cname type-recs level . args)
(define (process-members members inherited-methods cname type-recs level test? . args)
(let loop ((members members)
(fields null)
(methods null)
@ -1205,8 +1337,8 @@
(loop (cdr members)
fields
(cons (if (null? args)
(process-method (car members) inherited-methods cname type-recs level)
(process-method (car members) inherited-methods cname type-recs level (car args)))
(process-method (car members) inherited-methods cname type-recs level test?)
(process-method (car members) inherited-methods cname type-recs level test? (car args)))
methods)
inners))
((def? (car members))
@ -1229,8 +1361,8 @@
(if (class-name) (cons (class-name) (cdr cname)) cname)
(field-type field)))
;; process-method: method (list method-record) (list string) type-records symbol -> method-record
(define (process-method method inherited-methods cname type-recs level . args)
;; process-method: method (list method-record) (list string) type-records symbol boolean -> method-record
(define (process-method method inherited-methods cname type-recs level test? . args)
(let* ((name (id-string (method-name method)))
(parms (map (lambda (p)
(set-field-type! p (type-spec-to-type (field-type-spec p) cname level type-recs))
@ -1250,6 +1382,11 @@
(method-throws method))))
(over? (overrides? name parms inherited-methods)))
(when (test-method? method)
(unless test? (testcase-not-in-test name (car cname) (id-src (method-name method))))
(unless (null? parms) (testcase-args-error name (car cname) (id-src (method-name method))))
(unless (eq? 'boolean ret) (testcase-ret-error name (car cname) ret (id-src (method-name method)))))
(when (and (memq level '(beginner intermediate))
(member name (map method-record-name inherited-methods))
(not over?))
@ -1577,7 +1714,28 @@
((implement-class)
(format "Only interfaces may be implemented, class ~a has attempted to implement class ~a." n s)))
s src)))
;test-extension-error: boolean id name src -> void
(define (test-extension-error class? name super src)
(let ([n (id->ext-name name)]
[s (id->ext-name (name-id super))])
(raise-error
'extends
(if class?
(format "Tests may only extend other tests.~nFound ~a, which is not a test and cannot be the parent of test ~a."
s n)
(format "Tests may not extend interfaces. Found interface ~a for test ~a." s n))
'extends src)))
;test-not-visible-ctor-error: id src -> void
(define (test-not-visible-ctor-error name src)
(raise-error
'test
(format
"Tests must have a non-private constructor expecting no arguments. ~a does not have a matching constructor."
(id->ext-name name))
'test src))
;method-error: symbol id (list type) type string src bool -> void
(define (method-error kind name parms ret class src ctor?)
(if (eq? kind 'inherited-conflict-field)
@ -1610,6 +1768,27 @@
m-full-name class r-name (type->ext-name ctor?))))
m-name src))))
;testcase-not-in-test: string string src -> void
(define (testcase-not-in-test name class src)
(raise-error
'testcase
(format "Testcase ~a may not appear in class ~a. Testcases may only occur in tests." name class)
'testcase src))
;testcase-args-error: string string src -> void
(define (testcase-args-error name class src)
(raise-error 'testcase
(format "A testcase cannot require parameters. testcase ~a in ~a specifies arguments."
name class)
'testcase src))
;testcase-ret-error: string string type src -> void
(define (testcase-ret-error name class ret src)
(raise-error 'testcase
(format "A testcase must return a boolean. testcase ~a from ~a returns a ~a instead."
name class (type->ext-name ret))
'testcase src))
;inherited-overload-error: string string (list type) (list type) src -> void
(define (inherited-overload-error curr-class name new-type inherit-type src)
(let* ((n (string->symbol name))

120
collects/profj/check.ss
View File

@ -265,9 +265,13 @@
(lambda ()
(error 'check-defs
"Internal error: Current def does not have a record entry")))))
(if (interface-def? def)
(check-interface def package-name (def-level def) type-recs)
(check-class def package-name (def-level def) type-recs empty-env)))
(cond
((interface-def? def)
(check-interface def package-name (def-level def) type-recs))
((class-def? def)
(check-class def package-name (def-level def) type-recs empty-env))
((test-def? def)
(check-test def package-name (def-level def) type-recs empty-env))))
(packages (cons def (packages)))
(when (not (null? (check-list)))
(check-defs (car (check-list)) level type-recs)))
@ -336,6 +340,18 @@
(set-def-uses! class (send type-recs get-class-reqs))
(update-class-with-inner old-update)
(send type-recs set-class-reqs old-reqs)))
;check-test: test-def (list string) symbol type-recs -> void
(define (check-test test package-name level type-recs env)
(unless (null? (test-header-tests (def-header test)))
(for-each (lambda (test-class)
(unless (type-exists? (id-string (name-id test-class))
(map id-string (name-path test-class))
#f (name-src test-class)
level type-recs)
(tested-not-found (def-name test) test-class (name-src test-class))))
(test-header-tests (def-header test))))
(check-class test package-name level type-recs env))
;check-interface: interface-def (list string) symbol type-recs -> void
(define (check-interface iface p-name level type-recs)
@ -400,6 +416,14 @@
(eq? (var-type-properties type-var) final-method-var)))
(environment-types env)))))
;tested-not-found: id name src -> void
(define (tested-not-found test class src)
(raise-error
'tests
(format "test ~a does not test class ~a, as the class cannot be found."
(id->ext-name test) (path->ext (name->path class)))
'tests src))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Member checking methods
@ -1512,15 +1536,9 @@
env)))
((check? exp)
(set-expr-type exp
(check-test-expr (check-test exp)
(check-actual exp)
(check-range exp)
check-sub-expr
env
level
(check-ta-src exp)
(expr-src exp)
type-recs)))
(check-test-exprs exp
check-sub-expr
env level type-recs)))
)))
;;check-bin-op: symbol exp exp (exp env -> type/env) env src-loc symbol type-records -> type/env
@ -2676,8 +2694,34 @@
(and (special-name? expr)
(equal? "this" (special-name-name expr))))
;check-test-exprs: exp (exp env -> type/env) env symbol type-records -> type/env
(define (check-test-exprs exp check-sub-expr env level type-recs)
(cond
((check-expect? exp)
(check-test-expect (check-expect-test exp)
(check-expect-actual exp)
(check-expect-range exp)
check-sub-expr
env
level
(check-expect-ta-src exp)
(expr-src exp)
type-recs))
((check-catch? exp)
(check-test-catch (check-sub-expr (check-catch-test exp) env)
(check-catch-exn exp)
(expr-src exp)
type-recs))
((check-mutate? exp)
(check-test-mutate (check-mutate-mutate exp)
(check-mutate-check exp)
check-sub-expr
env
(expr-src exp)
type-recs))))
;check-test-expr: exp exp (U #f exp) (exp env -> type/env) env symbol src src type-records-> type/env
(define (check-test-expr test actual range check-e env level ta-src src type-recs)
(define (check-test-expect test actual range check-e env level ta-src src type-recs)
(let* ((test-te (check-e test env))
(test-t (type/env-t test-te))
(actual-te (check-e actual (type/env-e test-te)))
@ -2728,7 +2772,30 @@
level
test-t actual-t ta-src)))))
;check-test-catch: type/env type-spec src type-records -> type/env
(define (check-test-catch test-type type src type-recs)
(let ((catch-type (type-spec-to-type type #f 'full type-recs)))
(unless (is-eq-subclass? catch-type throw-type type-recs)
(check-catch-error catch-type (type-spec-src type)))
(when (reference-type? catch-type)
(send type-recs add-req (make-req (ref-type-class/iface catch-type) (ref-type-path catch-type))))
(make-type/env 'boolean (type/env-e test-type))))
;check-test-mutate: exp exp (exp env -> type/env) env src type-records -> type/env
(define (check-test-mutate mutatee check check-sub-expr env src type-recs)
(unless (or (call? mutatee)
(assignment? mutatee)
(class-alloc? mutatee)
(post-expr? mutatee)
(pre-expr? mutatee))
(check-mutate-kind-error (expr-src mutatee)))
(let* ((mutatee-type (check-sub-expr mutatee env))
(checker-type (check-sub-expr check (type/env-e mutatee-type))))
(unless (eq? 'boolean (type/env-t checker-type))
(check-mutate-check-error (type/env-t checker-type) (expr-src check)))
(make-type/env 'boolean (type/env-e checker-type))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Expression Errors
@ -3369,8 +3436,8 @@
;;Assignment errors
;illegal-assignment: src -> void
(define (illegal-assignment src)
(raise-error '= "Assignment is only allowed in the constructor" '= src))
(raise-error '= "Assignment is only allowed in the constructor." '= src))
;ctor-illegal-assignment: id src -> void
(define (ctor-illegal-assignment name src)
(raise-error '=
@ -3471,6 +3538,29 @@
'check ta-src
))
;check-catch-error: type src -> void
(define (check-catch-error name src)
(raise-error
'check
(format "check catch expects a subtype of Throwable to catch, found ~a, which is not allowed."
(type->ext-name name))
'catch src))
;check-mutate-kind-error: src -> void
(define (check-mutate-kind-error src)
(raise-error
'->
"The preceeding expression in a mutation test must be allowable as a statement. This expression is not."
'-> src))
;check-mutate-check-error: type src -> void
(define (check-mutate-check-error type src)
(raise-error
'->
(format "The expression following -> in a mutation test must return a boolean; found expresstion returning ~a."
(type->ext-name type))
'-> src))
(define check-location (make-parameter #f))

1
collects/profj/compile.ss
View File

@ -148,7 +148,6 @@
(define (compile-ast ast level type-recs)
(packages null)
(check-list null)
(to-file #f)
(load-lang type-recs)
(build-info ast level type-recs #f)
(unless (null? (check-list))

7
collects/profj/installer.ss
View File

@ -1,11 +1,12 @@
(module installer mzscheme
(require (prefix lang: (lib "installer.ss" "profj" "libs" "java" "lang"))
(prefix io: (lib "installer.ss" "profj" "libs" "java" "io"))
(prefix util: (lib "installer.ss" "profj" "libs" "java" "util")))
(prefix util: (lib "installer.ss" "profj" "libs" "java" "util"))
(prefix test: (lib "installer.ss" "profj" "libs" "java" "tester")))
(provide installer)
(define (installer plthome)
(io:installer plthome)
(lang:installer plthome)
; (io:installer plthome)
(util:installer plthome)))
(util:installer plthome)
(test:installer plthome)))

153
collects/profj/libs/java/runtime.scm
View File

@ -7,17 +7,18 @@
(module runtime mzscheme
(require (lib "class.ss")
(lib "list.ss")
(lib "Object.ss" "profj" "libs" "java" "lang")
(lib "String.ss" "profj" "libs" "java" "lang")
(lib "Throwable.ss" "profj" "libs" "java" "lang")
(lib "ArithmeticException.ss" "profj" "libs" "java" "lang")
(lib "ClassCastException.ss" "profj" "libs" "java" "lang")
(lib "NullPointerException.ss" "profj" "libs" "java" "lang")
(lib "parameters.ss" "profj"))
)
(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-eq? dynamic-equal? compare compare-within check-catch check-mutate)
(define (check-eq? obj1 obj2)
(or (eq? obj1 obj2)
@ -165,19 +166,19 @@
(if (send val check-ref-type type dim)
val
(raise-class-cast
(format "Cast to ~a~a failed for ~a" name (make-brackets dim) (send (convert-to-string val) get-mzscheme-string))))
(format "Cast to ~a~a failed for ~a." name (make-brackets dim) (send (convert-to-string val) get-mzscheme-string))))
(cond
((and (eq? Object type) (is-a? val ObjectI)) val)
((and (is-a? val convert-assert-Object) (is-a? val ca-type)) val)
((is-a? val convert-assert-Object)
(or (send val down-cast type ca-type)
(raise-class-cast (format "Cast to ~a failed for ~a" name (send val my-name)))))
(raise-class-cast (format "Cast to ~a failed for ~a." name (send val my-name)))))
((and (is-a? val guard-convert-Object) (is-a? val gc-type)) val)
((is-a? val guard-convert-Object)
(or (send val down-cast type gc-type)
(raise-class-cast (format "Cast to ~a failed for ~a" name (send val my-name)))))
(raise-class-cast (format "Cast to ~a failed for ~a." name (send val my-name)))))
((is-a? val type) val)
(else (raise-class-cast (format "Cast to ~a failed for ~a" name (send val my-name)))))))
(else (raise-class-cast (format "Cast to ~a failed for ~a." name (send val my-name)))))))
;instanceof-array: bool val (U class sym) int -> bool
(define (instanceof-array prim? val type dim)
@ -198,13 +199,15 @@
(send exn NullPointerException-constructor-java.lang.String msg))
(current-continuation-marks))))
(define in-check-mutate? (make-parameter #f))
(define stored-checks (make-parameter null))
;compare: val val (list symbol string ...) string (U #f object)-> boolean
(define (compare test act info src test-obj)
(compare-within test act 0.0 info src test-obj #f))
;compare-within: val val val (list symbol string) (U #f object) . boolean -> boolean
;compare-within: (-> val) val val (list symbol string) (U #f object) . boolean -> boolean
(define (compare-within test act range info src test-obj . within?)
(when test-obj (send test-obj add-check))
(letrec ((java-equal?
(lambda (v1 v2 visited-v1 visited-v2)
(or (eq? v1 v2)
@ -239,42 +242,108 @@
(map (lambda (v) (cons v2 visited-v2)) v2-fields)))))))))
((and (not (object? v1)) (not (object? v2))) (equal? v1 v2))
(else #f))))))
(let ((res (java-equal? test act null null)))
(unless res
(when test-obj
(send test-obj
check-failed
(append '("check expected ")
(list (case (car info)
((field)
(format "the ~a field of class ~a to have value "
(caddr info) (cadr info)))
((static-field)
(format "the class field ~a of ~a to have value "
(caddr info) (cadr info)))
((var)
(format "the local variable ~a to have value" (cadr info)))
((alloc)
(format "the instantiation of class ~a with values with types ~a to produce a "
(cadr info)
(caddr info)
))
((call) (format "the call to method ~a from ~a, with values with types ~a, to produce the value "
(caddr info) (cadr info) (cadddr info)))
((array) "the array value ")
((unary) (format "the unary operation ~a to produce " (cadr info)))
((value) "value ")))
(if (null? within?)
(list "within " (send test-obj format-value range)
" of " (send test-obj format-value act))
(list (send test-obj format-value act)))
'(", instead found ")
(list (send test-obj format-value test)))
src)))
(set! test (test))
(let ([res (java-equal? test act null null)]
[values-list (append (list act test) (if (null? within?) (list range) null))])
(if (in-check-mutate?)
(stored-checks (cons (list res 'check-expect info values-list src) (stored-checks)))
(report-check-result res 'check-expect info values-list src test-obj))
res)))
;check-catch: (-> val) string class (list string) src object -> boolean
(define (check-catch test name thrown info src test-obj)
(let* ([result (with-handlers ([(lambda (e) (and (exn? e)
((exception-is-a? thrown) e)))
(lambda (e) #t)]
[(lambda (e) (and (exn? e)
((exception-is-a? Throwable) e)))
(handle-exception
(lambda (e) (send e my-name)))])
(test)
#f)]
[return (and (boolean? result) result)]
[values-list (cons name (if (boolean? result) null (list result)))])
(if (in-check-mutate?)
(stored-checks (cons (list return 'check-catch info values-list src) (stored-checks)))
(report-check-result return 'check-catch info values-list src test-obj))
return))
;check-mutate: (-> val) (-> boolean) (list string) src object -> boolean
(define (check-mutate mutatee check info src test-obj)
(mutatee)
(parameterize ([in-check-mutate? #t] [stored-checks null])
(let ([result-value (check)]
[mutate-msg-prefix (string-append "check following the "
(construct-info-msg info)
" expected ")])
(when test-obj
(let report-results ([checks (stored-checks)])
(unless (null? checks)
(let ([current-check (first checks)])
(send test-obj add-check)
(unless (first current-check)
(send test-obj check-failed
(compose-message test-obj
(second current-check)
(third current-check)
(fourth current-check)
mutate-msg-prefix)
(fifth current-check))))
(report-results (cdr checks)))))
result-value)))
;array->list: java-array -> (list 'a)
(define (report-check-result res check-kind info values src test-obj)
(when test-obj
(send test-obj add-check)
(unless res
(send test-obj
check-failed
(compose-message test-obj check-kind info values #f)
src))))
(define (compose-message test-obj check-kind info values mutate-message)
(let ((test-format (construct-info-msg info))
(formatted-values (map (lambda (v) (send test-obj format-value v)) values))
(expected-format
(case check-kind
((check-expect) "to produce ")
((check-catch) "to throw an instance of "))))
(append (list (if mutate-message mutate-message "check expected ")
test-format
expected-format
(first formatted-values))
(case check-kind
((check-expect)
(if (= (length formatted-values) 3)
(list ", within " (third formatted-values) ", instead found " (second formatted-values))
(list ", instead found" (second formatted-values))))
((check-catch)
(if (= (length formatted-values) 1)
(list ", instead no exceptions occured")
(list ", instead an instance of " (second formatted-values) " was thrown"))))
(list "."))))
;construct-info-msg (list symbol string ...) -> string
(define (construct-info-msg info)
(case (first info)
((field)
(format "the ~a field of class ~a " (third info) (second info)))
((static-field)
(format "the class field ~a of ~a " (third info) (second info)))
((var)
(format "the local variable ~a " (second info)))
((alloc)
(format "the instantiation of ~a, using values with types ~a, "
(second info) (third info)))
((call)
(format "the call to method ~a of ~a, using values with types ~a, "
(third info) (second info) (fourth info)))
((array) "the array value ")
((unary) (format "the unary operation ~a " (second info)))
((assignment) (format "the assignment of ~a" (construct-info-msg (cdr info))))
((value) "value ")))
;array->list: java-array -> (list 'a)
(define (array->list v)
(letrec ((len (send v length))
(build-up

20
collects/profj/libs/java/tester/TestBase.djava Normal file
View File

@ -0,0 +1,20 @@
package java.tester;
public final class TestBase {
protected boolean useEquals = false;
public void setup() { }
public void breakdown() { }
dynamic testMethods() {
return null;
}
// void || (listof (list string (listof string (listof int))))
dynamic testCoverage( boolean getResult, int src) {
return null;
}
}

3
collects/profj/libs/java/tester/info.ss Normal file
View File

@ -0,0 +1,3 @@
(module info (lib "infotab.ss" "setup")
(define name "ProfessorJ: libs java tester")
#;(define install-collection "installer.ss"))

18
collects/profj/libs/java/tester/installer.ss Normal file
View File

@ -0,0 +1,18 @@
(module installer mzscheme
(require (lib "compile.ss" "profj"))
(provide installer)
(define (installer plthome)
(let ([java.test (build-path
(collection-path "profj" "libs" "java" "tester"))])
(let ([javac
(lambda (file)
(parameterize ([current-load-relative-directory
java.test])
(compile-java 'file
'file
'full
(build-path java.test file)
#f
#f)))])
(javac "TestBase.djava")))))

3
collects/profj/parameters.ss
View File

@ -40,6 +40,9 @@
;Stores whether testing extension is on or not
(define test-ext? (make-parameter #t))
;Stores whether the test case extension is on or not
(define testcase-ext? (make-parameter #t))
;Stores whether the test window should pop up
(define tests? (make-parameter #t))

4
collects/profj/parsers/advanced-parser.ss
View File

@ -773,9 +773,9 @@
(CheckExpression
[(ConditionalExpression) $1]
[(check ConditionalExpression expect ConditionalExpression)
(make-check #f (build-src 4) $2 $4 #f (build-src 2 4))]
(make-check-expect #f (build-src 4) $2 $4 #f (build-src 2 4))]
[(check ConditionalExpression expect ConditionalExpression within ConditionalExpression)
(make-check #f (build-src 6) $2 $4 $6 (build-src 2 4))])
(make-check-expect #f (build-src 6) $2 $4 $6 (build-src 2 4))])
(AssignmentExpression
[#;(ConditionalExpression)(CheckExpression) $1])

4
collects/profj/parsers/beginner-parser.ss
View File

@ -445,9 +445,9 @@
(CheckExpression
[(ConditionalOrExpression) $1]
[(check ConditionalOrExpression expect ConditionalOrExpression)
(make-check #f (build-src 4) $2 $4 #f (build-src 2 4))]
(make-check-expect #f (build-src 4) $2 $4 #f (build-src 2 4))]
[(check ConditionalOrExpression expect ConditionalOrExpression within ConditionalOrExpression)
(make-check #f (build-src 6) $2 $4 $6 (build-src 2 4))])
(make-check-expect #f (build-src 6) $2 $4 $6 (build-src 2 4))])
(Assignment
[(LeftHandSide AssignmentOperator CheckExpression)

94
collects/profj/parsers/full-parser.ss
View File

@ -154,8 +154,7 @@
(TypeDeclaration
[(ClassDeclaration) $1]
[(InterfaceDeclaration) $1]
#;[(INTERACTIONS_BOX) $1]
#;[(CLASS_BOX) (parse-class-box $1 (build-src 1) 'full)]
[(TestDeclaration) $1]
[(TEST_SUITE) $1]
[(EXAMPLE) $1]
[(SEMI_COLON) #f])
@ -435,6 +434,84 @@
(AbstractMethodDeclaration
[(MethodHeader SEMI_COLON) $1])
;;test extension stuff
(TestDeclaration
[(test IDENTIFIER TestBody)
(make-test-def (make-test-header (make-id $2 (build-src 2 2))
(list (make-modifier 'public #f))
null null null (build-src 2) null)
$3
(build-src 1)
(build-src 3)
(file-path)
'full null 'top null)]
[(test IDENTIFIER tests TestClasses TestBody)
(make-test-def (make-test-header (make-id $2 (build-src 2 2))
(list (make-modifier 'public #f))
null null null (build-src 4) $4)
$5
(build-src 1)
(build-src 5)
(file-path)
'full null 'top null)]
[(test IDENTIFIER extends ClassType TestBody)
(make-test-def (make-test-header (make-id $2 (build-src 2 2))
(list (make-modifier 'public #f))
(list $4) null null (build-src 4) null)
$5
(build-src 1)
(build-src 5)
(file-path)
'full null 'top null)]
[(test IDENTIFIER extends ClassType tests TestClasses TestBody)
(make-test-def (make-test-header (make-id $2 (build-src 2 2))
(list (make-modifier 'public #f))
(list $4) null null (build-src 6) $6)
$7
(build-src 1)
(build-src 7)
(file-path)
'full null 'top null)])
(TestClasses
[(ClassType) (list $1)]
[(TestClasses COMMA ClassType) (cons $3 $1)])
(TestBody
[(O_BRACE TestMemberDeclarations C_BRACE) $2])
(TestMemberDeclarations
[() null]
[(TestMemberDeclarations TestMemberDeclaration)
(cond
((not $2) $1)
((list? $2) (append $2 $1))
(else (cons $2 $1)))])
(TestMemberDeclaration
[(FieldDeclaration) $1]
[(MethodDeclaration) $1]
[(TestcaseDeclaration) $1]
[(ConstructorDeclaration) $1]
[(SEMI_COLON) #f])
(TestcaseDeclaration
[(testcase MethodDeclarator Block)
(let ([method-header (construct-method-header (list (make-modifier 'public (build-src 1)))
null
(make-type-spec 'boolean 0 (build-src 1))
$2
null)])
(make-test-method (method-modifiers method-header)
(method-type method-header)
null
(method-name method-header)
(method-parms method-header)
null
$3
#f #f (build-src 3)))])
;; 19.10
(ArrayInitializer
@ -947,12 +1024,19 @@
(CheckExpression
[(ConditionalExpression) $1]
[(check ConditionalExpression expect ConditionalExpression)
(make-check #f (build-src 4) $2 $4 #f (build-src 2 4))]
(make-check-expect #f (build-src 4) $2 $4 #f (build-src 2 4))]
[(check ConditionalExpression expect ConditionalExpression within ConditionalExpression)
(make-check #f (build-src 6) $2 $4 $6 (build-src 2 4))])
(make-check-expect #f (build-src 6) $2 $4 $6 (build-src 2 4))]
[(check ConditionalExpression catch Type)
(make-check-catch #f (build-src 4) $2 $4)])
(MutateExpression
[(CheckExpression) $1]
[(CheckExpression -> CheckExpression)
(make-check-mutate #f (build-src 3) $1 $3 (build-src 2 2))])
(AssignmentExpression
[#;(ConditionalExpression) (CheckExpression) $1]
[#;(ConditionalExpression) #;(CheckExpression) (MutateExpression) $1]
[(Assignment) $1])
(Assignment

4
collects/profj/parsers/intermediate-parser.ss
View File

@ -582,9 +582,9 @@
(CheckExpression
[(ConditionalOrExpression) $1]
[(check ConditionalOrExpression expect ConditionalOrExpression)
(make-check #f (build-src 4) $2 $4 #f (build-src 2 4))]
(make-check-expect #f (build-src 4) $2 $4 #f (build-src 2 4))]
[(check ConditionalOrExpression expect ConditionalOrExpression within ConditionalOrExpression)
(make-check #f (build-src 6) $2 $4 $6 (build-src 2 4))])
(make-check-expect #f (build-src 6) $2 $4 $6 (build-src 2 4))])
#;(ConditionalExpression
[(ConditionalOrExpression) $1])

18
collects/profj/parsers/lexer.ss
View File

@ -44,7 +44,7 @@
const for new switch
continue goto package synchronized))
(define-empty-tokens ExtraKeywords (dynamic check expect within))
(define-empty-tokens ExtraKeywords (dynamic check expect within -> ->> ->>> test tests testcase))
(define-tokens java-vals
(STRING_LIT CHAR_LIT INTEGER_LIT LONG_LIT FLOAT_LIT DOUBLE_LIT
@ -250,6 +250,10 @@
((string=? l "||") (token-OR))
((string=? l "|=") (token-OREQUAL))
(else (string->symbol l)))))
("->" (string->symbol lexeme))
("->>" (string->symbol lexeme))
("->>>" (string->symbol lexeme))
;; 3.11
("(" (token-O_PAREN))
@ -313,6 +317,11 @@
((test-ext?) (string->symbol lexeme))
(else (token-IDENTIFIER lexeme))))
((re:or "test" "tests" "testcase")
(cond
((testcase-ext?) (string->symbol lexeme))
(else (token-IDENTIFIER lexeme))))
;; 3.9
(Keyword (string->symbol lexeme))
@ -418,6 +427,13 @@
(else 'identifier))
#f start-pos end-pos))
((re:or "test" "tests ""testcase")
(syn-val lexeme
(cond
((testcase-ext?) 'keyword)
(else 'identifier))
#f start-pos end-pos))
(KnownTypes
(syn-val lexeme 'prim-type #f start-pos end-pos))

64
collects/profj/tester.scm
View File

@ -10,7 +10,7 @@
(lib "file.ss")
(lib "etc.ss"))
(require "ast.ss" "display-java.ss")
(require "ast.ss" "display-java.ss" "parameters.ss")
(provide test-info% test-display% test-tool@)
@ -27,7 +27,8 @@
#;(make-single-test string (listof testcase) (listof string)
int (listof failed-check) (listof src))
(define-struct single-test (name testcases not-tested
num-checks failed-checks covered-exprs))
num-checks failed-checks covered-exprs
covered-methods))
;(make-failed-check src (listof (U string snip%)) (listof src))
(define-struct failed-check (src msg covers))
@ -44,13 +45,15 @@
(define covered null);------------- (listof src)
(define nearly-tested-classes null);(listof string)
(define current-class (make-single-test "" null null 0 null null))
(define current-class (make-single-test "" null null 0 null null null))
(define current-testcoverage null)
(define total-tests 0)
(define failed-tests 0)
(define total-checks 0)
(define failed-checks 0)
(define current-test-obj null)
(define/public (add-check)
(set-single-test-num-checks! current-class
@ -73,7 +76,9 @@
(set! current-testcoverage (cons src current-testcoverage))
(set-single-test-covered-exprs!
current-class
(cons src (single-test-covered-exprs current-class))))
(cons src (single-test-covered-exprs current-class)))
(when (and (testcase-ext?) src)
(send current-test-obj testCoverage-boolean-int #f (src-pos src))))
(define/public (provide-test-results)
(values tested-classes covered nearly-tested-classes total-tests
@ -86,19 +91,39 @@
(let ((objects
(map
(lambda (name/class)
(set! current-class (make-single-test (car name/class) null null 0 null null))
(set! current-class (make-single-test (car name/class) null null 0 null null null))
(let ((obj (make-object (cadr name/class))))
(when (testcase-ext?) (set! current-test-obj obj))
(with-handlers ((exn? (lambda (e) (raise e))))
((current-eval)
#`(send #,obj #,(string->symbol (string-append (car name/class)
"-constructor")))))
(run-methods obj)
(if (testcase-ext?)
(run-testcases obj)
(run-methods obj))
(set! tested-classes (cons current-class tested-classes))
(when (testcase-ext?)
(set-single-test-covered-methods! current-class (send obj testCoverage-boolean-int #t 1)))
(list (car name/class) obj)))
tests)))
(set! nearly-tested-classes close-names)
(map cadr objects)))
(define/private (run-testcases object)
(let loop ([methods (send object testMethods)])
(cond
[(null? methods) (void)]
[else
(set! total-tests (add1 total-tests))
(set! current-testcoverage null)
(let ((res ((cadr (car methods)))))
(set-single-test-testcases!
current-class
(cons (make-testcase (car (car methods)) res current-testcoverage)
(single-test-testcases current-class)))
(unless res (set! failed-tests (add1 failed-tests))))
(loop (cdr methods))])))
(define/private (run-methods object)
(let loop ([methods (reverse (interface->method-names (object-interface object)))])
(cond
@ -224,7 +249,9 @@
(make-covered-button covered editor #f)
(send editor insert "\n"))
(send editor insert "Tested the following Example classes:\n")
(if (testcase-ext?)
(send editor insert "Run the following tests:\n")
(send editor insert "Tested the following Example classes:\n"))
(for-each
(lambda (test-info)
(send editor insert "\n")
@ -251,6 +278,29 @@
(make-covered-button (testcase-covers test) editor #f))
(next-line))
(reverse (single-test-testcases test-info)))))
(unless (null? (single-test-covered-methods test-info))
(next-line)
(send editor insert "Tested the following classes:")
(next-line)
(for-each (lambda (class)
(let ((num-methods (length (car (cdr class))))
(uncovered-methods (filter (lambda (m) (not (car (cdr m)))) (car (cdr class)))))
(send editor insert (format "class ~a with ~a of its methods covered."
(car class)
(cond
((null? uncovered-methods) "all")
((= (length uncovered-methods) num-methods) "none")
(else
(- num-methods (length uncovered-methods))))))
(next-line)
(let loop ((methods uncovered-methods))
(unless (null? methods)
(send editor insert (format "Method ~a was not fully covered."
(car (car methods))))
(next-line)
(loop (cdr methods))))))
(single-test-covered-methods test-info)))
(when (> (single-test-num-checks test-info) 0)
(next-line)
(send editor insert (format "Ran ~a checks." (single-test-num-checks test-info)))

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

@ -16,6 +16,9 @@
;NOTE! Abstract classes are treated no differently than any class.
;Parameters for getting to the source of other classes
(define classes (make-parameter null))
;Parameters for information about each class
(define class-name (make-parameter "interactions"))
(define loc (make-parameter #f))
@ -207,16 +210,16 @@
(list (id-string (name-id (package-name program)))))
null))
(full-defs (if (null? (packages)) (package-defs program) (append (packages) (package-defs program))))
(dependent-defs (find-dependent-defs full-defs type-recs))
(modules (map (lambda (defs)
(let*-values (((ordered-defs) (order-defs defs))
((translated-defs reqs) (translate-defs ordered-defs type-recs)))
(make-compilation-unit (map (lambda (def) (id-string (def-name def))) ordered-defs)
translated-defs
(map def-file ordered-defs)
reqs)))
dependent-defs)))
modules))
(dependent-defs (find-dependent-defs full-defs type-recs)))
(classes full-defs)
(map (lambda (defs)
(let*-values (((ordered-defs) (order-defs defs))
((translated-defs reqs) (translate-defs ordered-defs type-recs)))
(make-compilation-unit (map (lambda (def) (id-string (def-name def))) ordered-defs)
translated-defs
(map def-file ordered-defs)
reqs)))
dependent-defs)))
;get-package: definition type-records -> (list string)
(define (get-package def type-recs)
@ -352,9 +355,13 @@
`(file ,(path->string (build-path (string-append (symbol->string (module-name)) ".zo")))))
(module-name)))
(let* ((translated-defs (map (lambda (d)
(if (class-def? d)
(translate-class d type-recs 0)
(translate-interface d type-recs)))
(cond
((class-def? d)
(translate-class d type-recs #f 0))
((test-def? d)
(translate-class d type-recs #t 0))
(else
(translate-interface d type-recs))))
defs))
(group-reqs (apply append (map (lambda (d)
(map (lambda (r) (list (def-file d) r)) (def-uses d)))
@ -476,8 +483,8 @@
(build-src (name-src i))))))
imp))
;translate-class: class-def type-records -> (list syntax syntax)
(define (translate-class class type-recs depth)
;translate-class: class-def type-records boolean int -> (list syntax syntax)
(define (translate-class class type-recs test? depth)
;Let's grab onto the enclosing class-specific info incase depth > 0
(let ((old-class-name (class-name))
(old-parent-name (parent-name))
@ -492,7 +499,9 @@
((closure-args) (def-closure-args class))
((parent parent-src extends-object?)
(if (null? (header-extends header))
(values "Object" #f #t)
(if (not test?)
(values "Object" #f #t)
(values "TestBase" #f #t))
(let-values (((p p-s) (get-parent (header-extends header))))
(values p p-s
(class-record-object?
@ -532,7 +541,7 @@
(accesses-protected methods))
overridden-methods))
#;(dynamic-method-defs (generate-dyn-method-defs names-for-dynamic))
;(p~ (printf "about to call class-record-methods : ~a ~a ~n" (class-name) (string? (class-name))))
#;(p~ (printf "about to call class-record-methods : ~a ~a ~n" (class-name) (string? (class-name))))
(wrapper-classes (append (generate-wrappers (class-name)
(parent-name)
(filter
@ -677,6 +686,71 @@
,(if (null? (accesses-private methods))
'(make-hash-table)
(build-method-table (accesses-private methods) private-generics)))
,@(if test?
(cons
(let ((test-methods (filter test-method? (accesses-public methods))))
`(define/override (testMethods)
,(if (null? test-methods)
'(super testMethods)
`(append (list
,@(map
(lambda (testcase)
`(list ,(id-string (method-name testcase))
(lambda ()
(send this ,(build-identifier
(id-string (method-name testcase)))))))
(filter test-method? (accesses-public methods))))
(super testMethods)))))
(if (null? (test-header-tests header))
null
(let* ((test-classes
(map id-string
(map name-id (test-header-tests header))))
(class-defs
(filter (lambda (d) (member (id-string (def-name d)) test-classes))
(classes)))
(class/methods-list
(map (lambda (d)
(cons (id-string (def-name d))
(filter (lambda (m)
(and (method? m) (method-src m))) (def-members d))))
class-defs))
(class/lookup-funcs
(map (lambda (c)
(let* ((m-name (lambda (m) (id-string (method-name m))))
(m-start (lambda (m) (src-pos (method-src m))))
(m-stop (lambda (m)
(+ (m-start m) (src-span (method-src m))))))
`(let ((methods-covered ',(map (lambda (m) `(,(m-name m) #f))
(cdr c)))
(srcs ',(map (lambda (m)
`(,(m-name m) ,(get-srcs (method-body m))))
(cdr c))))
(list ,(car c)
methods-covered
(lambda (x)
(cond
,@(map
(lambda (m)
`((and (< ,(m-start m) x) (< x ,(m-stop m)))
(let ((m-list (assq ,(m-name m) srcs)))
(unless (null? (car (cdr m-list)))
(set-cdr! m-list (list (,remove x (car (cdr m-list)))))
(when (null? (car (cdr m-list)))
(set-cdr! (assq ,(m-name m) methods-covered) (list #t)))))))
(cdr c))))))))
class/methods-list)))
(list `(define/override (testCoverage-boolean-int report? src)
(let ((class/lookups (list ,@class/lookup-funcs)))
(if report?
(append (map (lambda (c) (list (car c) (cadr c)))
class/lookups)
(super testCoverage-boolean-int report? src))
(begin
(for-each (lambda (c) ((caddr c) src)) class/lookups)
(super testCoverage-boolean-int report? src)))))))))
null)
,@(map (lambda (i) (translate-initialize (initialize-static i)
(initialize-block i)
@ -697,7 +771,7 @@
(append (accesses-public fields)
(accesses-package fields)
(accesses-protected fields)))
,@(map (lambda (def) (translate-class def type-recs (add1 depth)))
,@(map (lambda (def) (translate-class def type-recs #f (add1 depth)))
(members-inner class-members))
,@(create-static-methods (append static-method-names
(make-static-method-names
@ -900,7 +974,7 @@
(cond
((symbol? type)
(case type
((int byte short long float double char boolean dynamic void) value)
((int byte short long float double char boolean dynamic void null) value)
((string) (if from-dynamic?
`(make-java-string ,value)
`(send ,value get-mzscheme-string)))))
@ -953,7 +1027,8 @@
((char) (check 'char?))
((string) (check 'string?))
((boolean) (check 'boolean?))
((dynamic) value))))
((dynamic) value)
((null) value))))
((and (ref-type? type) (equal? string-type type))
(assert-value value 'string from-dynamic? kind name))
(else value))))
@ -1191,6 +1266,90 @@
(build-src (name-src n)))))
extends))
(define (get-srcs stmt)
(cond
[(ifS? stmt)
(append (get-expr-srcs (ifS-cond stmt))
(get-srcs (ifS-then stmt))
(get-srcs (ifS-else stmt)))]
[(throw? stmt)
(get-expr-srcs (throw-expr stmt))]
[(return? stmt)
(get-expr-srcs (return-expr stmt))]
[(while? stmt)
(append (get-expr-srcs (while-cond stmt))
(get-srcs (while-loop stmt)))]
[(doS? stmt)
(append (get-srcs (doS-loop stmt))
(get-expr-srcs (doS-cond stmt)))]
[(for? stmt)
(get-srcs (for-loop stmt))]
[(try? stmt)
(append (get-srcs (try-body stmt))
(apply append
(map (compose get-srcs catch-body) (try-catches stmt))))
]
[(block? stmt)
(apply append (map get-srcs (block-stmts stmt)))]
[(statement-expression? stmt) (get-expr-srcs stmt)]
[else null]))
(define (get-expr-srcs expr)
(cond
((not (expr-src expr)) null)
((bin-op? expr) (cons (src-pos (expr-src expr))
(append (get-expr-srcs (bin-op-left expr))
(get-expr-srcs (bin-op-right expr)))))
((access? expr)
(if (or (local-access? (access-name expr))
(not (field-access-object (access-name expr))))
(list (src-pos (expr-src expr)))
(cons (src-pos (expr-src expr))
(get-expr-srcs (field-access-object (access-name expr))))))
((call? expr)
(cons (src-pos (expr-src expr))
(append
(if (call-expr expr)
(get-expr-srcs (call-expr expr))
null)
(apply append
(map get-expr-srcs (call-args expr))))))
((class-alloc? expr)
(cons (src-pos (expr-src expr))
(apply append (map get-expr-srcs (class-alloc-args expr)))))
((array-alloc? expr)
(cons (src-pos (expr-src expr))
(apply append
(map get-expr-srcs (array-alloc-size expr)))))
((cond-expression? expr)
(cons (src-pos (expr-src expr))
(append (get-expr-srcs (cond-expression-cond expr))
(get-expr-srcs (cond-expression-then expr))
(get-expr-srcs (cond-expression-else expr)))))
((array-access? expr)
(cons (src-pos (expr-src expr))
(append (get-expr-srcs (array-access-name expr))
(get-expr-srcs (array-access-index expr)))))
((post-expr? expr)
(cons (src-pos (expr-src expr))
(get-expr-srcs (post-expr-expr expr))))
((pre-expr? expr)
(cons (src-pos (expr-src expr))
(get-expr-srcs (pre-expr-expr expr))))
((unary? expr)
(cons (src-pos (expr-src expr))
(get-expr-srcs (unary-expr expr))))
((cast? expr)
(cons (src-pos (expr-src expr))
(get-expr-srcs (cast-expr expr))))
((instanceof? expr)
(cons (src-pos (expr-src expr))
(get-expr-srcs (instanceof-expr expr))))
((assignment? expr)
(cons (src-pos (expr-src expr))
(get-expr-srcs (assignment-right expr))))
(else (list (src-pos (expr-src expr))))))
;translate-interface: interface-def type-records-> (list syntax)
(define (translate-interface iface type-recs)
(let* ((header (def-header iface))
@ -1938,7 +2097,7 @@
((dynamic-val? type) val)
((symbol? type)
(case type
((int short long byte float double boolean char dynamic void) val)
((int short long byte float double boolean char dynamic void null) val)
((string String) `(send ,val get-mzscheme-string))))
((ref-type? type)
(if (equal? type string-type)
@ -2078,10 +2237,7 @@
(expr-types expr)
(assignment-key-src expr)
(expr-src expr)))
((check? expr) (translate-check (check-test expr)
(check-actual expr)
(check-range expr)
(expr-src expr)))
((check? expr) (translate-check expr))
(else
(error 'translate-expression (format "Translate Expression given unrecognized expression ~s" expr)))))
@ -2752,10 +2908,25 @@
(send ,name set ,index ,new-val)
,new-val)
(build-src src))))
;translate-check: expr -> syntax
(define (translate-check expr)
(cond
((check-expect? expr) (translate-check-expect (check-expect-test expr)
(check-expect-actual expr)
(check-expect-range expr)
(expr-src expr)))
((check-catch? expr) (translate-check-catch (check-catch-test expr)
(check-catch-exn expr)
(expr-src expr)))
((check-mutate? expr) (translate-check-mutate (check-mutate-mutate expr)
(check-mutate-check expr)
(expr-src expr)))))
;translate-check: expression expression (U expression #f) src -> syntax
(define (translate-check test actual range src)
(let ((t (translate-expression test))
(define (translate-check-expect test actual range src)
(let ((t (make-syntax #f `(lambda () ,(translate-expression test)) #f))
(a (translate-expression actual))
(r (when range (translate-expression range)))
(extracted-info (checked-info test)))
@ -2767,6 +2938,26 @@
(lambda () #f)))
(build-src src))))
;translate-check-catch: expression type-spec src -> syntax
(define (translate-check-catch test catch src)
(let ((t (create-syntax #f `(lambda () ,(translate-expression test)) #f))
(n (get-class-name catch)))
(make-syntax #f
`(javaRuntime:check-catch ,t ,(symbol->string (syntax-object->datum n)) ,n ,(checked-info test) ,src
(namespace-variable-value 'current~test~object% #f
(lambda () #f)))
(build-src src))))
;translate-check-mutate: expression expression src -> syntax
(define (translate-check-mutate mutatee check src)
(let ((t (create-syntax #f `(lambda () ,(translate-expression mutatee)) #f))
(c (create-syntax #f `(lambda () ,(translate-expression check)) #f)))
(make-syntax #f
`(javaRuntime:check-mutate ,t ,c ,(checked-info mutatee) ,src
(namespace-variable-value 'current~test~object% #f
(lambda () #f)))
(build-src src))))
(require "error-messaging.ss")
;checked-info: expression -> (list sym string...)
@ -2806,6 +2997,9 @@
'(list (quote array)))
((unary? exp)
'(list (quote unary) (quote (unary-op exp))))
((assignment? exp)
`(list (quote assignment)
,@(checked-info (assignment-left exp))))
(else '(list (quote value)))))
(define (type-spec->ext-name t)

29
collects/profj/tool.ss
View File

@ -143,7 +143,7 @@
;(make-profj-settings symbol boolean boolean boolean boolean (list string))
(define-struct profj-settings
(print-style print-full? allow-check? run-tests? coverage? classpath) (make-inspector))
(print-style print-full? allow-check? allow-test? run-tests? coverage? classpath) (make-inspector))
;ProfJ general language mixin
(define (java-lang-mixin level name number one-line dyn?)
@ -179,8 +179,8 @@
;default-settings: -> profj-settings
(define/public (default-settings)
(if (memq level `(beginner intermediate advanced))
(make-profj-settings 'field #f #t #t #t null)
(make-profj-settings 'type #f #t #f #f null)))
(make-profj-settings 'field #f #t #f #t #t null)
(make-profj-settings 'type #f #t #t #f #f null)))
;default-settings? any -> bool
(define/public (default-settings? s) (equal? s (default-settings)))
@ -188,6 +188,7 @@
(make-profj-settings (profj-settings-print-style s)
(profj-settings-print-full? s)
(profj-settings-allow-check? s)
(profj-settings-allow-test? s)
test?
(profj-settings-coverage? s)
(profj-settings-classpath s)))
@ -197,20 +198,22 @@
(list (list (profj-settings-print-style s))
(list (profj-settings-print-full? s))
(list (profj-settings-allow-check? s))
(list (profj-settings-allow-test? s))
(list (profj-settings-run-tests? s))
(list (profj-settings-coverage? s))))
;unmarshall-settings: any -> (U profj-settings #f)
(define/public (unmarshall-settings s)
(if (and (pair? s) (= (length s) 5)
(if (and (pair? s) (= (length s) 6)
(pair? (car s)) (= (length (car s)) 1)
(pair? (cadr s)) (= (length (cadr s)) 1)
(pair? (caddr s)) (= (length (caddr s)) 1)
(pair? (cadddr s)) (= (length (cadddr s)) 1)
(pair? (list-ref s 4)) (= (length (list-ref s 4)) 1))
(pair? (list-ref s 4)) (= (length (list-ref s 4)) 1)
(pair? (list-ref s 5)) (= (length (list-ref s 5)) 1))
(make-profj-settings (caar s) (caadr s) (caaddr s)
(car (cadddr s))
(car (list-ref s 4)) null)
(car (list-ref s 4)) (car (list-ref s 5)) null)
#f))
;Create the ProfessorJ settings selection panel
@ -244,6 +247,9 @@
(string-constant profj-language-config-testing-check)
testing-prefs
(lambda (x y) update-at)))]
[allow-test (when (eq? level 'full)
(make-object check-box% "Support test Language extension?"
testing-prefs (lambda (x y) update-at2)))]
[display-testing
(make-object check-box% (string-constant profj-language-config-testing-enable)
testing-prefs (lambda (x y) (update-dt x y)))]
@ -254,6 +260,7 @@
[update-pf (lambda () (void))]
[update-ps (lambda () (void))]
[update-at (lambda () (void))]
[update-at2 (lambda () (void))]
[update-dt (lambda (box event)
(when (eq? 'check-box (send event get-event-type))
(send collect-coverage enable (send box get-value))))]
@ -406,6 +413,8 @@
(send print-full get-value))
(or (not (eq? level 'full))
(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)
(send collect-coverage get-value))
@ -420,6 +429,8 @@
(send print-full set-value (profj-settings-print-full? settings)))
(when (eq? level 'full)
(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 collect-coverage set-value (profj-settings-coverage? settings))
@ -595,11 +606,13 @@
[n (current-namespace)]
[e (current-eventspace)])
(test-ext? (profj-settings-allow-check? settings))
(testcase-ext? (profj-settings-allow-test? settings))
(let ((execute-types (create-type-record)))
(read-case-sensitive #t)
(run-in-user-thread
(lambda ()
(test-ext? (profj-settings-allow-check? settings))
(testcase-ext? (profj-settings-allow-test? settings))
(tests? (profj-settings-run-tests? settings))
(coverage? (and (tests?) (profj-settings-coverage? settings)))
(error-display-handler
@ -614,7 +627,9 @@
(execution? #t)
(set! execute-types (create-type-record))
(let* ((compilation-units (compile-ast exp level execute-types))
(examples (find-examples compilation-units)))
(examples (if (testcase-ext?)
(list (send execute-types get-test-classes) null)
(find-examples compilation-units))))
(let ((name-to-require #f)
(tests-run? #f))
(let loop ((mods (order compilation-units))

7
collects/profj/types.ss
View File

@ -9,7 +9,7 @@
"ast.ss")
(provide (all-defined-except number-assign-conversions remove-dups meth-member?
contained-in? consolidate-lists subset?
contained-in? consolidate-lists subset? depth conversion-steps
generate-require-spec))
;; symbol-type = 'null | 'string | 'boolean | 'char | 'byte | 'short | 'int
@ -552,6 +552,11 @@
(lambda (k v) (add-to-env k v 'interactions)))
(set! execution-loc #f)))
(define test-classes null)
(define/public (add-test-class name)
(set! test-classes (cons name test-classes)))
(define/public (get-test-classes) test-classes)
(super-instantiate ())))
(define get-importer (class-field-accessor type-records importer))