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

Merged testing branch in with trunk-- merge -r 2619:3114 branches/kathyg

Browse Source 
svn: r3115
This commit is contained in:
Kathy Gray 2006-05-30 05:24:21 +00:00
parent 57c783162c
commit 86cafcc1a1
24 changed files with 1873 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/profj/ast.ss
View File

@ -201,6 +201,7 @@
; | cast
; | instanceof
; | assignment
; | check
;(make-literal (U #f type) src value)
(p-define-struct (literal expr) (val))
@ -282,6 +283,7 @@
;Op -> = *= /= %= += -= <<= >>= >>>= &= ^= or=
;(make-check (U #f type) src Expression Expression (U #f Expression) src)
(p-define-struct (check expr) (test actual range ta-src))
)

115
collects/profj/check.ss
View File

@ -1509,7 +1509,19 @@
c-class
level
type-recs
env))))))
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-bin-op: symbol exp exp (exp env -> type/env) env src-loc symbol type-records -> type/env
;;Fully checks bin-ops, including checking the subexpressions
@ -2614,8 +2626,8 @@
(local-access? (access-name l-exp)))
(add-set-to-env (id-string (local-access-name (access-name l-exp)))
(type/env-e rtype/env))
(type/env-e rtype/env)))))
(type/env-e rtype/env)))))
;check-final: expression bool bool string -> void
(define (check-final expr ctor? static-init? c-class env)
(let ((access (access-name expr))
@ -2659,7 +2671,58 @@
(and (special-name? expr)
(equal? "this" (special-name-name expr))))
;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)
(let* ((test-te (check-e test env))
(test-t (type/env-t test-te))
(actual-te (check-e actual (type/env-e test-te)))
(actual-t (type/env-t actual-te))
(range-te (if range (check-e range (type/env-e actual-te)) actual-te))
(range-t (when range (type/env-t range-te)))
(res (make-type/env 'boolean (type/env-e range-te))))
(when (eq? test-t 'void)
(check-type-error 'void test-t actual-t (expr-src test)))
(when (eq? actual-t 'void)
(check-type-error 'void test-t actual-t (expr-src actual)))
(when (and range (not (prim-numeric-type? range-t)))
(check-range-error (expr-src range) range-t))
(cond
((and (eq? 'boolean test-t)
(eq? 'boolean actual-t)) res)
((and (prim-numeric-type? test-t)
(prim-numeric-type? actual-t))
(if (or (and (prim-integral-type? test-t)
(prim-integral-type? actual-t))
range)
res
(check-double-error test-t actual-t
(expr-src test) (expr-src actual))))
((and (memq level '(advanced full))
(reference-type? test-t) (reference-type? actual-t))
(cond
((castable? actual-t test-t type-recs) res)
(else (check-type-error 'cast test-t actual-t ta-src))))
((and (memq level '(advanced full))
(or (array-type? test-t) (array-type? actual-t)))
(cond
((castable? actual-t test-t type-recs) res)
(else
(check-type-error 'cast test-t actual-t ta-src))))
((and (eq? level 'beginner) (reference-type? test-t) (reference-type? actual-t))
(if (or (is-eq-subclass? actual-t test-t type-recs)
(implements? actual-t test-t type-recs))
res
(check-type-error 'iface test-t actual-t ta-src)))
((and (reference-type? test-t) (reference-type? actual-t))
(if (or (is-eq-subclass? actual-t test-t type-recs)
(implements? actual-t test-t type-recs))
res
(check-type-error 'subtype test-t actual-t ta-src)))
(else
(check-type-error (if (memq level '(advanced full)) 'cast 'subtype)
test-t actual-t ta-src)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Expression Errors
@ -3345,6 +3408,50 @@
class)
(string->symbol class) src))
(define (check-range-error src type)
(raise-error
'check
(format "Within clause of 'check' must specify a range with a number, found ~a."
(type->ext-name type))
'within
src))
(define (check-double-error test-type actual-type test-src actual-src)
(let ((check-fault? (prim-integral-type? actual-type)))
(raise-error
(if check-fault? 'check 'expect)
(format "When ~a of a 'check' expression is a ~a, the expression must specify a range with 'within'."
(if check-fault?
"the expression to check"
"the expected expression")
(type->ext-name
(if check-fault? test-type actual-type)))
'check (if check-fault? test-src actual-src)
)))
(define (check-type-error kind test-type actual-type ta-src)
(raise-error
'check
(cond
((and (eq? kind 'void) (eq? test-type 'void))
"The test of a 'check' expression must produce a value. Current expression does not.")
((and (eq? kind 'void) (eq? actual-type 'void))
"The expected result of a 'check' expression must be a value. Current expression is not a value.")
(else
(string-append
(format "In a 'check' expression, the type of the expected expression must be ~a the tested expression.~n"
(if (eq? kind 'cast) "castable to" "a subtype of"))
(format "Found ~a, which is not ~a ~a, the type of the tested expression."
(type->ext-name actual-type)
(case kind
((cast) "castable to")
((iface subtype) "a subtype of"))
(type->ext-name test-type)
))))
'check ta-src
))
(define check-location (make-parameter #f))
(define raise-error (make-error-pass check-location))

167
collects/profj/display-java.ss Normal file
View File

@ -0,0 +1,167 @@
(module display-java mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred")
(lib "Object.ss" "profj" "libs" "java" "lang")
(lib "String.ss" "profj" "libs" "java" "lang")
(lib "array.ss" "profj" "libs" "java" "lang"))
(provide format-java-value make-format-style make-java-snip)
;
;
;
; ###### #
; # # # #
; # # &##& ## $#$ ##*# *#* $@#$: ##### ##### :## ##*##* $#@ ##
; ### &+ +& #$* : #+*#$*# -# # # # #+ *# $+ +#
; # # # # # # # # $##$# # # # # # # #
; # # # # # # # @+ # # # # # # # #
; # &+ +& # # # # #- +# #* :$ #* :$ # # # &+ +#
; ### &##& ##### ### ## # *##$ ## *##$ *##$ ##### ### ### $#@ #
; -@
; $##$
;
(define-struct format-style (print-full? display multi-line?))
;format-java-value: value format-style -> (listof (U string snip%))
(define (format-java-value value style)
(internal-format value
(format-style-print-full? style)
(format-style-display style)
null
(format-style-multi-line? style)
0))
;internal-format: value boolean symbol (listof value) boolean int -> (listof (U string snip%))
(define (internal-format value full-print? style already-printed newline? num-tabs)
(cond
((null? value) '("null"))
((number? value) (list (format "~a" value)))
((char? value) (list (format "'~a'" value)))
((boolean? value) (list (if value "true" "false")))
((is-java-array? value)
(if full-print?
(format-array->list value (send value length) -1 #t style already-printed newline? num-tabs)
(format-array->list value 3 (- (send value length) 3) #f style already-printed newline? num-tabs)))
((is-a? value String) (list (format "~v" (send value get-mzscheme-string))))
((string? value) (list (format "~v" value)))
((or (is-a? value ObjectI) (supports-printable-interface? value))
(cond
((and (equal? "Image" (send value my-name))
(object-method-arity-includes? value 'Image-constructor-dynamic 1)
(object-method-arity-includes? value 'movePinhole-graphics.Posn 1))
(list (cadr ((send value fields-for-display)))))
(else
(if (memq value already-printed)
(list (send value my-name))
(case style
((type) (list (send value my-name)))
((field)
(let* ((retrieve-fields (send value fields-for-display))
(st (format "~a(" (send value my-name)))
(new-tabs (+ num-tabs 3))
(fields null))
(let loop ((current (retrieve-fields)))
(let ((next (retrieve-fields)))
(when current
(set! fields
(append fields
(cons
(format "~a~a = "
(if newline? (if (eq? fields null)
(format "~n~a" (get-n-spaces new-tabs))
(get-n-spaces new-tabs)) "")
(car current))
(append
(if (memq (cadr current) already-printed)
(internal-format (cadr current) full-print? 'type already-printed #f 0)
(internal-format (cadr current) full-print? style
(cons value already-printed) newline?
(if newline?
(+ new-tabs (if (string? (car current))
(string-length (car current)) 1) 3)
num-tabs)))
(list (format "~a~a"
(if next "," "")
(if newline? (format "~n") " ")))))))
(loop next))))
(cons st
(append
(if (> (length fields) 1)
(reverse (cdr (reverse fields))) null) (list ")")))))
(else (list (send value my-name))))))))
(else (list value))))
;format-array->list: java-value int int bool symbol (list value) -> (list val)
(define (format-array->list value stop restart full-print? style already-printed nl? nt)
(letrec ((len (send value length))
(make-partial-string
(lambda (idx first-test second-test)
(cond
((first-test idx) "")
((second-test idx)
(append (internal-format (send value access idx) full-print? style already-printed nl? nt)
(list (make-partial-string (add1 idx) first-test second-test))))
(else
(append (internal-format (send value access idx) full-print? style already-printed nl? nt)
(list " "
(make-partial-string (add1 idx) first-test second-test))))))))
(if (or full-print? (< restart stop))
(append '("[") (make-partial-string 0 (lambda (i) (>= i len)) (lambda (i) (= i (sub1 len)))) '("]"))
(append '("[")
(make-partial-string 0 (lambda (i) (or (>= i stop) (>= i len))) (lambda (i) (= i (sub1 stop))))
'(" ... ")
(make-partial-string restart (lambda (i) (>= i len)) (lambda (i) (= i (sub1 len))))
'("]")))))
(define (get-n-spaces n)
(cond
((= n 0) "")
(else (string-append " " (get-n-spaces (sub1 n))))))
(define (supports-printable-interface? o)
(and (is-a? o object%)
(method-in-interface? 'my-name (object-interface o))
(method-in-interface? 'fields-for-display (object-interface o))))
;
;
;
; $#@*# #
; @ :#
; @+ ##*##* :## ##:#@
; $@## #+ *# # #* -$
; +$ # # # # #
; # # # # # #
; #$+ :$ # # # #: -$
; #*@#$ ### ### ##### # #@
; #
; ###
(define (make-java-snip value style)
(let* ((formatted-java (format-java-value value style))
(editor (new text%))
(snip (new editor-snip% (editor editor)
(with-border? #f))))
(when (> (total-length formatted-java) 28)
(set! formatted-java (format-java-value value
(make-format-style
(format-style-print-full? style)
(format-style-display style)
#t))))
(for-each (lambda (i)
(send editor insert i))
formatted-java)
snip))
(define (total-length lst)
(cond
((null? lst) 0)
((string? (car lst)) (+ (string-length (car lst))
(total-length (cdr lst))))
(else (add1 (total-length (cdr lst))))))
)

44
collects/profj/doc.txt
View File

@ -15,17 +15,50 @@ Java examples boxes, and test suite boxes. (i.e. what would be given to
javac plus two graphical boxes). Descriptions of these boxes can be
found in the DrScheme manual.
_ProfessorJ Beginner
_Testing in Java language levels:
The ProfessorJ language levels support a language extension to support testing
endeavors. This extension can be turned off with a language preference in
ProfessorJ Full and Java + dynamic. The extension adds two expression forms
to Java:
check EXPR expect EXPR
check EXPR expect EXPR within EXPR
To include these expressions in any larger expression (i.e. EXPR || EXPR), the check
expression must be within parentheses. The resulting type of both expressions is a
boolean. The check expression compares the two subexpressions for equality (without
using .equals). When the two subexpressions are floats or doubles, the check-within
expression must be used. The within subexpression must be a number; non-doubles can
be compared with the check-within expression. The within subexpression specifies how
precise different floats or doubles must be.
Additionally, the ProfessorJ languages support automatic execution of tests, which
can also be turned off with a language preference. Any class with the word 'Example'
in the name (i.e. CarExample, Examples, MyExamples) whose constructor does not
require any arguments is instantiated on Run. Any method within this class that
begins with the word 'test' (i.e. testAccelerate, test1) that does not require
any arguments is called; a boolean return is expected. The test methods are run
in the order in which they appear within the class, top to bottom.
A dockable window opens on Run reporting the result of executing all checks within
each Example class and the result of executing each test method. Failed checks (i.e.
returning false) provide source information. Coverage information is also available for
each Example class and each testMethod. The collection of coverage information does
slow execution and can be turned off with a language preference. Colors for the
coverage information can be set in the Java color preference window.
_ProfessorJ Beginner_
In Version 300, the Beginner language level has undergone significant changes.
Largest among these is that interfaces are supported within the language, but
abstract classes are no longer allowed. Further, interface implementation is supported
but class extension is not. For further details please see the language manual.
_ProfessorJ Intermediate
_ProfessorJ Intermediate_
In Version 300, instanceof is now allowed. For further language details please see
the language manual.
_ProfessorJ Advanced
_ProfessorJ Advanced_
For details, please see the language manual.
_ProfessorJ Full
@ -91,11 +124,6 @@ _Java + dynamic_ language level
Known bugs for dynamic:
Programs of the following form will not produce the expected result:
Object o = new Object();
dynamic x = o;
boolean t = x == o;
In this program, t will have the value false, not true as expected.
Some casts will fail and instanceof's return false that aught to succeed:
interface I { }
class C implements I { }

4
collects/profj/info.ss
View File

@ -2,8 +2,8 @@
(require (lib "string-constant.ss" "string-constants"))
(define name "ProfessorJ")
(define doc.txt "doc.txt")
(define tools '(("tool.ss")))
(define tool-names '("ProfessorJ"))
(define tools (list (list "tool.ss") (list "test-tool.ss")))
(define tool-names '("ProfessorJ" "ProfessorJ Testing"))
(define install-collection "installer.ss")
(define pre-install-collection "pre-installer.ss")
(define compile-subcollections

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

@ -12,11 +12,12 @@
(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 "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?)
check-eq? dynamic-equal? compare compare-within)
(define (check-eq? obj1 obj2)
(or (eq? obj1 obj2)
@ -197,4 +198,106 @@
(send exn NullPointerException-constructor-java.lang.String msg))
(current-continuation-marks))))
;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
(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)
(already-seen? v1 v2 visited-v1 visited-v2)
(cond
((and (number? v1) (number? v2))
(if (or (inexact? v1) (inexact? v2))
(<= (abs (- v1 v2)) range)
(= v1 v2)))
((and (object? v1) (object? v2))
(cond
((equal? "String" (send v1 my-name))
(and (equal? "String" (send v2 my-name))
(equal? (send v1 get-mzscheme-string) (send v2 get-mzscheme-string))))
((equal? "array" (send v1 my-name))
(and (equal? "array" (send v2 my-name))
(= (send v1 length) (send v2 length))
(let ((v1-vals (array->list v1))
(v2-vals (array->list v2)))
(andmap (lambda (x) x)
(map java-equal? v1-vals v2-vals
(map (lambda (v) (cons v1 visited-v1)) v1-vals)
(map (lambda (v) (cons v2 visited-v2)) v2-vals))))))
(else
(and (equal? (send v1 my-name) (send v2 my-name))
(let ((v1-fields (send v1 field-values))
(v2-fields (send v2 field-values)))
(and (= (length v1-fields) (length v2-fields))
(andmap (lambda (x) x)
(map java-equal? v1-fields v2-fields
(map (lambda (v) (cons v1 visited-v1)) v1-fields)
(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)))
res)))
;array->list: java-array -> (list 'a)
(define (array->list v)
(letrec ((len (send v length))
(build-up
(lambda (c)
(if (= c len)
null
(cons (send v access c)
(build-up (add1 c)))))))
(build-up 0)))
;already-seen?: 'a 'a (list 'a) (list 'a)-> bool
(define (already-seen? v1 v2 visited-v1 visited-v2)
(cond
((and (null? visited-v1) (null? visited-v2)) #f)
((memq v1 visited-v1)
(let ((position-v1 (get-position v1 visited-v1 0)))
(eq? v2 (list-ref visited-v2 position-v1))))
(else #f)))
;get-position: 'a (list 'a) int -> int
(define (get-position v1 visited pos)
(if (eq? v1 (car visited))
pos
(get-position v1 (cdr visited) (add1 pos))))
)

12
collects/profj/parameters.ss
View File

@ -1,4 +1,7 @@
(module parameters mzscheme
(require (lib "class.ss"))
(provide (all-defined))
;Stores the classpath for the current run
@ -34,6 +37,15 @@
;Stores whether dynamic typing is allowed
(define dynamic? (make-parameter #f))
;Stores whether testing extension is on or not
(define test-ext? (make-parameter #t))
;Stores whether the test window should pop up
(define tests? (make-parameter #t))
;Stores whether coverage information should be gathered
(define coverage? (make-parameter #t))
;Stores whether or not we're in MrEd and therefore images can appear in the text
(define mred? (make-parameter #f))

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

@ -22,7 +22,7 @@
(parser
(start CompilationUnit AdvancedInteractions VariableInitializer Type)
;;(debug "parser.output")
(tokens java-vals special-toks Keywords Separators EmptyLiterals Operators)
(tokens java-vals special-toks Keywords Separators EmptyLiterals Operators ExtraKeywords)
;(terminals val-tokens special-tokens keyword-tokens separator-tokens literal-tokens operator-tokens)
(error (lambda (tok-ok name val start-pos end-pos)
(if ((determine-error))
@ -770,8 +770,15 @@
[(ConditionalOrExpression ? Expression : ConditionalExpression)
(make-cond-expression #f (build-src 5) $1 $3 $5 (build-src 2 2))])
(CheckExpression
[(ConditionalExpression) $1]
[(check ConditionalExpression expect ConditionalExpression)
(make-check #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))])
(AssignmentExpression
[(ConditionalExpression) $1])
[#;(ConditionalExpression)(CheckExpression) $1])
(Assignment
[(LeftHandSide AssignmentOperator AssignmentExpression)

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

@ -21,8 +21,9 @@
(define parsers
(parser
;(debug "out2.ss")
(start CompilationUnit BeginnerInteractions Expression Type)
(tokens java-vals special-toks Keywords Separators EmptyLiterals Operators)
(tokens java-vals special-toks Keywords Separators EmptyLiterals Operators ExtraKeywords)
;(terminals val-tokens special-tokens keyword-tokens separator-tokens literal-tokens operator-tokens)
(error (lambda (tok-ok name val start-pos end-pos)
(if ((determine-error))
@ -440,9 +441,16 @@
[(ConditionalAndExpression) $1]
[(ConditionalOrExpression OR ConditionalAndExpression)
(make-bin-op #f (build-src 3) 'oror $1 $3 (build-src 2 2))])
(CheckExpression
[(ConditionalOrExpression) $1]
[(check ConditionalOrExpression expect ConditionalOrExpression)
(make-check #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))])
(Assignment
[(LeftHandSide AssignmentOperator ConditionalOrExpression)
[(LeftHandSide AssignmentOperator CheckExpression)
(make-assignment #f (build-src 3) $1 $2 $3 (build-src 2 2))])
(LeftHandSide
@ -450,10 +458,11 @@
[(FieldAccess) $1])
(AssignmentOperator
[(=) '=])
[(=) '=])
(Expression
[(ConditionalOrExpression) $1])
;[(ConditionalOrExpression) $1]
[(CheckExpression) $1])
)))

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

@ -944,13 +944,20 @@
[(ConditionalOrExpression ? Expression : ConditionalExpression)
(make-cond-expression #f (build-src 5) $1 $3 $5 (build-src 2 2))])
(AssignmentExpression
(CheckExpression
[(ConditionalExpression) $1]
[(check ConditionalExpression expect ConditionalExpression)
(make-check #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))])
(AssignmentExpression
[#;(ConditionalExpression) (CheckExpression) $1]
[(Assignment) $1])
(Assignment
[(LeftHandSide AssignmentOperator AssignmentExpression)
(make-assignment #f (build-src 3) $1 $2 $3 (build-src 2 2))])
(make-assignment #f (build-src 3) $1 $2 $3 (build-src 2 2))])
(LeftHandSide
[(Name) (name->access $1)]

3
collects/profj/parsers/general-parsing.ss
View File

@ -294,6 +294,9 @@
(package "ackage" "pckage" "pakage" "pacage" "packge" "packae" "packag")
(protected "rotected" "portected")
(final "inal" "fnal" "fial" "finl" "finale" "fianl")
(check "chek" "cehck" "chck" "chack")
(expect "expct" "expeet" "expec" "exect")
(within "with" "withi" "withen" "wihtin")
))
(define (select-words key)

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

@ -1,4 +1,3 @@
#cs
(module intermediate-parser mzscheme
(require "general-parsing.ss"
@ -26,7 +25,7 @@
(testing-parser
(start CompilationUnit IntermediateInteractions Expression Type)
;;(debug "parser.output")
(tokens java-vals special-toks Keywords Separators EmptyLiterals Operators)
(tokens java-vals special-toks Keywords Separators EmptyLiterals Operators ExtraKeywords)
;(terminals val-tokens special-tokens keyword-tokens separator-tokens literal-tokens operator-tokens)
(error (lambda (tok-ok name val start-pos end-pos)
(if ((determine-error))
@ -580,9 +579,19 @@
[(ConditionalOrExpression OR ConditionalAndExpression)
(make-bin-op #f (build-src 3) 'oror $1 $3 (build-src 2 2))])
(ConditionalExpression
(CheckExpression
[(ConditionalOrExpression) $1]
[(check ConditionalOrExpression expect ConditionalOrExpression)
(make-check #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))])
#;(ConditionalExpression
[(ConditionalOrExpression) $1])
(ConditionalExpression
((CheckExpression) $1))
(AssignmentExpression
[(ConditionalExpression) $1])

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

@ -44,7 +44,7 @@
const for new switch
continue goto package synchronized))
(define-empty-tokens ExtraKeywords (dynamic))
(define-empty-tokens ExtraKeywords (dynamic check expect within))
(define-tokens java-vals
(STRING_LIT CHAR_LIT INTEGER_LIT LONG_LIT FLOAT_LIT DOUBLE_LIT
@ -107,6 +107,9 @@
(Identifier (re:: JavaLetter (re:* JavaLetterOrDigit)))
(JavaLetter (re:or (re:/ "AZ" "az") "_" "$"))
(JavaLetterOrDigit (re:or JavaLetter (re:/ "09")))
(KnownTypes (re:or "boolean" "byte" "char" "double" "float" "int" "long" "short"
"String" "Object"))
;; 3.9
(Keyword (re:or "abstract" "default" "if" "private" "this"
@ -305,6 +308,11 @@
((dynamic?) (string->symbol lexeme))
(else (token-IDENTIFIER lexeme))))
((re:or "check" "expect" "within")
(cond
((test-ext?) (string->symbol lexeme))
(else (token-IDENTIFIER lexeme))))
;; 3.9
(Keyword (string->symbol lexeme))
@ -327,13 +335,7 @@
(token-IMAGE_SPECIAL lexeme))
(else
(token-OTHER_SPECIAL (list lexeme start-pos end-pos)))))
#;(cond
((class-case? lexeme) (token-CLASS_BOX lexeme))
((interact-case? lexeme) (token-INTERACTIONS_BOX lexeme))
((test-case? lexeme) (token-TEST_SUITE lexeme))
(else (token-OTHER_SPECIAL (list lexeme start-pos end-pos))))
;; 3.6
((re:+ WhiteSpace) (return-without-pos (get-token input-port)))
@ -409,6 +411,16 @@
((dynamic?) (syn-val lexeme 'keyword #f start-pos end-pos))
(else (syn-val lexeme 'identifier #f start-pos end-pos))))
((re:or "check" "expect" "within")
(syn-val lexeme
(cond
((test-ext?) 'keyword)
(else 'identifier))
#f start-pos end-pos))
(KnownTypes
(syn-val lexeme 'prim-type #f start-pos end-pos))
;; 3.9
(Keyword (syn-val lexeme 'keyword #f start-pos end-pos))

56
collects/profj/parsers/parse-error.ss
View File

@ -678,7 +678,7 @@
(end (get-end cur))
(ps (if (null? pre) null (get-start pre)))
(pe (if (null? pre) null (get-end pre))))
;(printf "parse-members: pre-out ~a current-out ~a~n" (if (null? pre) null (format-out (get-tok pre))) out)
#;(printf "parse-members: pre-out ~a current-out ~a~n" (if (null? pre) null (format-out (get-tok pre))) out)
(case state
((start)
@ -836,15 +836,26 @@
;Intermediate
((field-init-end)
(case kind
((EOF) (parse-error "Expected a ';' or comma after field, class body still requires a }" ps pe))
((COMMA) (parse-members cur (getter) 'field-list getter #f just-method?))
((EOF)
(if (beginner?)
(parse-error "Expected a ';' after field, class body still requires a '};." ps pe)
(parse-error "Expected a ';' or comma after field, class body still requires a '}'." ps pe)))
((COMMA)
(if (beginner?)
(parse-error "Expected a ';' to end field, found ',' which does not end the field declaration"
ps end)
(parse-members cur (getter) 'field-list getter #f just-method?)))
((SEMI_COLON) (parse-members cur (getter) 'start getter #f just-method?))
((IDENTIFIER) (parse-error (format "Fields must be separated by commas, ~a not allowed" out) srt end))
((IDENTIFIER)
(if (beginner?)
(parse-error (format "Expected a ';' to end field, found ~a which is not allowed." out)
srt end)
(parse-error (format "Fields must be separated by commas, ~a not allowed" out) srt end)))
(else
(parse-error
(if (beginner?)
(format "Expected a ';' to end the field, found ~a" out)
(format "Expected a ; to end field, or more field names, found ~a" out)) srt end))))
(format "Expected a ';' to end field, or more field names, found ~a" out)) srt end))))
((method)
(cond
((eof? tok) (parse-error "Expected method, and class body still requires a }" ps pe))
@ -2119,8 +2130,8 @@
;parse-expression: token token state (->token) bool bool -> token
(define (parse-expression pre cur-tok state getter statement-ok? stmt-exp?)
;(printf "parse-expression state ~a pre ~a cur-tok ~a statement-ok? ~a stmt-exp? ~a ~n"
; state pre cur-tok statement-ok? stmt-exp?)
#;(printf "parse-expression state ~a pre ~a cur-tok ~a statement-ok? ~a stmt-exp? ~a ~n"
state pre cur-tok statement-ok? stmt-exp?)
(let* ((tok (get-tok cur-tok))
(kind (get-token-name tok))
(out (format-out tok))
@ -2166,6 +2177,8 @@
(parse-expression cur-tok (parse-expression cur-tok (getter) 'start getter #f #f)
'c-paren getter statement-ok? stmt-exp?)))
((new) (parse-expression cur-tok (getter) 'alloc-start getter statement-ok? stmt-exp?))
((check)
(parse-expression pre cur-tok 'check getter statement-ok? stmt-exp?))
((IDENTIFIER) (parse-expression cur-tok (getter) 'name getter statement-ok? stmt-exp?))
((STRING_ERROR)
(if (eq? 'STRING_NEWLINE (get-token-name (caddr (token-value tok))))
@ -2468,6 +2481,35 @@
(if (close-separator? tok)
(parse-error (format "Expected ) to close constructor arguments, found ~a" out) start end)
(parse-error (format "A ',' is required between expressions in a constructor call, found ~a" out) start end)))))
((check)
(parse-expression cur-tok
(parse-expression cur-tok (getter) 'start getter #f stmt-exp?)
'check-expect getter statement-ok? stmt-exp?))
((check-expect)
(case kind
((EOF) (parse-error "Expected 'expect' and rest of 'check' expression" ps end))
((expect)
(parse-expression pre (parse-expression cur-tok (getter) 'start getter #f stmt-exp?)
'within-or-end getter statement-ok? stmt-exp?))
(else
(if (close-to-keyword? tok 'expect)
(parse-error
(format "Expected 'expect' for the intended result of check.~n Found ~a which is similar to 'expect', check spelling and capitolization."
out)
start end)
(parse-error (format "Expected 'expect' for the intended result of check. Found ~a which may not appear here."
out)
ps end)))))
((within-or-end)
(case kind
((within)
(parse-expression cur-tok (getter) 'start getter #f stmt-exp?))
(else
(if (close-to-keyword? tok 'within)
(parse-error
(format "Expected 'within' for range of check, found ~a which is similar to 'within'. Check capitolization and spelling."
out))
cur-tok))))
((name)
(case kind
((PERIOD) (parse-expression cur-tok (parse-name (getter) getter #f) 'name getter statement-ok? stmt-exp?))

5
collects/profj/test-tool.ss Normal file
View File

@ -0,0 +1,5 @@
(module test-tool mzscheme
(require "tester.scm")
(provide (rename test-tool@ tool@)))

642
collects/profj/tester.scm Normal file
View File

@ -0,0 +1,642 @@
(module tester mzscheme
(require (lib "mred.ss" "mred")
(lib "tool.ss" "drscheme")
(lib "unitsig.ss")
(lib "framework.ss" "framework")
(lib "class.ss")
(lib "list.ss")
(lib "file.ss")
(lib "etc.ss"))
(require "ast.ss" "display-java.ss")
(provide test-info% test-display% test-tool@)
; # *##$ *#*
; # # #* # #
; ##### $##$ *###$# ##### :## ##*##* @##### &##& *#*
; # $ -$ #$ -# # # #+ *# # &+ +& -+$#
; # ###### *###$ # ###### # # # # # # +$&:
; # $ +# # # # # # # # *#*
; #* :$ +* # *# #* :$ # # # # &+ +& # #
; *##$ +##$+ @*###* *##$ ##### ### ### :##### &##& *#*
#;(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))
;(make-failed-check src (listof (U string snip%)) (listof src))
(define-struct failed-check (src msg covers))
;(make-testcase string boolean (listof src))
(define-struct testcase (name passed? covers))
(define-local-member-name provide-test-results provide-covered)
(define test-info%
(class* object% ()
(define tested-classes null);------ (listof single-test)
(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-testcoverage null)
(define total-tests 0)
(define failed-tests 0)
(define total-checks 0)
(define failed-checks 0)
(define/public (add-check)
(set-single-test-num-checks! current-class
(add1 (single-test-num-checks current-class)))
(set! total-checks (add1 total-checks)))
;check-failed: (list (U string snip%)) src -> void
(define/public (check-failed msg src)
(set-single-test-failed-checks! current-class
(cons
(make-failed-check src msg null)
(single-test-failed-checks current-class)))
(set! failed-checks (add1 failed-checks)))
(define/public (format-value value)
(make-java-snip value (make-format-style #t 'field #f)))
(define/public (covered-position src)
(set! covered (cons src covered))
(set! current-testcoverage (cons src current-testcoverage))
(set-single-test-covered-exprs!
current-class
(cons src (single-test-covered-exprs current-class))))
(define/public (provide-test-results)
(values tested-classes covered nearly-tested-classes total-tests
failed-tests total-checks failed-checks))
(define/public (provide-covered) covered)
;run-tests: (listof (list string class)) (listof string) -> (listof object)
(define/public (run-tests tests close-names)
(let ((objects
(map
(lambda (name/class)
(set! current-class (make-single-test (car name/class) null null 0 null null))
(let ((obj (make-object (cadr name/class))))
(with-handlers ((exn? (lambda (e) (raise e))))
((current-eval)
#`(send #,obj #,(string->symbol (string-append (car name/class)
"-constructor")))))
(run-methods obj)
(set! tested-classes (cons current-class tested-classes))
(list (car name/class) obj)))
tests)))
(set! nearly-tested-classes close-names)
(map cadr objects)))
(define/private (run-methods object)
(let loop ([methods (reverse (interface->method-names (object-interface object)))])
(cond
((null? methods) (void))
((test-method? (car methods))
(set! total-tests (add1 total-tests))
(set! current-testcoverage null)
(let ((res ((current-eval)
#`(send #,object #,(car methods)))))
(set-single-test-testcases!
current-class
(cons (make-testcase (car methods) res current-testcoverage)
(single-test-testcases current-class)))
(unless res (set! failed-tests (add1 failed-tests))))
(loop (cdr methods)))
((test-method-name? (car methods))
(set-single-test-not-tested!
current-class
(cons (format "Method ~a could not run due to requiring arguments."
(car methods))
(single-test-not-tested current-class)))
(loop (cdr methods)))
((close-to-test-name? (car methods))
(set-single-test-not-tested!
current-class
(cons (format "Method ~a has a name similar to a test, but does not begin with 'test'."
(car methods))
(single-test-not-tested current-class)))
(loop (cdr methods)))
(else (loop (cdr methods))))))
(define (test-method? name)
(and (test-method-name? name) (no-args? name)))
(define (test-method-name? name)
(regexp-match "^test" (symbol->string name)))
(define (no-args? name)
(not (regexp-match "-" (symbol->string name))))
(define (close-to-test-name? name)
(let ((n (symbol->string name)))
(or (regexp-match "^tst" n)
(regexp-match "^tet" n)
(regexp-match "^Test" n)
(regexp-match "^tes" n))))
(super-instantiate ())
))
; ## # ## *#*
; # # # # # #
; ##### $##$ *###$# ##### $#@ # :## *###$# ##:#@ # $@#$: ##: :## *#*
; # $ -$ #$ -# # $+ +# # #$ -# #* -$ # -# -$ $ -+$#
; # ###### *###$ # ###### # # # *###$ # # # $##$# $- *$ +$&:
; # $ +# # # # # +# # # # @+ # @ @ *#*
; #* :$ +* # *# #* :$ $+ +# # # *# #: -$ # #- +# $$$ # #
; *##$ +##$+ @*###* *##$ $#@ ## ##### @*###* # #@ ##### *##$ ## # *#*
; # ++
; ### ###
(define test-display%
(class object% ()
(init-field (drscheme-frame #f))
(init-field (current-tab #f))
(define/public (pop-up-window test-results)
(let* ((curr-win (send current-tab get-test-window))
(window
(if curr-win
curr-win
(make-object test-window%)))
(content (make-object text%)))
(fill-in content test-results)
(send content lock #t)
(send window update-editor content)
(send current-tab current-test-editor content)
(unless curr-win
(send current-tab current-test-window window)
(send drscheme-frame register-test-window window))
(send window update-switch
(lambda () (send drscheme-frame dock-tests)))
(send window update-closer
(lambda()
(send drscheme-frame deregister-test-window window)
(send current-tab current-test-window #f)
(send current-tab current-test-editor #f)))
(if (get-preference 'profj:test-window:docked?
(lambda () (put-preferences '(profj:test-window:docked?) '(#f)) #f))
(send drscheme-frame display-test-panel content)
(send window show #t))))
(define/private (fill-in editor test-results)
(let-values (((tested-classes covered nearly-tested-classes total-tests
failed-tests total-checks failed-checks)
(send test-results provide-test-results)))
(letrec ((insert-content
(lambda (source nextline?)
(let loop ((contents source))
(unless (null? contents)
(send editor insert (car contents))
(when nextline? (next-line))
(loop (cdr contents))))))
(next-line (lambda ()
(send editor insert "\n "))))
(unless (= 0 total-tests)
(send editor insert (format "Ran ~a total tests\n" total-tests))
(if (= 0 failed-tests)
(send editor insert "All tests passed!\n\n")
(send editor insert (format "~a of ~a tests failed. See below for details.\n\n"
failed-tests total-tests))))
(unless (= 0 total-checks)
(send editor insert (format "Ran ~a total checks\n" total-checks))
(if (= 0 failed-checks)
(send editor insert "All checks passed!\n\n")
(send editor insert (format "~a of ~a checks failed. See below for details.\n\n"
failed-checks total-checks))))
(unless (null? covered)
(make-covered-button covered editor #f)
(send editor insert "\n"))
(send editor insert "Tested the following Example classes:\n")
(for-each
(lambda (test-info)
(send editor insert "\n")
(send editor insert (single-test-name test-info))
(unless (null? (single-test-covered-exprs test-info))
(make-covered-button (single-test-covered-exprs test-info) editor #t))
(unless (null? (single-test-testcases test-info))
(let ((num-tests (length (single-test-testcases test-info)))
(failed-tests (filter (compose not testcase-passed?)
(single-test-testcases test-info))))
(next-line)
(send editor insert (format "Ran ~a test methods." num-tests))
(next-line)
(if (null? failed-tests)
(send editor insert "All tests passed!")
(send editor insert (format "~a of ~a tests failed:"
(length failed-tests) num-tests)))
(next-line)
(for-each (lambda (test)
(send editor insert
(format "~a ~a" (testcase-name test)
(if (testcase-passed? test) "succeeded!" "failed.")))
(unless (null? (testcase-covers test))
(make-covered-button (testcase-covers test) editor #f))
(next-line))
(reverse (single-test-testcases 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)))
(next-line)
(if (null? (single-test-failed-checks test-info))
(send editor insert "All checks succeeded!\n")
(begin
(send editor insert (format "~a of ~a checks failed:"
(length (single-test-failed-checks test-info))
(single-test-num-checks test-info)))
(next-line)
(for-each (lambda (check)
(make-link editor (failed-check-msg check)
(failed-check-src check))
(next-line))
(reverse (single-test-failed-checks test-info)))))
))
tested-classes)
(unless (null? nearly-tested-classes)
(send editor insert "\n")
(send editor insert "The following classes were not run, but are similar to example classes:\n")
(insert-content nearly-tested-classes #f)))))
(super-instantiate ())))
(define test-window%
(class frame% ()
(super-instantiate ("Test Results" #f 400 350))
(define editor #f)
(define switch-func void)
(define close-cleanup void)
(define content
(make-object editor-canvas% this #f '(auto-vscroll)))
(define button-panel (make-object horizontal-panel% this
'() #t 0 0 0 0 '(right bottom) 0 0 #t #f))
(define buttons
(list (make-object button%
"Close"
button-panel
(lambda (b c)
(when (eq? 'button (send c get-event-type))
(close-cleanup)
(send this show #f))))
(make-object button%
"Close and disable testing"
button-panel
(lambda (b c)
(when (eq? 'button (send c get-event-type))
(put-preferences '(profj:test-enable) '(#f))
(close-cleanup)
(send this show #f))))
(make-object button%
"Dock"
button-panel
(lambda (b c)
(when (eq? 'button (send c get-event-type))
(send this show #f)
(put-preferences '(profj:test-window:docked?) '(#t))
(switch-func))))))
(define/public (update-editor e)
(set! editor e)
(send content set-editor editor))
(define/public (update-switch thunk)
(set! switch-func thunk))
(define/public (update-closer thunk)
(set! close-cleanup thunk))
))
(define test-panel%
(class vertical-panel% ()
(inherit get-parent)
(super-instantiate () )
(define content (make-object editor-canvas% this #f '()))
(define button-panel (make-object horizontal-panel% this
'() #t 0 0 0 0 '(right bottom) 0 0 #t #f))
(define (hide)
(let ((current-tab (send frame get-current-tab)))
(send frame deregister-test-window
(send current-tab get-test-window))
(send current-tab current-test-window #f)
(send current-tab current-test-editor #f))
(remove))
(make-object button%
"Hide"
button-panel
(lambda (b c)
(when (eq? 'button (send c get-event-type))
(hide))))
(make-object button%
"Hide and disable testing"
button-panel
(lambda (b c)
(when (eq? 'button (send c get-event-type))
(hide)
(put-preferences '(profj:test-enable) '(#f)))))
(make-object button%
"Undock"
button-panel
(lambda (b c)
(when (eq? 'button (send c get-event-type))
(put-preferences '(profj:test-window:docked?) '(#f))
(send frame undock-tests)
)))
(define/public (update-editor e)
(send content set-editor e))
(define frame #f)
(define/public (update-frame f)
(set! frame f))
(define/public (remove)
(let ((parent (get-parent)))
(put-preferences '(profj:test-dock-size) (list (send parent get-percentages)))
(send parent delete-child this)))
))
; ##@ $## #
; #@ ##
; #$&$# :## *###$# $##*#
; #*@+# # #$ -# $$ :#
; # # # # *###$ #
; # # # +# #
; # # # # *# $+ :$
; ### ### ##### @*###* $##$
;make-link: text% (listof (U string snip%)) src -> void
(define (make-link text msg dest)
(for-each (lambda (m) (send text insert m)) msg)
(let ((start (send text get-end-position)))
(send text insert (format-src dest))
(send text set-clickback
start (send text get-end-position)
(lambda (t s e)
(open-and-highlight-in-file dest))
#f #f)
(let ((end (send text get-end-position))
(c (new style-delta%)))
(send text insert " ")
(send text change-style (make-object style-delta% 'change-underline #t)
start end #f)
(send c set-delta-foreground "royalblue")
(send text change-style c start end #f))
))
(define (open-and-highlight-in-file srcloc)
(let* ([position (src-pos srcloc)]
[span (src-span srcloc)]
[rep/ed (get-editor srcloc #t)])
(when rep/ed
(cond
[(is-a? (cadr rep/ed) text:basic<%>)
(let ((highlight
(lambda ()
(send (car rep/ed) highlight-error (cadr rep/ed) position (+ position span)))))
(queue-callback highlight))]))))
(define (make-covered-button covered dest partial?)
(send dest insert " ")
(let* ((editor (new text%))
(snip (new editor-snip% (editor editor)
(with-border? #t)))
(start (send dest get-end-position)))
(if partial?
(send editor insert "Show covered expressions")
(send editor insert "Show all covered expressions"))
(send dest insert snip)
(send dest insert " ")
(send editor set-clickback
0 (send editor get-end-position)
(lambda (t s e)
(color-covered covered))
#f #f)
(let ((c (new style-delta%)))
(send c set-delta-foreground "royalblue")
(send dest change-style c start (sub1 (send dest get-end-position)) #f))
))
(define (color-covered covered)
(unless (null? covered)
(let* ([editor (get-editor (car covered) #f)]
[style-list (editor:get-standard-style-list)]
[uncover-color (send style-list find-named-style "profj:syntax-coloring:scheme:uncovered")]
[cover-color (send style-list find-named-style "profj:syntax-coloring:scheme:covered")])
(when editor
;(send cover-color set-delta-foreground "darkmagenta")
;(send uncover-color set-delta-foreground "black")
(letrec ((color-buff
(lambda ()
(cond
((or (send editor is-locked?) (send editor in-edit-sequence?))
(queue-callback color-buff))
(else
(unless (send editor test-froze-colorer?)
(send editor freeze-colorer)
(send editor toggle-test-status))
(send editor begin-test-color)
(send editor change-style uncover-color 0 (send editor last-position) #f)
(let loop ((srcs covered))
(unless (null? srcs)
(send editor change-style cover-color (sub1 (src-pos (car srcs)))
(sub1 (+ (src-pos (car srcs))
(src-span (car srcs)))) #f)
(loop (cdr srcs))))
(send editor end-test-color))))))
(queue-callback color-buff))))))
(define (get-editor src rep?)
(let* ([source (src-file src)]
[frame (cond
[(path? source) (handler:edit-file source)]
[(is-a? source editor<%>)
(let ([canvas (send source get-canvas)])
(and canvas
(send canvas get-top-level-window)))])]
[editor (cond
[(path? source)
(cond
[(and frame (is-a? frame #;drscheme:unit:frame<%>))
(send frame get-definitions-text)]
[(and frame (is-a? frame frame:editor<%>))
(send frame get-editor)]
[else #f])]
[(is-a? source editor<%>) source])]
[rep (and frame
#;(is-a? frame drscheme:unit:frame%)
(send frame get-interactions-text))])
(when frame
(unless (send frame is-shown?) (send frame show #t)))
(if (and rep? rep editor)
(list rep editor)
(and rep editor))))
(define (format-src src)
(string-append (cond
((path? (src-file src)) (string-append "in " (src-file src) " at "))
((is-a? (src-file src) editor<%>) "at "))
"line " (number->string (src-line src))
" column " (number->string (src-col src))))
;
; ####* $#@*# ######
; # -#* @ :# # # #
; # # ## $#$ @+ # # ## ## ##### *###$#
; # # #$* : $@## ### $ $ # #$ -#
; # # # +$ # # $$ # *###$
; # # # # # $$ # +#
; # @* # #$+ :$ # # $ $ #* :$ # *#
; ####* ##### #*@#$ ###### ## ## *##$ @*###*
;
(define-local-member-name toggle-test-status test-froze-colorer? begin-test-color end-test-color)
(define test-tool@
(unit/sig drscheme:tool-exports^
(import drscheme:tool^)
(define (phase1) (void))
(define (phase2) (void))
(define (test-definitions-text%-mixin %)
(class % ()
(inherit begin-edit-sequence end-edit-sequence)
(define colorer-frozen-by-test? #f)
(define/public (test-froze-colorer?) colorer-frozen-by-test?)
(define/public (toggle-test-status)
(set! colorer-frozen-by-test?
(not colorer-frozen-by-test?)))
(define/public (begin-test-color)
(begin-edit-sequence #f))
(define/public (end-test-color)
(end-edit-sequence))
(define/augment (on-delete start len)
(begin-edit-sequence)
(inner (void) on-delete start len))
(define/augment (after-delete start len)
(inner (void) after-delete start len)
(when colorer-frozen-by-test?
(send this thaw-colorer)
(send this toggle-test-status))
(end-edit-sequence))
(define/augment (on-insert start len)
(begin-edit-sequence)
(inner (void) on-insert start len))
(define/augment (after-insert start len)
(inner (void) after-insert start len)
(when colorer-frozen-by-test?
(send this thaw-colorer)
(send this toggle-test-status))
(end-edit-sequence))
(super-instantiate ())))
(define (test-frame-mixin %)
(class % ()
(inherit get-current-tab)
(define/public (display-test-panel editor)
(send test-panel update-editor editor)
(unless (send test-panel is-shown?)
(send test-frame add-child test-panel)
(let ((test-box-size
(get-preference 'profj:test-dock-size (lambda () '(2/3 1/3)))))
(send test-frame set-percentages test-box-size))
))
(define test-panel null)
(define test-frame null)
(define test-windows null)
(define/public (register-test-window t)
(set! test-windows (cons t test-windows)))
(define/public (deregister-test-window t)
(set! test-windows (remq t test-windows)))
(define/public (dock-tests)
(for-each (lambda (t) (send t show #f)) test-windows)
(let ((ed (send (get-current-tab) get-test-editor)))
(when ed (display-test-panel ed))))
(define/public (undock-tests)
(send test-panel remove)
(for-each (lambda (t) (send t show #t)) test-windows))
(define/override (make-root-area-container cls parent)
(let* ([outer-p (super make-root-area-container panel:vertical-dragable% parent)]
[louter-panel (make-object vertical-panel% outer-p)]
[test-p (make-object test-panel% outer-p '(deleted))]
[root (make-object cls louter-panel)])
(set! test-panel test-p)
(send test-panel update-frame this)
(set! test-frame outer-p)
root))
(define/augment (on-tab-change from-tab to-tab)
(let ((test-editor (send to-tab get-test-editor))
(panel-shown? (send test-panel is-shown?))
(dock? (get-preference 'profj:test-window:docked? (lambda () #f))))
(cond
((and test-editor panel-shown? dock?)
(send test-panel update-editor test-editor))
((and test-editor dock?)
(display-test-panel test-editor))
((and panel-shown? (not dock?))
(undock-tests))
(panel-shown? (send test-panel remove)))
(inner (void) on-tab-change from-tab to-tab)))
(super-instantiate () )))
(define (test-tab%-mixin %)
(class % ()
(inherit get-frame)
(define test-editor #f)
(define/public (get-test-editor) test-editor)
(define/public (current-test-editor ed)
(set! test-editor ed))
(define test-window #f)
(define/public (get-test-window) test-window)
(define/public (current-test-window w)
(set! test-window w))
(define/augment (on-close)
(when test-window
(send (get-frame) deregister-test-window test-window))
(inner (void) on-close))
(super-instantiate () )))
(drscheme:get/extend:extend-definitions-text test-definitions-text%-mixin)
(drscheme:get/extend:extend-unit-frame test-frame-mixin)
(drscheme:get/extend:extend-tab test-tab%-mixin)
))
)

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

@ -1983,8 +1983,19 @@
;translates a Java expression into a Scheme expression.
;raises an error if it has no implementation for an expression type
;translate-expression: Expression -> syntax
(define (translate-expression expr)
(let ((translated-expr (translate-expression-unannotated expr)))
(if (and (not (to-file)) (coverage?) (expr-src expr))
(make-syntax #f `(begin0 ,translated-expr
(cond
((namespace-variable-value 'current~test~object% #f (lambda () #f))
=> (lambda (test)
(send test covered-position ,(expr-src expr))))))
#f)
translated-expr)))
;translate-expression: Expression -> syntax
(define (translate-expression-unannotated expr)
(cond
((literal? expr) (translate-literal (expr-types expr)
(literal-val expr)
@ -2036,12 +2047,12 @@
((array-access? expr) (translate-array-access (translate-expression (array-access-name expr))
(translate-expression (array-access-index expr))
(expr-src expr)))
((post-expr? expr) (translate-post-expr (translate-expression (post-expr-expr expr))
((post-expr? expr) (translate-post-expr (translate-expression-unannotated (post-expr-expr expr))
(post-expr-op expr)
(post-expr-key-src expr)
(expr-src expr)))
((pre-expr? expr) (translate-pre-expr (pre-expr-op expr)
(translate-expression (pre-expr-expr expr))
(translate-expression-unannotated (pre-expr-expr expr))
(pre-expr-key-src expr)
(expr-src expr)))
((unary? expr) (translate-unary (unary-op expr)
@ -2063,6 +2074,10 @@
(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)))
(else
(error 'translate-expression (format "Translate Expression given unrecognized expression ~s" expr)))))
@ -2175,7 +2190,7 @@
(make-syntax #f
(cond
((or (dynamic-val? left-type) (dynamic-val? right-type))
`(,(create-syntax #f 'javaRuntime:dynamic-equal key-src) ,left ,right))
`(,(create-syntax #f 'javaRuntime:dynamic-equal? key-src) ,left ,right))
((and (prim-numeric-type? left-type) (prim-numeric-type? right-type))
`(,(create-syntax #f '= key-src) ,left ,right))
(else
@ -2577,24 +2592,22 @@
;converted
;translate-post-expr: syntax symbol src src -> syntax
(define translate-post-expr
(lambda (expr op key src)
(make-syntax #f `(begin0
,expr
(set! ,expr ( ,(create-syntax #f (if (eq? op '++) 'add1 'sub1) (build-src key))
,expr)))
(build-src src))))
(define (translate-post-expr expr op key src)
(make-syntax #f `(begin0
,expr
(set! ,expr ( ,(create-syntax #f (if (eq? op '++) 'add1 'sub1) (build-src key))
,expr)))
(build-src src)))
;converted
;translate-pre-expr: symbol syntax src src -> syntax
(define translate-pre-expr
(lambda (op expr key src)
(make-syntax #f
`(begin
(set! ,expr (,(create-syntax #f (if (eq? op '++) 'add1 'sub1) (build-src key))
,expr))
,expr)
(build-src src))))
(define (translate-pre-expr op expr key src)
(make-syntax #f
`(begin
(set! ,expr (,(create-syntax #f (if (eq? op '++) 'add1 'sub1) (build-src key))
,expr))
,expr)
(build-src src)))
;converted
;translate-unary: symbol syntax src src -> syntax
@ -2729,6 +2742,75 @@
,new-val)
(build-src src))))
;translate-check: expression expression (U expression #f) src -> syntax
(define (translate-check test actual range src)
(let ((t (translate-expression test))
(a (translate-expression actual))
(r (when range (translate-expression range)))
(extracted-info (checked-info test)))
(make-syntax #f
`(,(if (not range) 'javaRuntime:compare 'javaRuntime:compare-within)
,@(if range (list t a r) (list t a))
,extracted-info ,src
(namespace-variable-value 'current~test~object% #f
(lambda () #f)))
(build-src src))))
(require "error-messaging.ss")
;checked-info: expression -> (list sym string...)
(define (checked-info exp)
(cond
((access? exp)
(cond
((field-access? (access-name exp))
(let ((field (access-name exp)))
`(list (quote
,(if (var-access-static? (field-access-access field)) 'static-field 'field))
,(var-access-class (field-access-access field))
,(id-string (field-access-field field)))))
(else
`(list (quote var)
,(id-string (local-access-name (access-name exp)))))))
((class-alloc? exp)
`(list (quote alloc)
(quote ,(type->ext-name (expr-types exp)))
(list ,@(map (lambda (t) `(quote ,t))
(map type->ext-name
(map expr-types
(class-alloc-args exp)))))))
((call? exp)
`(list (quote call)
(quote ,(if (call-expr exp)
(type->ext-name (expr-types (call-expr exp)))
'no-exp))
,(id-string (call-method-name exp))
(list ,@(map (lambda (t) `(quote ,t))
(map type->ext-name
(map expr-types
(call-args exp)))))))
((instanceof? exp)
`(list (quote instanceof) (quote ,(type-spec->ext-name (instanceof-type exp)))))
((array-access? exp)
'(list (quote array)))
((unary? exp)
'(list (quote unary) (quote (unary-op exp))))
(else '(list (quote value)))))
(define (type-spec->ext-name t)
(format "~a~a"
(cond
((name? (type-spec-name t))
(id-string (name-id t)))
((symbol? (type-spec-name t))
(type-spec-name t)))
(if (= 0 (type-spec-dim t))
""
"[]")))
(define (src->ext-name src)
(format "~a:~a:~a" (src-file src) (src-line src) (src-col src)))
;translate-id: string src -> syntax
(define translate-id
(lambda (id src)

252
collects/profj/tool.ss
View File

@ -1,12 +1,13 @@
(module tool mzscheme
(require (lib "tool.ss" "drscheme")
(lib "mred.ss" "mred") (lib "framework.ss" "framework") (lib "unitsig.ss")
(lib "file.ss")
(lib "include-bitmap.ss" "mrlib") (lib "etc.ss")
(lib "class.ss")
(lib "string-constant.ss" "string-constants")
(lib "Object.ss" "profj" "libs" "java" "lang") (lib "array.ss" "profj" "libs" "java" "lang")
(lib "String.ss" "profj" "libs" "java" "lang"))
(require "compile.ss" "parameters.ss" "parsers/lexer.ss" "parser.ss" "ast.ss")
(require "compile.ss" "parameters.ss" "parsers/lexer.ss" "parser.ss" "ast.ss" "tester.scm")
(require-for-syntax "compile.ss")
@ -22,13 +23,21 @@
;Set the Java editing colors
(define color-prefs-table
`((keyword ,(make-object color% "black") ,(string-constant profj-java-mode-color-keyword))
(prim-type ,(make-object color% "darkmagenta")
"primitive types"
#;,(string-constant profj-java-mode-color-primtype))
(identifier ,(make-object color% 38 38 128) ,(string-constant profj-java-mode-color-identifier))
(string ,(make-object color% "forestgreen") ,(string-constant profj-java-mode-color-string))
(literal ,(make-object color% "forestgreen") ,(string-constant profj-java-mode-color-literal))
(comment ,(make-object color% 194 116 31) ,(string-constant profj-java-mode-color-comment))
(error ,(make-object color% "red") ,(string-constant profj-java-mode-color-error))
(identifier ,(make-object color% 38 38 128) ,(string-constant profj-java-mode-color-identifier))
(default ,(make-object color% "black") ,(string-constant profj-java-mode-color-default))))
;Set the Java coverage colors
(define coverage-color-prefs
`((uncovered ,(make-object color% "black") "default")
(covered ,(make-object color% "darkmagenta") "covered expression")))
;; short-sym->pref-name : symbol -> symbol
;; returns the preference name for the color prefs
(define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym)))
@ -41,15 +50,22 @@
;; extend-preferences-panel : vertical-panel -> void
;; adds in the configuration for the Java colors to the prefs panel
(define (extend-preferences-panel parent)
(for-each
(lambda (line)
(let ([sym (car line)])
(color-prefs:build-color-selection-panel
parent
(short-sym->pref-name sym)
(short-sym->style-name sym)
(format "~a" sym))))
color-prefs-table))
(let ((standard-color-prefs
(make-object group-box-panel% "Edit Colors" parent))
(coverage-color-panel
(make-object group-box-panel% "Coverage Colors" parent))
(put
(lambda (p)
(lambda (line)
(let ([sym (car line)]
[str (caddr line)])
(color-prefs:build-color-selection-panel
p
(short-sym->pref-name sym)
(short-sym->style-name sym)
str))))))
(for-each (put standard-color-prefs) color-prefs-table)
(for-each (put coverage-color-panel) coverage-color-prefs)))
;Create the Java editing mode
(define mode-surrogate
@ -125,8 +141,9 @@
(drscheme:language-configuration:add-language
(make-object ((drscheme:language:get-default-mixin) beginner-lang%))))
;(make-profj-settings symbol boolean (list string))
(define-struct profj-settings (print-style print-full? classpath) (make-inspector))
;(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))
;ProfJ general language mixin
(define (java-lang-mixin level name number one-line dyn?)
@ -146,22 +163,31 @@
;default-settings: -> profj-settings
(define/public (default-settings)
(if (memq level `(beginner intermediate advanced))
(make-profj-settings 'field #f null)
(make-profj-settings 'type #f null)))
(make-profj-settings 'field #f #t #t #t null)
(make-profj-settings 'type #f #t #f #t null)))
;default-settings? any -> bool
(define/public (default-settings? s) (equal? s (default-settings)))
;marshall-settings: profj-settings -> (list (list symbol) (list bool) (list string))
(define/public (marshall-settings 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-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) 2)
(if (and (pair? s) (= (length s) 5)
(pair? (car s)) (= (length (car s)) 1)
(pair? (cadr s)) (= (length (cadr s)) 1))
(make-profj-settings (caar s) (caadr s) null)
(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))
(make-profj-settings (caar s) (caadr s) (caaddr s)
(get-preference 'profj:test-enable
(lambda () (car (cadddr s))))
(car (list-ref s 4)) null)
#f))
;Create the ProfessorJ settings selection panel
@ -173,21 +199,39 @@
(stretchable-height #f)
(stretchable-width #f))]
[output-panel (instantiate group-box-panel% ()
[print-prefs (instantiate group-box-panel% ()
(label "Display Preferences")
(parent parent)
(alignment '(left center)))]
[print-full (when (memq level '(advanced full))
(make-object check-box% "Print entire contents of arrays?" output-panel
(make-object check-box% "Print entire contents of arrays?" print-prefs
(lambda (x y) update-pf)))]
[print-style (make-object radio-box%
"Display style"
(list "Class" "Class+Fields" );"Graphical")
output-panel
print-prefs
(lambda (x y) (update-ps)))]
[testing-prefs (instantiate group-box-panel% ()
(label "Testing Preferences")
(parent parent)
(alignment '(left center)))]
[allow-testing (when (eq? level 'full)
(make-object check-box% "Allow check expression?" testing-prefs
(lambda (x y) update-at)))]
[display-testing (make-object check-box% "Display testing results on Run?"
testing-prefs (lambda (x y) (update-dt x y)))]
[collect-coverage (make-object check-box% "Collect coverage for tests?"
testing-prefs (lambda (x y) update-cc))]
[update-pf (lambda () (void))]
[update-ps (lambda () (void))]
[update-at (lambda () (void))]
[update-dt (lambda (box event)
(when (eq? 'check-box (send event get-event-type))
(put-preferences '(profj:test-enable)
`(,(send box get-value)))
(send collect-coverage enable (send box get-value))))]
[update-cc (lambda () (void))]
[cp-panel (instantiate group-box-panel% ()
(parent parent)
@ -322,9 +366,13 @@
[(0) 'type]
[(1) 'field]
[(2) 'graphical])
(if (memq level '(advanced full))
(send print-full get-value)
#f)
(and (memq level '(advanced full))
(send print-full get-value))
(or (not (eq? level 'full))
(send allow-testing get-value))
(send display-testing get-value)
(and (send display-testing get-value)
(send collect-coverage get-value))
(get-classpath))]
[(settings)
(send print-style set-selection
@ -334,6 +382,12 @@
((graphical) 2)))
(when (memq level '(advanced full))
(send print-full set-value (profj-settings-print-full? settings)))
(when (eq? level 'full)
(send allow-testing set-value (profj-settings-allow-check? settings)))
(send display-testing set-value (profj-settings-run-tests? settings))
(if (profj-settings-run-tests? settings)
(send collect-coverage set-value (profj-settings-coverage? settings))
(send collect-coverage enable #f))
(install-classpath (profj-settings-classpath settings))])))
;;Stores the types that can be used in the interactions window
@ -349,7 +403,8 @@
(let ((end? (eof-object? (peek-char-or-special port))))
(if end?
eof
(datum->syntax-object #f `(parse-java-full-program ,(parse port name level)) #f)))))))
(datum->syntax-object #f `(parse-java-full-program ,(parse port name level)
,name) #f)))))))
(define/public (front-end/interaction port settings teachpack-cache)
(mred? #t)
(let ([name (object-name port)]
@ -418,6 +473,43 @@
(let-values (((syn-list t t2)
(send interact-box read-special #f #f #f #f))) syn-list))
(process-extras (cdr extras) type-recs))))))
(define/private (find-examples cus)
(let cu-loop ((cs cus) (examples null) (near-examples null))
(cond
((null? cs) (list examples near-examples))
(else
(let class-loop ((names (compilation-unit-contains (car cs)))
(ex examples)
(ne near-examples))
(cond
((null? names) (cu-loop (cdr cs) ex ne))
((regexp-match "Example" (car names))
(class-loop (cdr names)
(cons (car names) ex)
ne))
((or (regexp-match "Eample" (car names))
(regexp-match "Exmple" (car names))
(regexp-match "Exaple" (car names))
(regexp-match "Examle" (car names))
(regexp-match "Exampe" (car names))
(regexp-match "Exampl" (car names))
(regexp-match "Eaxmple" (car names)))
(class-loop (cdr names)
ex
(cons (format "Class ~a's name contains a phrase close to Example."
(car names))
ne)))
((regexp-match "example" (car names))
(class-loop (cdr names)
ex
(cons (format "Class ~a's name contains a miscapitalized example."
(car names))
ne)))
(else
(class-loop (cdr names) ex ne))))))))
;find-main-module: (list compilation-unit) -> (U syntax #f)
(define/private (find-main-module mod-lists)
@ -464,41 +556,88 @@
[string-path ((current-module-name-resolver) '(lib "String.ss" "profj" "libs" "java" "lang") #f #f)]
[class-path ((current-module-name-resolver) '(lib "class.ss") #f #f)]
[mred-path ((current-module-name-resolver) '(lib "mred.ss" "mred") #f #f)]
[n (current-namespace)])
[n (current-namespace)]
[e (current-eventspace)])
(test-ext? (profj-settings-allow-check? settings))
(tests? (get-preference 'profj:test-enable
(lambda () (profj-settings-run-tests? settings))))
(coverage? (profj-settings-coverage? settings))
(let ((execute-types (create-type-record)))
(read-case-sensitive #t)
(run-in-user-thread
(lambda ()
(test-ext? (profj-settings-allow-check? settings))
(tests? (get-preference 'profj:test-enable
(lambda () (profj-settings-run-tests? settings))))
(coverage? (profj-settings-coverage? settings))
(error-display-handler
(drscheme:debug:make-debug-error-display-handler (error-display-handler)))
(let ((old-current-eval (drscheme:debug:make-debug-eval-handler (current-eval))))
(current-eval
(lambda (exp)
(syntax-case exp (parse-java-full-program parse-java-interactions)
((parse-java-full-program ex)
(let ((exp (old-current-eval (syntax ex))))
((parse-java-full-program ex s)
(let ((exp (old-current-eval (syntax ex)))
(src (old-current-eval (syntax s))))
(execution? #t)
(set! execute-types (create-type-record))
(let ((name-to-require #f))
(let loop ((mods (order (compile-ast exp level execute-types)))
(extras (process-extras
(send execute-types get-interactions-boxes) execute-types))
(require? #f))
(cond
((and (not require?) (null? mods) (null? extras)) (void))
((and (not require?) (null? mods))
(old-current-eval (syntax-as-top (car extras)))
(loop mods (cdr extras) require?))
(require?
(old-current-eval
(syntax-as-top (with-syntax ([name name-to-require])
(syntax (require name)))))
(loop mods extras #f))
(else
(let-values (((name syn) (get-module-name (expand (car mods)))))
(set! name-to-require name)
(syntax-as-top (old-current-eval syn))
(loop (cdr mods) extras #t))))))))
(let* ((compilation-units (compile-ast exp level execute-types))
(examples (find-examples compilation-units)))
(let ((name-to-require #f)
(tests-run? #f))
(let loop ((mods (order compilation-units))
(extras (process-extras
(send execute-types get-interactions-boxes)
execute-types))
(require? #f))
(cond
((and (not require?) (null? mods) tests-run? (null? extras)) (void))
((and (not require?) (null? mods) (not tests-run?))
(when (tests?)
(let ((tc (make-object test-info%)))
(namespace-set-variable-value! 'current~test~object% tc)
(let ((objs (send tc run-tests
(map (lambda (c)
(list c (old-current-eval (string->symbol c))))
(car examples))
(cadr examples))))
(let inner-loop ((os objs))
(unless (null? os)
(let ((formatted
(format-java-list (car os) #t 'field null #f 0)))
(when (< 24 (total-length formatted))
(set! formatted
(format-java-list (car os) #t 'field null #t 0)))
(let loop ((out formatted))
(unless (null? out)
(write-special (car out))
(loop (cdr out))))
(newline))
(inner-loop (cdr os))))
(parameterize ([current-eventspace e])
(queue-callback
(lambda ()
(let* ((tab (and (is-a? src drscheme:unit:definitions-text<%>)
(send src get-tab)))
(frame (and tab (send tab get-frame)))
(test-window
(make-object test-display% frame tab)))
(send test-window pop-up-window tc))))))))
(set! tests-run? #t)
(loop mods extras require?))
((and (not require?) (null? mods) tests-run?)
(old-current-eval (syntax-as-top (car extras)))
(loop mods (cdr extras) require?))
(require?
(old-current-eval
(syntax-as-top (with-syntax ([name name-to-require])
(syntax (require name)))))
(loop mods extras #f))
(else
(let-values (((name syn) (get-module-name (expand (car mods)))))
(set! name-to-require name)
(syntax-as-top (old-current-eval syn))
(loop (cdr mods) extras #t)))))))))
((parse-java-interactions ex loc)
(let ((exp (syntax-object->datum (syntax ex))))
(old-current-eval
@ -577,13 +716,14 @@
(drscheme:modes:add-mode (string-constant profj-java-mode) mode-surrogate repl-submit matches-language)
(color-prefs:add-to-preferences-panel (string-constant profj-java) extend-preferences-panel)
(for-each (lambda (line)
(let ([sym (car line)]
[color (cadr line)])
(color-prefs:register-color-pref (short-sym->pref-name sym)
(short-sym->style-name sym)
color)))
color-prefs-table)
(define (register line)
(let ([sym (car line)]
[color (cadr line)])
(color-prefs:register-color-pref (short-sym->pref-name sym)
(short-sym->style-name sym)
color)))
(for-each register color-prefs-table)
(for-each register coverage-color-prefs)
;;Java Boxes
(define java-box%

3
collects/profj/types.ss
View File

@ -205,7 +205,8 @@
(else
(or (type=? (array-type-type to) (array-type-type from))
(castable? (array-type-type from)
(array-type-type to))))))))
(array-type-type to)
type-recs)))))))
;Do the two lists of method signatures have conflicting methods
;signature-conflicts? (list method-record) (list method-record) -> bool

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

@ -6,6 +6,14 @@
;;Execution tests without errors
(execute-test
"class Checkclass { }
class ExampleCheck {
boolean t1 = check new Checkclass[10] expect new Checkclass[10];
boolean t2 = check (new int[3])[1] expect 0;
}"
'advanced #f "check expressions")
(execute-test
"class Blah {
Blah () {}
@ -286,6 +294,22 @@ class WeeklyPlanner{
;;Interaction tests, mix of right and error
(interact-test 'advanced '("int a = 1;" "++a") '((void) 2) "Test of ++")
(interact-test
'advanced
'("check (new int[12])[3] expect 0"
"check new int[2] expect new int[4]"
"check new int[3] expect new int[3]"
"String[] t = new String[3];"
"t[2] = \"\";"
"check new Object[3] expect t"
"check new String[3] expect new Object[3]"
"check new int[3][3] expect new int[3]")
`(#t #f #t (void) ,(make-java-string "") #f #t #f)
"Check of arrays")
(interact-test
"class Afirst {
private int x = 10;
@ -346,13 +370,14 @@ class WeeklyPlanner{
(interact-test
'advanced
(list "(new int[2][])[0]" #;"(new int[2][])[1]=new int[2];")
(list null #;0)
(list "(new int[2][])[0]")
(list null)
"multi-dimension array - not all intialized")
(interact-test
'advanced
(list "int[] x = new int[10];" "for( int i = 0; i< x.length; i++) x[i]=i;" "x.length" "x[5]")
(list "int[] x = new int[10];"
"for( int i = 0; i< x.length; i++) x[i]=i;" "x.length" "x[5]")
(list '(void) '(void) 10 5)
"Array & for loop")

59
collects/tests/profj/beginner-tests.ss
View File

@ -10,6 +10,32 @@
;;Execution tests that should pass
(execute-test
"class MyClass {
Object field;
MyClass( Object f ) { this.field = f; }
MyClass method() { return this; }
}
class CorrectChecks {
boolean t;
boolean t2 = check 1 expect 3;
boolean t3 = (check 1 expect 3) || (check 2 expect 3);
boolean t4 = (check 1 expect 1) && (check 3 expect 3);
boolean t5 = check \"Hi\" expect \"\";
boolean t6 = check 1.5 expect 2 within .4;
boolean t7 = check true expect false;
boolean t8 = check new MyClass(\"\") expect new MyClass(\"\");
boolean t9 = check new MyClass(\"\").field expect \"\";
boolean t10 = check new MyClass(\"\").method() expect new MyClass(\"\");
CorrectChecks() { this.t= check 1 expect 4; }
}" language #f "Class with many different style of checks within it")
(execute-test
"interface A {
boolean s( B b);
@ -117,6 +143,26 @@
;;Execution tests that should produce errors
(execute-test
"class CorrectChecks {
boolean t;
boolean t2 = check 1 expect 3;
boolean t3 = (check 1 expect 3) || (check 2 expect 3);
boolean t4 = (check 1 expect 1) && (check 3 expect 3);
boolean t5 = check \"Hi\" expect \"\";
boolean t6 = check 1.5 expect 2 within .4;
boolean t7 = check true expect false;
boolean t8 = check new MyClass(\"\") expect new MyClass(\"\");
boolean t9 = check new MyClass(\"\").field expect \"\";
boolean t10 = check new MyClass(\"\").method() expect new MyClass(\"\");
()
CorrectChecks() { this.t= check 1 expect 4; }
}" language #t "Correct checks, followed by a parse error: should mention (")
(execute-test
"class X {
int x = this.y;
@ -475,5 +521,18 @@
(list '(void) 1.0 2.0)
"Converting ints into doubles appropriately")
(interact-test
language
(list "check true expect true"
"check true expect 1"
"check true expect true within 1"
"check new Object() expect \"hi\""
"check \"hi\" expect new Object()"
"check 1.4 expect 1"
"check 1.4 expect 1 within .5"
"check 1.4 expect 1 within true")
(list #t 'error #t #f 'error 'error #t 'error)
"Calling check in many ways")
(report-test-results))

136
collects/tests/profj/beginnerTest.java Normal file
View File

@ -0,0 +1,136 @@
// Expected results:
// 14 checks
// 2 failed checks, one in each test class
// 6 tests, all passing
// All methods of both classes are covered
interface Automobile {
int milesTraveled();
Automobile travel( int miles );
String makeAndModel();
double price(int year);
}
class Car implements Automobile {
String make;
String model;
int miles;
double basePrice;
Car(String make, String model, int miles, double basePrice) {
this.make = make;
this.model = model;
this.miles = miles;
this.basePrice = basePrice;
}
int milesTraveled() {
return this.miles;
}
String makeAndModel() {
return this.make.concat(this.model);
}
Automobile travel(int miles) {
return new Car(this.make, this.model, this.miles+miles, this.basePrice);
}
double price(int year) {
if ((2006 - year) == 0)
return this.basePrice;
else if ((2006 - year) > 0)
return this.basePrice - (this.basePrice / (2006 - year));
else
return this.basePrice + (this.basePrice / (year - 2006));
}
}
class CarExamples {
CarExamples() { }
Car myCar = new Car("Toyota","Tercel",100000, 16000.00);
Car momCar = new Car("Honda","Excel",10000, 32000.00);
boolean test1 = check this.myCar expect this.momCar;
boolean test2 = check this.myCar.milesTraveled() expect 100000;
boolean testTravel() {
return (check this.myCar.travel(10) expect new Car("Toyota","Tercel",100010, 16000.00)) ||
(check this.momCar.travel(90000) expect this.myCar);
}
boolean testMakeModel() {
return check this.myCar.makeAndModel() expect "ToyotaTercel";
}
boolean testPrice() {
return (check this.myCar.price(2006) expect 16000.00 within .01) &&
(check this.myCar.price(1991) expect 14933.33 within .01) &&
(check this.myCar.price(2007) expect 32000.00 within .01);
}
}
class Truck implements Automobile {
String make;
int miles;
int numDoors;
boolean extendedBed;
double basePrice;
Truck( String make, int miles, int numDoors, boolean bed, double basePrice) {
this.make = make;
this.miles = miles;
this.numDoors = numDoors;
this.extendedBed = bed;
this.basePrice = basePrice;
}
int milesTraveled() { return this.miles; }
String makeAndModel() {
if (this.extendedBed)
return this.make.concat("Extended");
else
return this.make.concat(String.valueOf(this.numDoors));
}
Automobile travel(int miles) {
return new Truck(this.make, this.miles + miles, this.numDoors, this.extendedBed, this.basePrice);
}
double price( int year ) {
// Uncomment to test runtime error behavior
//return this.basePrice - (2 * (this.basePrice / (2006 -year)));
if (year == 2006)
return this.basePrice;
else
return this.basePrice - (2 * (this.basePrice / (2006 - year)));
}
}
class TruckExamples {
Truck oneTruck = new Truck("Toyota",10000, 2,false,20000.00);
Truck twoTruck = new Truck("Ford",100000,2,true,35000.00);
boolean test1 = check this.oneTruck.milesTraveled() expect 10000;
boolean test2 = check this.oneTruck expect this.twoTruck;
TruckExamples() { }
boolean testPrice() {
return (check this.oneTruck.price(2006) expect 20000.00 within .01) &&
(check this.oneTruck.price(1996) expect 16000.00 within .01);
}
boolean testTravel() {
return check this.oneTruck.travel(1000) expect new Truck("Toyota",11000,2,false,20000.00);
}
boolean testMakeAndModel() {
return (check this.oneTruck.makeAndModel() expect "Toyota2") &&
(check this.twoTruck.makeAndModel() expect "FordExtended");
}
}

43
collects/tests/profj/intermediate-tests.ss
View File

@ -13,9 +13,9 @@
#f "abstract class not fully implementing an interface")
(execute-test
"interface A { int a(); }
abstract class B implements A { }
class C extends B {
"interface A1 { int a(); }
abstract class B1 implements A1 { }
class C1 extends B1 {
int a() { return 3; }
}"
'intermediate
@ -29,21 +29,21 @@
#f "Simple abstract class with abstract method")
(execute-test
"abstract class Foo {
"abstract class Foo1 {
abstract int f();
}
class FooP extends Foo {
class FooP extends Foo1 {
int f() { return 3; }
}"
'intermediate
#f "Simple abstract class with extending sub class")
(execute-test
"abstract class Foo {
"abstract class Foo2 {
abstract int f();
int fp() { return 3; }
}
class FooP extends Foo {
class FooP2 extends Foo2 {
int f() { return this.fp(); }
}"
'intermediate
@ -70,8 +70,8 @@
'intermediate #f "Class extension")
(execute-test
"class first { int x() { return 3; } }
class second extends first { int x() { return 6; }}"
"class first1 { int x() { return 3; } }
class second1 extends first1 { int x() { return 6; }}"
'intermediate #f "Overriding")
(execute-test
@ -318,6 +318,23 @@
;;Execute tests with errors
(execute-test
"class CheckError {
void foo() { }
}
class Examples {
boolean t1 = check new CheckError().foo() expect false;
}
" 'intermediate #t "Check with void method call in test")
(execute-test
"class CheckError {
void foo() { }
}
class Examples {
boolean t1 = check 3 expect new CheckError().foo();
}" 'intermediate #t "Check with void method call in expect")
(execute-test
"class A {
a b c;
@ -518,7 +535,7 @@ class BlockWorld extends World {
return this. block.draw(this);
}
boolean drawBackground() {
return this. theCanvas.drawRect(new Posn(0,0),this. WIDTH,this. HEIGHT,this. BACKGROUND);
return true;//this. theCanvas.drawRect(new Posn(0,0),this. WIDTH,this. HEIGHT,this. BACKGROUND);
}
}
@ -573,4 +590,10 @@ class DrpBlock {
'("Examples a = new Examples();") '((void))
"Cycle: used to cause multiple declarations of a class")
(interact-test
'intermediate
'("int a = 3;" "a = 45;" "a")
'((void) 45 45)
"Test of assignment")
(report-test-results))

120
collects/tests/profj/intermediateTest.java Normal file
View File

@ -0,0 +1,120 @@
// 14 checks; 2 failures
// 6 tests; no failures
// Order of calling testMethods crucial for test success
interface Automobile {
int milesTraveled();
void travel( int miles );
}
abstract class Auto implements Automobile {
int miles;
int milesTraveled() { return miles; }
void travel(int miles) {
this.miles = this.miles + miles;
}
}
class Car extends Auto {
double basePrice;
Car(int miles, double basePrice) {
this.miles = miles;
this.basePrice = basePrice;
}
double price(int year) {
if ((2006 - year) == 0)
return this.basePrice;
else if ((2006 - year) > 0)
return this.basePrice - (this.basePrice / (2006 - year));
else
return this.basePrice + (this.basePrice / (year - 2006));
}
}
class CarExamples {
Car myCar = new Car(100000, 16000.00);
Car momCar = new Car(10000, 32000.00);
boolean test1 = check this.myCar expect this.momCar;
boolean test2 = check this.myCar.milesTraveled() expect 100000;
boolean testTravel() {
myCar.travel(10);
return (check this.myCar expect new Car(100010, 16000.00));
}
boolean testTravel2() {
myCar.travel(10);
return (check this.myCar expect new Car(100020, 16000.00));
}
boolean testPrice() {
return (check this.myCar.price(2006) expect 16000.00 within .01) &&
(check this.myCar.price(1991) expect 14933.33 within .01) &&
(check this.myCar.price(2007) expect 32000.00 within .01);
}
}
class Truck extends Auto {
String make;
int numDoors;
boolean extendedBed;
double basePrice;
Truck( String make, int miles, int numDoors, boolean bed, double basePrice) {
this.make = make;
this.miles = miles;
this.numDoors = numDoors;
this.extendedBed = bed;
this.basePrice = basePrice;
}
String makeAndModel() {
if (this.extendedBed)
return this.make.concat("Extended");
else
return this.make.concat(String.valueOf(this.numDoors));
}
double price( int year ) {
// Uncomment to test runtime error behavior
//return this.basePrice - (2 * (this.basePrice / (2006 -year)));
if (year == 2006)
return this.basePrice;
else
return this.basePrice - (2 * (this.basePrice / (2006 - year)));
}
}
class TruckExamples {
Truck oneTruck = new Truck("Toyota",10000, 2,false,20000.00);
Truck twoTruck = new Truck("Ford",100000,2,true,35000.00);
boolean test1 = check this.oneTruck.milesTraveled() expect 10000;
boolean test2 = check this.oneTruck expect this.twoTruck;
TruckExamples() { }
boolean testPrice() {
return (check this.oneTruck.price(2006) expect 20000.00 within .01) &&
(check this.oneTruck.price(1996) expect 16000.00 within .01);
}
boolean testTravel() {
oneTruck.travel(1000);
return check this.oneTruck expect new Truck("Toyota",11000,2,false,20000.00);
}
boolean testMakeAndModel() {
return (check this.oneTruck.makeAndModel() expect "Toyota2") &&
(check this.twoTruck.makeAndModel() expect "FordExtended");
}
}