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

Made test-boxes work in ProfessorJ

Browse Source 
svn: r219
This commit is contained in:
Kathy Gray 2005-06-19 15:38:35 +00:00
parent d3a3a665eb
commit fdc3e5d0e4
5 changed files with 42 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/profj/compile.ss
View File

@ -169,16 +169,16 @@
(begin
(build-interactions-info ast level location type-recs)
(check-interactions-types ast level location type-recs)
(translate-interactions ast location type-recs)))))
(translate-interactions ast location type-recs #t)))))
(define (compile-interactions-ast ast location level type-recs)
(define (compile-interactions-ast ast location level type-recs gen-require?)
(to-file #f)
(if (null? ast)
(datum->syntax-object #f '(void) #f)
(begin
(build-interactions-info ast level location type-recs)
(check-interactions-types ast level location type-recs)
(translate-interactions ast location type-recs))))
(translate-interactions ast location type-recs gen-require?))))
(define-struct elt (prev val next))

8
collects/profj/libs/java/lang/Object-composite.ss
View File

@ -49,7 +49,7 @@
(define Object-Mix
(lambda (parent)
(class* parent (ObjectI)
(inspect #f)
(define/public (Object-constructor) (void))
;Needs to do something
@ -269,7 +269,7 @@
(define java-array
(class* Object ()
(inspect #f)
(define array null)
(define rt #f)
(define/public (get-rt) rt)
@ -411,7 +411,8 @@
(define String
(class* Object (Comparable Serializable)
(inspect #f)
;private field containing scheme string
(define text "")
;Accessor for scheme string
@ -796,6 +797,7 @@
(define Throwable
(class* Object (Serializable)
(inspect #f)
;private fields
;message: String
(define message (make-java-string ""))

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

@ -316,7 +316,9 @@
(syntax-case lexeme ()
((parse-example-box examples) (token-EXAMPLE (make-example-box (syntax examples))))
(_
(token-OTHER_SPECIAL (list lexeme start-pos end-pos)))))
(if (syntax-property lexeme 'test-case-box)
(token-TEST_SUITE (make-test-case lexeme))
(token-OTHER_SPECIAL (list lexeme start-pos end-pos))))))
#;(begin(printf "lexing a special")
(syntax-case lexeme ()

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

@ -160,8 +160,8 @@
;-------------------------------------------------------------------------------------------------------------------------
;Translation
;translate-interactions: ast location type-records -> syntax
(define (translate-interactions prog location type-recs)
;translate-interactions: ast location type-records boolean-> syntax
(define (translate-interactions prog location type-recs gen-reqs?)
(loc location)
(interactions? #t)
(types type-recs)
@ -171,7 +171,7 @@
(send type-recs set-class-reqs null)
(make-syntax #f
`(begin ,@(map (lambda (f)
(translate-interactions f location type-recs))
(translate-interactions f location type-recs gen-reqs?))
prog))
#f))
((field? prog)
@ -187,7 +187,7 @@
((expr? prog) (translate-expression prog))
(else
(error 'translate-interactions "Internal Error: translate-interactions given ~a" prog)))))
(if (null? reqs)
(if (or (null? reqs) (not gen-reqs?))
syn
(make-syntax #f
`(begin (require ,@(remove-dup-syntax (translate-interact-require reqs type-recs)))

69
collects/profj/tool.ss
View File

@ -123,7 +123,7 @@
(drscheme:language-configuration:add-language
(make-object ((drscheme:language:get-default-mixin) intermediate-lang%)))
(drscheme:language-configuration:add-language
(make-object ((drscheme:language:get-default-mixin) beginner-lang%))))
(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))
@ -353,7 +353,7 @@
(lambda ()
(if (eof-object? (peek-char-or-special port))
eof
(syntax-as-top
(syntax-as-top
(datum->syntax-object
#f
#;`(compile-interactions-helper ,(lambda (ast) (compile-interactions-ast ast name level execute-types))
@ -365,7 +365,7 @@
(define/private (process-extras extras type-recs)
(cond
((null? extras) null)
((example-box? (car extras))
((example-box? (car extras))
(let ((contents (eval (example-box-contents (car extras)))))
(append
(map (lambda (example)
@ -381,43 +381,24 @@
contents)
(process-extras (cdr extras) type-recs))))
((test-case? (car extras))
(cons
(let ((new-test-case
(lambda (to-test-stx exp-stx record set-actuals)
(let ([to-test-values (call-with-values (lambda () to-test-stx) list)]
[exp-values (call-with-values (lambda () exp-stx) list)])
(record (and (= (length to-test-values) (length exp-values))
(andmap (dynamic-require '(lib "profj-testing.ss" "profj") 'java-values-equal?)
to-test-values exp-values)))
(set-actuals to-test-values)))))
(let-values (((syn t t2) (send (test-case-test (car extras)) read-special #f #f #f #f)))
(syntax-case syn ()
((test-case equal? exp1 exp2 exp3 exp4)
(syntax-case (syntax exp1) (begin require)
((begin (require req ...) exp)
(syntax-case (syntax exp2) (begin require)
((begin (require req2 ...) new-exp2)
(datum->syntax-object #f
`(begin ,(syntax (require req ... req2 ...))
(,new-test-case ,(syntax exp) ,(syntax new-exp2)
,(syntax exp3) ,(syntax exp4)))
#f))
(else
(datum->syntax-object #f
`(begin ,(syntax (require req ...))
(,new-test-case ,(syntax exp) ,(syntax exp2) ,(syntax exp3) ,(syntax exp4)))
#f))))
(else
(syntax-case (syntax exp2) (begin require)
((begin (require req2 ...) new-exp2)
(datum->syntax-object #f
`(begin ,(syntax (require req2 ...))
(,new-test-case ,(syntax exp1) ,(syntax new-exp2) ,(syntax exp3) ,(syntax exp4)))
#f))
(else
(datum->syntax-object #f `(,new-test-case ,(syntax exp1) ,(syntax exp2) ,(syntax exp3) ,(syntax exp4)) #f))))))
(else syn))))
(process-extras (cdr extras) type-recs)))
;(printf "in process-extras~n")
;(printf "~a~n" (test-case-test (car extras)))
(cons
(let ((tc (test-case-test (car extras))))
(syntax-case tc (parse-java-interactions)
((test-case eq (parse-java-interactions ast-1 ed-1)
(parse-java-interactions ast-2 ed-2) end1 end2)
(datum->syntax-object #f
`(,(syntax test-case)
,(dynamic-require '(lib "profj-testing.ss" "profj") 'java-values-equal?);,(syntax eq)
,(compile-interactions-ast (syntax-object->datum (syntax ast-1))
(syntax-object->datum (syntax ed-1)) level type-recs #f)
,(compile-interactions-ast (syntax-object->datum (syntax ast-2))
(syntax-object->datum (syntax ed-2)) level type-recs #f)
,(syntax end1) ,(syntax end2))
#f))
(_ tc))) (process-extras (cdr extras) type-recs))
#;(cons (test-case-test (car extras)) (process-extras (cdr extras) type-recs)))
((interact-case? (car extras))
(let ((interact-box (interact-case-box (car extras))))
(send interact-box set-level level)
@ -512,7 +493,7 @@
((parse-java-interactions ex loc)
(let ((exp (syntax-object->datum (syntax ex))))
(old-current-eval
(syntax-as-top (compile-interactions-ast exp (syntax loc) level execute-types)))))
(syntax-as-top (compile-interactions-ast exp (syntax loc) level execute-types #t)))))
(_ (old-current-eval exp))))))
(with-handlers ([void (lambda (x) (printf "~a~n" (exn-message x)))])
(namespace-require 'mzscheme)
@ -529,7 +510,10 @@
(let ((print-full? (profj-settings-print-full? settings))
(style (profj-settings-print-style settings)))
(if (is-a? value String)
(write-special (format "~v" (send value get-mzscheme-string)) port)
(display (format-java value print-full? style null #t 0) port)
#;(begin
(write-special (format "~v" (send value get-mzscheme-string)) port)
(void))
(let ((out (format-java value print-full? style null #f 0)))
(if (< 25 (string-length out))
(display (format-java value print-full? style null #t 0) port)
@ -538,6 +522,7 @@
(render-value value settings port)(newline port))
(define/public (create-executable fn parent . args)
(printf "create-exe called~n")
(message-box "Unsupported"
"Sorry - executables are not supported for Java at this time"
parent))