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 (begin
(build-interactions-info ast level location type-recs) (build-interactions-info ast level location type-recs)
(check-interactions-types 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) (to-file #f)
(if (null? ast) (if (null? ast)
(datum->syntax-object #f '(void) #f) (datum->syntax-object #f '(void) #f)
(begin (begin
(build-interactions-info ast level location type-recs) (build-interactions-info ast level location type-recs)
(check-interactions-types 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)) (define-struct elt (prev val next))

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

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

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

@ -316,7 +316,9 @@
(syntax-case lexeme () (syntax-case lexeme ()
((parse-example-box examples) (token-EXAMPLE (make-example-box (syntax examples)))) ((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") #;(begin(printf "lexing a special")
(syntax-case lexeme () (syntax-case lexeme ()

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

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