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) ;;(make-interface-def header (list member) src src string symbol (list req) symbol)
(p-define-struct (interface-def def) ()) (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)) ;;(make-req string (list string))
(p-define-struct req (class path)) (p-define-struct req (class path))
;;(make-header id (list modifier) (list name) (list name) (list gj-info) src) ;;(make-header id (list modifier) (list name) (list name) (list gj-info) src)
(p-define-struct header (id modifiers extends implements type-parms 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) ;;(make-modifier symbol src)
(p-define-struct modifier (kind 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) ;;(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)) (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) ;;(make-initialize bool block src)
(p-define-struct initialize (static block src)) (p-define-struct initialize (static block src))
@ -282,8 +291,16 @@
(p-define-struct (assignment expr) (left op right key-src)) (p-define-struct (assignment expr) (left op right key-src))
;Op -> = *= /= %= += -= <<= >>= >>>= &= ^= or= ;Op -> = *= /= %= += -= <<= >>= >>>= &= ^= or=
;(make-check (U #f type) src Expression Expression (U #f Expression) src) (p-define-struct (check expr) ())
(p-define-struct (check expr) (test actual range ta-src))
;(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))))) (list (id-string (name-id (package-name prog)))))
null)) null))
(lang-pack `("java" "lang")) (lang-pack `("java" "lang"))
(test-pack `("java" "tester"))
(lang (filter (lambda (class) (lang (filter (lambda (class)
(not (forbidden-lang-class? class level))) (not (forbidden-lang-class? class level)))
(send type-recs get-package-contents lang-pack (send type-recs get-package-contents lang-pack
(lambda () (error 'type-recs "Internal error: Type record not set with lang"))))) (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))) (defs (let loop ((cur-defs (package-defs prog)))
(cond (cond
((null? cur-defs) null) ((null? cur-defs) null)
@ -88,7 +92,7 @@
(loop (cdr cur-defs)))))) (loop (cdr cur-defs))))))
(current-loc (cond (current-loc (cond
((not (null? defs)) (def-file (car defs))) ((not (null? defs)) (def-file (car defs)))
((not (null? (package-imports prog))) ((not (null? (package-imports prog)))
(import-file (car (package-imports prog))))))) (import-file (car (package-imports prog)))))))
(set-package-defs! prog defs) (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) (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) (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 ;Set location for type error messages
(build-info-location current-loc) (build-info-location current-loc)
@ -402,34 +410,48 @@
;load-lang: type-records -> void (adds lang to type-recs) ;load-lang: type-records -> void (adds lang to type-recs)
(define (load-lang type-recs) (define (load-lang type-recs)
(let* ((lang `("java" "lang")) (let* ((lang `("java" "lang"))
(dir (find-directory lang (lambda () (error 'load-lang "Internal-error: Lang not accessible")))) (test '("java" "tester"))
(class-list (map (lambda (fn) (substring fn 0 (- (string-length fn) 6))) (lang-dir (find-directory lang (lambda () (error 'load-lang "Internal-error: Lang not accessible"))))
(map path->string (test-dir (when (testcase-ext?)
(filter (lambda (f) (equal? (filename-extension f) #"jinfo")) (find-directory test (lambda () (error 'load-lang "Internal-error: Test not accessible")))))
(directory-list (build-path (dir-path-path dir) "compiled")))))) (get-classes
(array (datum->syntax-object #f `(lib "array.ss" "profj" "libs" "java" "lang") #f))) (lambda (base-dir)
;(printf "class-list ~a~n" class-list) (map (lambda (fn) (substring fn 0 (- (string-length fn) 6)))
(send type-recs add-package-contents lang class-list) (map path->string
(for-each (lambda (c) (import-class c lang dir #f type-recs 'full #f #f)) class-list) (filter (lambda (f) (equal? (filename-extension f) #"jinfo"))
(send type-recs add-require-syntax (list 'array) (list array array)) (directory-list (build-path (dir-path-path base-dir) "compiled")))))))
(lang-classes (get-classes lang-dir))
;Add lang to interactions environment (test-classes (when (testcase-ext?) (get-classes test-dir)))
(for-each (lambda (class) (send type-recs add-to-env class lang 'interactions)) class-list) (array (datum->syntax-object #f `(lib "array.ss" "profj" "libs" "java" "lang") #f))
(send type-recs set-location! 'interactions)
(for-each (lambda (class) (send type-recs add-class-req (cons class lang) #f 'interactions)) class-list) (add
(send type-recs add-class-req (list 'array) #f 'interactions) (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 ;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) (define (process-class/iface ci package-name type-recs look-in-table put-in-table level)
(cond (cond
((interface-def? ci) [(interface-def? ci)
(process-interface ci package-name type-recs look-in-table put-in-table level)) (process-interface ci package-name type-recs look-in-table put-in-table level)]
((class-def? ci) [(class-def? ci)
(process-class ci package-name type-recs look-in-table put-in-table level)))) (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 ;;get-parent-record: (list string) name (list string) type-records (list string) -> record
(define (get-parent-record name n child-name level type-recs) (define (get-parent-record name n child-name level type-recs)
@ -535,9 +557,9 @@
(let*-values (((old-methods) (class-record-methods super-record)) (let*-values (((old-methods) (class-record-methods super-record))
((f m i) ((f m i)
(if (memq 'strictfp test-mods) (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)) (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))) ((ctor?) (has-ctor? m)))
(unless ctor? (unless ctor?
@ -744,7 +766,7 @@
(let-values (((f m i) (process-members members (apply append (let-values (((f m i) (process-members members (apply append
(map class-record-methods super-records)) (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-field-names? f members m level type-recs)
(valid-method-sigs? m members 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) (get-record (send type-recs get-class-record iname #f build-record) type-recs)
(build-record))))) (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) ;;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)))) (find-member member-record (cdr members) level type-recs))))
(else (else
(find-member member-record (cdr members) level type-recs)))) (find-member member-record (cdr members) level type-recs))))
;valid-method-sigs? (list method-record) (list member) symbol type-records -> bool ;valid-method-sigs? (list method-record) (list member) symbol type-records -> bool
(define (valid-method-sigs? methods members level type-recs) (define (valid-method-sigs? methods members level type-recs)
(or (null? methods) (or (null? methods)
@ -1187,9 +1319,9 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Methods to process fields and methods ;;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)) ;; (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) (let loop ((members members)
(fields null) (fields null)
(methods null) (methods null)
@ -1205,8 +1337,8 @@
(loop (cdr members) (loop (cdr members)
fields fields
(cons (if (null? args) (cons (if (null? args)
(process-method (car members) inherited-methods cname type-recs level) (process-method (car members) inherited-methods cname type-recs level test?)
(process-method (car members) inherited-methods cname type-recs level (car args))) (process-method (car members) inherited-methods cname type-recs level test? (car args)))
methods) methods)
inners)) inners))
((def? (car members)) ((def? (car members))
@ -1229,8 +1361,8 @@
(if (class-name) (cons (class-name) (cdr cname)) cname) (if (class-name) (cons (class-name) (cdr cname)) cname)
(field-type field))) (field-type field)))
;; process-method: method (list method-record) (list string) type-records symbol -> method-record ;; process-method: method (list method-record) (list string) type-records symbol boolean -> method-record
(define (process-method method inherited-methods cname type-recs level . args) (define (process-method method inherited-methods cname type-recs level test? . args)
(let* ((name (id-string (method-name method))) (let* ((name (id-string (method-name method)))
(parms (map (lambda (p) (parms (map (lambda (p)
(set-field-type! p (type-spec-to-type (field-type-spec p) cname level type-recs)) (set-field-type! p (type-spec-to-type (field-type-spec p) cname level type-recs))
@ -1250,6 +1382,11 @@
(method-throws method)))) (method-throws method))))
(over? (overrides? name parms inherited-methods))) (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)) (when (and (memq level '(beginner intermediate))
(member name (map method-record-name inherited-methods)) (member name (map method-record-name inherited-methods))
(not over?)) (not over?))
@ -1577,7 +1714,28 @@
((implement-class) ((implement-class)
(format "Only interfaces may be implemented, class ~a has attempted to implement class ~a." n s))) (format "Only interfaces may be implemented, class ~a has attempted to implement class ~a." n s)))
s src))) 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 ;method-error: symbol id (list type) type string src bool -> void
(define (method-error kind name parms ret class src ctor?) (define (method-error kind name parms ret class src ctor?)
(if (eq? kind 'inherited-conflict-field) (if (eq? kind 'inherited-conflict-field)
@ -1610,6 +1768,27 @@
m-full-name class r-name (type->ext-name ctor?)))) m-full-name class r-name (type->ext-name ctor?))))
m-name src)))) 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 ;inherited-overload-error: string string (list type) (list type) src -> void
(define (inherited-overload-error curr-class name new-type inherit-type src) (define (inherited-overload-error curr-class name new-type inherit-type src)
(let* ((n (string->symbol name)) (let* ((n (string->symbol name))

120
collects/profj/check.ss
View File

@ -265,9 +265,13 @@
(lambda () (lambda ()
(error 'check-defs (error 'check-defs
"Internal error: Current def does not have a record entry"))))) "Internal error: Current def does not have a record entry")))))
(if (interface-def? def) (cond
(check-interface def package-name (def-level def) type-recs) ((interface-def? def)
(check-class def package-name (def-level def) type-recs empty-env))) (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))) (packages (cons def (packages)))
(when (not (null? (check-list))) (when (not (null? (check-list)))
(check-defs (car (check-list)) level type-recs))) (check-defs (car (check-list)) level type-recs)))
@ -336,6 +340,18 @@
(set-def-uses! class (send type-recs get-class-reqs)) (set-def-uses! class (send type-recs get-class-reqs))
(update-class-with-inner old-update) (update-class-with-inner old-update)
(send type-recs set-class-reqs old-reqs))) (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 ;check-interface: interface-def (list string) symbol type-recs -> void
(define (check-interface iface p-name level type-recs) (define (check-interface iface p-name level type-recs)
@ -400,6 +416,14 @@
(eq? (var-type-properties type-var) final-method-var))) (eq? (var-type-properties type-var) final-method-var)))
(environment-types env))))) (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 ;;Member checking methods
@ -1512,15 +1536,9 @@
env))) env)))
((check? exp) ((check? exp)
(set-expr-type exp (set-expr-type exp
(check-test-expr (check-test exp) (check-test-exprs exp
(check-actual exp) check-sub-expr
(check-range exp) env level type-recs)))
check-sub-expr
env
level
(check-ta-src exp)
(expr-src exp)
type-recs)))
))) )))
;;check-bin-op: symbol exp exp (exp env -> type/env) env src-loc symbol type-records -> type/env ;;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) (and (special-name? expr)
(equal? "this" (special-name-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 ;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)) (let* ((test-te (check-e test env))
(test-t (type/env-t test-te)) (test-t (type/env-t test-te))
(actual-te (check-e actual (type/env-e test-te))) (actual-te (check-e actual (type/env-e test-te)))
@ -2728,7 +2772,30 @@
level level
test-t actual-t ta-src))))) 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 ;;Expression Errors
@ -3369,8 +3436,8 @@
;;Assignment errors ;;Assignment errors
;illegal-assignment: src -> void ;illegal-assignment: src -> void
(define (illegal-assignment src) (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 ;ctor-illegal-assignment: id src -> void
(define (ctor-illegal-assignment name src) (define (ctor-illegal-assignment name src)
(raise-error '= (raise-error '=
@ -3471,6 +3538,29 @@
'check ta-src '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)) (define check-location (make-parameter #f))

1
collects/profj/compile.ss
View File

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

7
collects/profj/installer.ss
View File

@ -1,11 +1,12 @@
(module installer mzscheme (module installer mzscheme
(require (prefix lang: (lib "installer.ss" "profj" "libs" "java" "lang")) (require (prefix lang: (lib "installer.ss" "profj" "libs" "java" "lang"))
(prefix io: (lib "installer.ss" "profj" "libs" "java" "io")) (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) (provide installer)
(define (installer plthome) (define (installer plthome)
(io:installer plthome) (io:installer plthome)
(lang: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 (module runtime mzscheme
(require (lib "class.ss") (require (lib "class.ss")
(lib "list.ss")
(lib "Object.ss" "profj" "libs" "java" "lang") (lib "Object.ss" "profj" "libs" "java" "lang")
(lib "String.ss" "profj" "libs" "java" "lang") (lib "String.ss" "profj" "libs" "java" "lang")
(lib "Throwable.ss" "profj" "libs" "java" "lang") (lib "Throwable.ss" "profj" "libs" "java" "lang")
(lib "ArithmeticException.ss" "profj" "libs" "java" "lang") (lib "ArithmeticException.ss" "profj" "libs" "java" "lang")
(lib "ClassCastException.ss" "profj" "libs" "java" "lang") (lib "ClassCastException.ss" "profj" "libs" "java" "lang")
(lib "NullPointerException.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 (provide convert-to-string shift not-equal bitwise mod divide-dynamic divide-int
divide-float and or cast-primitive cast-reference instanceof-array nullError 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) (define (check-eq? obj1 obj2)
(or (eq? obj1 obj2) (or (eq? obj1 obj2)
@ -165,19 +166,19 @@
(if (send val check-ref-type type dim) (if (send val check-ref-type type dim)
val val
(raise-class-cast (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 (cond
((and (eq? Object type) (is-a? val ObjectI)) val) ((and (eq? Object type) (is-a? val ObjectI)) val)
((and (is-a? val convert-assert-Object) (is-a? val ca-type)) val) ((and (is-a? val convert-assert-Object) (is-a? val ca-type)) val)
((is-a? val convert-assert-Object) ((is-a? val convert-assert-Object)
(or (send val down-cast type ca-type) (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) ((and (is-a? val guard-convert-Object) (is-a? val gc-type)) val)
((is-a? val guard-convert-Object) ((is-a? val guard-convert-Object)
(or (send val down-cast type gc-type) (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) ((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 ;instanceof-array: bool val (U class sym) int -> bool
(define (instanceof-array prim? val type dim) (define (instanceof-array prim? val type dim)
@ -198,13 +199,15 @@
(send exn NullPointerException-constructor-java.lang.String msg)) (send exn NullPointerException-constructor-java.lang.String msg))
(current-continuation-marks)))) (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 ;compare: val val (list symbol string ...) string (U #f object)-> boolean
(define (compare test act info src test-obj) (define (compare test act info src test-obj)
(compare-within test act 0.0 info src test-obj #f)) (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?) (define (compare-within test act range info src test-obj . within?)
(when test-obj (send test-obj add-check))
(letrec ((java-equal? (letrec ((java-equal?
(lambda (v1 v2 visited-v1 visited-v2) (lambda (v1 v2 visited-v1 visited-v2)
(or (eq? v1 v2) (or (eq? v1 v2)
@ -239,42 +242,108 @@
(map (lambda (v) (cons v2 visited-v2)) v2-fields))))))))) (map (lambda (v) (cons v2 visited-v2)) v2-fields)))))))))
((and (not (object? v1)) (not (object? v2))) (equal? v1 v2)) ((and (not (object? v1)) (not (object? v2))) (equal? v1 v2))
(else #f)))))) (else #f))))))
(let ((res (java-equal? test act null null))) (set! test (test))
(unless res (let ([res (java-equal? test act null null)]
(when test-obj [values-list (append (list act test) (if (null? within?) (list range) null))])
(send test-obj (if (in-check-mutate?)
check-failed (stored-checks (cons (list res 'check-expect info values-list src) (stored-checks)))
(append '("check expected ") (report-check-result res 'check-expect info values-list src test-obj))
(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)))
res))) 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) (define (array->list v)
(letrec ((len (send v length)) (letrec ((len (send v length))
(build-up (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 ;Stores whether testing extension is on or not
(define test-ext? (make-parameter #t)) (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 ;Stores whether the test window should pop up
(define tests? (make-parameter #t)) (define tests? (make-parameter #t))

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

@ -773,9 +773,9 @@
(CheckExpression (CheckExpression
[(ConditionalExpression) $1] [(ConditionalExpression) $1]
[(check ConditionalExpression expect ConditionalExpression) [(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) [(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 (AssignmentExpression
[#;(ConditionalExpression)(CheckExpression) $1]) [#;(ConditionalExpression)(CheckExpression) $1])

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

@ -445,9 +445,9 @@
(CheckExpression (CheckExpression
[(ConditionalOrExpression) $1] [(ConditionalOrExpression) $1]
[(check ConditionalOrExpression expect ConditionalOrExpression) [(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) [(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 (Assignment
[(LeftHandSide AssignmentOperator CheckExpression) [(LeftHandSide AssignmentOperator CheckExpression)

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

@ -154,8 +154,7 @@
(TypeDeclaration (TypeDeclaration
[(ClassDeclaration) $1] [(ClassDeclaration) $1]
[(InterfaceDeclaration) $1] [(InterfaceDeclaration) $1]
#;[(INTERACTIONS_BOX) $1] [(TestDeclaration) $1]
#;[(CLASS_BOX) (parse-class-box $1 (build-src 1) 'full)]
[(TEST_SUITE) $1] [(TEST_SUITE) $1]
[(EXAMPLE) $1] [(EXAMPLE) $1]
[(SEMI_COLON) #f]) [(SEMI_COLON) #f])
@ -435,6 +434,84 @@
(AbstractMethodDeclaration (AbstractMethodDeclaration
[(MethodHeader SEMI_COLON) $1]) [(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 ;; 19.10
(ArrayInitializer (ArrayInitializer
@ -947,12 +1024,19 @@
(CheckExpression (CheckExpression
[(ConditionalExpression) $1] [(ConditionalExpression) $1]
[(check ConditionalExpression expect ConditionalExpression) [(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) [(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 (AssignmentExpression
[#;(ConditionalExpression) (CheckExpression) $1] [#;(ConditionalExpression) #;(CheckExpression) (MutateExpression) $1]
[(Assignment) $1]) [(Assignment) $1])
(Assignment (Assignment

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

@ -582,9 +582,9 @@
(CheckExpression (CheckExpression
[(ConditionalOrExpression) $1] [(ConditionalOrExpression) $1]
[(check ConditionalOrExpression expect ConditionalOrExpression) [(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) [(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 #;(ConditionalExpression
[(ConditionalOrExpression) $1]) [(ConditionalOrExpression) $1])

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

@ -44,7 +44,7 @@
const for new switch const for new switch
continue goto package synchronized)) 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 (define-tokens java-vals
(STRING_LIT CHAR_LIT INTEGER_LIT LONG_LIT FLOAT_LIT DOUBLE_LIT (STRING_LIT CHAR_LIT INTEGER_LIT LONG_LIT FLOAT_LIT DOUBLE_LIT
@ -250,6 +250,10 @@
((string=? l "||") (token-OR)) ((string=? l "||") (token-OR))
((string=? l "|=") (token-OREQUAL)) ((string=? l "|=") (token-OREQUAL))
(else (string->symbol l))))) (else (string->symbol l)))))
("->" (string->symbol lexeme))
("->>" (string->symbol lexeme))
("->>>" (string->symbol lexeme))
;; 3.11 ;; 3.11
("(" (token-O_PAREN)) ("(" (token-O_PAREN))
@ -313,6 +317,11 @@
((test-ext?) (string->symbol lexeme)) ((test-ext?) (string->symbol lexeme))
(else (token-IDENTIFIER lexeme)))) (else (token-IDENTIFIER lexeme))))
((re:or "test" "tests" "testcase")
(cond
((testcase-ext?) (string->symbol lexeme))
(else (token-IDENTIFIER lexeme))))
;; 3.9 ;; 3.9
(Keyword (string->symbol lexeme)) (Keyword (string->symbol lexeme))
@ -418,6 +427,13 @@
(else 'identifier)) (else 'identifier))
#f start-pos end-pos)) #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 (KnownTypes
(syn-val lexeme 'prim-type #f start-pos end-pos)) (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 "file.ss")
(lib "etc.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@) (provide test-info% test-display% test-tool@)
@ -27,7 +27,8 @@
#;(make-single-test string (listof testcase) (listof string) #;(make-single-test string (listof testcase) (listof string)
int (listof failed-check) (listof src)) int (listof failed-check) (listof src))
(define-struct single-test (name testcases not-tested (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)) ;(make-failed-check src (listof (U string snip%)) (listof src))
(define-struct failed-check (src msg covers)) (define-struct failed-check (src msg covers))
@ -44,13 +45,15 @@
(define covered null);------------- (listof src) (define covered null);------------- (listof src)
(define nearly-tested-classes null);(listof string) (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 current-testcoverage null)
(define total-tests 0) (define total-tests 0)
(define failed-tests 0) (define failed-tests 0)
(define total-checks 0) (define total-checks 0)
(define failed-checks 0) (define failed-checks 0)
(define current-test-obj null)
(define/public (add-check) (define/public (add-check)
(set-single-test-num-checks! current-class (set-single-test-num-checks! current-class
@ -73,7 +76,9 @@
(set! current-testcoverage (cons src current-testcoverage)) (set! current-testcoverage (cons src current-testcoverage))
(set-single-test-covered-exprs! (set-single-test-covered-exprs!
current-class 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) (define/public (provide-test-results)
(values tested-classes covered nearly-tested-classes total-tests (values tested-classes covered nearly-tested-classes total-tests
@ -86,19 +91,39 @@
(let ((objects (let ((objects
(map (map
(lambda (name/class) (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)))) (let ((obj (make-object (cadr name/class))))
(when (testcase-ext?) (set! current-test-obj obj))
(with-handlers ((exn? (lambda (e) (raise e)))) (with-handlers ((exn? (lambda (e) (raise e))))
((current-eval) ((current-eval)
#`(send #,obj #,(string->symbol (string-append (car name/class) #`(send #,obj #,(string->symbol (string-append (car name/class)
"-constructor"))))) "-constructor")))))
(run-methods obj) (if (testcase-ext?)
(run-testcases obj)
(run-methods obj))
(set! tested-classes (cons current-class tested-classes)) (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))) (list (car name/class) obj)))
tests))) tests)))
(set! nearly-tested-classes close-names) (set! nearly-tested-classes close-names)
(map cadr objects))) (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) (define/private (run-methods object)
(let loop ([methods (reverse (interface->method-names (object-interface object)))]) (let loop ([methods (reverse (interface->method-names (object-interface object)))])
(cond (cond
@ -224,7 +249,9 @@
(make-covered-button covered editor #f) (make-covered-button covered editor #f)
(send editor insert "\n")) (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 (for-each
(lambda (test-info) (lambda (test-info)
(send editor insert "\n") (send editor insert "\n")
@ -251,6 +278,29 @@
(make-covered-button (testcase-covers test) editor #f)) (make-covered-button (testcase-covers test) editor #f))
(next-line)) (next-line))
(reverse (single-test-testcases test-info))))) (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) (when (> (single-test-num-checks test-info) 0)
(next-line) (next-line)
(send editor insert (format "Ran ~a checks." (single-test-num-checks test-info))) (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. ;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 ;Parameters for information about each class
(define class-name (make-parameter "interactions")) (define class-name (make-parameter "interactions"))
(define loc (make-parameter #f)) (define loc (make-parameter #f))
@ -207,16 +210,16 @@
(list (id-string (name-id (package-name program))))) (list (id-string (name-id (package-name program)))))
null)) null))
(full-defs (if (null? (packages)) (package-defs program) (append (packages) (package-defs program)))) (full-defs (if (null? (packages)) (package-defs program) (append (packages) (package-defs program))))
(dependent-defs (find-dependent-defs full-defs type-recs)) (dependent-defs (find-dependent-defs full-defs type-recs)))
(modules (map (lambda (defs) (classes full-defs)
(let*-values (((ordered-defs) (order-defs defs)) (map (lambda (defs)
((translated-defs reqs) (translate-defs ordered-defs type-recs))) (let*-values (((ordered-defs) (order-defs defs))
(make-compilation-unit (map (lambda (def) (id-string (def-name def))) ordered-defs) ((translated-defs reqs) (translate-defs ordered-defs type-recs)))
translated-defs (make-compilation-unit (map (lambda (def) (id-string (def-name def))) ordered-defs)
(map def-file ordered-defs) translated-defs
reqs))) (map def-file ordered-defs)
dependent-defs))) reqs)))
modules)) dependent-defs)))
;get-package: definition type-records -> (list string) ;get-package: definition type-records -> (list string)
(define (get-package def type-recs) (define (get-package def type-recs)
@ -352,9 +355,13 @@
`(file ,(path->string (build-path (string-append (symbol->string (module-name)) ".zo"))))) `(file ,(path->string (build-path (string-append (symbol->string (module-name)) ".zo")))))
(module-name))) (module-name)))
(let* ((translated-defs (map (lambda (d) (let* ((translated-defs (map (lambda (d)
(if (class-def? d) (cond
(translate-class d type-recs 0) ((class-def? d)
(translate-interface d type-recs))) (translate-class d type-recs #f 0))
((test-def? d)
(translate-class d type-recs #t 0))
(else
(translate-interface d type-recs))))
defs)) defs))
(group-reqs (apply append (map (lambda (d) (group-reqs (apply append (map (lambda (d)
(map (lambda (r) (list (def-file d) r)) (def-uses d))) (map (lambda (r) (list (def-file d) r)) (def-uses d)))
@ -476,8 +483,8 @@
(build-src (name-src i)))))) (build-src (name-src i))))))
imp)) imp))
;translate-class: class-def type-records -> (list syntax syntax) ;translate-class: class-def type-records boolean int -> (list syntax syntax)
(define (translate-class class type-recs depth) (define (translate-class class type-recs test? depth)
;Let's grab onto the enclosing class-specific info incase depth > 0 ;Let's grab onto the enclosing class-specific info incase depth > 0
(let ((old-class-name (class-name)) (let ((old-class-name (class-name))
(old-parent-name (parent-name)) (old-parent-name (parent-name))
@ -492,7 +499,9 @@
((closure-args) (def-closure-args class)) ((closure-args) (def-closure-args class))
((parent parent-src extends-object?) ((parent parent-src extends-object?)
(if (null? (header-extends header)) (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)))) (let-values (((p p-s) (get-parent (header-extends header))))
(values p p-s (values p p-s
(class-record-object? (class-record-object?
@ -532,7 +541,7 @@
(accesses-protected methods)) (accesses-protected methods))
overridden-methods)) overridden-methods))
#;(dynamic-method-defs (generate-dyn-method-defs names-for-dynamic)) #;(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) (wrapper-classes (append (generate-wrappers (class-name)
(parent-name) (parent-name)
(filter (filter
@ -677,6 +686,71 @@
,(if (null? (accesses-private methods)) ,(if (null? (accesses-private methods))
'(make-hash-table) '(make-hash-table)
(build-method-table (accesses-private methods) private-generics))) (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) ,@(map (lambda (i) (translate-initialize (initialize-static i)
(initialize-block i) (initialize-block i)
@ -697,7 +771,7 @@
(append (accesses-public fields) (append (accesses-public fields)
(accesses-package fields) (accesses-package fields)
(accesses-protected 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)) (members-inner class-members))
,@(create-static-methods (append static-method-names ,@(create-static-methods (append static-method-names
(make-static-method-names (make-static-method-names
@ -900,7 +974,7 @@
(cond (cond
((symbol? type) ((symbol? type)
(case 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? ((string) (if from-dynamic?
`(make-java-string ,value) `(make-java-string ,value)
`(send ,value get-mzscheme-string))))) `(send ,value get-mzscheme-string)))))
@ -953,7 +1027,8 @@
((char) (check 'char?)) ((char) (check 'char?))
((string) (check 'string?)) ((string) (check 'string?))
((boolean) (check 'boolean?)) ((boolean) (check 'boolean?))
((dynamic) value)))) ((dynamic) value)
((null) value))))
((and (ref-type? type) (equal? string-type type)) ((and (ref-type? type) (equal? string-type type))
(assert-value value 'string from-dynamic? kind name)) (assert-value value 'string from-dynamic? kind name))
(else value)))) (else value))))
@ -1191,6 +1266,90 @@
(build-src (name-src n))))) (build-src (name-src n)))))
extends)) 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) ;translate-interface: interface-def type-records-> (list syntax)
(define (translate-interface iface type-recs) (define (translate-interface iface type-recs)
(let* ((header (def-header iface)) (let* ((header (def-header iface))
@ -1938,7 +2097,7 @@
((dynamic-val? type) val) ((dynamic-val? type) val)
((symbol? type) ((symbol? type)
(case 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)))) ((string String) `(send ,val get-mzscheme-string))))
((ref-type? type) ((ref-type? type)
(if (equal? type string-type) (if (equal? type string-type)
@ -2078,10 +2237,7 @@
(expr-types expr) (expr-types expr)
(assignment-key-src expr) (assignment-key-src expr)
(expr-src expr))) (expr-src expr)))
((check? expr) (translate-check (check-test expr) ((check? expr) (translate-check expr))
(check-actual expr)
(check-range expr)
(expr-src expr)))
(else (else
(error 'translate-expression (format "Translate Expression given unrecognized expression ~s" expr))))) (error 'translate-expression (format "Translate Expression given unrecognized expression ~s" expr)))))
@ -2752,10 +2908,25 @@
(send ,name set ,index ,new-val) (send ,name set ,index ,new-val)
,new-val) ,new-val)
(build-src src)))) (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 ;translate-check: expression expression (U expression #f) src -> syntax
(define (translate-check test actual range src) (define (translate-check-expect test actual range src)
(let ((t (translate-expression test)) (let ((t (make-syntax #f `(lambda () ,(translate-expression test)) #f))
(a (translate-expression actual)) (a (translate-expression actual))
(r (when range (translate-expression range))) (r (when range (translate-expression range)))
(extracted-info (checked-info test))) (extracted-info (checked-info test)))
@ -2767,6 +2938,26 @@
(lambda () #f))) (lambda () #f)))
(build-src src)))) (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") (require "error-messaging.ss")
;checked-info: expression -> (list sym string...) ;checked-info: expression -> (list sym string...)
@ -2806,6 +2997,9 @@
'(list (quote array))) '(list (quote array)))
((unary? exp) ((unary? exp)
'(list (quote unary) (quote (unary-op exp)))) '(list (quote unary) (quote (unary-op exp))))
((assignment? exp)
`(list (quote assignment)
,@(checked-info (assignment-left exp))))
(else '(list (quote value))))) (else '(list (quote value)))))
(define (type-spec->ext-name t) (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)) ;(make-profj-settings symbol boolean boolean boolean boolean (list string))
(define-struct profj-settings (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 ;ProfJ general language mixin
(define (java-lang-mixin level name number one-line dyn?) (define (java-lang-mixin level name number one-line dyn?)
@ -179,8 +179,8 @@
;default-settings: -> profj-settings ;default-settings: -> profj-settings
(define/public (default-settings) (define/public (default-settings)
(if (memq level `(beginner intermediate advanced)) (if (memq level `(beginner intermediate advanced))
(make-profj-settings 'field #f #t #t #t null) (make-profj-settings 'field #f #t #f #t #t null)
(make-profj-settings 'type #f #t #f #f null))) (make-profj-settings 'type #f #t #t #f #f null)))
;default-settings? any -> bool ;default-settings? any -> bool
(define/public (default-settings? s) (equal? s (default-settings))) (define/public (default-settings? s) (equal? s (default-settings)))
@ -188,6 +188,7 @@
(make-profj-settings (profj-settings-print-style s) (make-profj-settings (profj-settings-print-style s)
(profj-settings-print-full? s) (profj-settings-print-full? s)
(profj-settings-allow-check? s) (profj-settings-allow-check? s)
(profj-settings-allow-test? s)
test? test?
(profj-settings-coverage? s) (profj-settings-coverage? s)
(profj-settings-classpath s))) (profj-settings-classpath s)))
@ -197,20 +198,22 @@
(list (list (profj-settings-print-style s)) (list (list (profj-settings-print-style s))
(list (profj-settings-print-full? s)) (list (profj-settings-print-full? s))
(list (profj-settings-allow-check? s)) (list (profj-settings-allow-check? s))
(list (profj-settings-allow-test? s))
(list (profj-settings-run-tests? s)) (list (profj-settings-run-tests? s))
(list (profj-settings-coverage? s)))) (list (profj-settings-coverage? s))))
;unmarshall-settings: any -> (U profj-settings #f) ;unmarshall-settings: any -> (U profj-settings #f)
(define/public (unmarshall-settings s) (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? (car s)) (= (length (car s)) 1)
(pair? (cadr s)) (= (length (cadr s)) 1) (pair? (cadr s)) (= (length (cadr s)) 1)
(pair? (caddr s)) (= (length (caddr s)) 1) (pair? (caddr s)) (= (length (caddr s)) 1)
(pair? (cadddr s)) (= (length (cadddr 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) (make-profj-settings (caar s) (caadr s) (caaddr s)
(car (cadddr s)) (car (cadddr s))
(car (list-ref s 4)) null) (car (list-ref s 4)) (car (list-ref s 5)) null)
#f)) #f))
;Create the ProfessorJ settings selection panel ;Create the ProfessorJ settings selection panel
@ -244,6 +247,9 @@
(string-constant profj-language-config-testing-check) (string-constant profj-language-config-testing-check)
testing-prefs testing-prefs
(lambda (x y) update-at)))] (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 [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)))]
@ -254,6 +260,7 @@
[update-pf (lambda () (void))] [update-pf (lambda () (void))]
[update-ps (lambda () (void))] [update-ps (lambda () (void))]
[update-at (lambda () (void))] [update-at (lambda () (void))]
[update-at2 (lambda () (void))]
[update-dt (lambda (box event) [update-dt (lambda (box event)
(when (eq? 'check-box (send event get-event-type)) (when (eq? 'check-box (send event get-event-type))
(send collect-coverage enable (send box get-value))))] (send collect-coverage enable (send box get-value))))]
@ -406,6 +413,8 @@
(send print-full get-value)) (send print-full get-value))
(or (not (eq? level 'full)) (or (not (eq? level 'full))
(send allow-testing get-value)) (send allow-testing get-value))
(and (eq? level 'full)
(send allow-test get-value))
(send display-testing get-value) (send display-testing get-value)
(and (send display-testing get-value) (and (send display-testing get-value)
(send collect-coverage get-value)) (send collect-coverage get-value))
@ -420,6 +429,8 @@
(send print-full set-value (profj-settings-print-full? settings))) (send print-full set-value (profj-settings-print-full? settings)))
(when (eq? level 'full) (when (eq? level 'full)
(send allow-testing set-value (profj-settings-allow-check? settings))) (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)) (send display-testing set-value (profj-settings-run-tests? settings))
(if (send display-testing get-value) (if (send display-testing get-value)
(send collect-coverage set-value (profj-settings-coverage? settings)) (send collect-coverage set-value (profj-settings-coverage? settings))
@ -595,11 +606,13 @@
[n (current-namespace)] [n (current-namespace)]
[e (current-eventspace)]) [e (current-eventspace)])
(test-ext? (profj-settings-allow-check? settings)) (test-ext? (profj-settings-allow-check? settings))
(testcase-ext? (profj-settings-allow-test? settings))
(let ((execute-types (create-type-record))) (let ((execute-types (create-type-record)))
(read-case-sensitive #t) (read-case-sensitive #t)
(run-in-user-thread (run-in-user-thread
(lambda () (lambda ()
(test-ext? (profj-settings-allow-check? settings)) (test-ext? (profj-settings-allow-check? settings))
(testcase-ext? (profj-settings-allow-test? settings))
(tests? (profj-settings-run-tests? settings)) (tests? (profj-settings-run-tests? settings))
(coverage? (and (tests?) (profj-settings-coverage? settings))) (coverage? (and (tests?) (profj-settings-coverage? settings)))
(error-display-handler (error-display-handler
@ -614,7 +627,9 @@
(execution? #t) (execution? #t)
(set! execute-types (create-type-record)) (set! execute-types (create-type-record))
(let* ((compilation-units (compile-ast exp level execute-types)) (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) (let ((name-to-require #f)
(tests-run? #f)) (tests-run? #f))
(let loop ((mods (order compilation-units)) (let loop ((mods (order compilation-units))

7
collects/profj/types.ss
View File

@ -9,7 +9,7 @@
"ast.ss") "ast.ss")
(provide (all-defined-except number-assign-conversions remove-dups meth-member? (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)) generate-require-spec))
;; symbol-type = 'null | 'string | 'boolean | 'char | 'byte | 'short | 'int ;; symbol-type = 'null | 'string | 'boolean | 'char | 'byte | 'short | 'int
@ -552,6 +552,11 @@
(lambda (k v) (add-to-env k v 'interactions))) (lambda (k v) (add-to-env k v 'interactions)))
(set! execution-loc #f))) (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 ()))) (super-instantiate ())))
(define get-importer (class-field-accessor type-records importer)) (define get-importer (class-field-accessor type-records importer))