From 7f085f7e2be423e5b2270d1c17cee45b884b7720 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Thu, 12 Jun 2008 14:46:43 +0000 Subject: [PATCH] Switching to scheme/base instead of mzscheme Addition of support for stm (to-scheme.ss only) svn: r10232 --- collects/profj/ast.ss | 10 +- collects/profj/build-info.ss | 14 +- collects/profj/check.ss | 14 +- collects/profj/compile.ss | 25 +- collects/profj/display-java.ss | 4 +- collects/profj/error-messaging.ss | 7 +- collects/profj/graph-scc.ss | 57 +++-- .../profj/libs/java/lang/Object-composite.ss | 20 +- collects/profj/libs/java/lang/Object.ss | 2 +- collects/profj/name-utils.scm | 4 +- collects/profj/parameters.ss | 6 +- collects/profj/parser.ss | 6 +- collects/profj/profj-pref.ss | 5 +- collects/profj/restrictions.ss | 3 +- collects/profj/to-scheme.ss | 231 +++++++++--------- collects/profj/tool.ss | 10 +- collects/profj/types.ss | 145 ++++++----- collects/tests/profj/all-tests.ss | 2 +- collects/{ => tests}/profj/profj-testing.ss | 64 ++--- 19 files changed, 300 insertions(+), 329 deletions(-) rename collects/{ => tests}/profj/profj-testing.ss (81%) diff --git a/collects/profj/ast.ss b/collects/profj/ast.ss index 3763893c4f..6778a7c89a 100644 --- a/collects/profj/ast.ss +++ b/collects/profj/ast.ss @@ -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) diff --git a/collects/profj/build-info.ss b/collects/profj/build-info.ss index 6fc2e66261..199a40115d 100644 --- a/collects/profj/build-info.ss +++ b/collects/profj/build-info.ss @@ -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?) diff --git a/collects/profj/check.ss b/collects/profj/check.ss index ca7799feaa..f95e402343 100644 --- a/collects/profj/check.ss +++ b/collects/profj/check.ss @@ -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) diff --git a/collects/profj/compile.ss b/collects/profj/compile.ss index 0843ed7bae..c20061a7d8 100644 --- a/collects/profj/compile.ss +++ b/collects/profj/compile.ss @@ -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% () diff --git a/collects/profj/display-java.ss b/collects/profj/display-java.ss index ff62be53da..082390ac0f 100644 --- a/collects/profj/display-java.ss +++ b/collects/profj/display-java.ss @@ -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 diff --git a/collects/profj/error-messaging.ss b/collects/profj/error-messaging.ss index 278554801a..dd6922d6e8 100644 --- a/collects/profj/error-messaging.ss +++ b/collects/profj/error-messaging.ss @@ -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) diff --git a/collects/profj/graph-scc.ss b/collects/profj/graph-scc.ss index 3e7f1cd290..dda3b5b714 100644 --- a/collects/profj/graph-scc.ss +++ b/collects/profj/graph-scc.ss @@ -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) diff --git a/collects/profj/libs/java/lang/Object-composite.ss b/collects/profj/libs/java/lang/Object-composite.ss index 413995b2a1..2bdfe23c9f 100644 --- a/collects/profj/libs/java/lang/Object-composite.ss +++ b/collects/profj/libs/java/lang/Object-composite.ss @@ -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) ) diff --git a/collects/profj/libs/java/lang/Object.ss b/collects/profj/libs/java/lang/Object.ss index bfab608277..316a044630 100644 --- a/collects/profj/libs/java/lang/Object.ss +++ b/collects/profj/libs/java/lang/Object.ss @@ -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)) diff --git a/collects/profj/name-utils.scm b/collects/profj/name-utils.scm index de56686538..949a858d6f 100644 --- a/collects/profj/name-utils.scm +++ b/collects/profj/name-utils.scm @@ -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) diff --git a/collects/profj/parameters.ss b/collects/profj/parameters.ss index 4904d35be3..f7e718bfad 100644 --- a/collects/profj/parameters.ss +++ b/collects/profj/parameters.ss @@ -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)) diff --git a/collects/profj/parser.ss b/collects/profj/parser.ss index ec8c7187e8..b64d720c9e 100644 --- a/collects/profj/parser.ss +++ b/collects/profj/parser.ss @@ -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) diff --git a/collects/profj/profj-pref.ss b/collects/profj/profj-pref.ss index 4d0aeffbb6..a143469b9d 100644 --- a/collects/profj/profj-pref.ss +++ b/collects/profj/profj-pref.ss @@ -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) diff --git a/collects/profj/restrictions.ss b/collects/profj/restrictions.ss index f6cb7fc3d6..740e34a9d1 100644 --- a/collects/profj/restrictions.ss +++ b/collects/profj/restrictions.ss @@ -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?) diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index 788bdc8949..0cef166e4b 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -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) diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index 1d73b19516..b11e53f5fc 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -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)]) diff --git a/collects/profj/types.ss b/collects/profj/types.ss index 5c145a5b0c..175d9d3fb1 100644 --- a/collects/profj/types.ss +++ b/collects/profj/types.ss @@ -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))))))) diff --git a/collects/tests/profj/all-tests.ss b/collects/tests/profj/all-tests.ss index 642d8e69b4..02a5be3c4b 100644 --- a/collects/tests/profj/all-tests.ss +++ b/collects/tests/profj/all-tests.ss @@ -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") ) diff --git a/collects/profj/profj-testing.ss b/collects/tests/profj/profj-testing.ss similarity index 81% rename from collects/profj/profj-testing.ss rename to collects/tests/profj/profj-testing.ss index dbf91de460..e788956b71 100644 --- a/collects/profj/profj-testing.ss +++ b/collects/tests/profj/profj-testing.ss @@ -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)