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

Fixing dynamic bug, and adding Util.error

Browse Source 
svn: r334
This commit is contained in:
Kathy Gray 2005-07-04 21:32:23 +00:00
parent bbded8247a
commit 57e8d8dab4
5 changed files with 83 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

4
collects/profj/compile.ss
View File

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

11
collects/profj/libs/java/lang/Util.djava Normal file
View File

@ -0,0 +1,11 @@
package java.lang;
class Util {
private Util() { }
public static dynamic error( String msg ) {
throw new RuntimeException( msg );
}
}

1
collects/profj/libs/java/lang/installer.ss
View File

@ -15,6 +15,7 @@
(build-path java.lang file)
#f
#f)))])
(javac "Util.djava")
(javac "Math.java")
(javac "System.java")
(javac "Number.java")

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

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