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

Switching to scheme/base instead of mzscheme

Browse Source 
Addition of support for stm (to-scheme.ss only)

svn: r10232
This commit is contained in:
Kathy Gray 2008-06-12 14:46:43 +00:00
parent 64147e45ab
commit 7f085f7e2b
19 changed files with 300 additions and 329 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/profj/ast.ss
View File

@ -1,16 +1,16 @@
(module ast mzscheme
(module ast scheme/base
;Macro to allow structure definition and provision
(define-syntax p-define-struct
(syntax-rules ()
[(_ (name inherit) fields)
(begin
(provide (struct name fields))
(define-struct (name inherit) fields (make-inspector)))]
(provide (struct-out name))
(define-struct (name inherit) fields #:mutable #:transparent))]
[(_ name fields)
(begin
(provide (struct name fields))
(define-struct name fields (make-inspector)))]))
(provide (struct-out name))
(define-struct name fields #:mutable #:transparent))]))
;(make-src int int int int loc)

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

@ -1,6 +1,6 @@
(module build-info mzscheme
(module build-info scheme/base
(require mzlib/class mzlib/file mzlib/list
(require scheme/class scheme/path
"ast.ss" "types.ss" "error-messaging.ss" "parameters.ss"
"restrictions.ss" "parser.ss" "profj-pref.ss")
@ -30,7 +30,7 @@
;build-require-syntax: string (list string) dir bool bool-> (list syntax)
(define (build-require-syntax name path dir local? scheme?)
(let* ((syn (lambda (acc) (datum->syntax-object #f acc #f)))
(let* ((syn (lambda (acc) (datum->syntax #f acc #f)))
(profj-lib? (ormap (lambda (p) (same-base-dir? dir p))
(map (lambda (p) (build-path p "profj" "libs"))
(current-library-collection-paths))))
@ -53,13 +53,13 @@
(string-append n ".ss")
(string->symbol n))))))
(if scheme?
(list (syn `(prefix ,(string->symbol
(list (syn `(prefix-in ,(string->symbol
(apply string-append
(append (map (lambda (s) (string-append s ".")) path)
(list name "-"))))
,(syn (access (make-name)))))
(syn `(prefix ,(string->symbol (string-append name "-")) ,(syn (access (make-name))))))
(list (syn `(prefix ,(string->symbol (apply string-append
(syn `(prefix-in ,(string->symbol (string-append name "-")) ,(syn (access (make-name))))))
(list (syn `(prefix-in ,(string->symbol (apply string-append
(map (lambda (s) (string-append s ".")) path)))
,(syn (access (make-name)))))
(syn (access (make-name)))))))
@ -452,7 +452,7 @@
(directory-list (build-path (dir-path-path base-dir) "compiled")))))))
(lang-classes (get-classes lang-dir))
(test-classes (when (testcase-ext?) (get-classes test-dir)))
(array (datum->syntax-object #f `(lib "array.ss" "profj/libs/java/lang") #f))
(array (datum->syntax #f `(lib "array.ss" "profj/libs/java/lang") #f))
(add
(lambda (path classes dir array?)

14
collects/profj/check.ss
View File

@ -1,4 +1,4 @@
(module check mzscheme
(module check scheme/base
(require "ast.ss"
"types.ss"
@ -7,8 +7,8 @@
"restrictions.ss"
"profj-pref.ss"
"build-info.ss"
mzlib/class mzlib/list mzlib/file
(prefix srfi: srfi/1) mzlib/string)
scheme/class scheme/path
(prefix-in srfi: srfi/1) mzlib/string)
(provide check-defs check-interactions-types)
;symbol-remove-last: symbol->symbol
@ -24,20 +24,20 @@
;env =>
;(make-environment (list var-type) (list string) (list type) (list string) (list inner-rec))
(define-struct environment (types set-vars exns labels local-inners) (make-inspector))
(define-struct environment (types set-vars exns labels local-inners) #:transparent)
;Constant empty environment
(define empty-env (make-environment null null null null null))
;; var-type => (make-var-type string type properties)
(define-struct var-type (var type properties) (make-inspector))
(define-struct var-type (var type properties) #:transparent)
;;inner-rec ==> (make-inner-rec string (U symbol void) (list string) class-rec)
(define-struct inner-rec (name unique-name package record))
;;Environment variable properties
;;(make-properties bool bool bool bool bool bool)
(define-struct properties (parm? field? static? settable? final? usable? set?) (make-inspector))
(define-struct properties (parm? field? static? settable? final? usable? set?) #:transparent #:mutable)
(define parm (make-properties #t #f #f #t #f #t #t))
(define final-parm (make-properties #t #f #f #f #t #t #t))
(define method-var (make-properties #f #f #f #t #f #t #f))
@ -3666,7 +3666,7 @@
;implicit import error
;class-lookup-error: string src -> void
(define (class-lookup-error class src)
(if (path? class) (set! class (path->string class)))
(when (path? class) (set! class (path->string class)))
(raise-error (string->symbol class)
(format "Implicit import of class ~a failed as this class does not exist at the specified location"
class)

25
collects/profj/compile.ss
View File

@ -1,8 +1,9 @@
(module compile mzscheme
(module compile scheme/base
(require "parameters.ss" "ast.ss" "types.ss" "parser.ss" "build-info.ss" "check.ss" "to-scheme.ss" "profj-pref.ss")
(require mzlib/list
mzlib/file
mzlib/class)
(require #;mzlib/list
#;mzlib/file
scheme/path
scheme/class)
(provide compile-java compile-interactions compile-files compile-ast compile-interactions-ast
compilation-unit-code compilation-unit-contains set-compilation-unit-code!
@ -74,7 +75,7 @@
(compile-java-internal port loc type-recs #f level)))))
(define (compile-module expr)
(parameterize ([current-namespace (make-namespace)])
(parameterize ([current-namespace (make-base-namespace)])
(compile expr)))
;compile-to-file: port location level -> void
@ -121,19 +122,19 @@
#f
class-record-error)
port))
'truncate/replace)))
#:exists 'truncate/replace)))
names syntaxes locations)))
(compile-java-internal port location type-recs #t level))))
;; call-with-output-zo-file* path-string path-string proc [symbol ...] ->
;; Like call-with-output-file*, but takes an extra initial path to use
;; as a original location, so that marshaled paths in a generated .zo file
;; as an original location, so that marshaled paths in a generated .zo file
;; can be written as relative paths
(define (call-with-output-zo-file* loc name proc . flags)
(define (call-with-output-zo-file* loc name proc flag)
(let ([dir (and (path-string? loc)
(path-only (path->complete-path loc)))])
(parameterize ([current-write-relative-directory dir])
(apply call-with-output-file* name proc flags))))
(call-with-output-file* name proc #:exists flag))))
(define (class-record-error) (error 'compile-to-file "Internal error: class record not found"))
@ -215,7 +216,7 @@
(to-file #f)
(let ((ast (parse-interactions port location level)))
(if (null? ast)
(datum->syntax-object #f '(void) #f)
(datum->syntax #f '(void) #f)
(begin
(build-interactions-info ast level location type-recs)
(check-interactions-types ast level location type-recs)
@ -224,13 +225,13 @@
(define (compile-interactions-ast ast location level type-recs gen-require?)
(to-file #f)
(if (null? ast)
(datum->syntax-object #f '(void) #f)
(datum->syntax #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 gen-require?))))
(define-struct elt (prev val next))
(define-struct elt (prev val next) #:mutable)
(define fifo
(class* object% ()

4
collects/profj/display-java.ss
View File

@ -1,6 +1,6 @@
(module display-java mzscheme
(module display-java scheme/base
(require mzlib/class
(require scheme/class
mred
framework
profj/libs/java/lang/Object

7
collects/profj/error-messaging.ss
View File

@ -1,7 +1,6 @@
(module error-messaging mzscheme
(module error-messaging scheme/base
(require "ast.ss")
(require "types.ss")
(require "ast.ss" "types.ss")
(provide make-error-pass get-expected type->ext-name id->ext-name
get-call-type method-name->ext-name path->ext name->path
@ -16,7 +15,7 @@
;make-so: symbol src (-> location) -> syntax-object
(define (make-so id src parm)
(datum->syntax-object #f id (build-src-list src parm)))
(datum->syntax #f id (build-src-list src parm)))
;build-src-list: src (-> location) -> (U bool (list loc int int int int))
(define (build-src-list src parm)

57
collects/profj/graph-scc.ss
View File

@ -1,13 +1,11 @@
(module graph-scc mzscheme
#;(require "ast.ss")
(module graph-scc scheme/base
(provide get-scc)
(define (get-scc nodes get-successors for-each-node)
(letrec ([in-component (make-hash-table)]
[dpth-nums (make-hash-table)]
[root-of-node (make-hash-table)]
(letrec ([in-component (make-hasheq)]
[dpth-nums (make-hasheq)]
[root-of-node (make-hasheq)]
[counter 0]
[stack null]
[sccs null]
@ -15,30 +13,31 @@
;node -> boolean
[visited?
(lambda (node)
(symbol? (hash-table-get in-component node #f)))]
(symbol? (hash-ref in-component node #f)))]
;node -> boolean
[in-component?
(lambda (node)
(eq? 'true (hash-table-get in-component node #f)))]
(eq? 'true (hash-ref in-component node #f)))]
;node node -> node
[min-root
(lambda (old-min new-node)
#;(printf "~a <= ~a, ~a" (hash-table-get dpth-nums old-min)
(hash-table-get dpth-nums
(hash-table-get root-of-node new-node)
(lambda () (add1 counter))) counter)
(if (<= (hash-table-get dpth-nums old-min)
(hash-table-get dpth-nums
(hash-table-get root-of-node new-node)
(add1 counter)))
#;(printf "~a <= ~a, ~a"
(hash-ref dpth-nums old-min)
(hash-ref dpth-nums
(hash-ref root-of-node new-node)
(lambda () (add1 counter))) counter)
(if (<= (hash-ref dpth-nums old-min)
(hash-ref dpth-nums
(hash-ref root-of-node new-node)
(add1 counter)))
old-min
new-node))]
;node -> void
[assign-depth-num
(lambda (node)
(unless (hash-table-get dpth-nums node #f)
(hash-table-put! dpth-nums node counter)
(unless (hash-ref dpth-nums node #f)
(hash-set! dpth-nums node counter)
(set! counter (add1 counter))))]
[push! (lambda (v) (set! stack (cons v stack)))]
@ -49,8 +48,8 @@
(lambda (node)
#;(printf "visit of ~a~n" (def-name node))
(let ([root-v node])
(hash-table-put! root-of-node node root-v)
(hash-table-put! in-component node 'false)
(hash-set! root-of-node node root-v)
(hash-set! in-component node 'false)
(assign-depth-num node)
(push! node)
(for-each-node
@ -65,18 +64,18 @@
(get-successors node))
#;(printf "root-v ~a for visit of ~a~n" (def-name root-v)
(def-name node))
(hash-table-put! root-of-node node root-v)
(if (eq? root-v node)
(let loop ([w (pop!)] [scc null])
#;(printf "~a ~a ~n" w scc)
(hash-table-put! in-component w 'true)
(if (eq? w node)
(set! sccs (cons (cons w scc) sccs))
(loop (pop!) (cons w scc)))))))])
(hash-set! root-of-node node root-v)
(when (eq? root-v node)
(let loop ([w (pop!)] [scc null])
#;(printf "~a ~a ~n" w scc)
(hash-set! in-component w 'true)
(if (eq? w node)
(set! sccs (cons (cons w scc) sccs))
(loop (pop!) (cons w scc)))))))])
(for-each-node (lambda (node)
(set! counter 0)
(set! dpth-nums (make-hash-table))
(set! dpth-nums (make-hasheq))
(unless (visited? node) (visit node)))
nodes)

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

@ -6,23 +6,7 @@
profj/libs/java/lang/Comparable
profj/libs/java/io/Serializable)
#;(require "compile-lang-syntax.ss")
(define make-hash-table make-hash)
(define hash-table-put! hash-set!)
;Runtime needed code
(define (javaRuntime:convert-to-string data)
(cond
((number? data) (make-java-string (number->string data)))
((boolean? data)
(make-java-string (if data "true" "false")))
((char? data) (make-java-string (string data)))
((is-a? data ObjectI) (send data toString))
((is-a? data object%) (make-java-string "SchemeObject"))
(else (error 'JavaRuntime:Internal_Error:convert-to-string
(format "Convert to string given unsupported data: ~s" data)))))
#;(require "compile-lang-syntax.ss")
;
; ;; ;
@ -1442,5 +1426,7 @@
(define static-NullPointerException/c
(c:flat-named-contract "NullPointerException" (lambda (c) (is-a? c guard-convert-NullPointerException))))
(define stm-wrapper (interface () log get-field set-field!))
(provide stm-wrapper)
)

2
collects/profj/libs/java/lang/Object.ss
View File

@ -2,4 +2,4 @@
(require "Object-composite.ss")
(provide ObjectI Object-Mix Object)
(provide guard-convert-Object convert-assert-Object wrap-convert-assert-Object
dynamic-Object/c static-Object/c wrapper))
dynamic-Object/c static-Object/c wrapper stm-wrapper))

4
collects/profj/name-utils.scm
View File

@ -1,6 +1,6 @@
(module name-utils mzscheme
(module name-utils scheme/base
(provide (all-defined-except getter))
(provide (except-out (all-defined-out) getter))
(define (getter match-pattern replace-pattern)
(lambda (name)

6
collects/profj/parameters.ss
View File

@ -1,8 +1,6 @@
(module parameters mzscheme
(module parameters scheme/base
(require mzlib/class)
(provide (all-defined))
(provide (all-defined-out))
;Stores the classpath for the current run
(define classpath (make-parameter null))

6
collects/profj/parser.ss
View File

@ -1,5 +1,5 @@
(module parser mzscheme
(module parser scheme/base
(require "parsers/full-parser.ss"
"parsers/advanced-parser.ss"
"parsers/intermediate-access-parser.ss"
@ -8,11 +8,11 @@
"parsers/general-parsing.ss"
"parsers/parse-error.ss"
"parsers/lexer.ss"
(prefix err: "comb-parsers/parsers.scm")
(prefix-in err: "comb-parsers/parsers.scm")
"ast.ss"
"parameters.ss")
(require (all-except parser-tools/lex input-port)
(require (except-in parser-tools/lex input-port)
syntax/readerr
)
(provide parse parse-interactions parse-expression parse-type parse-name lex-stream)

5
collects/profj/profj-pref.ss
View File

@ -1,7 +1,6 @@
(module profj-pref mzscheme
(module profj-pref scheme/base
(require mzlib/file
mzlib/list)
(require mzlib/file)
(provide reset-classpath add-to-classpath get-classpath)

3
collects/profj/restrictions.ss
View File

@ -1,5 +1,4 @@
#cs
(module restrictions mzscheme
(module restrictions scheme/base
(provide is-field-restricted? is-method-restricted? forbidden-lang-class? is-import-restricted?)

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

@ -1,19 +1,18 @@
(module to-scheme mzscheme
(module to-scheme scheme/base
(require "ast.ss"
"types.ss"
"name-utils.scm"
"graph-scc.ss"
"parameters.ss"
mzlib/class
mzlib/list
scheme/class
mzlib/etc
(prefix int-set: (lib "integer-set.ss"))
(prefix-in int-set: (lib "integer-set.ss"))
)
(provide translate-program translate-interactions (struct compilation-unit (contains code locations depends)))
(provide translate-program translate-interactions (struct-out compilation-unit))
;(make-compilation-unit (list string) (list syntax) (list location) (list (list string)))
(define-struct compilation-unit (contains code locations depends) (make-inspector))
(define-struct compilation-unit (contains code locations depends) #:transparent #:mutable)
;File takes java AST as defined by ast.ss and produces
;semantically (hopefully) equivalent scheme code
@ -37,6 +36,8 @@
(define current-depth (make-parameter 0))
(define current-local-classes (make-parameter null))
(define datum->syntax-object datum->syntax)
(define syntax-object->datum syntax->datum)
(define stx-for-original-property (read-syntax #f (open-input-string "original")))
(define (stx-for-source) stx-for-original-property)
(define (create-syntax oddness sexpression source)
@ -117,8 +118,8 @@
;get-class-name: (U name type-spec) -> syntax
(define (get-class-name name)
(if (type-spec? name)
(set! name (type-spec-name name)))
(when (type-spec? name)
(set! name (type-spec-name name)))
(if (null? (name-path name))
(translate-id (id-string (name-id name))
(id-src (name-id name)))
@ -253,84 +254,7 @@
(lambda (def)
(filter (lambda (x) x) (map find (def-uses def)))))
)
(get-scc defs get-requires for-each)
#;(get-strongly-connected-components defs for-each-def get-requires)))
;get-strongly-connected-components: GRAPH (GRAPH (NODE -> void) -> void) (NODE -> (list NODE)) -> (list (list NODE))
(define (get-strongly-connected-components graph for-each-node get-connected-nodes)
(let ((marks (make-hash-table))
(strongly-connecteds null)
(cur-cycle-length 0)
(current-cycle null))
(letrec ((already-in-cycle?
(lambda (n) (eq? 'in-a-cycle (hash-table-get marks n))))
(in-current-cycle?
(lambda (n) (hash-table-get current-cycle n (lambda () #f))))
(current-cycle-memq
(lambda (nodes) (ormap in-current-cycle? nodes)))
(add-to-current-cycle
(lambda (n)
(set! cur-cycle-length (add1 cur-cycle-length))
(hash-table-put! current-cycle n #t)))
(retrieve-current-cycle
(lambda () (hash-table-map current-cycle (lambda (key v) key))))
;; componetize : NODE (list NODE) bool -> void
(componentize
(lambda (node successors member?)
(unless (already-in-cycle? node)
(printf "componentize ~a ~a ~a~n"
(id-string (def-name node))
(map id-string (map def-name successors))
(map id-string (map def-name (retrieve-current-cycle)))
)
(let ((added? #f)
(cur-length cur-cycle-length)
(old-mark (hash-table-get marks node)))
(when (and (not member?) (current-cycle-memq successors))
(set! added? #t)
(add-to-current-cycle node))
(hash-table-put! marks node 'in-progress)
(for-each
(lambda (successor)
(unless (or (in-current-cycle? successor)
(eq? 'in-progress (hash-table-get marks successor)))
(componentize successor (get-connected-nodes successor) #f)))
successors)
(printf "finished successors for ~a~n" (id-string (def-name node)))
(when (not (= cur-length cur-cycle-length))
(add-to-current-cycle node))
(if (or added? (= cur-length cur-cycle-length))
(hash-table-put! marks node old-mark)
(componentize node successors #f)))))))
(for-each-node graph (lambda (n) (hash-table-put! marks n 'no-info)))
(for-each-node graph
(lambda (node)
#;(hash-table-for-each
marks
(lambda (key val) (printf "~a -> ~a~n" (eq-hash-code key) val)))
#;(printf "Working on ~a~n~n" (eq-hash-code node))
#;(printf "node: ~a successors: ~a" (def-name node) (map def-name (get-connected-nodes node)))
(when (eq? (hash-table-get marks node) 'no-info)
(set! current-cycle (make-hash-table))
(add-to-current-cycle node)
(set! cur-cycle-length 0)
(printf "calling componetice ~a~n" (id-string (def-name node)))
(for-each (lambda (node) (componentize node (get-connected-nodes node) #f))
(get-connected-nodes node))
(set! strongly-connecteds
(cons (retrieve-current-cycle) strongly-connecteds))
(printf "~a~n~n" (map id-string (map def-name (car strongly-connecteds))))
(hash-table-for-each
current-cycle
(lambda (n v) (hash-table-put! marks n 'in-a-cycle))))))
strongly-connecteds)))
(get-scc defs get-requires for-each)))
;order-defs: (list def) -> (list def)
(define (order-defs defs)
@ -389,10 +313,10 @@
defs)))
(reqs (filter-reqs group-reqs defs type-recs)))
(values (if (> (length translated-defs) 1)
(cons (make-syntax #f `(module ,(module-name) mzscheme
(require mzlib/class
(prefix javaRuntime: profj/libs/java/runtime)
(prefix c: mzlib/contract)
(cons (make-syntax #f `(module ,(module-name) scheme/base
(require scheme/class
(prefix-in javaRuntime: profj/libs/java/runtime)
(prefix-in c: scheme/contract)
,@(remove-dup-syntax (translate-require reqs type-recs)))
,@(apply append (map car translated-defs)))
#f)
@ -401,11 +325,10 @@
`(module ,(build-identifier (regexp-replace "-composite"
(symbol->string (module-name))
""))
mzscheme
(require mzlib/class
(prefix javaRuntime: profj/libs/java/runtime)
#;(prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java"))
(prefix c: mzlib/contract)
scheme/base
(require scheme/class
(prefix-in javaRuntime: profj/libs/java/runtime)
(prefix-in c: scheme/contract)
,@(remove-dup-syntax
(translate-require (map (lambda (r) (list (def-file (car defs)) r))
(def-uses (car defs)))
@ -538,9 +461,10 @@
;set class specific parameters - old ones are safe
(class-name (id-string (header-id header)))
(parent-name parent)
(class-override-table (make-hash-table))
(class-override-table (make-hasheq))
(let* ((class (translate-id (class-name) (id-src (header-id header))))
(class-rec (send type-recs get-class-record (list (class-name))))
(overridden-methods (get-overridden-methods (append (accesses-public methods)
(accesses-package methods)
(accesses-protected methods))))
@ -570,12 +494,14 @@
(filter
(lambda (m) (not (or (private? (method-record-modifiers m))
(static? (method-record-modifiers m)))))
(begin0
(class-record-methods (send type-recs get-class-record (list (class-name))))
#;(printf "finished class-record-methods~n")))
(class-record-methods class-rec))
(append (accesses-public fields) (accesses-package fields)
(accesses-protected fields)))
(generate-contract-defs (class-name))))
(stm-class (generate-stm-class (class-name)
(parent-name)
(class-record-methods class-rec)
(class-record-fields class-rec)))
(static-method-names (make-static-method-names (accesses-static methods) type-recs))
(static-field-names (make-static-field-names (accesses-static fields)))
(static-field-setters (make-static-field-setters-names
@ -705,7 +631,7 @@
(define field-setters ,(build-field-table create-set-name 'set fields))
(define private-methods
,(if (null? (accesses-private methods))
'(make-hash-table)
'(make-hasheq)
(build-method-table (accesses-private methods) private-generics)))
,@(if test?
@ -803,8 +729,9 @@
(members-init class-members))
))
,@wrapper-classes
,stm-class
#;,@(create-generic-methods (append (accesses-public methods)
(accesses-package methods)
@ -865,7 +792,7 @@
(c:flat-named-contract ,class-name
(lambda (v) (is-a? v ,(build-identifier (string-append "guard-convert-" class-name))))))))
;generate-wrappers: string (list method-record) (list field) -> (list sexp)
;generate-wrappers: string string (list method-record) (list field) -> (list sexp)
(define (generate-wrappers class-name super-name methods fields)
(let* (;these methods will be used to detect when a method is now overloaded when it wasn't in the super class
(wrapped-methods-initial
@ -1010,6 +937,8 @@
,@list-of-args) (method-record-rtype method) #f))))))))
methods))
;list-from: int int -> (listof int)
;Produces a list of integers starting at from and going to one less than to
(define (list-from from to)
(cond
((= from to) null)
@ -1017,7 +946,7 @@
;methods->contract: (list method-record) -> sexp
(define (methods->contract methods)
`(c:object-contract ,@(map (lambda (m)
`(object-contract ,@(map (lambda (m)
`(,(build-identifier (mangle-method-name (method-record-name m)
(method-record-atypes m)))
(c:-> ,@(map (lambda (a) 'c:any/c) (method-record-atypes m)) c:any/c)))
@ -1167,9 +1096,9 @@
;build-method-table: (list method) (list symbol) -> sexp
(define (build-method-table methods generics)
`(let ((table (make-hash-table)))
`(let ((table (make-hasheq)))
(for-each (lambda (method generic)
(hash-table-put! table (string->symbol method) generic))
(hash-set! table (string->symbol method) generic))
(list ,@(map (lambda (m)
(mangle-method-name (id-string (method-name m))
(method-record-atypes (method-rec m))))
@ -1179,9 +1108,9 @@
;build-field-table: (string->string) symbol accesses -> sexp
(define (build-field-table maker type fields)
`(let ((table (make-hash-table)))
`(let ((table (make-hasheq)))
(for-each (lambda (field field-method)
(hash-table-put! table (string->symbol field) field-method))
(hash-set! table (string->symbol field) field-method))
,@(let ((non-private-fields (map (lambda (n) (id-string (field-name n)))
(append (accesses-public fields)
(accesses-package fields)
@ -1201,7 +1130,62 @@
private-fields))))))
table))
;generate-stm: string string (list method-record) (list field-record) -> syntax
(define (generate-stm-class class parent methods fields)
(create-syntax #f
`(begin
(require scheme/private/class-internal)
(provide ,(string->symbol (string-append class "-stm")))
(define ,(string->symbol (string-append class "-stm"))
(class* object% (stm-wrapper)
(super-instantiate ())
(define o null)
(define field-map (make-hasheq))
(define/public (log obj) (set! o obj))
(define/public (get-field field)
(or (hash-ref field-map field #f)
(get-field o field)))
(define/public (set-field! field value)
(hash-set! field-map field value)
value)
,@(generate-stm-fields fields)
,@(generate-stm-methods methods))))
#f))
;generate-stm-fields: (listof field-record) -> (list of sexpr)
(define (generate-stm-fields fields)
(apply append
(map (lambda (field-rec)
(let* ([name (field-record-name field-rec)]
[s-name (string->symbol name)]
[get (create-get-name name)])
(list
`(define/public (,get obj)
(or (hash-ref field-map ',name #f)
(send o ,get o)))
`(define/public (,(create-set-name name) obj val)
(hash-set! field-map ',name val)
val))))
(filter (lambda (f) (private? (field-record-modifiers f))) fields))))
;generate-stm-methods: (listof method-record) -> (listof sexpr)
(define (generate-stm-methods methods)
(map (lambda (method-rec)
(let ([method-name (string->symbol (mangle-method-name (method-record-name method-rec)
(method-record-atypes method-rec)))]
[args (map (lambda (a) (gensym 'arg-)) (method-record-atypes method-rec))])
#;(printf "~a~n" method-rec)
`(define/public (,method-name ,@args)
(let-values ([(method obj) (find-method/who 'send o ',method-name)])
(method this ,@args)))))
(filter (lambda (method-rec)
(and (not (static? (method-record-modifiers method-rec)))
(not (method-record-override method-rec))))
methods)))
;generate-inner-makers: (list def) int type-records -> (list syntax)
(define (generate-inner-makers defs depth type-recs)
(apply append
@ -1244,9 +1228,9 @@
;Code to separate different member types for easier access
;(make-accesses (list member) (list member) (list member) ...)
(define-struct accesses (private protected static public package private-static))
(define-struct accesses (private protected static public package private-static) #:mutable)
;(make-members (list method) (list field) (list init) (list init) (list def) (list def))
(define-struct members (method field static-init init nested inner))
(define-struct members (method field static-init init nested inner) #:mutable)
;update: ('a 'b -> void) 'a ('b -> (list 'a)) 'b) -> 'b
;Allows a set! to be passed in and applied
@ -1491,7 +1475,7 @@
(filter (lambda (m)
(let ((mname (id-string (method-name m))))
(and (method-record-override (method-rec m))
(hash-table-put! (class-override-table)
(hash-set! (class-override-table)
(build-identifier
((if (constructor? mname) build-constructor-name mangle-method-name)
mname
@ -1684,6 +1668,7 @@
(lambda (obj)
(cond
((is-a? obj ,class) (normal-get obj))
((is-a? obj stm-wrapper) (send obj get-field))
(else
(send obj
,(build-identifier (format "~a-wrapped" getter))))))))
@ -1694,9 +1679,11 @@
`(define ,setter
(let ((normal-set (class-field-mutator ,class ,quote-name)))
(lambda (obj val)
(if (is-a? obj ,class)
(normal-set obj val)
(send obj ,(build-identifier (format "~a-wrapped" setter)) val)))))
(cond
[(is-a? obj ,class) (normal-set obj val)]
[(is-a? obj stm-wrapper) (send obj set-field! val)]
[else
(send obj ,(build-identifier (format "~a-wrapped" setter)) val)]))))
#f))
null))
(create-field-accessors (if final (cdr names) (cddr names)) (cdr fields))))))
@ -2151,22 +2138,22 @@
((string String)
(if from-dynamic?
`string?
`(c:is-a?/c ,(if (send (types) require-prefix? '("String" "java" "lang") (lambda () #f))
`(is-a?/c ,(if (send (types) require-prefix? '("String" "java" "lang") (lambda () #f))
'java.lang.String 'String))))
((dynamic void) 'c:any/c)))
((ref-type? type)
(if (equal? type string-type)
(type->contract 'string from-dynamic?)
`(c:or/c (c:is-a?/c object%) string?)))
`(c:or/c (is-a?/c object%) string?)))
((unknown-ref? type)
(if (not (null? stop?))
`(c:or/c (c:is-a?/c object%) string?)
`(c:or/c (is-a?/c object%) string?)
(cond
((method-contract? (unknown-ref-access type))
`(c:object-contract (,(string->symbol (java-name->scheme (method-contract-name (unknown-ref-access type))))
`(object-contract (,(string->symbol (java-name->scheme (method-contract-name (unknown-ref-access type))))
,(type->contract (unknown-ref-access type) from-dynamic?))))
((field-contract? (unknown-ref-access type))
`(c:object-contract (field ,(build-identifier (string-append (field-contract-name (unknown-ref-access type)) "~f"))
`(object-contract (field ,(build-identifier (string-append (field-contract-name (unknown-ref-access type)) "~f"))
,(type->contract (field-contract-type (unknown-ref-access type)) from-dynamic?)))))))
((method-contract? type)
`(c:-> ,@(map (lambda (a) (type->contract a from-dynamic?)) (method-contract-args type))
@ -2488,7 +2475,7 @@
(access (field-access-access name))
(obj (field-access-object name))
(cant-be-null? (never-null? obj))
(expr (if obj (translate-expression obj))))
(expr (and obj (translate-expression obj))))
(cond
((var-access-static? access)
(let ((static-name (build-static-name field-string (var-access-class access)))
@ -2737,7 +2724,7 @@
(else #f)))
(define (overridden? name)
(hash-table-get (class-override-table) name (lambda () #f)))
(hash-ref (class-override-table) name #f))
;translate-class-alloc: (U name id def) (list type) (list syntax) src bool bool method-record-> syntax
(define (translate-class-alloc class-type arg-types args src inner? local-inner? ctor-record)
@ -2982,7 +2969,7 @@
(field-src (id-src (field-access-field access)))
(vaccess (field-access-access access))
(obj (field-access-object access))
(expr (if obj (translate-expression obj))))
(expr (and obj (translate-expression obj))))
(cond
((var-access-static? vaccess)
(set-h (build-identifier (build-static-name (build-var-name field)

10
collects/profj/tool.ss
View File

@ -1,12 +1,12 @@
(module tool scheme/base
(require drscheme/tool mzlib/contract
(require drscheme/tool scheme/contract
mred framework
errortrace/errortrace-lib
(prefix-in u: mzlib/unit)
(prefix-in u: scheme/unit)
scheme/file
mrlib/include-bitmap
mzlib/etc
mzlib/class
scheme/class
string-constants
profj/libs/java/lang/Object profj/libs/java/lang/array
profj/libs/java/lang/String)
@ -14,7 +14,7 @@
(lib "test-engine.scm" "test-engine")
(lib "java-tests.scm" "test-engine")
(lib "test-coverage.scm" "test-engine")
(except-in "ast.ss" for) #;"tester.scm"
(except-in "ast.ss" for)
"display-java.ss")
(require (for-syntax scheme/base
@ -832,7 +832,7 @@
(dynamic-require 'profj/libs/java/lang/Object #f)
(let ([obj-path ((current-module-name-resolver) 'profj/libs/java/lang/Object #f #f)]
[string-path ((current-module-name-resolver) 'profj/libs/java/lang/String #f #f)]
[class-path ((current-module-name-resolver) 'mzlib/class #f #f)]
[class-path ((current-module-name-resolver) 'scheme/class #f #f)]
[mred-path ((current-module-name-resolver) 'mred #f #f)]
[n (current-namespace)]
[e (current-eventspace)])

145
collects/profj/types.ss
View File

@ -1,16 +1,17 @@
(module types mzscheme
(module types scheme/base
(require
(only srfi/1 lset-intersection)
(only-in srfi/1 lset-intersection)
mzlib/etc
mzlib/pretty
mzlib/list
mzlib/class
scheme/class
"ast.ss")
(provide (all-defined-except number-assign-conversions remove-dups meth-member?
contained-in? consolidate-lists subset? depth conversion-steps
generate-require-spec))
(provide (except-out (all-defined-out)
number-assign-conversions remove-dups meth-member?
contained-in? consolidate-lists subset? depth conversion-steps
generate-require-spec))
;; symbol-type = 'null | 'string | 'boolean | 'char | 'byte | 'short | 'int
;; | 'long | 'float | 'double | 'void | 'dynamic
@ -22,7 +23,7 @@
;; | dynamic-val
;; | unknown-ref
(define-struct ref-type (class/iface path) (make-inspector))
(define-struct ref-type (class/iface path) #:transparent)
(define-struct array-type (type dim))
(define object-type (make-ref-type "Object" `("java" "lang")))
@ -337,33 +338,33 @@
;; (list method-records) (list inner-record) (list (list strings)) (list (list strings)))
;; After full processing fields and methods should contain all inherited fields
;; and methods. Also parents and ifaces should contain all super-classes/ifaces
(define-struct class-record (name modifiers class? object? fields methods inners parents ifaces) (make-inspector))
(define-struct class-record (name modifiers class? object? fields methods inners parents ifaces) #:mutable #:transparent)
(define interactions-record (make-class-record (list "interactions") null #f #f null null null null null))
;; (make-field-record string (list symbol) bool (list string) type)
(define-struct field-record (name modifiers init? class type) (make-inspector))
(define-struct field-record (name modifiers init? class type) #:mutable #:transparent)
;; (make-method-record string (list symbol) type (list type) (list type) (U bool method-record) string)
(define-struct method-record (name modifiers rtype atypes throws override class) (make-inspector))
(define-struct method-record (name modifiers rtype atypes throws override class) #:mutable #:transparent)
;;(make-inner-record string string (list symbol) bool)
(define-struct inner-record (name full-name modifiers class?) (make-inspector))
(define-struct inner-record (name full-name modifiers class?) #:mutable #:transparent)
;;(make-scheme-record string (list string) path (list dynamic-val))
(define-struct scheme-record (name path dir provides))
(define-struct scheme-record (name path dir provides) #:mutable #:transparent)
;;(make-dynamic-val (U type method-contract unknown-ref))
(define-struct dynamic-val (type) (make-inspector))
(define-struct dynamic-val (type) #:mutable #:transparent)
;;(make-unknown-ref (U method-contract field-contract))
(define-struct unknown-ref (access) (make-inspector))
(define-struct unknown-ref (access) #:mutable #:transparent)
;;(make-method-contract string type (list type) (U #f string))
(define-struct method-contract (name return args prefix) (make-inspector))
(define-struct method-contract (name return args prefix) #:mutable #:transparent)
;;(make-field-contract string type)
(define-struct field-contract (name type))
(define-struct field-contract (name type) #:mutable #:transparent)
;
; ;;
@ -388,25 +389,25 @@
(error 'internal-error "type-records importer field was not set"))))
;Stores type information and require syntax per compile or execution
(define records (make-hash-table 'equal))
(define requires (make-hash-table 'equal))
(define package-contents (make-hash-table 'equal))
(define records (make-hash))
(define requires (make-hash))
(define package-contents (make-hash))
;Stores per-class information accessed by location
(define class-environment (make-hash-table))
(define class-require (make-hash-table))
(define class-environment (make-hasheq))
(define class-require (make-hasheq))
(define compilation-location (make-hash-table))
(define compilation-location (make-hasheq))
(define class-reqs null)
(define location #f)
;add-class-record: class-record -> void
(define/public (add-class-record r)
(hash-table-put! records (class-record-name r) r))
(hash-set! records (class-record-name r) r))
;add-to-records: (list string) ( -> 'a) -> void
(define/public (add-to-records key thunk)
(hash-table-put! records key thunk))
(hash-set! records key thunk))
;; get-class-record: (U type (list string) 'string) (U (list string) #f) ( -> 'a) ->
;; (U class-record scheme-record procedure)
@ -434,13 +435,13 @@
(not (null? outer-record))
(not (eq? outer-record 'in-progress))
(member key (map inner-record-name (class-record-inners (get-record outer-record this)))))
(hash-table-get records (cons key-inner (cdr container)) fail))
(hash-ref records (cons key-inner (cdr container)) fail))
((and container (not (null? outer-record)) (eq? outer-record 'in-progress))
(let ((res (hash-table-get records (cons key-inner inner-path) (lambda () #f))))
(let ((res (hash-ref records (cons key-inner inner-path) #f)))
(or res
(hash-table-get records (cons key path) new-search))))
(hash-ref records (cons key path) new-search))))
(else
(hash-table-get records (cons key path) new-search))))))
(hash-ref records (cons key path) new-search))))))
;normalize-key: (U 'strung ref-type (list string)) -> (values string (list string))
(define/private (normalize-key ctype)
@ -453,7 +454,7 @@
;search-for-record string string (list string) (-> #f) (-> 'a) -> class-record
(define/private (search-for-record class-name new-prefix path test-fail fail)
(let* ((new-class-name (string-append new-prefix "." class-name))
(rec? (hash-table-get records (cons new-class-name path) test-fail))
(rec? (hash-ref records (cons new-class-name path) test-fail))
(back-path (reverse path)))
(cond
(rec? rec?)
@ -462,10 +463,10 @@
;add-package-contents: (list string) (list string) -> void
(define/public (add-package-contents package classes)
(let ((existing-classes (hash-table-get package-contents package (lambda () null))))
(let ((existing-classes (hash-ref package-contents package null)))
(if (null? existing-classes)
(hash-table-put! package-contents package classes)
(hash-table-put! package-contents package (non-dup-append classes existing-classes)))))
(hash-set! package-contents package classes)
(hash-set! package-contents package (non-dup-append classes existing-classes)))))
(define/private (non-dup-append cl pa)
(cond
@ -475,23 +476,23 @@
;get-package-contents: (list string) ( -> 'a) -> (list string)
(define/public (get-package-contents package fail)
(hash-table-get package-contents package fail))
(hash-ref package-contents package fail))
;add-to-env: string (list string) file -> void
(define/public (add-to-env class path loc)
#;(printf "add-to-env class ~a path ~a loc ~a~n~n" class path loc)
(unless (hash-table-get (hash-table-get class-environment loc
(lambda ()
(let ([new-t (make-hash-table 'equal)])
(hash-table-put! class-environment loc new-t)
new-t)))
class (lambda () #f))
(hash-table-put! (hash-table-get class-environment loc) class path)))
(unless (hash-ref (hash-ref class-environment loc
(lambda ()
(let ([new-t (make-hash)])
(hash-set! class-environment loc new-t)
new-t)))
class #f)
(hash-set! (hash-ref class-environment loc) class path)))
;Returns the environment of classes for the current location
;get-class-env: -> (list string)
(define/public (get-class-env)
(hash-table-map (hash-table-get class-environment location) (lambda (key val) key)))
(hash-map (hash-ref class-environment location) (lambda (key val) key)))
(define (env-failure)
(error 'class-environment "Internal Error: environment does not have location"))
@ -500,35 +501,33 @@
(define/public (lookup-path class fail)
#;(printf "class ~a location ~a~n" class location)
#;(printf "lookup ~a~n" class)
#;(hash-table-for-each (hash-table-get class-environment location)
(lambda (k v) (printf "~a -> ~a~n" k v)))
#;(hash-for-each (hash-ref class-environment location)
(lambda (k v) (printf "~a -> ~a~n" k v)))
(if location
(hash-table-get (hash-table-get class-environment
location
env-failure)
class fail)
(hash-ref (hash-ref class-environment location env-failure)
class fail)
(fail)))
;add-require-syntax: (list string) (list syntax syntax) -> void
(define/public (add-require-syntax name syn)
(get-require-syntax #t name (lambda () (hash-table-put! requires (cons #t name) (car syn))))
(get-require-syntax #f name (lambda () (hash-table-put! requires (cons #f name) (cadr syn)))))
(get-require-syntax #t name (lambda () (hash-set! requires (cons #t name) (car syn))))
(get-require-syntax #f name (lambda () (hash-set! requires (cons #f name) (cadr syn)))))
(define (syntax-fail)
(error 'syntax "Internal Error: syntax did not have given req"))
;get-require-syntax: bool (list string) . ( -> 'a) -> syntax
(define/public (get-require-syntax prefix? name . fail)
(hash-table-get requires (cons prefix? name) (if (null? fail) syntax-fail (car fail))))
(hash-ref requires (cons prefix? name) (if (null? fail) syntax-fail (car fail))))
;add-class-req: name boolean location -> void
(define/public (add-class-req name pre loc)
(hash-table-put! (hash-table-get class-require
loc
(lambda () (let ((new-t (make-hash-table 'equal)))
(hash-table-put! class-require loc new-t)
new-t)))
name pre))
(hash-set! (hash-ref class-require
loc
(lambda () (let ((new-t (make-hash)))
(hash-set! class-require loc new-t)
new-t)))
name pre))
;require-fail
(define (require-fail)
@ -536,7 +535,7 @@
;require-prefix?: (list string) ( -> 'a) -> bool
(define/public (require-prefix? name fail)
(hash-table-get (hash-table-get class-require location require-fail) name fail))
(hash-ref (hash-ref class-require location require-fail) name fail))
(define/private (member-req req reqs)
(and (not (null? reqs))
@ -544,17 +543,17 @@
(equal? (req-path req) (req-path (car reqs))))
(member-req req (cdr reqs)))))
(define/public (set-compilation-location loc dir) (hash-table-put! compilation-location loc dir))
(define/public (set-compilation-location loc dir) (hash-set! compilation-location loc dir))
(define/public (get-compilation-location)
(hash-table-get compilation-location location
(lambda () (error 'get-compilation-location "Internal error: location not found"))))
(define/public (set-composite-location name dir) (hash-table-put! compilation-location name dir))
(hash-ref compilation-location location
(lambda () (error 'get-compilation-location "Internal error: location not found"))))
(define/public (set-composite-location name dir) (hash-set! compilation-location name dir))
(define/public (get-composite-location name)
;(printf "get-composite-location for ~a~n" name)
;(hash-table-for-each compilation-location
;(hash-for-each compilation-location
; (lambda (k v) (printf "~a -> ~a~n" k v)))
(hash-table-get compilation-location name
(lambda () (error 'get-composite-location "Internal error: name not found"))))
(hash-ref compilation-location name
(lambda () (error 'get-composite-location "Internal error: name not found"))))
(define/public (add-req req)
(unless (member-req req class-reqs)
@ -585,8 +584,8 @@
(define/public (give-interaction-execution-names)
(when execution-loc
(hash-table-for-each (hash-table-get class-environment execution-loc)
(lambda (k v) (add-to-env k v 'interactions)))
(hash-for-each (hash-ref class-environment execution-loc)
(lambda (k v) (add-to-env k v 'interactions)))
(set! execution-loc #f)))
(define test-classes null)
@ -794,14 +793,14 @@
(define (module-has-binding? mod-ref variable fail)
(let ((var (string->symbol (java-name->scheme variable))))
(or (memq var (scheme-record-provides mod-ref))
(let ((mod-syntax (datum->syntax-object #f
`(,#'module m mzscheme
(require ,(generate-require-spec (java-name->scheme (scheme-record-name mod-ref))
(scheme-record-path mod-ref)))
,var)
#f)))
(let ((mod-syntax (datum->syntax #f
`(,#'module m mzscheme
(require ,(generate-require-spec (java-name->scheme (scheme-record-name mod-ref))
(scheme-record-path mod-ref)))
,var)
#f)))
(with-handlers ((exn? (lambda (e) (fail))))
(parameterize ([current-namespace (make-namespace)])
(parameterize ([current-namespace (make-base-namespace)])
(expand mod-syntax)))
(set-scheme-record-provides! mod-ref (cons var (scheme-record-provides mod-ref)))))))

2
collects/tests/profj/all-tests.ss
View File

@ -1,7 +1,7 @@
(module all-tests mzscheme
(require "full-tests.ss")
(require "advanced-tests.ss")
(require "intermediate-access-tests.scm")
#;(require "intermediate-access-tests.scm")
(require "intermediate-tests.ss")
(require "beginner-tests.ss")
)

64
collects/profj/profj-testing.ss → collects/tests/profj/profj-testing.ss
View File

@ -1,4 +1,4 @@
(module profj-testing mzscheme
(module profj-testing scheme
(require (lib "compile.ss" "profj")
(lib "parameters.ss" "profj")
@ -80,7 +80,7 @@
(get-position v1 (cdr visited) (add1 pos))))
;interact-internal: symbol (list string) (list evalable-value) string type-record -> void
(define (interact-internal level interacts vals msg type-recs)
(define (interact-internal level interacts vals msg type-recs namespace)
(for-each (lambda (ent val)
(let ((st (open-input-string ent)))
(with-handlers
@ -94,18 +94,18 @@
(interaction-msgs (cons
(format "Test ~a: Exception raised for ~a : ~a"
msg ent (exn-message exn)) (interaction-msgs))))))])
(let ((new-val (eval `(begin
(require mzlib/class
(prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java"))
(prefix c: mzlib/contract))
,(compile-interactions st st type-recs level)))))
(when (eq? val 'error)
(missed-expected-errors (add1 (missed-expected-errors)))
(expected-failed-tests (cons msg (expected-failed-tests))))
(unless (and (not (eq? val 'error)) (java-equal? (eval val) new-val null null))
(interaction-errors (add1 (interaction-errors)))
(interaction-msgs (cons (format "Test ~a: ~a evaluated to ~a instead of ~a"
msg ent new-val val) (interaction-msgs))))))))
(parameterize ([current-namespace namespace][coverage? #f])
(let ((new-val (eval `(begin (require mzlib/class
(prefix-in javaRuntime: (lib "runtime.ss" "profj" "libs" "java"))
(prefix-in c: scheme/contract))
,(compile-interactions st st type-recs level)))))
(when (eq? val 'error)
(missed-expected-errors (add1 (missed-expected-errors)))
(expected-failed-tests (cons msg (expected-failed-tests))))
(unless (and (not (eq? val 'error)) (java-equal? (eval val) new-val null null))
(interaction-errors (add1 (interaction-errors)))
(interaction-msgs (cons (format "Test ~a: ~a evaluated to ~a instead of ~a"
msg ent new-val val) (interaction-msgs)))))))))
interacts vals))
;interact-test: symbol (list string) (list evalable-value) string |
@ -113,10 +113,11 @@
(define interact-test
(case-lambda
[(level in val msg)
(interact-internal level in val msg (create-type-record))]
(interact-internal level in val msg (create-type-record) (make-base-namespace))]
((defn level in val msg)
(let* ((type-recs (create-type-record))
(def-st (open-input-string defn)))
(def-st (open-input-string defn))
(cur-namespace (make-base-namespace)))
(with-handlers
([exn?
(lambda (exn)
@ -125,13 +126,14 @@
msg (exn-message exn))
(interaction-msgs))))])
(execution? #t)
(eval-modules (compile-java 'port 'port level #f def-st def-st type-recs))
(interact-internal level in val msg type-recs))))))
(eval-modules (compile-java 'port 'port level #f def-st def-st type-recs) cur-namespace)
(interact-internal level in val msg type-recs cur-namespace))))))
;interact-test-java-expected: string symbol (list string) (list string) string -> void
(define (interact-test-java-expected defn level in val msg)
(let* ((type-recs (create-type-record))
(def-st (open-input-string defn)))
(def-st (open-input-string defn))
(cur-namespace (make-base-namespace)))
(with-handlers
([exn?
(lambda (exn)
@ -140,14 +142,15 @@
msg (exn-message exn))
(interaction-msgs))))])
(execution? #t)
(eval-modules (compile-java 'port 'port level #f def-st def-st type-recs))
(eval-modules (compile-java 'port 'port level #f def-st def-st type-recs) cur-namespace)
(let ((vals (map (lambda (ex-val)
(let ((st (open-input-string ex-val)))
(eval `(begin (require mzlib/class
(prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java")))
,(compile-interactions st st type-recs level)))))
(parameterize ((current-namespace cur-namespace))
(eval `(begin (require mzlib/class
(prefix-in javaRuntime: (lib "runtime.ss" "profj" "libs" "java")))
,(compile-interactions st st type-recs level))))))
val)))
(interact-internal level in vals msg type-recs)))))
(interact-internal level in vals msg type-recs cur-namespace)))))
(define (execute-test defn level error? msg)
(let ((st (open-input-string defn)))
@ -161,7 +164,7 @@
(execution-errors (add1 (execution-errors)))
(execution-msgs (cons
(format "Test ~a : Exception-raised: ~a" msg (exn-message exn)) (execution-msgs))))))])
(eval-modules (compile-java 'port 'port level #f st st))
(eval-modules (compile-java 'port 'port level #f st st) (make-base-namespace))
(when error?
(missed-expected-errors (add1 (missed-expected-errors)))
(expected-failed-tests (cons msg (expected-failed-tests))))
@ -179,7 +182,7 @@
(list 'interact #f (exn-message exn)))])
(let* ((get-val (lambda (v-st v-pe)
(eval `(begin (require mzlib/class)
(require (prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java")))
(require (prefix-in javaRuntime: (lib "runtime.ss" "profj" "libs" "java")))
,(compile-interactions v-st v-st type-recs level)))))
(i-st (open-input-string interact))
(v-st (open-input-string val))
@ -210,10 +213,11 @@
(format "Test ~a :Exception-raised: ~a" msg (exn-message exn)) (file-msgs)))))])
(eval-modules (compile-java 'file 'port level file #f #f))))
(define (eval-modules modules)
(for-each eval
(apply append
(map compilation-unit-code modules))))
(define (eval-modules modules namespace)
(parameterize ([current-namespace namespace])
(for-each eval
(apply append
(map compilation-unit-code modules)))))
;prepare-for-tests: String -> void
(define (prepare-for-tests lang-level)