Fixing dynamic bug, and adding Util.error

svn: r334

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))

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)

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 );
+  }
+
+}

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")

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)
+    (cond
-        null
+      ((null? reqs) null)
-        (let* ((req (cadr (car reqs)))
+      ((member (cadr (car reqs))
-               (err (lambda () (error 'translate-require (format "Internal Error: ~a not found" req)))))
+               (list (make-req "Class" '("java" "lang"))
-          (cons (begin (send type-recs set-location! (car (car reqs)))
+                     (make-req "PrintString" '("java" "io"))
-                       (send type-recs get-require-syntax 
+                     (make-req "PrintWriter" '("java" "io"))))
-                             (send type-recs require-prefix? 
+       (translate-require (cdr reqs) type-recs))
-                                   (cons (req-class req) (req-path req)) 
+      (else
-                                   err)
+       (let* ((req (cadr (car reqs)))
-                             (cons (req-class req) (req-path req))
+              (err (lambda () 
-                             err))
+                     (error 'translate-require 
-                (translate-require (cdr reqs) type-recs)))))
+                            (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)