From 57e8d8dab4b519535e4dc5b6c39efeeb4b22feee Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Mon, 4 Jul 2005 21:32:23 +0000 Subject: [PATCH] Fixing dynamic bug, and adding Util.error svn: r334 --- collects/profj/build-info.ss | 45 ++++++++++++++++++++++ collects/profj/compile.ss | 4 ++ collects/profj/libs/java/lang/Util.djava | 11 ++++++ collects/profj/libs/java/lang/installer.ss | 1 + collects/profj/to-scheme.ss | 35 ++++++++++------- 5 files changed, 83 insertions(+), 13 deletions(-) create mode 100644 collects/profj/libs/java/lang/Util.djava diff --git a/collects/profj/build-info.ss b/collects/profj/build-info.ss index 9d37d1522b..95122e52e8 100644 --- a/collects/profj/build-info.ss +++ b/collects/profj/build-info.ss @@ -484,6 +484,10 @@ (make-req (car name-list) (cdr name-list)))) (cons super-name (map name->list (header-implements info)))))) + (set! reqs + (remove-dup-reqs + (append (get-method-reqs (class-record-methods super-record)) + reqs))) (send type-recs set-location! (def-file class)) (set-def-uses! class reqs) @@ -632,6 +636,47 @@ (car methods)) (find-default-ctor (cdr methods))))) + ;remove-dup-reqs (list req) -> (list req) + (define (remove-dup-reqs reqs) + (cond + ((null? reqs) null) + ((member (car reqs) (cdr reqs)) + (remove-dup-reqs (cdr reqs))) + (else + (cons (car reqs) (remove-dup-reqs (cdr reqs)))))) + + ;get-method-reqs: (list method-record) -> (list req) + (define (get-method-reqs methods) + (cond + ((null? methods) methods) + ((or (memq (method-record-rtype (car methods)) '(void ctor short byte int long float double + boolean dynamic char)) + (array-type? (method-record-rtype (car methods)))) + (append (get-reqs-parms (method-record-atypes (car methods))) + (get-method-reqs (cdr methods)))) + ((null? (method-record-atypes (car methods))) + (cons (type->req (method-record-rtype (car methods))) + (get-method-reqs (cdr methods)))) + (else + (cons (type->req (method-record-rtype (car methods))) + (append (get-reqs-parms (method-record-atypes (car methods))) + (get-method-reqs (cdr methods))))))) + + (define (get-reqs-parms parms) + (cond + ((null? parms) null) + ((memq (car parms) '(short byte int char long float double boolean dynamic)) + (get-reqs-parms (cdr parms))) + ((array-type? (car parms)) (get-reqs-parms (cdr parms))) + (else (cons (type->req (car parms)) (get-reqs-parms (cdr parms)))))) + (define (type->req t) + (cond + ((or (eq? 'string t) (equal? string-type t)) + (make-req "String" '("java" "lang"))) + ((ref-type? t) + (make-req (ref-type-class/iface t) (ref-type-path t))) + #;(else (make-req 'array '())))) + ;; process-interface: interface-def (list string) type-records bool bool symbol -> class-record (define (process-interface iface package-name type-recs look-in-table? put-in-table? level) (let* ((info (def-header iface)) diff --git a/collects/profj/compile.ss b/collects/profj/compile.ss index e57c20c509..13337190ca 100644 --- a/collects/profj/compile.ss +++ b/collects/profj/compile.ss @@ -27,6 +27,10 @@ (when (and (eq? src 'file) (not (file-exists? name))) (error 'compile-java "compile-java given file that does not exist: ~a" name)) + (when (and (eq? src 'file) + (path? name) + (regexp-match #".djava$" (path->bytes name))) + (dynamic? #t)) (when (null? (classpath)) (get-classpath)) (let ((type-recs (if (null? type-recs) (make-object type-records) diff --git a/collects/profj/libs/java/lang/Util.djava b/collects/profj/libs/java/lang/Util.djava new file mode 100644 index 0000000000..c3b35b41b7 --- /dev/null +++ b/collects/profj/libs/java/lang/Util.djava @@ -0,0 +1,11 @@ +package java.lang; + +class Util { + + private Util() { } + + public static dynamic error( String msg ) { + throw new RuntimeException( msg ); + } + +} \ No newline at end of file diff --git a/collects/profj/libs/java/lang/installer.ss b/collects/profj/libs/java/lang/installer.ss index b4fbf5491c..e93e91d125 100644 --- a/collects/profj/libs/java/lang/installer.ss +++ b/collects/profj/libs/java/lang/installer.ss @@ -15,6 +15,7 @@ (build-path java.lang file) #f #f)))]) + (javac "Util.djava") (javac "Math.java") (javac "System.java") (javac "Number.java") diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index 62440110da..61e2980cbd 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -536,20 +536,29 @@ (lambda () #f))) (translate-interact-require (cdr reqs) type-recs))))) - ;translate-require: (list req) type-records -> (list syntax) + ;translate-require: (list (list location req)) type-records -> (list syntax) (define (translate-require reqs type-recs) - (if (null? reqs) - null - (let* ((req (cadr (car reqs))) - (err (lambda () (error 'translate-require (format "Internal Error: ~a not found" req))))) - (cons (begin (send type-recs set-location! (car (car reqs))) - (send type-recs get-require-syntax - (send type-recs require-prefix? - (cons (req-class req) (req-path req)) - err) - (cons (req-class req) (req-path req)) - err)) - (translate-require (cdr reqs) type-recs))))) + (cond + ((null? reqs) null) + ((member (cadr (car reqs)) + (list (make-req "Class" '("java" "lang")) + (make-req "PrintString" '("java" "io")) + (make-req "PrintWriter" '("java" "io")))) + (translate-require (cdr reqs) type-recs)) + (else + (let* ((req (cadr (car reqs))) + (err (lambda () + (error 'translate-require + (format "Internal Error: (make-req ~a ~a) not found" + (req-class req) (req-path req)))))) + (cons (begin (send type-recs set-location! (car (car reqs))) + (send type-recs get-require-syntax + (send type-recs require-prefix? + (cons (req-class req) (req-path req)) + err) + (cons (req-class req) (req-path req)) + err)) + (translate-require (cdr reqs) type-recs)))))) ;translate-implements: (list name) -> (list syntax) (define (translate-implements imp)