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

Adding dynamic type and interoperability support to ProfJ; also brings profj up to date after the switch from cvs to svn

Browse Source 
svn: r50
This commit is contained in:
Kathy Gray 2005-06-02 04:36:59 +00:00
parent cb12af77ed
commit 095c8dbb87
45 changed files with 1617 additions and 547 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/profj/ast.ss
View File

@ -71,15 +71,17 @@
(p-define-struct type-var (name bound src))
;;Code for accessing fields: var-decl and var-init
(provide field? field-name field-modifiers field-type field-src)
(provide field? field-name field-modifiers field-type-spec field-type set-field-type! field-src)
(define (field? v) (or (var-decl? v) (var-init? v)))
(define (field-name v) (var-decl-name (if (var-init? v) (var-init-var-decl v) v)))
(define (field-modifiers v) (var-decl-modifiers (if (var-init? v) (var-init-var-decl v) v)))
(define (field-type-spec v) (var-decl-type-spec (if (var-init? v) (var-init-var-decl v) v)))
(define (field-type v) (var-decl-type (if (var-init? v) (var-init-var-decl v) v)))
(define (set-field-type! v t) (set-var-decl-type! (if (var-init? v) (var-init-var-decl v) v) t))
(define (field-src v) (var-decl-src (if (var-init? v) (var-init-var-decl v) v)))
;;(make-var-decl id (list modifier) type-spec src)
(p-define-struct var-decl (name modifiers type src))
;;(make-var-decl id (list modifier) type-spec (U #f type) src)
(p-define-struct var-decl (name modifiers type-spec type src))
;;(make-var-init var-decl (U array-init expression) src)
(p-define-struct var-init (var-decl init src))

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

@ -42,9 +42,10 @@
((and local? (not (to-file))) name)
(else `(file ,(path->string (build-path dir name)))))))
(make-name (lambda ()
(let ((n (if scheme? (java-name->scheme name) name)))
(if (or (not local?) profj-lib? htdch-lib? (to-file))
(string-append name ".ss")
(string->symbol name)))))
(string-append n ".ss")
(string->symbol n))))))
(if scheme?
(list (syn `(prefix ,(string->symbol
(apply string-append
@ -232,7 +233,7 @@
loc type-recs level caller-src add-to-env))
(append (class-record-parents record) (class-record-ifaces record)))
))
((and (scheme-ok?) (dir-path-scheme? in-dir) (check-scheme-file-exists? class dir))
((and (dynamic?) (dir-path-scheme? in-dir) (check-scheme-file-exists? class dir))
(send type-recs add-to-records class-name (make-scheme-record class (cdr path) dir null))
(send type-recs add-require-syntax class-name (build-require-syntax class path dir #f #t)))
(class-exists?
@ -281,8 +282,8 @@
;check-scheme-file-exists? string path -> bool
(define (check-scheme-file-exists? name path)
(or (file-exists? (build-path path (string-append name ".ss")))
(file-exists? (build-path path (string-append name ".scm")))))
(or (file-exists? (build-path path (string-append (java-name->scheme name) ".ss")))
(file-exists? (build-path path (string-append (java-name->scheme name) ".scm")))))
(define (create-scheme-type-rec mod-name req-path) 'scheme-types)
@ -326,7 +327,7 @@
(define (find-directory path fail)
(cond
((null? path) (make-dir-path (build-path 'same) #f))
((and (scheme-ok?) (equal? (car path) "scheme"))
((and (dynamic?) (equal? (car path) "scheme"))
(cond
((null? (cdr path)) (make-dir-path (build-path 'same) #t))
((not (equal? (cadr path) "lib"))
@ -359,7 +360,7 @@
;get-class-list: dir-path -> (list string)
(define (get-class-list dir)
(if (and (scheme-ok?) (dir-path-scheme? dir))
(if (and (dynamic?) (dir-path-scheme? dir))
(filter (lambda (f) (or (equal? (filename-extension f) #".ss")
(equal? (filename-extension f) #".scm")))
(directory-list (dir-path-path dir)))
@ -763,9 +764,9 @@
(length (method-parms (car members))))
(andmap type=?
(method-record-atypes member-record)
(map (lambda (t)
(type-spec-to-type t (method-record-class member-record) level type-recs))
(map field-type (method-parms (car members)))))
;(map (lambda (t)
;(type-spec-to-type t (method-record-class member-record) level type-recs))
(map field-type-spec (method-parms (car members))));)
(type=? (method-record-rtype member-record)
(type-spec-to-type (method-type (car members)) (method-record-class member-record) level type-recs)))
(car members)
@ -794,8 +795,8 @@
#f)
(method-error 'repeated
(method-name m)
(map (lambda (t)
(type-spec-to-type (field-type t) class level type-recs))
(map field-type #;(lambda (t)
(type-spec-to-type (field-type-spec t) class level type-recs))
(method-parms m))
(car class)
(method-src m)
@ -814,7 +815,7 @@
#f)
(method-error 'ctor-ret-value
(method-name m)
(map (lambda (t) (type-spec-to-type (field-type t) class level type-recs))
(map field-type #;(lambda (t) (type-spec-to-type (field-type-spec t) class level type-recs))
(method-parms m))
(car class)
(method-src m)
@ -833,7 +834,7 @@
#f)
(method-error 'class-name
(method-name m)
(map (lambda (t) (type-spec-to-type (field-type t) class level type-recs))
(map field-type #;(lambda (t) (type-spec-to-type (field-type-spec t) class level type-recs))
(method-parms m))
(car class)
(method-src m)
@ -908,8 +909,8 @@
#f)
(method-error 'conflict
(method-name method)
(map (lambda (t)
(type-spec-to-type (field-type t) class level type-recs))
(map field-type #;(lambda (t)
(type-spec-to-type (field-type-spec t) class level type-recs))
(method-parms method))
(car class)
(method-src method)
@ -953,8 +954,8 @@
(class (method-record-class (car methods))))
(method-error 'illegal-abstract
(method-name method)
(map (lambda (t)
(type-spec-to-type (field-type t) class level type-recs))
(map field-type #;(lambda (t)
(type-spec-to-type (field-type-spec t) class level type-recs))
(method-parms method))
(car class)
(method-src method)
@ -999,17 +1000,19 @@
;; process-field: field (string list) type-records symbol -> field-record
(define (process-field field cname type-recs level)
(set-field-type! field (type-spec-to-type (field-type-spec field) cname level type-recs))
(make-field-record (id-string (field-name field))
(check-field-modifiers level (field-modifiers field))
(var-init? field)
cname
(type-spec-to-type (field-type field) cname level type-recs)))
(field-type field)))
;; process-method: method (list method-record) (list string) type-records symbol -> method-record
(define (process-method method inherited-methods cname type-recs level . args)
(let* ((name (id-string (method-name method)))
(parms (map (lambda (p)
(type-spec-to-type (field-type p) cname level type-recs))
(set-field-type! p (type-spec-to-type (field-type-spec p) cname level type-recs))
(field-type p))
(method-parms method)))
(mods (if (null? args) (method-modifiers method) (cons (car args) (method-modifiers method))))
(ret (type-spec-to-type (method-type method) cname level type-recs))

287
collects/profj/check.ss
View File

@ -269,12 +269,14 @@
(check-interactions-types p level loc type-recs)) prog))
((var-init? prog)
(let* ((name (id-string (field-name prog)))
(check-env (remove-var-from-env name env)))
(check-env (remove-var-from-env name env))
(type (type-spec-to-type (field-type-spec prog) #f level type-recs)))
(set-field-type! prog type)
(check-var-init (var-init-init prog)
(lambda (e env)
(check-expr e env level type-recs c-class #f #t #t #f))
check-env
(type-spec-to-type (field-type prog) #f level type-recs)
type
(string->symbol name)
type-recs)))
((var-decl? prog) (void))
@ -293,6 +295,10 @@
(update-class-with-inner (lambda (inner)
(set-def-members! class (cons inner (def-members class)))))
(send type-recs set-class-reqs (def-uses class))
(send type-recs add-req (make-req "String" '("java" "lang")))
(send type-recs add-req (make-req "Object" '("java" "lang")))
(let ((this-ref (make-ref-type name package-name)))
(check-members (def-members class)
(add-var-to-env "this" this-ref parm class-env)
@ -316,6 +322,10 @@
(update-class-with-inner (lambda (inner)
(set-def-members! iface (cons inner (def-members iface)))))
(send type-recs set-class-reqs (def-uses iface))
(send type-recs add-req (make-req "String" '("java" "lang")))
(send type-recs add-req (make-req "Object" '("java" "lang")))
(check-members (def-members iface) empty-env level type-recs
(cons (id-string (def-name iface)) p-name) #t #f (def-kind iface) #f)
(set-def-uses! iface (send type-recs get-class-reqs))
@ -398,7 +408,9 @@
((field? member)
(let ((static? (memq 'static (map modifier-kind (field-modifiers member))))
(name (id-string (field-name member)))
(type (type-spec-to-type (field-type member) c-class level type-recs)))
(type (field-type member)))
(when (ref-type? type)
(add-required c-class (ref-type-class/iface type) (ref-type-path type) type-recs))
(if (var-init? member)
(check-var-init (var-init-init member)
(lambda (e env)
@ -690,12 +702,19 @@
(return (if ctor?
'void
(type-spec-to-type (method-type method) c-class level type-recs))))
(when (ref-type? return)
(add-required c-class (ref-type-class/iface return) (ref-type-path return) type-recs))
(when (eq? 'string return)
(add-required c-class "String" '("java" "lang") type-recs))
(when iface? (set! mods (cons 'abstract mods)))
(when (memq 'native mods)
(send type-recs add-req (make-req (string-append (car c-class) "-native-methods") (cdr c-class))))
(if (or (memq 'abstract mods) (memq 'native mods))
(when body
(begin (when body
(method-error (if (memq 'abstract mods) 'abstract 'native) sym-name (id-src name)))
;build the method env anyway, as that's where parametr checking happens
(build-method-env (method-parms method) env level c-class type-recs)
(void))
(begin
(when (not body) (method-error 'no-body sym-name (id-src name)))
(when (and (not (eq? return 'void))
@ -709,14 +728,8 @@
(name->type n c-class (name-src n) level type-recs))
(method-throws method))
(build-method-env (method-parms method) env level c-class type-recs))
level
type-recs
c-class
ctor?
static?
#f
#f
#f)
level type-recs c-class
ctor? static? #f #f #f)
))))
;build-method-env: (list field) env symbol (list string) type-records-> env
@ -724,9 +737,14 @@
(cond
((null? parms) env)
(else
(when (ref-type? (field-type (car parms)))
(add-required c-class (ref-type-class/iface (field-type (car parms)))
(ref-type-path (field-type (car parms))) type-recs))
(when (eq? 'string (field-type (car parms)))
(add-required c-class "String" '("java" "lang") type-recs))
(build-method-env (cdr parms)
(add-var-to-env (id-string (field-name (car parms)))
(type-spec-to-type (field-type (car parms)) c-class level type-recs)
(field-type (car parms))
(if (memq 'final (field-modifiers (car parms)))
final-parm
parm)
@ -994,8 +1012,8 @@
(unless (eq? 'boolean t)
(kind-condition-error kind t cond-src)))))
(cond
((and (scheme-val? cond?) (scheme-val-type cond?)) => check)
((scheme-val? cond?) (set-scheme-val-type! cond? 'boolean))
((and (dynamic-val? cond?) (dynamic-val-type cond?)) => check)
((dynamic-val? cond?) (set-dynamic-val-type! cond? 'boolean))
(else (check cond?))))))
;check-ifS: type/env src (stmt env -> type/env) stmt (U stmt #f) -> type/env
@ -1013,10 +1031,11 @@
(define (check-throw exp/env src env interact? type-recs)
(let ((exp-type (type/env-t exp/env)))
(cond
((and (scheme-val? exp-type) (scheme-val-type exp-type))
((and (dynamic-val? exp-type) (dynamic-val-type exp-type))
=>
(lambda (t) (check-throw t src env interact? type-recs)))
((scheme-val? exp-type) (set-scheme-val-type! throw-type))
((dynamic-val? exp-type)
(set-dynamic-val-type! exp-type throw-type))
((or (not (ref-type? exp-type))
(not (is-eq-subclass? exp-type throw-type type-recs)))
(throw-error 'not-throwable exp-type src))
@ -1082,8 +1101,13 @@
(name (id-string (field-name local)))
(in-env? (lookup-var-in-env name env))
(sym-name (string->symbol name))
(type (type-spec-to-type (field-type local) c-class level type-recs))
(type (type-spec-to-type (field-type-spec local) c-class level type-recs))
(new-env (lambda (extend-env) (add-var-to-env name type method-var extend-env))))
(set-field-type! local type)
(when (ref-type? type)
(add-required c-class (ref-type-class/iface type) (ref-type-path type) type-recs))
(when (eq? 'string type)
(add-required c-class "String" '("java" "lang")))
(when (and in-env? (not (properties-field? (var-type-properties in-env?))))
(illegal-redefinition (field-name local) (field-src local)))
(if is-var-init?
@ -1100,7 +1124,7 @@
(if (null? catches)
new-env
(let* ((catch (car catches))
(type (field-type (catch-cond catch))))
(type (field-type-spec (catch-cond catch))))
(unless (and (ref-type? type)
(is-eq-subclass? type throw-type type-recs))
(catch-error type (field-src (catch-cond catch))))
@ -1113,7 +1137,7 @@
(if (and in-env? (not (properties-field? (var-type-properties in-env?))))
(illegal-redefinition (field-name field) (field-src field))
(check-s (catch-body catch)
(add-var-to-env name (field-type field) parm env)))))
(add-var-to-env name (field-type-spec field) parm env)))))
catches)
(when finally (check-s finally env)
body-res)))
@ -1479,9 +1503,12 @@
((and (eq? 'boolean l) (eq? 'boolean r)) 'boolean)
(else (bin-op-bitwise-error op l r src))))
((&& oror) ;; 15.23, 15.24
(prim-check (lambda (b) (eq? b 'boolean))
(lambda (l r) 'boolean) 'bool l r op src))))
(prim-check (lambda (b) (or (dynamic-val? b) (eq? b 'boolean)))
(lambda (l r)
(when (dynamic-val? l) (set-dynamic-val-type! l 'boolean))
(when (dynamic-val? r) (set-dynamic-val-type! r 'boolean))
'boolean)
'bool l r op src))))
;prim-check: (type -> bool) (type type -> type) type type src -> type
(define (prim-check ok? return expt l r op src)
@ -1495,10 +1522,10 @@
;;unary-promotion: type -> symbol
(define (unary-promotion t)
(cond
((and (scheme-val? t) (scheme-val-type t))
(unary-promotion (scheme-val-type t)))
((scheme-val? t)
(set-scheme-val-type! t 'int) 'int)
((and (dynamic-val? t) (dynamic-val-type t))
(unary-promotion (dynamic-val-type t)))
((dynamic-val? t)
(set-dynamic-val-type! t 'int) 'int)
(else
(case t ((byte short char) 'int) (else t)))))
@ -1506,21 +1533,23 @@
;; binary-promotion: type type -> type
(define (binary-promotion t1 t2)
(cond
((and (scheme-val? t1) (scheme-val? t2))
((and (dynamic-val? t1) (dynamic-val? t2))
(cond
((and (scheme-val-type t1) (scheme-val-type t2))
(binary-promotion (scheme-val-type t1) (scheme-val-type t2)))
((or (scheme-val-type t1) (scheme-val-type t2))
(error 'internal-error "Binary promotion does not know how to handle this situation yet"))
(else (make-scheme-val (gensym 'unnamed) #f #f #f))))
((scheme-val? t1)
((and (dynamic-val-type t1) (dynamic-val-type t2))
(binary-promotion (dynamic-val-type t1) (dynamic-val-type t2)))
((dynamic-val-type t1)
(binary-promotion (dynamic-val-type t1) t2))
((dynamic-val-type t2)
(binary-promotion t1 (dynamic-val-type t2)))
(else (make-dynamic-val #f))))
((dynamic-val? t1)
(cond
((scheme-val-type t1) (binary-promotion (scheme-val-type t1) t2))
(else (set-scheme-val-type! t1 t2) t2)))
((scheme-val? t2)
((dynamic-val-type t1) (binary-promotion (dynamic-val-type t1) t2))
(else (set-dynamic-val-type! t1 t2) t2)))
((dynamic-val? t2)
(cond
((scheme-val-type t2) (binary-promotion t1 (scheme-val-type t2)))
(else (set-scheme-val-type! t2 t1) t1)))
((dynamic-val-type t2) (binary-promotion t1 (dynamic-val-type t2)))
(else (set-dynamic-val-type! t2 t1) t1)))
((or (eq? 'double t1) (eq? 'double t2)) 'double)
((or (eq? 'float t1) (eq? 'float t2)) 'float)
((or (eq? 'long t1) (eq? 'long t2)) 'long)
@ -1536,10 +1565,14 @@
(fname (id-string (field-access-field acc)))
(src (id-src (field-access-field acc)))
(class-rec null)
(record null))
(set! record
(if obj
(field-lookup fname (type/env-t obj-type/env) obj src level type-recs)
(record
(cond
((and obj (dynamic-val? (expr-types obj)))
(set-dynamic-val-type! (expr-types obj)
(make-unknown-ref (make-field-contract fname (make-dynamic-val #f))))
(expr-types obj))
(obj (field-lookup fname (type/env-t obj-type/env) obj src level type-recs))
(else
(let* ((name (var-access-class (field-access-access acc))))
(set! class-rec
;First clause: static field of a local inner class
@ -1563,12 +1596,14 @@
(make-ref-type (if (pair? name) (car name) name) null)
src)))))
((scheme-record? class-rec)
(lookup-scheme class-rec fname
(module-has-binding? class-rec fname
(lambda () (field-lookup-error 'not-found
(string->symbol fname)
(make-ref-type (if (pair? name) (car name) name)
(list "scheme"))
src))))))))
src)))
(set-id-string! (field-access-field acc) (java-name->scheme fname))
(make-dynamic-val #f))))))))
(cond
((field-record? record)
(let* ((field-class (if (null? (cdr (field-record-class record)))
@ -1629,14 +1664,15 @@
(restricted-field-access-err (field-access-field acc) field-class src)))
(make-type/env (field-record-type record)
(if (type/env? obj-type/env) (type/env-e obj-type/env) env))))
((and (scheme-val? record) (scheme-val-instance? record))
((and (dynamic-val? record) (dynamic-val-type record))
(set-field-access-access! acc (make-var-access #f #t #t 'public 'unknown))
(make-type/env record (type/env-e obj-type/env)))
((scheme-val? record)
(make-type/env (field-contract-type (unknown-ref-access (dynamic-val-type record)))
obj-type/env))
((dynamic-val? record)
(add-required c-class (scheme-record-name class-rec)
(cons "scheme" (scheme-record-path class-rec)) type-recs)
(set-field-access-access! acc (make-var-access #t #t #t 'public (scheme-record-name class-rec)))
(make-type/env record (type/env-e obj-type/env)))
(make-type/env record (if obj (type/env-e obj-type/env) env)))
(else
(error 'internal-error "field-access given unknown form of field information")))))
((local-access? acc)
@ -1648,7 +1684,10 @@
(unless (properties-parm? (var-type-properties var))
(unless (var-set? (var-type-var var) env)
(unset-var-error (string->symbol (var-type-var var)) (id-src (local-access-name acc)))))))
(make-type/env (var-type-type var) env)))
(make-type/env (if (eq? 'dynamic (var-type-type var))
(make-dynamic-val #f)
(var-type-type var))
env)))
(else
(let* ((first-acc (id-string (car acc)))
@ -1738,24 +1777,11 @@
(equal? (send type-recs get-interactions-package) (cdr class1)))
(else (equal? (cdr class1) (cdr class2)))))
;; field-lookup: string type expression src symbol type-records -> (U field-record scheme-val)
;; field-lookup: string type expression src symbol type-records -> (U field-record dynamic-val)
(define (field-lookup fname obj-type obj src level type-recs)
(let ((obj-src (expr-src obj))
(name (string->symbol fname)))
(cond
((and (scheme-val? obj-type) (scheme-val-type obj-type))
(field-lookup fname (scheme-val-type obj-type) obj src level type-recs))
((scheme-val? obj-type)
(let ((field-c (make-scheme-val fname #t #t #f)))
(set-scheme-val-type! (make-unknown-ref null (list field-c)))
field-c))
((unknown-ref? obj-type)
(cond
((field-contract-lookup fname (unknown-ref-fields obj-type)) => (lambda (x) x))
(else
(let ((field-c (make-scheme-val fname #t #t #f)))
(set-unknown-ref-fields! obj-type (cons field-c (unknown-ref-fields obj-type)))
field-c))))
((reference-type? obj-type)
(let ((obj-record (get-record (send type-recs get-class-record obj-type #f
((get-importer type-recs) obj-type type-recs level obj-src))
@ -1860,6 +1886,7 @@
(let* ((this (unless static? (lookup-this type-recs env)))
(src (expr-src call))
(name (call-method-name call))
(name-string (when (id? name) (id-string name)))
(expr (call-expr call))
(exp-type #f)
(handle-call-error
@ -1879,27 +1906,18 @@
(car (class-record-name record))
(lambda () null))
(cdr (class-record-name record))))))
(get-method-records (id-string name) record))
(get-method-records name-string record))
((scheme-record? record)
(let ((result
(lookup-scheme record (id-string name)
(module-has-binding? record name-string
(lambda () (no-method-error 'class 'not-found
(string->symbol (id-string name))
(make-ref-type (if (pair? name) (car name) name)
(list "scheme"))
src)))))
(if (scheme-val-type result)
(if (method-contract? (scheme-val-type result))
(list (scheme-val-type result))
(no-method-error 'class 'field (string->symbol (id-string name))
(make-ref-type (if (pair? name) (car name) name)
(list "scheme"))
src))
(let ((m-c
(make-method-contract (id-string name)
(make-scheme-val 'method-result #t #f #f) #f)))
(set-scheme-val-type! result m-c)
(list m-c)))))))
(string->symbol name-string)
(make-ref-type name (list "scheme"))
src)))
(cond
((name? name) (set-id-string! (name-id name) (java-name->scheme name-string)))
((id? name) (set-id-string! name (java-name->scheme name-string))))
(list (make-method-contract (java-name->scheme name-string) #f #f)))))
;Teaching languages
(if (and (= (length (access-name expr)) 1)
(with-handlers ((exn:fail:syntax? (lambda (exn) #f)))
(type-exists? (id-string (car (access-name expr)))
@ -1915,7 +1933,7 @@
(send type-recs lookup-path
(car (class-record-name record))
(lambda () null)))))
(let ((methods (get-method-records (id-string name) record)))
(let ((methods (get-method-records name-string record)))
(unless (andmap (lambda (x) x)
(map (lambda (mrec) (memq 'static (method-record-modifiers mrec)))
methods))
@ -1935,13 +1953,13 @@
(get-method-records (car (class-record-name this)) this))))
(else
(cond
((special-name? expr)
(if (equal? (special-name-name expr) "super")
((and (special-name? expr) (equal? (special-name-name expr) "super"))
(when static?
(super-special-error (expr-src expr) interact?))
(let ((parent (car (class-record-parents this))))
(set! exp-type 'super)
(get-method-records (id-string name)
(send type-recs get-class-record parent)))
(get-method-records (id-string name) this)))
(get-method-records name-string
(send type-recs get-class-record parent))))
(expr
(let* ((call-exp/env
(with-handlers ((exn:fail:syntax? handle-call-error))
@ -1956,21 +1974,16 @@
((list? call-exp) call-exp)
((array-type? call-exp)
(set! exp-type call-exp)
(get-method-records (id-string name)
(get-method-records name-string
(send type-recs get-class-record object-type)))
((and (scheme-val? call-exp) (scheme-val-type call-exp)
(unknown-ref? (scheme-val-type call-exp)))
((dynamic-val? call-exp)
(let ((m-contract (make-method-contract name-string #f #f)))
(set-dynamic-val-type! call-exp (make-unknown-ref m-contract))
(set! exp-type call-exp)
(get-method-contracts (id-string name) (scheme-val-type call-exp)))
((and (scheme-val? call-exp) (not (scheme-val-type call-exp)))
(let ((m-contract (make-method-contract (id-string name)
(make-scheme-val 'method-return #t #f #f) #f)))
(set! exp-type call-exp)
(set-scheme-val-type! call-exp (make-unknown-ref (list m-contract) null))
(list m-contract)))
((reference-type? call-exp)
(set! exp-type call-exp)
(get-method-records (id-string name)
(get-method-records name-string
(get-record
(send type-recs get-class-record call-exp #f
((get-importer type-recs)
@ -1982,8 +1995,14 @@
(if (eq? level 'beginner)
(beginner-method-access-error name (id-src name))
(let ((rec (if static? (send type-recs get-class-record c-class) this)))
(if (null? rec) null
(get-method-records (id-string name) rec))))))))))
(cond
((and (null? rec) (dynamic?) (lookup-var-in-env name-string env)) =>
(lambda (var-type)
(if (eq? 'dynamic (var-type-type var-type))
(list (make-method-contract (string-append name-string "~f") #f #f))
null)))
((null? rec) null)
(else (get-method-records name-string rec)))))))))))
(when (null? methods)
(let* ((rec (if exp-type
@ -1993,32 +2012,33 @@
(field? (cond
((array-type? exp-type) (equal? (id-string name) "length"))
((null? rec)
(member (id-string name)
(member name-string
(map field-record-name (send type-recs get-interactions-fields))))
(else (member (id-string name) (map field-record-name (get-field-records rec))))))
(else (member name-string (map field-record-name (get-field-records rec))))))
(sub-kind (if class? 'class-name (if field? 'field-name 'not-found))))
(cond
((eq? exp-type 'super) (no-method-error 'super sub-kind exp-type name src))
(exp-type (no-method-error 'class sub-kind exp-type name src))
(else
(cond
((close-to-keyword? (id-string name))
((close-to-keyword? name-string)
(close-to-keyword-error 'method name src))
(interact? (interaction-call-error name src level))
(else
(no-method-error 'this sub-kind exp-type name src)))))))
(unless (method-contract? (car methods))
(when (and (not ctor?)
(eq? (method-record-rtype (car methods)) 'ctor))
(ctor-called-error exp-type name src))
(ctor-called-error exp-type name src)))
(let* ((args/env (check-args arg-exps check-sub
env))
(let* ((args/env (check-args arg-exps check-sub env))
(args (car args/env))
(method-record
(cond
((method-contract? (car methods))
(set-method-contract-args! (car methods) args)
(set-method-contract-return! (car methods) (make-dynamic-val #f))
(car methods))
((memq level '(full advanced))
(resolve-overloading methods
@ -2031,7 +2051,7 @@
(let ((teaching-error
(lambda (kind)
(if (error-file-exists? (method-record-class (car methods)) type-recs)
(call-provided-error (id-string name) args kind)
(call-provided-error name-string args kind)
(teaching-call-error kind #f name args exp-type src methods)))))
(resolve-overloading methods
args
@ -2076,10 +2096,14 @@
(eq? 'void (method-record-rtype method-record)))
(beginner-call-error name src))
(unless (eq? level 'full)
(when (and (id? name) (is-method-restricted? (id-string name) (method-record-class method-record)))
(when (and (id? name) (is-method-restricted? name-string (method-record-class method-record)))
(restricted-method-call name (method-record-class method-record) src)))
(set-call-method-record! call method-record)
(make-type/env (method-record-rtype method-record) (cadr args/env)))
(make-type/env
(if (eq? 'dynamic (method-record-rtype method-record))
(make-dynamic-val #f)
(method-record-rtype method-record))
(cadr args/env)))
((method-contract? method-record)
(set-call-method-record! call method-record)
(make-type/env (method-contract-return method-record) (cadr args/env)))))))
@ -2249,8 +2273,8 @@
(else
(let* ((t/env (check-sub-exp (car subs) env))
(t (type/env-t t/env)))
(when (and (scheme-val? t) (not (scheme-val-type t)))
(set-scheme-val-type! t 'int))
(when (and (dynamic-val? t) (not (dynamic-val-type t)))
(set-dynamic-val-type! t 'int))
(unless (prim-integral-type? t)
(array-size-error type t (expr-src (car subs))))
(loop (cdr subs) (type/env-e t/env))))))))
@ -2288,25 +2312,28 @@
(then (type/env-t then/env))
(else-t (type/env-t else/env)))
(cond
((and (scheme-val? test) (scheme-val-type test))
(unless (eq? 'boolean (scheme-val-type test))
(condition-error (scheme-val-type test) test-src)))
((scheme-val? test) (set-scheme-val-type! test 'boolean))
((and (dynamic-val? test) (dynamic-val-type test))
(unless (eq? 'boolean (dynamic-val-type test))
(condition-error (dynamic-val-type test) test-src)))
((dynamic-val? test) (set-dynamic-val-type! test 'boolean))
(else
(unless (eq? 'boolean test) (condition-error test test-src))))
(make-type/env
(cond
((and (or (scheme-val? then) (scheme-val? else-t))
((and (or (dynamic-val? then) (dynamic-val? else-t))
(or (eq? 'boolean then) (eq? 'boolean else-t)))
(cond
((scheme-val? then)
((dynamic-val? then)
(cond
((and (scheme-val-type then) (eq? 'boolean (scheme-val-type then))) 'boolean)
(else (set-scheme-val-type! then 'boolean) 'boolean)))
((scheme-val? else-t)
((and (dynamic-val-type then) (eq? 'boolean (dynamic-val-type then))) 'boolean)
(else (set-dynamic-val-type! then 'boolean) 'boolean)))
((dynamic-val? else-t)
(cond
((and (scheme-val-type else-t) (eq? 'boolean (scheme-val-type else-t))) 'boolean)
(else (set-scheme-val-type! else-t 'boolean) 'boolean)))))
((and (dynamic-val-type else-t) (eq? 'boolean (dynamic-val-type else-t))) 'boolean)
(else (set-dynamic-val-type! else-t 'boolean) 'boolean)))))
((and (dynamic-val? then) (dynamic-val? else-t)
(not (dynamic-val-type then)) (not (dynamic-val-type else-t)))
(make-dynamic-val #f))
((and (eq? 'boolean then) (eq? 'boolean else-t)) 'boolean)
((and (prim-numeric-type? then) (prim-numeric-type? else-t))
;; This is not entirely correct, but close enough due to using scheme ints
@ -2389,6 +2416,10 @@
(send type-recs add-req (make-req (ref-type-class/iface type) (ref-type-path type)))))
(make-type/env
(cond
((dynamic-val? exp-type)
(set-dynamic-val-type! exp-type type)
type)
((eq? 'dynamic type) (make-dynamic-val #f))
((and (reference-type? exp-type) (reference-type? type)) type)
((and (not (reference-type? exp-type)) (not (reference-type? type))) type)
((reference-type? exp-type) (cast-error 'from-prim exp-type type src))
@ -2429,6 +2460,7 @@
((and (array-type? exp-type) (array-type? type)
(= (array-type-dim exp-type) (array-type-dim type))
(or (assignment-conversion exp-type type type-recs))) 'boolean)
((dynamic-val? exp-type) 'boolean)
((and (array-type? exp-type) (array-type? type))
(instanceof-error 'not-related-array type exp-type src))
((array-type? exp-type)
@ -2676,6 +2708,13 @@
(if interactions? "the interactions window" "static code"))
'this src))
;super-special-error: src bool -> void
(define (super-special-error src interact?)
(raise-error 'super
(format "use of 'super' is not allowed in ~a"
(if interact? "the interactions window" "static code"))
'super src))
;;Call errors
;prim-call-error type id src symbol -> void
@ -3159,10 +3198,10 @@
((field) (format "final field ~a may only be set in the containing class's constructor" n)))
n (id-src name))))
;implicit import error
;class-lookup-error: string src -> void
(define (class-lookup-error class src)
(if (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)

14
collects/profj/compile.ss
View File

@ -34,19 +34,25 @@
(cond
((and (eq? src 'file) (eq? dest 'file))
(let-values (((path-base file dir?) (split-path (path->complete-path (build-path name)))))
(let ((compiled-path (build-path path-base "compiled" (path-replace-suffix file ".zo"))))
(unless (and (file-exists? compiled-path)
(let ((compiled-path (build-path path-base "compiled" (path-replace-suffix file ".zo")))
(type-path (build-path path-base "compiled" (path-replace-suffix file ".jinfo"))))
(unless (and (and (file-exists? compiled-path)
(> (file-or-directory-modify-seconds compiled-path)
(file-or-directory-modify-seconds (build-path name))))
(and (file-exists? type-path)
(read-record type-path)))
(call-with-input-file name (lambda (port) (compile-to-file port name level)))))))
((eq? dest 'file)
(compile-to-file port loc level))
((eq? src 'file)
(let-values (((path-base file dir?) (split-path (path->complete-path (build-path name)))))
(let ((compiled-path (build-path path-base "compiled" (path-replace-suffix file ".zo"))))
(unless (and (file-exists? compiled-path)
(let ((compiled-path (build-path path-base "compiled" (path-replace-suffix file ".zo")))
(type-path (build-path path-base "compiled" (path-replace-suffix file ".jinfo"))))
(unless (or (and (file-exists? compiled-path)
(> (file-or-directory-modify-seconds compiled-path)
(file-or-directory-modify-seconds (build-path name))))
(and (file-exists? type-path)
(read-record type-path)))
(call-with-input-file
name
(lambda (port) (compile-java-internal port name type-recs #f level)))))))

2
collects/profj/libs/java/io/Serializable.jinfo
View File

@ -7,4 +7,4 @@
()
()
()
"version1")
"version2")

12
collects/profj/libs/java/lang/ArithmeticException.ss
View File

@ -1,3 +1,11 @@
(module |ArithmeticException| mzscheme
(module ArithmeticException mzscheme
(require "Object-composite.ss")
(provide |ArithmeticException|))
(provide
ArithmeticException
guard-convert-ArithmeticException
convert-assert-ArithmeticException
wrap-convert-assert-ArithmeticException
dynamic-ArithmeticException/c
static-ArithmeticException/c
ArithmeticException-ArithmeticException-constructor~generic
ArithmeticException-ArithmeticException-constructor-java.lang.String~generic))

13
collects/profj/libs/java/lang/ArrayIndexOutOfBoundsException.ss
View File

@ -1,3 +1,12 @@
(module |ArrayIndexOutOfBoundsException| mzscheme
(module ArrayIndexOutOfBoundsException mzscheme
(require "Object-composite.ss")
(provide |ArrayIndexOutOfBoundsException|))
(provide
ArrayIndexOutOfBoundsException
guard-convert-ArrayIndexOutOfBoundsException
convert-assert-ArrayIndexOutOfBoundsException
wrap-convert-assert-ArrayIndexOutOfBoundsException
dynamic-ArrayIndexOutOfBoundsException/c
static-ArrayIndexOutOfBoundsException/c
ArrayIndexOutOfBoundsException-ArrayIndexOutOfBoundsException-constructor~generic
ArrayIndexOutOfBoundsException-ArrayIndexOutOfBoundsException-constructor-java.lang.String~generic
ArrayIndexOutOfBoundsException-ArrayIndexOutOfBoundsException-constructor-int~generic))

12
collects/profj/libs/java/lang/ArrayStoreException.ss
View File

@ -1,3 +1,11 @@
(module |ArrayStoreException| mzscheme
(module ArrayStoreException mzscheme
(require "Object-composite.ss")
(provide |ArrayStoreException|))
(provide
ArrayStoreException
guard-convert-ArrayStoreException
convert-assert-ArrayStoreException
wrap-convert-assert-ArrayStoreException
dynamic-ArrayStoreException/c
static-ArrayStoreException/c
ArrayStoreException-ArrayStoreException-constructor~generic
ArrayStoreException-ArrayStoreException-constructor-java.lang.String~generic))

12
collects/profj/libs/java/lang/ClassCastException.ss
View File

@ -1,3 +1,11 @@
(module |ClassCastException| mzscheme
(module ClassCastException mzscheme
(require "Object-composite.ss")
(provide |ClassCastException|))
(provide
ClassCastException
guard-convert-ClassCastException
convert-assert-ClassCastException
wrap-convert-assert-ClassCastException
dynamic-ClassCastException/c
static-ClassCastException/c
ClassCastException-ClassCastException-constructor~generic
ClassCastException-ClassCastException-constructor-java.lang.String~generic))

15
collects/profj/libs/java/lang/ClassNotFoundException.ss
View File

@ -1,3 +1,14 @@
(module |ClassNotFoundException| mzscheme
(module ClassNotFoundException mzscheme
(require "Object-composite.ss")
(provide |ClassNotFoundException|))
(provide
ClassNotFoundException
guard-convert-ClassNotFoundException
convert-assert-ClassNotFoundException
wrap-convert-assert-ClassNotFoundException
dynamic-ClassNotFoundException/c
static-ClassNotFoundException/c
ClassNotFoundException-ClassNotFoundException-constructor~generic
ClassNotFoundException-ClassNotFoundException-constructor-java.lang.String~generic
ClassNotFoundException-ClassNotFoundException-constructor-java.lang.String-java.lang.Throwable~generic
ClassNotFoundException-getException~generic
ClassNotFoundException-getCause~generic))

12
collects/profj/libs/java/lang/CloneNotSupportedException.ss
View File

@ -1,3 +1,11 @@
(module |CloneNotSupportedException| mzscheme
(module CloneNotSupportedException mzscheme
(require "Object-composite.ss")
(provide |CloneNotSupportedException|))
(provide
CloneNotSupportedException
guard-convert-CloneNotSupportedException
convert-assert-CloneNotSupportedException
wrap-convert-assert-CloneNotSupportedException
dynamic-CloneNotSupportedException/c
static-CloneNotSupportedException/c
CloneNotSupportedException-CloneNotSupportedException-constructor~generic
CloneNotSupportedException-CloneNotSupportedException-constructor-java.lang.String~generic))

2
collects/profj/libs/java/lang/Comparable.jinfo
View File

@ -7,4 +7,4 @@
()
()
()
"version1")
"version2")

14
collects/profj/libs/java/lang/Exception.ss
View File

@ -1,3 +1,13 @@
(module |Exception| mzscheme
(module Exception mzscheme
(require "Object-composite.ss")
(provide |Exception|))
(provide
Exception
guard-convert-Exception
convert-assert-Exception
wrap-convert-assert-Exception
dynamic-Exception/c
static-Exception/c
Exception-Exception-constructor~generic
Exception-Exception-constructor-java.lang.String~generic
Exception-Exception-constructor-java.lang.String-java.lang.Throwable~generic
Exception-Exception-constructor-java.lang.Throwable~generic))

12
collects/profj/libs/java/lang/IllegalAccessException.ss
View File

@ -1,3 +1,11 @@
(module |IllegalAccessException| mzscheme
(module IllegalAccessException mzscheme
(require "Object-composite.ss")
(provide |IllegalAccessException|))
(provide
IllegalAccessException
guard-convert-IllegalAccessException
convert-assert-IllegalAccessException
wrap-convert-assert-IllegalAccessException
dynamic-IllegalAccessException/c
static-IllegalAccessException/c
IllegalAccessException-IllegalAccessException-constructor~generic
IllegalAccessException-IllegalAccessException-constructor-java.lang.String~generic))

12
collects/profj/libs/java/lang/IllegalArgumentException.ss
View File

@ -1,3 +1,11 @@
(module |IllegalArgumentException| mzscheme
(module IllegalArgumentException mzscheme
(require "Object-composite.ss")
(provide |IllegalArgumentException|))
(provide
IllegalArgumentException
guard-convert-IllegalArgumentException
convert-assert-IllegalArgumentException
wrap-convert-assert-IllegalArgumentException
dynamic-IllegalArgumentException/c
static-IllegalArgumentException/c
IllegalArgumentException-IllegalArgumentException-constructor~generic
IllegalArgumentException-IllegalArgumentException-constructor-java.lang.String~generic))

12
collects/profj/libs/java/lang/IllegalMonitorStateException.ss
View File

@ -1,3 +1,11 @@
(module |IllegalMonitorStateException| mzscheme
(module IllegalMonitorStateException mzscheme
(require "Object-composite.ss")
(provide |IllegalMonitorStateException|))
(provide
IllegalMonitorStateException
guard-convert-IllegalMonitorStateException
convert-assert-IllegalMonitorStateException
wrap-convert-assert-IllegalMonitorStateException
dynamic-IllegalMonitorStateException/c
static-IllegalMonitorStateException/c
IllegalMonitorStateException-IllegalMonitorStateException-constructor~generic
IllegalMonitorStateException-IllegalMonitorStateException-constructor-java.lang.String~generic))

12
collects/profj/libs/java/lang/IllegalStateException.ss
View File

@ -1,3 +1,11 @@
(module |IllegalStateException| mzscheme
(module IllegalStateException mzscheme
(require "Object-composite.ss")
(provide |IllegalStateException|))
(provide
IllegalStateException
guard-convert-IllegalStateException
convert-assert-IllegalStateException
wrap-convert-assert-IllegalStateException
dynamic-IllegalStateException/c
static-IllegalStateException/c
IllegalStateException-IllegalStateException-constructor~generic
IllegalStateException-IllegalStateException-constructor-java.lang.String~generic))

12
collects/profj/libs/java/lang/IllegalThreadStateException.ss
View File

@ -1,3 +1,11 @@
(module |IllegalThreadStateException| mzscheme
(module IllegalThreadStateException mzscheme
(require "Object-composite.ss")
(provide |IllegalThreadStateException|))
(provide
IllegalThreadStateException
guard-convert-IllegalThreadStateException
convert-assert-IllegalThreadStateException
wrap-convert-assert-IllegalThreadStateException
dynamic-IllegalThreadStateException/c
static-IllegalThreadStateException/c
IllegalThreadStateException-IllegalThreadStateException-constructor~generic
IllegalThreadStateException-IllegalThreadStateException-constructor-java.lang.String~generic))

12
collects/profj/libs/java/lang/IndexOutOfBoundsException.ss
View File

@ -1,3 +1,11 @@
(module |IndexOutOfBoundsException| mzscheme
(module IndexOutOfBoundsException mzscheme
(require "Object-composite.ss")
(provide |IndexOutOfBoundsException|))
(provide
IndexOutOfBoundsException
guard-convert-IndexOutOfBoundsException
convert-assert-IndexOutOfBoundsException
wrap-convert-assert-IndexOutOfBoundsException
dynamic-IndexOutOfBoundsException/c
static-IndexOutOfBoundsException/c
IndexOutOfBoundsException-IndexOutOfBoundsException-constructor~generic
IndexOutOfBoundsException-IndexOutOfBoundsException-constructor-java.lang.String~generic))

12
collects/profj/libs/java/lang/InstantiationException.ss
View File

@ -1,3 +1,11 @@
(module |InstantiationException| mzscheme
(module InstantiationException mzscheme
(require "Object-composite.ss")
(provide |InstantiationException|))
(provide
InstantiationException
guard-convert-InstantiationException
convert-assert-InstantiationException
wrap-convert-assert-InstantiationException
dynamic-InstantiationException/c
static-InstantiationException/c
InstantiationException-InstantiationException-constructor~generic
InstantiationException-InstantiationException-constructor-java.lang.String~generic))

12
collects/profj/libs/java/lang/InterruptedException.ss
View File

@ -1,3 +1,11 @@
(module |InterruptedException| mzscheme
(module InterruptedException mzscheme
(require "Object-composite.ss")
(provide |InterruptedException|))
(provide
InterruptedException
guard-convert-InterruptedException
convert-assert-InterruptedException
wrap-convert-assert-InterruptedException
dynamic-InterruptedException/c
static-InterruptedException/c
InterruptedException-InterruptedException-constructor~generic
InterruptedException-InterruptedException-constructor-java.lang.String~generic))

12
collects/profj/libs/java/lang/NegativeArraySizeException.ss
View File

@ -1,3 +1,11 @@
(module |NegativeArraySizeException| mzscheme
(module NegativeArraySizeException mzscheme
(require "Object-composite.ss")
(provide |NegativeArraySizeException|))
(provide
NegativeArraySizeException
guard-convert-NegativeArraySizeException
convert-assert-NegativeArraySizeException
wrap-convert-assert-NegativeArraySizeException
dynamic-NegativeArraySizeException/c
static-NegativeArraySizeException/c
NegativeArraySizeException-NegativeArraySizeException-constructor~generic
NegativeArraySizeException-NegativeArraySizeException-constructor-java.lang.String~generic))

12
collects/profj/libs/java/lang/NoSuchFieldException.ss
View File

@ -1,3 +1,11 @@
(module |NoSuchFieldException| mzscheme
(module NoSuchFieldException mzscheme
(require "Object-composite.ss")
(provide |NoSuchFieldException|))
(provide
NoSuchFieldException
guard-convert-NoSuchFieldException
convert-assert-NoSuchFieldException
wrap-convert-assert-NoSuchFieldException
dynamic-NoSuchFieldException/c
static-NoSuchFieldException/c
NoSuchFieldException-NoSuchFieldException-constructor~generic
NoSuchFieldException-NoSuchFieldException-constructor-java.lang.String~generic))

12
collects/profj/libs/java/lang/NoSuchMethodException.ss
View File

@ -1,3 +1,11 @@
(module |NoSuchMethodException| mzscheme
(module NoSuchMethodException mzscheme
(require "Object-composite.ss")
(provide |NoSuchMethodException|))
(provide
NoSuchMethodException
guard-convert-NoSuchMethodException
convert-assert-NoSuchMethodException
wrap-convert-assert-NoSuchMethodException
dynamic-NoSuchMethodException/c
static-NoSuchMethodException/c
NoSuchMethodException-NoSuchMethodException-constructor~generic
NoSuchMethodException-NoSuchMethodException-constructor-java.lang.String~generic))

12
collects/profj/libs/java/lang/NullPointerException.ss
View File

@ -1,3 +1,11 @@
(module |NullPointerException| mzscheme
(module NullPointerException mzscheme
(require "Object-composite.ss")
(provide |NullPointerException|))
(provide
NullPointerException
guard-convert-NullPointerException
convert-assert-NullPointerException
wrap-convert-assert-NullPointerException
dynamic-NullPointerException/c
static-NullPointerException/c
NullPointerException-NullPointerException-constructor~generic
NullPointerException-NullPointerException-constructor-java.lang.String~generic))

12
collects/profj/libs/java/lang/NumberFormatException.ss
View File

@ -1,3 +1,11 @@
(module |NumberFormatException| mzscheme
(module NumberFormatException mzscheme
(require "Object-composite.ss")
(provide |NumberFormatException|))
(provide
NumberFormatException
guard-convert-NumberFormatException
convert-assert-NumberFormatException
wrap-convert-assert-NumberFormatException
dynamic-NumberFormatException/c
static-NumberFormatException/c
NumberFormatException-NumberFormatException-constructor~generic
NumberFormatException-NumberFormatException-constructor-java.lang.String~generic))

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

@ -2,6 +2,7 @@
(module Object-composite mzscheme
(require (lib "class.ss")
(prefix c: (lib "contract.ss"))
(lib "errortrace-lib.ss" "errortrace")
(lib "Comparable.ss" "profj" "libs" "java" "lang")
(lib "Serializable.ss" "profj" "libs" "java" "io"))
@ -35,13 +36,15 @@
; ;;;
;Object.java
(provide ObjectI Object-Mix Object)
(provide ObjectI Object-Mix Object
wrap-convert-assert-Object convert-assert-Object guard-convert-Object dynamic-Object/c static-Object/c)
;Object interface, and a mixin to create objects from.
(define ObjectI
(interface () Object-constructor clone equals-java.lang.Object finalize getClass
hashCode notify notifyAll toString wait wait-long wait-long-int my-name))
hashCode notify notifyAll toString wait wait-long wait-long-int my-name
equals hash-code to-string get-class))
(define Object-Mix
(lambda (parent)
@ -53,17 +56,20 @@
(define/public clone (lambda () void))
(define/public (equals-java.lang.Object obj) (eq? this obj))
(define/public (equals obj) (send this equals-java.lang.Object obj))
;Needs to do something
(define/public (finalize) void)
(public-final getClass)
(public-final getClass get-class)
(define (getClass)
(error 'ProfessorJ:getClass
(format "ProfessorJ does not support getClass calls. ~e"
(send this toString))))
(define (get-class) (getClass))
(define/public (hashCode) (eq-hash-code this))
(define/public (hash-code) (send this hashCode))
;Needs to do something when Threads more implemented
(public-final notify |notifyAll|)
@ -73,6 +79,7 @@
(define/public (my-name) "Object")
(define/public (toString)
(make-java-string (format "~a@~a" (send this my-name) (send this hashCode))))
(define/public (to-string) (send this toString))
(public-final wait wait-long wait-long-int)
(define wait (lambda () void))
@ -96,6 +103,152 @@
(define Object (Object-Mix object%))
(define (wrap-convert-assert-Object obj p n s c)
(if (string? obj)
(make-java-string string)
(begin
(c:contract (c:object-contract
(clone (c:-> c:any/c))
(equals-java.lang.Object (c:-> c:any/c c:any/c))
(finalize (c:-> c:any/c))
(getClass (c:-> c:any/c))
(hashCode (c:-> c:any/c))
(notify (c:-> c:any/c))
(notifyAll (c:-> c:any/c))
(toString (c:-> c:any/c))
(wait (c:-> c:any/c))
(wait-long (c:-> c:any/c c:any/c))
(wait-long-int (c:-> c:any/c c:any/c c:any/c))) obj p n s)
(make-object convert-assert-Object obj p n s c))))
(define convert-assert-Object
(class object%
(init w p n s c)
(define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null))
(set! wrapped w)
(set! pos-blame p)
(set! neg-blame n)
(set! src s)
(set! cc-marks c)
(define/public (clone) (send wrapped clone))
(define/public (equals-java.lang.Object obj)
(let ((val (send wrapped equals-java.lang.Object
(make-object guard-convert-Object obj pos-blame neg-blame src cc-marks))))
(unless (boolean? val)
(raise (make-exn:fail (string->immutable-string
(format "~a broke ~a contract here; Object's equals expects boolean return, given ~a"
pos-blame neg-blame val)) cc-marks)))
val))
(define/public (finalize) (send wrapped finalize))
(define/public (getClass) (send wrapped getClass))
(define/public (hashCode)
(let ((val (send wrapped hashCode)))
(unless (integer? val)
(raise (make-exn:fail (string->immutable-string
(format "~a broke ~a contract here; Object's hashCode expects int return, given ~a"
pos-blame neg-blame val)) cc-marks)))
val))
(define/public (notify) (send wrapped notify))
(define/public (notifyAll) (send wrapped notifyAll))
(define/public (toString)
(let ((val (send wrapped toString)))
(unless (string? val)
(raise (make-exn:fail (string->immutable-string
(format "~a broke ~a contract here: Object's toString expects String return, given ~a"
pos-blame neg-blame val)) cc-marks)))
(make-java-string val)))
(define/public (wait) (send wrapped wait))
(define/public (wait-long l) (send wrapped wait-long l))
(define/public (wait-long-int l i) (send wrapped wait-long l i))
(define/public (my-name) (send wrapped my-name))
(define/public (field-names) (send wrapped field-names))
(define/public (field-values) (send wrapped field-values))
(define/public (fields-for-display) (send wrapped fields-for-display))
(super-instantiate ())))
(define dynamic-Object/c
(c:flat-named-contract "Object" (lambda (v) (is-a? v convert-assert-Object))))
(define guard-convert-Object
(class object%
(init w p n s c)
(define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null))
(set! wrapped w)
(set! pos-blame p)
(set! neg-blame n)
(set! src s)
(set! cc-marks s)
(define/public (clone) (send wrapped clone))
(define/public (equals-java.lang.Object . obj)
(unless (= (length obj) 1)
(raise (make-exn:fail:contract:arity
(string->immutable-string
(format "~a broke ~a contract here: Object's equals expects to be called with 1 argument, given ~n"
pos-blame neg-blame (length obj))) cc-marks)))
(send wrapped equals-java.lang.Object (wrap-convert-assert-Object (car obj) pos-blame neg-blame src cc-marks)))
(define/public (equals . obj)
(unless (= (length obj) 1)
(raise (make-exn:fail:contract:arity
(string->immutable-string
(format "~a broke ~a contract here: Object's equals expects to be called with 1 argument, given ~n"
pos-blame neg-blame (length obj))) cc-marks)))
(send wrapped equals-java.lang.Object (wrap-convert-assert-Object (car obj) pos-blame neg-blame src cc-marks)))
(define/public (finalize) (send wrapped finalize))
(define/public (getClass) (send wrapped getClass))
(define/public (get-class) (send wrapped getClass))
(define/public (hashCode) (send wrapped hashCode))
(define/public (hash-code) (send wrapped hashCode))
(define/public (notify) (send wrapped notify))
(define/public (notifyAll) (send wrapped notifyAll))
(define/public (notify-all) (send wrapped notifyAll))
(define/public (toString)
(send (send wrapped toString) get-mzscheme-string))
(define/public (to-string) (send (send wrapped toString) get-mzscheme-string))
(define/public (wait) (send wrapped wait))
(define/public (wait-long . l)
(unless (= (length l) 1)
(raise (make-exn:fail:contract:arity
(string->immutable-string
(format "~a broke ~a contract here: Object's wait-long expects to be called with 1 argument, given ~n"
pos-blame neg-blame (length l))) cc-marks)))
(unless (integer? (car l))
(raise (make-exn:fail
(string->immutable-string
(format "~a broke ~a contract here: Object's wait that takes a long argument expected long, given ~a"
pos-blame neg-blame (car l))) cc-marks)))
(send wrapped wait-long (car l)))
(define/public (wait-long-int . l)
(unless (= (length l) 2)
(raise (make-exn:fail:contract:arity
(string->immutable-string
(format "~a broke ~a contract here: Object's wait-long-int expects to be called with 2 arguments, given ~n"
pos-blame neg-blame (length l))) cc-marks)))
(unless (integer? (car l))
(raise (make-exn:fail
(string->immutable-string
(format "~a broke ~a contract here: Object's wait-long-int expected long, given ~a"
pos-blame neg-blame (car l))) cc-marks)))
(unless (integer? (cadr l))
(raise (make-exn:fail
(string->immutable-string
(format "~a broke ~a contract here: Object's wait-long-int expected int, given ~a"
pos-blame neg-blame (cadr l))) cc-marks)))
(send wrapped wait-long (car l) (cadr l)))
(define/public (my-name) (send wrapped my-name))
(define/public (field-names) (send wrapped field-names))
(define/public (field-values) (send wrapped field-values))
(define/public (fields-for-display) (send wrapped fields-for-display))
(super-instantiate ())))
(define static-Object/c
(c:flat-named-contract "Object" (lambda (v) (is-a? v guard-convert-Object))))
;
;
@ -310,6 +463,7 @@
(define/public (length) (string-length text))
; int -> char
(define/public (charAt-int index) (string-ref text index))
(define/public (char-at i) (charAt-int i))
;-> void
(define/public (getChars-int-int-char1-int begin end dest i)
@ -321,6 +475,7 @@
(send dest set index (string-ref text offset))
(build-char-array (add1 offset) (add1 index)))))))
(build-char-array begin i)))
(define/public (get-chars b e d i) (getChars-int-int-char1-int b e d i))
;Does not mess with charset
(define/public (getBytes)
@ -348,6 +503,7 @@
(define/public (contentEquals-java.lang.StringBuffer buf)
(equals-java.lang.Object (send buf toString)))
(define/public (content-equals b) (contentEquals-java.lang.StringBuffer b))
;Object -> boolean
(define/override (equals-java.lang.Object obj)
@ -357,6 +513,7 @@
;Object -> boolean
(define/public (equalsIgnoreCase-java.lang.String str)
(string-ci=? text (send str get-mzscheme-string)))
(define/public (equals-ignore-case s) (equalsIgnoreCase-java.lang.String s))
;find-diff-chars: int int string-> (values int int)
(define/private (find-diff-chars i stop-length compare-string)
@ -420,6 +577,7 @@
(let-values (((int-text int-str) (find-diff-chars 0)))
(- int-text int-str))
(- text-l str-l))))))
(define/public (compare->ignore-case s) (compareToIgnoreCase-java.lang.String s))
;int String int int -> boolean
(define/public (regionMatches-int-java.lang.String-int-int toffset jstr ooffset len)
@ -458,6 +616,7 @@
(let ((suffix (send Jsuffix get-mzscheme-string)))
(and (<= (string-length suffix) (string-length text))
(string=? suffix (substring text (- (string-length text) (string-length suffix)) (string-length text))))))
(define/public (ends-with s) (endsWith-java.lang.String s))
; -> int
(define/override (hashCode)
@ -521,11 +680,13 @@
(define/public (subSequence-int-int begin end)
(error 'subSequence "Internal Error: subsequence is unimplemented because charSequence is unimplemented"))
(define/public (sub-sequence i j) (subSequence-int-int i j))
;String -> String
(define/public (concat-java.lang.String Jstr)
(let ((str (send Jstr get-mzscheme-string)))
(make-java-string (string-append text str))))
(define/public (concat s) (concat-java.lang.String s))
; .. -> String
(define/public (replace-char-char old new)
@ -536,16 +697,20 @@
(string-set! new-text pos new)
(loop (add1 index)))))
(make-java-string new-text)))
(define/public (replace c1 c2) (replace-char-char c1 c2))
;Does not currently work. Needs to replace regex in text with replace and return new string; PROBLEM
(define/public (replaceAll-java.lang.String-java.lang.String regex replace)
(error 'replaceAll "Internal error: replaceAll is unimplemented at this time"))
(define/public (replace-all s s2) (replaceAll-java.lang.String-java.lang.String s s2))
(define/public (replaceFirst-java.lang.String-java.lang.String regex replace)
(error 'replaceFirst "Internal error: replaceFirst is unimplemented at this time"))
(define/public (replace-first s s2) (replaceFirst-java.lang.String-java.lang.String s s2))
(define/public (matches-java.lang.String regex)
(error 'matches "Internal error: matches is unimplemented at this time"))
(define/public (matches s) (matches-java.lang.String s))
(define/public (split-java.lang.String-int regex limit)
(error 'split "Internal error: split is unimplemented at this time"))
@ -573,8 +738,9 @@
(error 'trim "Internal error: trim is unimplemented at this time."))
(define/public (toCharArray) (make-java-array 'char 0 (string->list text)))
(define/public (to-char-array) (toCharArray))
;PROBLEM I am not sure what the side effects of this are supposed to be! PROBLEM!
;PROBLEM I am not sure what the side effects of this should be in context! PROBLEM!
(define/public intern
(lambda () this))
@ -632,7 +798,7 @@
;private fields
;message: String
(define message "")
(define message (make-java-string ""))
;stack: continuation-mark-set
(define stack null)
;java:exception
@ -678,11 +844,16 @@
(define/public (getMessage) message)
(define/public (getCause) cause)
(define/public (getLocalizedMessage) (send this getMessage))
(define/public (get-message) (send this getMessage))
(define/public (get-cause) (send this getCause))
(define/public (get-localized-message) (send this getLocalizedMessage))
(define/public (setStackTrace-java.lang.StackTraceElement1 elments)
(error 'setStackTrace "Internal error: setStackTrace will not be implemented until strack trace element s implemented"))
(define/public (getStackTrace)
(error 'getStackTrace "Internal error: getStackTrace will not be implemented until StackTraceElement is implemented"))
(define/public (set-stack-trace e) (send this setStackTrace-java.lang.StackTraceElement1 e))
(define/public (get-stack-trace) (send this getStackTrace))
; -> string
(define/override (toString)
@ -695,7 +866,7 @@
; -> void
(define/public (printStackTrace)
(print-error-trace (current-output-port)
(make-exn message stack)))
(make-exn (string->immutable-string message) stack)))
;These functions do not work correctly yet, and won't until printStreams are implemented
(define/public printStackTrace-PrintStream (lambda (printStream) void))
@ -703,6 +874,7 @@
;This function does nothing at this time
(define/public (fillInStackTrace) this)
(define/public (fill-in-stack-trace) (send this fillInStackTrace))
; -> string
(define/override (my-name) "Throwable")
@ -731,6 +903,243 @@
(send exn set-exception! scheme-exn)
scheme-exn))
(provide convert-assert-Throwable wrap-convert-assert-Throwable dynamic-Throwable/c
guard-convert-Throwable static-Throwable/c)
(define (wrap-convert-assert-Throwable obj p n s c)
(c:contract (c:object-contract
(initCause (c:-> c:any/c c:any/c))
(getMessage (c:-> c:any/c))
(getCause (c:-> c:any/c))
(getLocalizedMessage (c:-> c:any/c))
(setStackTrace-java.lang.StackTraceElement1 (c:-> c:any/c c:any/c))
(getStackTrace (c:-> c:any/c))
(printStackTrace (c:-> c:any/c))
(printStackTrace-PrintStream (c:-> c:any/c))
(printStackTrace-PrintWriter (c:-> c:any/c))
(fillInStackTrace (c:-> c:any/c))
(clone (c:-> c:any/c))
(equals-java.lang.Object (c:-> c:any/c c:any/c))
(finalize (c:-> c:any/c))
(getClass (c:-> c:any/c))
(hashCode (c:-> c:any/c))
(notify (c:-> c:any/c))
(notifyAll (c:-> c:any/c))
(toString (c:-> c:any/c))
(wait (c:-> c:any/c))
(wait-long (c:-> c:any/c c:any/c))
(wait-long-int (c:-> c:any/c c:any/c c:any/c))) obj p n s)
(make-object convert-assert-Throwable obj p n s c))
(define convert-assert-Throwable
(class object%
(init w p n s c)
(define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null))
(set! wrapped w)
(set! pos-blame p)
(set! neg-blame n)
(set! src s)
(set! cc-marks c)
(define/public (set-exception! exn) (send wrapped set-exception! exn))
(define/public (get-mzscheme-exception) (send wrapped get-mzscheme-exception))
(define/public (initCause-java.lang.Throwable cse)
(wrap-convert-assert-Throwable
(send wrapped initCause-java.lang.Throwable (make-object guard-convert-Throwable cse
pos-blame neg-blame src cc-marks)
pos-blame neg-blame src cc-marks)))
(define/public (getMessage)
(let ((val (send wrapped getMessage)))
(if (string? val)
(make-java-string val)
(raise (make-exn:fail
(string->immutable-string
(format "~a broke ~a contract here; Throwable's getMessage expects string return, given ~a"
pos-blame neg-blame val)) cc-marks)))))
(define/public (getCause)
(wrap-convert-assert-Throwable (send wrapped getCause)))
(define/public (getLocalizedMessage)
(let ((val (send wrapped getLocalizedMessage)))
(if (string? val)
(make-java-string val)
(raise (make-exn:fail
(string->immutable-string
(format "~a broke ~a contract here; Throwable's getLocalizedMessage expects string return, given ~a"
pos-blame neg-blame val)) cc-marks)))))
(define/public (setStackTrace-java.lang.StackTraceElement1 elements)
(send wrapped setStackTrace-java.lang.StackTraceElement1 elements))
(define/public (getStackTrace) (send wrapped getStackTrace))
(define/public (printStackTrace) (send wrapped printStackTrace))
(define/public (printStackTrace-PrintStream printStream) (send wrapped printStackTrace-PrintStream))
(define/public (printStackTrace-PrintWriter pW) (send wrapped printStackTrace-PrintWriter))
(define/public (fillInStackTrace) (send wrapped fillInStackTrace))
(define/public (clone) (send wrapped clone))
(define/public (equals-java.lang.Object obj)
(let ((val (send wrapped equals-java.lang.Object
(make-object guard-convert-Object obj pos-blame neg-blame src cc-marks))))
(unless (boolean? val)
(raise (make-exn:fail
(string->immutable-string
(format "~a broke ~a contract here; Throwable's equals expects boolean return, given ~a"
pos-blame neg-blame val)) cc-marks)))
val))
(define/public (finalize) (send wrapped finalize))
(define/public (getClass) (send wrapped getClass))
(define/public (hashCode)
(let ((val (send wrapped hashCode)))
(unless (integer? val)
(raise (make-exn:fail
(string->immutable-string
(format "~a broke ~a contract here; Throwable's hashCode expects int return, given ~a"
pos-blame neg-blame val)) cc-marks)))
val))
(define/public (notify) (send wrapped notify))
(define/public (notifyAll) (send wrapped notifyAll))
(define/public (toString)
(let ((val (send wrapped toString)))
(unless (string? val)
(raise (make-exn:fail
(string->immutable-string
(format "~a broke ~a contract here: Throwable's toString expects String return, given ~a"
pos-blame neg-blame val)) cc-marks)))
(make-java-string val)))
(define/public (wait) (send wrapped wait))
(define/public (wait-long l) (send wrapped wait-long l))
(define/public (wait-long-int l i) (send wrapped wait-long l i))
(define/public (my-name) (send wrapped my-name))
(define/public (field-names) (send wrapped field-names))
(define/public (field-values) (send wrapped field-values))
(define/public (fields-for-display) (send wrapped fields-for-display))
(super-instantiate ())))
(define dynamic-Throwable/c
(c:flat-named-contract "Throwable" (lambda (v) (is-a? v convert-assert-Throwable))))
(define guard-convert-Throwable
(class object%
(init w p n s c)
(define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null))
(set! wrapped w)
(set! pos-blame p)
(set! neg-blame n)
(set! src s)
(set! cc-marks s)
(define/public (set-exception! exn) (send wrapped set-exception! exn))
(define/public (get-mzscheme-exception) (send wrapped get-mzscheme-exception))
(define/public (initCause-java.lang.Throwable . cse)
(unless (= 1 (length cse))
(raise (make-exn:fail:contract:arity
(string->immutable-string
(format "~a broke ~a contract here: Throwable's initCause expects to be called with 1 argument, given ~n"
pos-blame neg-blame (length cse))) cc-marks)))
(make-object guard-convert-Throwable
(send wrapped initCause-java.lang.Throwable (wrap-convert-assert-Throwable (car cse)))))
(define/public (init-cause . cse)
(unless (= 1 (length cse))
(raise (make-exn:fail:contract:arity
(string->immutable-string
(format "~a broke ~a contract here: Throwable's initCause expects to be called with 1 argument, given ~n"
pos-blame neg-blame (length cse))) cc-marks)))
(make-object guard-convert-Throwable
(send wrapped initCause-java.lang.Throwable (wrap-convert-assert-Throwable (car cse) pos-blame neg-blame src cc-marks))
pos-blame neg-blame src cc-marks))
(define/public (getMessage) (send (send wrapped getMessage) get-mzscheme-string))
(define/public (get-message) (send (send wrapped getMessage) get-mzscheme-string))
(define/public (getCause) (make-object guard-convert-Throwable (send wrapped getCause) pos-blame neg-blame src cc-marks))
(define/public (get-cause) (make-object guard-convert-Throwable
(send wrapped getCause) pos-blame neg-blame src cc-marks))
(define/public (getLocalizedMessage) (send (send wrapped getLocalizedMessage) get-mzscheme-string))
(define/public (get-localized-message) (send (send wrapped getLocalizedMessage) get-mzscheme-string))
(define/public (setStackTrace-java.lang.StackTraceElement1 elements)
(send wrapped setStackTrace-java.lang.StackTraceElement1 elements))
(define/public (set-stack-trace t)
(send wrapped setStackTrace-java.lang.StackTraceElement1 t))
(define/public (getStackTrace) (send wrapped getStackTrace))
(define/public (get-stack-trace) (send wrapped getStackTrace))
(define/public (printStackTrace) (send wrapped printStackTrace))
(define/public (printStackTrace-PrintStream printStream) (send wrapped printStackTrace-PrintStream))
(define/public (printStackTrace-PrintWriter pW) (send wrapped printStackTrace-PrintWriter))
(define/public (fillInStackTrace) (send wrapped fillInStackTrace))
(define/public (fill-in-stack-trace) (send wrapped fillInStackTrace))
(define/public (clone) (send wrapped clone))
(define/public (equals-java.lang.Object . obj)
(unless (= (length obj) 1)
(raise (make-exn:fail:contract:arity
(string->immutable-string
(format "~a broke ~a contract here: Throwable's equals expects to be called with 1 argument, given ~n"
pos-blame neg-blame (length obj))) cc-marks)))
(send wrapped equals-java.lang.Object (wrap-convert-assert-Object (car obj) pos-blame neg-blame src cc-marks)))
(define/public (equals . obj)
(unless (= (length obj) 1)
(raise (make-exn:fail:contract:arity
(string->immutable-string
(format "~a broke ~a contract here: Throwable's equals expects to be called with 1 argument, given ~n"
pos-blame neg-blame (length obj))) cc-marks)))
(send wrapped equals-java.lang.Object (wrap-convert-assert-Object (car obj) pos-blame neg-blame src cc-marks)))
(define/public (finalize) (send wrapped finalize))
(define/public (getClass) (send wrapped getClass))
(define/public (get-class) (send wrapped getClass))
(define/public (hashCode) (send wrapped hashCode))
(define/public (hash-code) (send wrapped hashCode))
(define/public (notify) (send wrapped notify))
(define/public (notifyAll) (send wrapped notifyAll))
(define/public (notify-all) (send wrapped notifyAll))
(define/public (my-name) (send wrapped my-name))
(define/public (toString)
(send (send wrapped toString) get-mzscheme-string))
(define/public (to-string) (send (send wrapped toString) get-mzscheme-string))
(define/public (wait) (send wrapped wait))
(define/public (wait-long . l)
(unless (= (length l) 1)
(raise (make-exn:fail:contract:arity
(string->immutable-string
(format "~a broke ~a contract here: Throwable's wait-long expects to be called with 1 argument, given ~n"
pos-blame neg-blame (length l))) cc-marks)))
(unless (integer? (car l))
(raise (make-exn:fail
(string->immutable-string
(format "~a broke ~a contract here: Throwable's wait that takes a long argument expected long, given ~a"
pos-blame neg-blame (car l))) cc-marks)))
(send wrapped wait-long (car l)))
(define/public (wait-long-int . l)
(unless (= (length l) 2)
(raise (make-exn:fail:contract:arity
(string->immutable-string
(format "~a broke ~a contract here: Throwable's wait-long-int expects to be called with 2 arguments, given ~n"
pos-blame neg-blame (length l))) cc-marks)))
(unless (integer? (car l))
(raise (make-exn:fail
(string->immutable-string
(format "~a broke ~a contract here: Throwable's wait-long-int expected long, given ~a"
pos-blame neg-blame (car l))) cc-marks)))
(unless (integer? (cadr l))
(raise (make-exn:fail
(string->immutable-string
(format "~a broke ~a contract here: Throwable's wait-long-int expected int, given ~a"
pos-blame neg-blame (cadr l))) cc-marks)))
(send wrapped wait-long (car l) (cadr l)))
(define/public (field-names) (send wrapped field-names))
(define/public (field-values) (send wrapped field-values))
(define/public (fields-for-display) (send wrapped fields-for-display))
(super-instantiate ())))
(define static-Throwable/c
(c:flat-named-contract "Throwable" (lambda (v) (is-a? v guard-convert-Throwable))))
(provide wrap-convert-assert-Class guard-convert-Class wrap-convert-assert-PrintString wrap-convert-assert-PrintWriter)
(define (wrap-convert-assert-Class . args) (void))
(define guard-convert-Class (class object% (super-new)))
(define (wrap-convert-assert-PrintString . args) (void))
(define (wrap-convert-assert-PrintWriter . args) (void))
(compile-rest-of-lang (list "Object" "Throwable" "String" "Exception" "RuntimeException" "Comparable"))
)

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

@ -17,5 +17,5 @@
()
(("Object" "java" "lang"))
()
"version1")
"version2")

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

@ -1,4 +1,6 @@
#cs
(module Object mzscheme
(require "Object-composite.ss")
(provide ObjectI Object-Mix Object))
(provide ObjectI Object-Mix Object)
(provide guard-convert-Object convert-assert-Object wrap-convert-assert-Object
dynamic-Object/c static-Object/c))

14
collects/profj/libs/java/lang/RuntimeException.ss
View File

@ -1,3 +1,13 @@
(module |RuntimeException| mzscheme
(module RuntimeException mzscheme
(require "Object-composite.ss")
(provide |RuntimeException|))
(provide
RuntimeException
guard-convert-RuntimeException
convert-assert-RuntimeException
wrap-convert-assert-RuntimeException
dynamic-RuntimeException/c
static-RuntimeException/c
RuntimeException-RuntimeException-constructor~generic
RuntimeException-RuntimeException-constructor-java.lang.String~generic
RuntimeException-RuntimeException-constructor-java.lang.String-java.lang.Throwable~generic
RuntimeException-RuntimeException-constructor-java.lang.Throwable~generic))

12
collects/profj/libs/java/lang/SecurityException.ss
View File

@ -1,3 +1,11 @@
(module |SecurityException| mzscheme
(module SecurityException mzscheme
(require "Object-composite.ss")
(provide |SecurityException|))
(provide
SecurityException
guard-convert-SecurityException
convert-assert-SecurityException
wrap-convert-assert-SecurityException
dynamic-SecurityException/c
static-SecurityException/c
SecurityException-SecurityException-constructor~generic
SecurityException-SecurityException-constructor-java.lang.String~generic))

6
collects/profj/libs/java/lang/String.jinfo
View File

@ -19,7 +19,7 @@
("getChars" (public) void (int int (1 char) int) () ("String" "java" "lang"))
("getBytes" (public) (1 byte) (("String" "java" "lang")) (("UnsupportedEncodingException" "java" "io")) ("String" "java" "lang"))
("getBytes" (public) (1 byte) () () ("String" "java" "lang"))
("equals" (public) boolean (("Object" "java" "lang")) () ("String" "java" "lang"))
;("equals" (public) boolean (("Object" "java" "lang")) () ("String" "java" "lang"))
("contentEquals" (public) boolean (("StringBuffer" "java" "lang")) () ("String" "java" "lang"))
("equalsIgnoreCase" (public) boolean (("String" "java" "lang")) () ("String" "java" "lang"))
("compareTo" (public) int (("String" "java" "lang")) () ("String" "java" "lang"))
@ -54,7 +54,7 @@
("toUpperCase" (public) ("String" "java" "lang") (("Locale" "java" "util")) () ("String" "java" "lang"))
("toUpperCase" (public) ("String" "java" "lang") () () ("String" "java" "lang"))
("trim" (public) ("String" "java" "lang") () () ("String" "java" "lang"))
("toString" (public) ("String" "java" "lang") () () ("String" "java" "lang"))
;("toString" (public) ("String" "java" "lang") () () ("String" "java" "lang"))
("toCharArray" (public) (1 char) () () ("String" "java" "lang"))
("valueOf" (public static) ("String" "java" "lang") (("Object" "java" "lang")) () ("String" "java" "lang"))
("valueOf" (public static) ("String" "java" "lang") ((1 char)) () ("String" "java" "lang"))
@ -85,4 +85,4 @@
()
(("Object" "java" "lang"))
(("Serializable" "java" "io") ("Comparable" "java" "lang") ("CharSequence" "java" "lang"))
"version1")
"version2")

13
collects/profj/libs/java/lang/StringIndexOutOfBoundsException.ss
View File

@ -1,3 +1,12 @@
(module |StringIndexOutOfBoundsException| mzscheme
(module StringIndexOutOfBoundsException mzscheme
(require "Object-composite.ss")
(provide |StringIndexOutOfBoundsException|))
(provide
StringIndexOutOfBoundsException
guard-convert-StringIndexOutOfBoundsException
convert-assert-StringIndexOutOfBoundsException
wrap-convert-assert-StringIndexOutOfBoundsException
dynamic-StringIndexOutOfBoundsException/c
static-StringIndexOutOfBoundsException/c
StringIndexOutOfBoundsException-StringIndexOutOfBoundsException-constructor~generic
StringIndexOutOfBoundsException-StringIndexOutOfBoundsException-constructor-java.lang.String~generic
StringIndexOutOfBoundsException-StringIndexOutOfBoundsException-constructor-int~generic))

4
collects/profj/libs/java/lang/Throwable.jinfo
View File

@ -17,7 +17,7 @@
("printStackTrace" (public) void (("PrintString" "java" "io")) () ("Throwable" "java" "lang"))
("printStackTrace" (public) void (("PrintWriter" "java" "io")) () ("Throwable" "java" "lang"))
("setStackTrace" (public) void ((1 ("StackTraceElement" "java" "lang"))) () ("Throwable" "java" "lang"))
("toString" (public) ("String" "java" "lang") () () ("Throwable" "java" "lang"))
;("toString" (public) ("String" "java" "lang") () () ("Throwable" "java" "lang"))
("Object" (public) ctor () () ("Object" "java" "lang"))
("clone" (protected) ("Object" "java" "lang") () (("CloneNotSupportedException" "java" "lang"))("Object" "java" "lang"))
@ -35,4 +35,4 @@
()
(("Object" "java" "lang"))
(("Serializable" "java" "io"))
"version1")
"version2")

4
collects/profj/libs/java/lang/Throwable.ss
View File

@ -2,4 +2,6 @@
(module Throwable mzscheme
(require "Object-composite.ss")
(provide Throwable (struct java:exception (object))
exception-is-a? handle-exception create-java-exception))
exception-is-a? handle-exception create-java-exception)
(provide guard-convert-Throwable convert-assert-Throwable wrap-convert-assert-Throwable
dynamic-Throwable/c static-Throwable/c))

12
collects/profj/libs/java/lang/UnsupportedOperationException.ss
View File

@ -1,3 +1,11 @@
(module |UnsupportedOperationException| mzscheme
(module UnsupportedOperationException mzscheme
(require "Object-composite.ss")
(provide |UnsupportedOperationException|))
(provide
UnsupportedOperationException
guard-convert-UnsupportedOperationException
convert-assert-UnsupportedOperationException
wrap-convert-assert-UnsupportedOperationException
dynamic-UnsupportedOperationException/c
static-UnsupportedOperationException/c
UnsupportedOperationException-UnsupportedOperationException-constructor~generic
UnsupportedOperationException-UnsupportedOperationException-constructor-java.lang.String~generic))

4
collects/profj/parsers/advanced-parser.ss
View File

@ -241,9 +241,9 @@
(VariableDeclaratorId
[(IDENTIFIER)
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f 0 (build-src 1)) (build-src 1))]
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f 0 (build-src 1)) #f (build-src 1))]
[(IDENTIFIER Dims)
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f $2 (build-src 2)) (build-src 2))])
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f $2 (build-src 2)) #f (build-src 2))])
(VariableInitializer
[(Expression) $1]

2
collects/profj/parsers/beginner-parser.ss
View File

@ -199,7 +199,7 @@
(VariableDeclaratorId
[(IDENTIFIER)
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f 0 (build-src 1)) (build-src 1))])
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f 0 (build-src 1)) #f (build-src 1))])
;; 19.8.3
(MethodDeclaration

14
collects/profj/parsers/full-parser.ss
View File

@ -20,7 +20,7 @@
(parser
(start CompilationUnit Interactions VariableInitializer Type)
;;(debug "parser.output")
(tokens java-vals special-toks Keywords Separators EmptyLiterals Operators)
(tokens java-vals special-toks Keywords ExtraKeywords Separators EmptyLiterals Operators)
(error (lambda (tok-ok name val start-pos end-pos)
(raise-read-error (format "Parse error near <~a:~a>" name val)
(file-path)
@ -59,7 +59,8 @@
;; 19.4
(Type
[(PrimitiveType) $1]
[(ReferenceType) $1])
[(ReferenceType) $1]
[(dynamic) (make-type-spec 'dynamic 0 (build-src 1))])
(PrimitiveType
[(NumericType) $1]
@ -250,9 +251,9 @@
(VariableDeclaratorId
[(IDENTIFIER)
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f 0 (build-src 1)) (build-src 1))]
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f 0 (build-src 1)) #f (build-src 1))]
[(IDENTIFIER Dims)
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f $2 (build-src 2)) (build-src 2))])
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f $2 (build-src 2)) #f (build-src 2))])
(VariableInitializer
[(Expression) $1]
@ -479,7 +480,8 @@
(else (var-init-var-decl d))))
(new-decl (make-var-decl (var-decl-name decl)
`(final)
(var-decl-type decl)
(var-decl-type-spec decl)
#f
(var-decl-src decl))))
(cond
@ -843,6 +845,8 @@
$5)]
[(O_PAREN PrimitiveType C_PAREN UnaryExpression)
(make-cast #f (build-src 4) $2 $4)]
[(O_PAREN dynamic C_PAREN UnaryExpression)
(make-cast #f (build-src 4) (make-type-spec 'dynamic 0 (build-src 2 2)) $4)]
[(O_PAREN Expression C_PAREN UnaryExpressionNotPlusMinus)
(if (access? $2)
(make-cast #f (build-src 4)

3
collects/profj/parsers/general-parsing.ss
View File

@ -78,8 +78,9 @@
(make-type-spec
(type-spec-name type)
(+ (type-spec-dim type)
(type-spec-dim (var-decl-type decl)))
(type-spec-dim (var-decl-type-spec decl)))
(type-spec-src type))
#f
(var-decl-src decl)))
((var-init? decl)
(make-var-init

2
collects/profj/parsers/intermediate-parser.ss
View File

@ -223,7 +223,7 @@
[(IDENTIFIER)
(make-var-decl (make-id $1 (build-src 1))
(list (make-modifier 'public #f))
(make-type-spec #f 0 (build-src 1)) (build-src 1))])
(make-type-spec #f 0 (build-src 1)) #f (build-src 1))])
(VariableInitializer
[(Expression) $1])

16
collects/profj/parsers/lexer.ss
View File

@ -7,7 +7,8 @@
(require (lib "lex.ss" "parser-tools")
(prefix re: (lib "lex-sre.ss" "parser-tools")))
(prefix re: (lib "lex-sre.ss" "parser-tools"))
(lib "parameters.ss" "profj"))
(provide (all-defined))
(define-struct test-case (test))
@ -39,6 +40,8 @@
const for new switch
continue goto package synchronized))
(define-empty-tokens ExtraKeywords (dynamic))
(define-tokens java-vals
(STRING_LIT CHAR_LIT INTEGER_LIT LONG_LIT FLOAT_LIT DOUBLE_LIT
IDENTIFIER STRING_ERROR NUMBER_ERROR HEX_LIT OCT_LIT HEXL_LIT OCTL_LIT))
@ -293,6 +296,11 @@
((re:: OctalNumeral IntegerTypeSuffix)
(token-OCTL_LIT (string->number (trim-string lexeme 1 1) 8)))
("dynamic"
(cond
((dynamic?) (string->symbol lexeme))
(else (token-IDENTIFIER lexeme))))
;; 3.9
(Keyword (string->symbol lexeme))
@ -390,6 +398,12 @@
;; 3.10.5
(#\" ((colorize-string start-pos) input-port))
("dynamic"
(cond
((dynamic?) (syn-val lexeme 'keyword #f start-pos end-pos))
(else (syn-val lexeme 'identifier #f start-pos end-pos))))
;; 3.9
(Keyword (syn-val lexeme 'keyword #f start-pos end-pos))

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

@ -3,7 +3,8 @@
"types.ss"
"parameters.ss"
(lib "class.ss")
(lib "list.ss"))
(lib "list.ss")
(lib "etc.ss"))
(provide translate-program translate-interactions (struct compilation-unit (contains code locations depends)))
@ -16,7 +17,7 @@
;NOTE! Abstract classes are treated no differently than any class.
;Parameters for information about each class
(define class-name (make-parameter #f))
(define class-name (make-parameter "interactions"))
(define loc (make-parameter #f))
(define interactions? (make-parameter #f))
(define class-override-table (make-parameter null))
@ -175,7 +176,7 @@
#f))
((field? prog)
(translate-field `(private)
(field-type prog)
(field-type-spec prog)
(field-name prog)
(and (var-init? prog) prog)
(if (var-init? prog)
@ -615,6 +616,14 @@
(accesses-protected methods))
overridden-methods))
(dynamic-method-defs (generate-dyn-method-defs names-for-dynamic))
(wrapper-classes (append (generate-wrappers (class-name)
(filter
(lambda (m) (not (or (private? (method-record-modifiers m))
(static? (method-record-modifiers m)))))
(class-record-methods (send type-recs get-class-record (list (class-name)))))
(append (accesses-public fields) (accesses-package fields)
(accesses-protected fields)))
(generate-contract-defs (class-name))))
(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
@ -625,6 +634,11 @@
(accesses-package fields)
(accesses-protected fields))))
(provides `(provide ,(build-identifier (class-name))
,@(map build-identifier (list (format "guard-convert-~a" (class-name))
(format "convert-assert-~a" (class-name))
(format "wrap-convert-assert-~a" (class-name))
(format "dynamic-~a/c" (class-name))
(format "static-~a/c" (class-name))))
;,@restricted-methods
,@(map build-identifier static-method-names)
,@(map build-identifier static-field-names)
@ -669,7 +683,7 @@
(else (cons (string->symbol (format "~a~~f" (car args)))
(loop (cdr args)))))))))
,@(map (lambda (f) (translate-field (map modifier-kind (field-modifiers f))
(field-type f)
(field-type-spec f)
(field-name f)
(and (var-init? f) f)
(if (var-init? f)
@ -765,6 +779,7 @@
(initialize-src i)
type-recs))
(members-static-init class-members))
,@wrapper-classes
)
#f)))
@ -782,15 +797,192 @@
(parent-name old-parent-name)
(class-override-table old-override-table))))))))
;generate-contract-defs: string -> (list sexp)
(define (generate-contract-defs class-name)
`((define ,(build-identifier (string-append "dynamic-" class-name "/c"))
(c:flat-named-contract ,class-name
(lambda (v) (is-a? v ,(build-identifier (string-append "convert-assert-" class-name))))))
(define ,(build-identifier (string-append "static-" class-name "/c"))
(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)
(define (generate-wrappers class-name methods fields)
(let* ((normal-methods (filter
(lambda (m)
(not (or (eq? (method-record-rtype m) 'ctor)
(method-record-override m)))) methods))
(class-text
(lambda (name from-dynamic? extra-methods)
`(define ,name
(class object%
(super-new)
(init w p n s c)
(define-values (wrapped-obj pos-blame neg-blame src cc-marks) (values null null null null null))
(set! wrapped-obj w)
(set! pos-blame p)
(set! neg-blame n)
(set! src s)
(set! cc-marks c)
,(generate-wrapper-fields fields from-dynamic?)
,@(generate-wrapper-methods (filter (lambda (m) (not (eq? (method-record-rtype m) 'ctor)))
normal-methods) #f from-dynamic?)
,@extra-methods
(define/public (my-name) (send wrapped-obj my-name))
(define/public (field-names) (send wrapped-obj field-names))
(define/public (field-values) (send wrapped-obj field-values))
(define/public (fields-for-display) (send wrapped-obj fields-for-display))
))))
(dynamic-callables (refine-method-list methods)))
(list
`(define (,(build-identifier (string-append "wrap-convert-assert-" class-name)) obj p n s c)
(c:contract ,(methods->contract normal-methods) obj p n s)
(make-object ,(build-identifier (string-append "convert-assert-" class-name)) obj p n s c))
(class-text (build-identifier (string-append "convert-assert-" class-name)) #t null)
(class-text (build-identifier (string-append "guard-convert-" class-name)) #f
(generate-wrapper-methods dynamic-callables #t #f)))))
;generate-wrapper-fields: (list field) boolean -> sexp
(define (generate-wrapper-fields fields from-dynamic?)
`(field ,@(map (lambda (field)
(let* ((field-name (id-string (field-name field)))
(value `(,(create-get-name field-name) wrapped-obj)))
`(,(build-identifier (build-var-name field-name))
,(convert-value (if from-dynamic? (assert-value value (field-type field) #t) value)
(field-type field)
from-dynamic?))))
fields)))
;generate-wrapper-methods: (list method-record) boolean boolean -> (list sexp)
;When is dynamic-callable?, will define methods callable from a dynamic context
(define (generate-wrapper-methods methods dynamic-callable? from-dynamic?)
(map (lambda (method)
(let* ((call-name (mangle-method-name (method-record-name method)
(method-record-atypes method)))
(define-name (if dynamic-callable? (java-name->scheme (method-record-name method)) call-name))
(list-of-args (map (lambda (a) (gensym "arg-")) (method-record-atypes method))))
(cond
((and dynamic-callable? (equal? define-name call-name))
`(void))
(from-dynamic?
`(define/public (,(build-identifier define-name) ,@list-of-args)
,(convert-value (assert-value `(send wrapped-obj ,(build-identifier call-name)
,@(map (lambda (arg type)
(convert-value (assert-value arg type #f) type #f))
list-of-args (method-record-atypes method)))
(method-record-rtype method) from-dynamic?)
(method-record-rtype method)
from-dynamic?)))
(else
`(define/public (,(build-identifier define-name) . args)
(unless (= (length args) ,(length list-of-args))
(raise (make-exn:fail:contract:arity
(string->immutable-string
(format "~a broke the contract with ~a here, method ~a called with ~a args, instead of ~a"
pos-blame neg-blame ,(method-record-name method) (length args) ,(length list-of-args)))
cc-marks)))
(let (,@(map (lambda (arg type ref)
`(,arg ,(convert-value (assert-value `(list-ref args ,ref) type #t) type #t)))
list-of-args (method-record-atypes method) (list-from 0 (length list-of-args))))
,(convert-value `(send wrapped-obj ,(build-identifier call-name)
,@list-of-args) (method-record-rtype method) #f)))))))
methods))
(define (list-from from to)
(cond
((= from to) null)
(else (cons from (list-from (add1 from) to)))))
;methods->contract: (list method-record) -> sexp
(define (methods->contract methods)
`(c: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)))
methods)))
;convert-value: sexp type boolean -> sexp
(define (convert-value value type from-dynamic?)
(cond
((symbol? type)
(case type
((int byte short long float double char boolean dynamic void) value)
((string) (if from-dynamic?
`(make-java-string ,value)
`(send ,value get-mzscheme-string)))))
((dynamic-val? type) value)
((array-type? type) value
#;(if from-dynamic?
`(wrap-convert-assert-array ,value pos-blame neg-blame src cc-marks)
`(make-object guard-convert-array ,value pos-blame neg-blame src cc-marks)))
((ref-type? type)
(cond
((and (equal? string-type type) from-dynamic?) `(make-java-string ,value))
((equal? string-type type) `(send ,value get-mzscheme-string))
((equal? type (make-ref-type "Class" '("java" "lang"))) value)
(from-dynamic? `(,(build-identifier (string-append "wrap-convert-assert-" (ref-type-class/iface type)))
,value pos-blame neg-blame src cc-marks))
(else `(make-object ,(build-identifier (string-append "guard-convert-" (ref-type-class/iface type)))
,value pos-blame neg-blame src cc-marks))))
(else value)))
;assert-value: sexp type boolean -> sexp
(define (assert-value value type from-dynamic?)
(cond
((symbol? type)
(let ((check
(lambda (ok?)
`(let ((v-1 ,value))
(if (,ok? v-1) v-1
(raise (make-exn:fail (string->immutable-string
(format "~a broke the contract with ~a here, type-mismatch expected ~a given ~a"
pos-blame neg-blame (quote ,type) v-1)) cc-marks)))))))
(case type
((int byte short long) (check 'integer?))
((float double) (check 'real?))
((char) (check 'character?))
((string) (check 'string?))
((boolean) (check 'boolean?))
((dynamic) value))))
((and (ref-type? type) (equal? string-type type))
(assert-value value 'string from-dynamic?))
(else value)))
;Removes from the list all methods that are not callable from a dynamic context
;refine-method-list: (list method-record) -> (list method-record)
(define (refine-method-list methods)
(cond
((null? methods) methods)
((method-record-override (car methods))
(refine-method-list (cdr methods)))
((eq? 'ctor (method-record-rtype (car methods)))
(refine-method-list (cdr methods)))
(else
(let ((overloaded-removed
(filter (lambda (m) (not (equal? (method-record-name (car methods))
(method-record-name m))))
(cdr methods))))
(if (> (length (cdr methods))
(length overloaded-removed))
(refine-method-list overloaded-removed)
(cons (car methods) (refine-method-list (cdr methods))))))))
;generate-dynamic-names: (list method) (list method)-> (list (list string method))
(define (generate-dynamic-names methods overridden-methods)
(map (lambda (method)
(list (java-name->scheme (id-string (method-name method)))
method))
(refine-method-list methods overridden-methods)))
(refine-method-list-old methods overridden-methods)))
;refine-method-list: (list method) (list method) -> (list method)
(define (refine-method-list methods overridden-methods)
;refine-method-list-old: (list method) (list method) -> (list method)
(define (refine-method-list-old methods overridden-methods)
(if (null? methods)
methods
(let ((overloaded-removed
@ -801,12 +993,12 @@
(cond
((> (length (cdr methods))
(length overloaded-removed))
(refine-method-list overloaded-removed overridden-methods))
(refine-method-list-old overloaded-removed overridden-methods))
((memq (car methods) overridden-methods)
(refine-method-list (cdr methods) overridden-methods))
(refine-method-list-old (cdr methods) overridden-methods))
((eq? 'ctor (method-record-rtype (method-rec (car methods))))
(refine-method-list (cdr methods) overridden-methods))
(else (cons (car methods) (refine-method-list (cdr methods) overridden-methods)))))))
(refine-method-list-old (cdr methods) overridden-methods))
(else (cons (car methods) (refine-method-list-old (cdr methods) overridden-methods)))))))
;generate-dyn-method-defs: (list (list string method)) -> (list syntax)
(define (generate-dyn-method-defs methods)
@ -884,7 +1076,7 @@
((= d 0) null)
(else (cons (string->symbol (format "encl-this-~a~~f" d))
(loop (sub1 d))))))))
(parm-types (map (lambda (p) (type-spec-to-type (field-type p) #f 'full type-recs)) parms)))
(parm-types (map field-type #;(lambda (p) (type-spec-to-type (field-type-spec p) #f 'full type-recs)) parms)))
(make-syntax #f
`(define/public (,(build-identifier (mangle-method-name ctor-name parm-types)) ,@translated-parms)
(let ((temp-obj (make-object ,(build-identifier class-name)
@ -1255,7 +1447,7 @@
(f (car fields)))
(cons (make-syntax #f
`(define ,(translate-id name (id-src (field-name f)))
,(translate-field-body (and (var-init? f) f) (field-type f)))
,(translate-field-body (and (var-init? f) f) (field-type-spec f)))
(build-src (if (var-init? f) (var-init-src f) (var-decl-src f))))
(create-static-fields (cdr names) (cdr fields))))))
@ -1268,14 +1460,22 @@
(make-syntax #f `(define ,field-name ,value) (build-src src))
(make-syntax #f `(field (,field-name ,value)) (build-src src)))))
;translate-field-body (U bool var-init) type -> syntax
;translate-field-body (U bool var-init) type-spec -> syntax
(define (translate-field-body init? type)
(if init?
(if (array-init? (var-init-init init?))
(cond
(init?
(let ((actual-type (if (array-init? (var-init-init init?))
'dynamic ;Problem: array type needed here
(expr-types (var-init-init init?))))
(body-syntax (if (array-init? (var-init-init init?))
(initialize-array (array-init-vals (var-init-init init?))
type)
(translate-expression (var-init-init init?)))
(get-default-value type)))
(translate-expression (var-init-init init?)))))
(if (or (eq? 'dynamic (field-type init?))
(dynamic-val? (field-type init?)))
(make-syntax #f (guard-convert-value body-syntax actual-type) body-syntax)
body-syntax)))
(else (get-default-value type))))
;translate-initialize: bool block src string type-records -> syntax
(define (translate-initialize static? body src type-recs)
@ -1373,7 +1573,7 @@
(lambda (expr key src)
(create-syntax #f `(let* ((obj ,expr)
(exn (make-java:exception
(send (send obj |getMessage|) get-mzscheme-string)
(string->immutable-string (send (send obj |getMessage|) get-mzscheme-string))
(current-continuation-marks) obj)))
(send obj set-exception! exn)
(,(create-syntax #f 'raise (build-src key)) exn))
@ -1405,11 +1605,11 @@
(build-src src)))
;translate-for: (U (list statement) (list field)) syntax (list syntax) syntax src type-records-> syntax
(define (translate-for init cond incr body src type-recs)
(define (translate-for init condi incr body src type-recs)
(let ((loop `(let/ec loop-k
(let loop ((continue? #f))
(when continue? ,@(if (null? incr) '((void)) incr))
(when ,cond
(when ,condi
,body
,@incr
(loop #f)))))
@ -1418,12 +1618,22 @@
(make-syntax #f `(letrec (,@(map (lambda (var)
`(,(translate-id (build-var-name (id-string (field-name var)))
(id-src (field-name var)))
,(if (var-init? var)
,(cond
((var-init? var)
(let ((actual-type
(if (array-init? (var-init-init var))
'dynamic ;Problem: need array-type here
(expr-types (var-init-init var))))
(var-value
(if (array-init? (var-init-init var))
(initialize-array (array-init-vals (var-init-init var))
(field-type var))
(translate-expression (var-init-init var)))
(get-default-value (field-type var)))))
(field-type-spec var))
(translate-expression (var-init-init var)))))
(if (or (eq? 'dynamic (field-type var))
(dynamic-val? (field-type var)))
(make-syntax #f (guard-convert-value var-value actual-type) var-value)
var-value)))
(else (get-default-value (field-type-spec var))))))
init))
,loop) source)
(make-syntax #f `(begin
@ -1478,8 +1688,8 @@
(map (lambda (catch)
(let* ((catch-var (catch-cond catch))
(var-src (var-decl-src catch-var))
(class-name (get-class-name (field-type catch-var)))
(isRuntime? (descendent-Runtime? (field-type catch-var) type-recs))
(class-name (get-class-name (field-type-spec catch-var)))
(isRuntime? (descendent-Runtime? (field-type-spec catch-var) type-recs))
(type
(if isRuntime?
(make-syntax #f `exn? (build-src var-src))
@ -1546,12 +1756,20 @@
(id (translate-id (build-var-name (id-string (field-name var))) (id-src (field-name var)))))
(list (make-syntax #f
`(letrec
((,id ,(if is-var-init?
(if (array-init? (var-init-init var))
((,id ,(cond
(is-var-init?
(let ((actual-type (if (array-init? (var-init-init var))
'dynamic ;Problem: need array type here
(expr-types (var-init-init var))))
(var-value (if (array-init? (var-init-init var))
(initialize-array (array-init-vals (var-init-init var))
(field-type var))
(translate-expression (var-init-init var)))
(get-default-value (field-type var)))))
(field-type-spec var))
(translate-expression (var-init-init var)))))
(if (or (eq? 'dynamic (field-type var))
(dynamic-val? (field-type var)))
(guard-convert-value var-value actual-type)
var-value)))
(else (get-default-value (field-type-spec var))))))
,@(if (null? statements)
(list `(void))
(translate statements)))
@ -1600,39 +1818,95 @@
;translate-contract
;translates types into contracts
;type->contract: type -> sexp
(define (type->contract type)
;type->contract: type boolean -> sexp
(define (type->contract type from-dynamic? . stop?)
(cond
((dynamic-val? type)
(if (null? stop?)
(type->contract (dynamic-val-type type) from-dynamic?)
(type->contract (dynamic-val-type type) from-dynamic? #t)))
((symbol? type)
(case type
((int short long byte) 'integer?)
((long float) '(c:and/c number? inexact?))
((double float) '(c:and/c number? inexact?))
((boolean) 'boolean?)
((char) 'char?)
((string) `(c:is-a?/c ,(if (send (types) require-prefix '("String" "java" "lang") (lambda () #f))
'java.lang.String 'String)))))
((string String)
(if from-dynamic?
`string?
`(c: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)
(let ((class-name (cons (ref-type-class/iface type) (ref-type-path type))))
`(c:is-a?/c
,(build-identifier (if (send (types) require-prefix class-name (lambda () #f))
(format "~a~a" (apply string-append (map (lambda (s) (string-append s "."))
(map id-string (ref-type-path type))))
(ref-type-class/iface type))
(ref-type-class/iface type))))))
(if (equal? type string-type)
(type->contract 'string from-dynamic?)
`(c:union (c:is-a?/c object%) string?)))
((unknown-ref? type)
`(c:object-contract ,@(map (lambda (m)
`(,(string->symbol (java-name->scheme (method-contract-name m)))
,(type->contract m)))
(unknown-ref-methods type))
,@(map (lambda (f) `(field ,(string->symbol (java-name->scheme (scheme-val-name f)))
,(type->contract (scheme-val-type f))))
(unknown-ref-fields type))))
(if (not (null? stop?))
`(c:union (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))))
,(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"))
,(type->contract (field-contract-type (unknown-ref-access type)) from-dynamic?)))))))
((method-contract? type)
`(c:-> ,@(map type->contract (map scheme-val-type (method-contract-args type)))
,(type->contract (scheme-val-type (method-contract-return type)))))
`(c:-> ,@(map (lambda (a) (type->contract a from-dynamic?)) (method-contract-args type))
,(type->contract (method-contract-return type) from-dynamic? #t)))
((not type) 'c:any/c)
))
;guard-convert-value syntax type -> sexp
(define (guard-convert-value val type)
(cond
((dynamic-val? type) val)
((symbol? type)
(case type
((int short long byte float double boolean char dynamic void) val)
((string String) `(send ,val get-mzscheme-string))))
((ref-type? type)
(if (equal? type string-type)
`(send ,val get-mzscheme-string)
(let ((prefix (if (send (types) require-prefix? (cons (ref-type-class/iface type) (ref-type-path type))
(lambda () #f))
(apply string-append (map (lambda (s) (string-append s ".")) (ref-type-path type)))
"")))
`(make-object ,(build-identifier (string-append prefix "guard-convert-" (ref-type-class/iface type)))
,val (quote ,(string->symbol (class-name))) '|infered contract| #`,val (current-continuation-marks)))))
(else val)))
;convert-assert-value: syntax type -> sexp
(define (convert-assert-value val type)
(cond
((dynamic-val? type) (convert-assert-value val (dynamic-val-type type)))
((symbol? type)
(case type
((int short long byte float double boolean char dynamic void) val)
((string String)
`(let ((val ,val))
(if (string? val)
(make-java-string val)
(raise (make-exn:fail (string->immutable-string
(format "~a broke infered contract here: expected String received ~a"
,(class-name) val)) (current-continuation-marks))))))))
((unknown-ref? type)
`(let ((val ,val))
(if (string? val)
(make-java-string val)
val)))
((ref-type? type)
(cond
((equal? type string-type)
(convert-assert-value val 'string))
(else
(let ((prefix (if (send (types) require-prefix? (cons (ref-type-class/iface type) (ref-type-path type))
(lambda () #f))
(apply string-append (map (lambda (s) (string-append s ".")) (ref-type-path type)))
"")))
`(,(build-identifier (string-append prefix "wrap-convert-assert-" (ref-type-class/iface type)))
,val (quote ,(string->symbol (class-name))) '|infered contract| #`,val (current-continuation-marks))))))
(else val)))
;------------------------------------------------------------------------------------------------------------------------
;translate-expression
;translates a Java expression into a Scheme expression.
@ -1662,7 +1936,9 @@
((call? expr) (translate-call (call-expr expr)
(call-method-name expr)
(map translate-expression (call-args expr))
(map expr-types (call-args expr))
(call-method-record expr)
(expr-types expr)
(expr-src expr)))
((class-alloc? expr) (translate-class-alloc (class-alloc-name expr)
(map expr-types (class-alloc-args expr))
@ -1704,6 +1980,7 @@
(expr-src expr)))
((cast? expr) (translate-cast (cast-type expr)
(translate-expression (cast-expr expr))
(expr-types expr)
(expr-src expr)))
((instanceof? expr) (translate-instanceof (translate-expression (instanceof-expr expr))
(instanceof-type expr)
@ -1740,8 +2017,8 @@
;;make-is-test sym -> (type -> bool)
(define (make-is-test kind)
(lambda (type)
(if (scheme-val? type)
(eq? (scheme-val-type type) kind)
(if (dynamic-val? type)
(eq? (dynamic-val-type type) kind)
(eq? type kind))))
;;is-string? type -> bool
@ -1751,65 +2028,107 @@
;;is-char? type -> bool
(define is-char? (make-is-test 'char))
;Converted
;translate-bin-op: symbol syntax type syntax type src src type-> syntax
(define (translate-bin-op op left left-type right right-type key src type)
(let* ((source (build-src src))
(op-syntax (create-syntax #f op (build-src key)))
(left (if (is-char? left-type)
(make-syntax #f `(char->integer ,left) #f)
left))
(right (if (is-char? right-type)
(make-syntax #f `(char->integer ,right) #f)
right))
(key-src (build-src key))
(op-syntax (create-syntax #f op key-src))
(left (cond
((is-char? left-type)
(make-syntax #f `(char->integer ,left) #f))
((and (dynamic-val? type) (not (memq op '(== != & ^ or && oror))))
(create-syntax #f `(c:contract number? ,left (quote ,(string->symbol (class-name))) '|infered contract|) left))
(else left)))
(right (cond
((is-char? right-type)
(make-syntax #f `(char->integer ,right) #f))
((and (dynamic-val? type) (not (memq op '(== != & ^ or && oror))))
(create-syntax #f `(c:contract number? ,right (quote ,(string->symbol (class-name))) '|infered contract|) right))
(else right)))
(result
(case op
;Mathematical operations
;PROBLEM! + and - do not take into account the possibility of overflow
((+)
(create-syntax #f
(cond
((and (is-string-type? type) (is-string-type? left-type))
(make-syntax #f `(send ,left concat-java.lang.String (javaRuntime:convert-to-string ,right)) source))
`(send ,left concat-java.lang.String (javaRuntime:convert-to-string ,right)))
((and (is-string-type? type) (is-string-type? right-type))
(make-syntax #f `(send (javaRuntime:convert-to-string ,left) concat-java.lang.String ,right) source))
`(send (javaRuntime:convert-to-string ,left) concat-java.lang.String ,right))
((is-string-type? type)
(make-syntax #f
`(send (javaRuntime:convert-to-string ,left) concat-java.lang.String
(javaRuntime:convert-to-string ,right))
source))
(javaRuntime:convert-to-string ,right)))
(else
(create-syntax #f `(,op-syntax ,left ,right) source))))
((- *) (make-syntax #f `(,op-syntax ,left ,right) source))
((/) (if (is-int? type)
(make-syntax #f `(,(create-syntax #f 'javaRuntime:divide-int (build-src key)) ,left ,right) source)
(make-syntax #f `(,(create-syntax #f 'javaRuntime:divide-float (build-src key)) ,left ,right) source)))
((%) (make-syntax #f `(,(create-syntax #f 'javaRuntime:mod (build-src key)) ,left ,right) source))
`(,op-syntax ,left ,right))) source))
((- *)
(create-syntax #f `(,op-syntax ,left ,right) source))
((/)
(make-syntax
#f
(cond
((or (is-int? type) (and (dynamic-val? type) (is-int? (dynamic-val-type type))))
`(,(create-syntax #f 'javaRuntime:divide-int key-src) ,left ,right))
(else
`(,(create-syntax #f 'javaRuntime:divide-float key-src) ,left ,right))) source))
((%) (make-syntax #f `(,(create-syntax #f 'javaRuntime:mod key-src) ,left ,right) source))
;Shift operations
((<< >> >>>) (make-syntax #f `(,(create-syntax #f 'javaRuntime:shift (build-src key)) (quote ,op) ,left ,right) source))
((<< >> >>>)
(make-syntax #f
`(,(create-syntax #f 'javaRuntime:shift key-src) (quote ,op) ,left ,right) source))
;comparisons
((< > <= >=) (make-syntax #f `(,op-syntax ,left ,right) source))
((==)
(if (and (prim-numeric-type? left-type) (prim-numeric-type? right-type))
(make-syntax #f `(,(create-syntax #f '= (build-src key)) ,left ,right) source)
(make-syntax #f `(,(create-syntax #f 'eq? (build-src key)) ,left ,right) source)))
((!=) (make-syntax #f `(,(create-syntax #f 'javaRuntime:not-equal (build-src key)) ,left ,right) source))
(make-syntax #f
(cond
((or (dynamic-val? left-type) (dynamic-val? right-type))
`(,(create-syntax #f 'eq? key-src) ,left ,right))
((and (prim-numeric-type? left-type) (prim-numeric-type? right-type))
`(,(create-syntax #f '= key-src) ,left ,right))
(else
`(,(create-syntax #f 'eq? key-src) ,left ,right))) source))
((!=)
(make-syntax #f `(,(create-syntax #f 'javaRuntime:not-equal key-src) ,left ,right) source))
;logicals
((& ^ or) (make-syntax #f `(,(create-syntax #f 'javaRuntime:bitwise (build-src key)) (quote ,op) ,left ,right) source))
((& ^ or)
(make-syntax #f
`(,(create-syntax #f 'javaRuntime:bitwise key-src) (quote ,op) ,left ,right) source))
;boolean
((&&) (make-syntax #f `(,(create-syntax #f 'javaRuntime:and (build-src key)) ,left ,right) source))
((oror) (make-syntax #f `(,(create-syntax #f 'javaRuntime:or (build-src key)) ,left ,right) source))
((&&) (make-syntax #f `(,(create-syntax #f 'javaRuntime:and key-src) ,left ,right) source))
((oror) (make-syntax #f `(,(create-syntax #f 'javaRuntime:or key-src) ,left ,right) source))
(else
(error 'translate-op (format "Translate op given unknown operation ~s" op))))))
(if (scheme-val? type)
(make-syntax #f `(contract ,(type->contract (scheme-val-type type)) ,result 'scheme 'java) source)
(if (dynamic-val? type)
(make-syntax #f
(convert-assert-value
(make-syntax #f `(c:contract ,(type->contract (dynamic-val-type type)) ,result
(quote ,(string->symbol (class-name))) '|infered contract|) source)
type)
source)
result)))
;translate-access: (U field-access local-access) type src -> syntax
(define (translate-access name type src)
(cond
((local-access? name)
(translate-id (build-var-name (id-string (local-access-name name)))
(id-src (local-access-name name))))
(let ((var (translate-id (build-var-name (id-string (local-access-name name)))
(id-src (local-access-name name)))))
(if (dynamic-val? type)
(let ((local-syntax (cond
((unknown-ref? (dynamic-val-type type))
`(let ((val-1 ,var))
(if (string? val-1)
(make-java-string val-1)
val-1)))
(else var))))
(make-syntax #f
(convert-assert-value
(make-syntax #f
`(c:contract ,(type->contract (dynamic-val-type type) #t)
,local-syntax (quote ,(string->symbol (class-name))) '|infered contract|)
(build-src (id-src (local-access-name name))))
(dynamic-val-type type)) (build-src (id-src (local-access-name name)))))
var)))
((field-access? name)
(let* ((field-string (id-string (field-access-field name)))
(field-src (id-src (field-access-field name)))
@ -1819,14 +2138,24 @@
(expr (if obj (translate-expression obj))))
(cond
((var-access-static? access)
(if (scheme-val? type)
(let ((static-name (build-static-name field-string (var-access-class access))))
(if (dynamic-val? type)
(let ((access-syntax (cond
((unknown-ref? (dynamic-val-type type))
`(let ((val-1 ,(translate-id static-name)))
(if (string? val-1)
(make-java-string val-1)
val-1)))
(else (translate-id static-name)))))
(make-syntax #f
`(c:contract ,(type->contract (scheme-val-type type))
,(translate-id (build-static-name field-string (var-access-class access)) field-src)
'scheme 'java)
(convert-assert-value
(make-syntax #f
`(c:contract ,(type->contract (dynamic-val-type type) #t)
,access-syntax
(quote ,(string->symbol (class-name))) '|infered contract|)
(build-src field-src))
(translate-id (build-var-name (build-static-name field-string (var-access-class access)))
field-src)))
(dynamic-val-type type)) (build-src field-src)))
(translate-id (build-var-name static-name) field-src))))
((eq? 'array (var-access-class access))
(if cant-be-null?
(make-syntax #f `(send ,expr ,(translate-id field-string field-src)) (build-src src))
@ -1836,22 +2165,56 @@
(send ,expr ,(translate-id field-string field-src)))
(build-src src))))
((and (eq? (var-access-access access) 'private) (static-method))
(let ((id (create-get-name field-string (var-access-class access))))
(if cant-be-null?
(make-syntax #f `(send ,expr ,id ,expr) (build-src src))
(let* ((id (create-get-name field-string (var-access-class access)))
(getter `(send ,expr ,id ,expr))
(get-syntax (if cant-be-null?
(make-syntax #f getter (build-src src))
(make-syntax #f `(if (null? ,expr)
(javaRuntime:nullError 'field)
(send ,expr ,id ,expr))
,getter)
(build-src src)))))
(if (dynamic-val? type)
(let ((access-syntax (cond
((unknown-ref? (dynamic-val-type type))
`(let ((val-1 ,get-syntax))
(if (string? val-1)
(make-java-string val-1)
val-1)))
(else get-syntax))))
(make-syntax #f
(convert-assert-value
(make-syntax #f
`(c:contract ,(type->contract (dynamic-val-type type) #t)
,access-syntax (quote ,(string->symbol (class-name))) '|infered contract|)
(build-src field-src))
(dynamic-val-type type)) (build-src field-src)))
get-syntax)))
(else
(let ((id (create-get-name field-string (var-access-class access))))
(let* ((id (create-get-name field-string (var-access-class access)))
(get-syntax
(if cant-be-null?
(make-syntax #f `(,id ,expr) (build-src src))
(make-syntax #f
`(if (null? ,expr)
(javaRuntime:nullError 'field)
(,id ,expr))
(build-src src))))))))))
(build-src src)))))
(if (dynamic-val? type)
(let ((access-syntax (cond
((unknown-ref? (dynamic-val-type type))
`(let ((val-1 ,get-syntax))
(if (string? val-1)
(make-java-string val-1)
val-1)))
(else get-syntax))))
(make-syntax #f
(convert-assert-value
(make-syntax #f
`(c:contract ,(type->contract (dynamic-val-type type) #t)
,access-syntax (quote ,(string->symbol (class-name))) '|infered contract|)
(build-src field-src))
(dynamic-val-type type)) (build-src field-src)))
get-syntax))))))))
;translate-special-name: string src -> syntax
(define (translate-special-name name src)
@ -1862,11 +2225,21 @@
(define (translate-specified-this var src)
(make-syntax #f (build-identifier (string-append var "~f")) (build-src src)))
;translate-call: (U expression #f) (U special-name id) (list syntax) method-record src-> syntax
(define (translate-call expr method-name args method-record src)
;translate-call: (U expression #f) (U special-name id) (list syntax) (list type) method-record type src-> syntax
(define (translate-call expr method-name args arg-types method-record rtype src)
(let ((cant-be-null? (never-null? expr))
(expression (if expr (translate-expression expr) #f))
(unique-name (gensym)))
(unique-name (gensym))
(translated-args
(if (method-contract? method-record)
(map (lambda (arg type)
(guard-convert-value arg type))
args arg-types)
(map (lambda (arg type call-type)
(if (eq? 'dynamic call-type)
(guard-convert-value arg type)
arg))
args arg-types (method-record-atypes method-record)))))
(cond
;Constructor case
((special-name? method-name)
@ -1894,63 +2267,86 @@
(build-src src))
(if cant-be-null?
(create-syntax #f `(send ,(if expr expression 'this) ,c-name ,@args) (build-src src))
(create-syntax #f `(send ,(if expr expression 'this) ,c-name ,@translated-args) (build-src src))
(create-syntax #f
`(let ((,unique-name ,expression))
(if (null? ,unique-name)
(javaRuntime:nullError 'method)
(send ,unique-name ,c-name ,@args)))
(send ,unique-name ,c-name ,@translated-args)))
(build-src src)))))
;Normal case
((id? method-name)
(let* ((static? (unless (method-contract? method-record)
(let* ((static? (and (not (method-contract? method-record))
(memq 'static (method-record-modifiers method-record))))
(temp (unless (method-contract? method-record)
(mangle-method-name (method-record-name method-record)
(method-record-atypes method-record))))
(m-name (unless (method-contract? method-record)
(if static?
(build-static-name temp (car (method-record-class method-record)))
temp)))
(m-name (cond
((method-contract? method-record) (java-name->scheme (method-contract-name method-record)))
(static?
(build-static-name temp (car (method-record-class method-record))))
(else temp)))
(generic-name (unless (method-contract? method-record)
(build-generic-name (car (method-record-class method-record)) m-name))))
(cond
((special-name? expr)
(let* ((over? (overridden? (string->symbol m-name)))
(name (translate-id m-name
#;(if (and (equal? (special-name-name expr) "super") over?)
(format "super.~a" m-name)
m-name)
(id-src method-name))))
(cond
(static? (create-syntax #f `(,name ,@args) (build-src src)))
(over? (create-syntax #f `(super ,name ,@args) (build-src src)))
(else (create-syntax #f `(send this ,name ,@args) (build-src src))))))
(name (translate-id m-name (id-src method-name)))
(new-exp (cond
(static? (create-syntax #f `(,name ,@translated-args) (build-src src)))
(over? (create-syntax #f `(super ,name ,@translated-args) (build-src src)))
(else (create-syntax #f `(send this ,name ,@translated-args) (build-src src))))))
(if (or (method-contract? method-record)
(dynamic-val? rtype))
(make-syntax #f (convert-assert-value new-exp (if (method-contract? method-record)
(method-contract-return method-record)
(dynamic-val-type rtype))) (build-src src))
new-exp)))
((not expr)
(cond
((method-contract? method-record)
(create-syntax #f `((contract ,(type->contract method-record)
,(java-name->scheme (method-contract-name method-record)))
,@args) (build-src src)))
(make-syntax #f (convert-assert-value
(create-syntax #f `((c:contract ,(type->contract method-record #t)
,(build-identifier (java-name->scheme (method-contract-name method-record)))
(quote ,(string->symbol (class-name))) '|infered contract|)
,@translated-args) (build-src src))
(method-contract-return method-record))
(build-src src)))
((or static? (memq 'private (method-record-modifiers method-record)))
(create-syntax #f `(,(translate-id m-name (id-src method-name)) ,@args) (build-src src)))
(let ((call-syn
(create-syntax #f `(,(translate-id m-name (id-src method-name)) ,@translated-args) (build-src src))))
(if (dynamic-val? rtype)
(make-syntax #f (convert-assert-value call-syn (dynamic-val-type rtype)) (build-src src))
call-syn)))
(else
(create-syntax #f `(send this ,(translate-id m-name (id-src method-name)) ,@args) (build-src src)))))
(let ((call-syn
(create-syntax #f `(send this ,(translate-id m-name (id-src method-name)) ,@translated-args)
(build-src src))))
(if (dynamic-val? rtype)
(make-syntax #f (convert-assert-value call-syn (dynamic-val-type rtype)) (build-src src))
call-syn)))))
(else
(let ((name (translate-id m-name (id-src method-name))))
(let* ((name (translate-id m-name (id-src method-name)))
(call
(cond
((and cant-be-null? (not static?))
(create-syntax #f `(send ,expression ,name ,@args) (build-src src)))
(static? (create-syntax #f `(,name ,@args) (build-src src)))
(create-syntax #f `(send ,expression ,name ,@translated-args) (build-src src)))
(static? (create-syntax #f `(,name ,@translated-args) (build-src src)))
(else
(create-syntax #f
`(let ((,unique-name ,expression))
(if (null? ,unique-name)
(javaRuntime:nullError 'method)
(send ,unique-name ,name ,@args)))
(build-src src)))))))))
(send ,unique-name ,name ,@translated-args)))
(build-src src))))))
(if (or (method-contract? method-record)
(dynamic-val? rtype))
(make-syntax #f (convert-assert-value call
(if (method-contract? method-record)
(method-contract-return method-record)
(dynamic-val-type rtype))) (build-src src))
call))))))
(else (error 'translate-call (format "Translate call given ~s as method-name" method-name))))))
;Add more checks perhaps to see in other cases if it can be null
@ -2114,15 +2510,25 @@
(build-src src))))
;converted
;translate-cast: type-spec syntax src
(define (translate-cast type expr src)
(if (symbol? (type-spec-name type))
;translate-cast: type-spec syntax type src
(define (translate-cast type expr expr-type src)
(cond
((eq? 'dynamic (type-spec-name type))
(make-syntax #f (guard-convert-value expr expr-type) (build-src src)))
((dynamic-val? expr-type)
(make-syntax #f (convert-assert-value
(create-syntax #f `(c:contract ,(type->contract expr-type #t) ,expr
(quote ,(string->symbol (class-name))) '|infered contract|)
(build-src src)) expr-type)
(build-src src)))
((symbol? (type-spec-name type))
(make-syntax #f `(javaRuntime:cast-primitive ,expr (quote ,(type-spec-name type)) ,(type-spec-dim type))
(build-src src))
(build-src src)))
(else
(make-syntax #f `(javaRuntime:cast-reference ,expr ,(get-class-name type)
,(type-spec-dim type)
(quote ,(get-class-name type)))
(build-src src))))
(build-src src)))))
;translate-instanceof: syntax type-spec src -> syntax
(define (translate-instanceof expr type src)
@ -2137,9 +2543,11 @@
(make-syntax #f `(is-a? ,expr ObjectI) (build-src src))
(make-syntax #f `(is-a? ,expr ,syntax-type) (build-src src))))))
;translate-assignment: (U access array-access) symbol syntax expression ?? src src -> syntax
;translate-assignment: (U access array-access) symbol syntax expression type src src -> syntax
(define (translate-assignment name op expr assign-to type key src)
(let ((expression (lambda (name) (case op
(let ((expression (lambda (name)
(let ((expanded-expr
(case op
((=) expr)
((*=) `(* ,name ,expr))
((/=) `(/ ,name ,expr))
@ -2149,7 +2557,10 @@
((<<=) `(javaRuntime:shift '<< ,name ,expr))
((>>>=) `(javaRuntime:shift '>>> ,name ,expr))
((%= &= ^= or=)
(error 'translate-assignment "Only supports =, +=, -=, *=, & /= >>= <<= >>>= at this time"))))))
(error 'translate-assignment "Only supports =, +=, -=, *=, & /= >>= <<= >>>= at this time")))))
(if (or (eq? type 'dynamic) (dynamic-val? type))
(guard-convert-value (make-syntax #f expanded-expr (build-src src)) (expr-types assign-to))
expanded-expr)))))
(cond
((array-access? name)
(translate-array-mutation name expression assign-to src))

21
collects/profj/tool.ss
View File

@ -114,7 +114,7 @@
(define (phase1) void)
;Add all the ProfessorJ languages into DrScheme
(define (phase2)
#;(drscheme:language-configuration:add-language
(drscheme:language-configuration:add-language
(make-object ((drscheme:language:get-default-mixin) dynamic-lang%)))
(drscheme:language-configuration:add-language
(make-object ((drscheme:language:get-default-mixin) full-lang%)))
@ -376,7 +376,7 @@
(val-editor (caddr example))
(val (parse-expression (open-input-text-editor val-editor) val-editor level)))
(compile-interactions-ast
(make-var-init (make-var-decl name null type #f) val #f)
(make-var-init (make-var-decl name null type #f) val #f #f)
val-editor level type-recs)))
contents)
(process-extras (cdr extras) type-recs))))
@ -474,8 +474,8 @@
(define/public (on-execute settings run-in-user-thread)
(dynamic-require '(lib "Object.ss" "profj" "libs" "java" "lang") #f)
(let ([obj-path ((current-module-name-resolver) '(lib "Object.ss" "profj" "libs" "java" "lang") #f #f)]
[string-path ((current-module-name-resolver) '(lib "String.ss" "profj" "libs" "java" "lang") #f #f)]
[class-path ((current-module-name-resolver) '(lib "class.ss") #f #f)]
[tool-path ((current-module-name-resolver) '(lib "tool.ss" "profj") #f #f)]
[n (current-namespace)])
(read-case-sensitive #t)
(run-in-user-thread
@ -517,9 +517,10 @@
(with-handlers ([void (lambda (x) (printf "~a~n" (exn-message x)))])
(namespace-require 'mzscheme)
(namespace-attach-module n obj-path)
(namespace-attach-module n string-path)
(namespace-attach-module n class-path)
(namespace-require obj-path)
#;(namespace-require '(lib "tool.ss" "profj"))
(namespace-require string-path)
(namespace-require class-path)
(namespace-require '(prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java")))
(namespace-require '(prefix c: (lib "contract.ss"))))))))
@ -528,7 +529,7 @@
(let ((print-full? (profj-settings-print-full? settings))
(style (profj-settings-print-style settings)))
(if (is-a? value String)
(write-special (send value get-mzscheme-string) port)
(write-special (format "~v" (send value get-mzscheme-string)) port)
(let ((out (format-java value print-full? style null #f 0)))
(if (< 25 (string-length out))
(display (format-java value print-full? style null #t 0) port)
@ -803,6 +804,11 @@
(syntax-object->datum (syntax ast)))))))
(define (supports-printable-interface? o)
(and (is-a? o object%)
(method-in-interface? 'my-name (object-interface o))
(method-in-interface? 'fields-for-display (object-interface o))))
(provide format-java)
;formats a java value (number, character or Object) into a string
;format-java: java-value bool symbol (list value) -> string
@ -816,8 +822,9 @@
(if full-print?
(array->string value (send value length) -1 #t style already-printed newline? num-tabs)
(array->string value 3 (- (send value length) 3) #f style already-printed newline? num-tabs)))
((is-a? value String) (format "~s" (send value get-mzscheme-string)))
((is-a? value ObjectI)
((is-a? value String) (format "~v" (send value get-mzscheme-string)))
((string? value) (format "~v" value))
((or (is-a? value ObjectI) (supports-printable-interface? value))
(case style
((type) (send value my-name))
((field)

111
collects/profj/types.ss
View File

@ -1,4 +1,3 @@
#cs
(module types mzscheme
(require (lib "etc.ss")
@ -8,16 +7,16 @@
"ast.ss")
(provide (all-defined-except sort number-assign-conversions remove-dups meth-member?
variable-member? generate-require-spec))
generate-require-spec))
;; symbol-type = 'null | 'string | 'boolean | 'char | 'byte | 'short | 'int
;; | 'long | 'float | 'double | 'void
;; | 'long | 'float | 'double | 'void | 'dynamic
;; reference-type = 'null | 'string | (make-ref-type string (list string))
;; array-type = (make-array-type type int)
;; type = symbol-type
;; | reference-type
;; | array-type
;; | scheme-val
;; | dynamic-val
;; | unknown-ref
(define-struct ref-type (class/iface path) (make-inspector))
@ -52,17 +51,17 @@
;; reference-type: 'a -> boolean
(define (reference-type? x)
(if (and (scheme-val? x) (scheme-val-type x))
(reference-type? (scheme-val-type x))
(or (scheme-val? x)
(if (and (dynamic-val? x) (dynamic-val-type x))
(reference-type? (dynamic-val-type x))
(or (dynamic-val? x)
(unknown-ref? x)
(ref-type? x)
(memq x `(null string)))))
;;is-string?: 'a -> boolean
(define (is-string-type? s)
(if (scheme-val? s)
(is-string-type? (scheme-val-type s))
(if (dynamic-val? s)
(is-string-type? (dynamic-val-type s))
(and (reference-type? s)
(or (eq? 'string s) (type=? s string-type)))))
@ -70,16 +69,16 @@
;; prim-integral-type?: 'a -> boolean
(define (prim-integral-type? t)
(cond
((and (scheme-val? t) (scheme-val-type t))
(prim-integral-type? (scheme-val-type t)))
((scheme-val? t) #t)
((and (dynamic-val? t) (dynamic-val-type t))
(prim-integral-type? (dynamic-val-type t)))
((dynamic-val? t) #t)
(else (memq t `(byte short int long char)))))
;; prim-numeric-type?: 'a -> boolean
(define (prim-numeric-type? t)
(cond
((and (scheme-val? t) (scheme-val-type t))
(prim-numeric-type? (scheme-val-type t)))
((scheme-val? t) #t)
((and (dynamic-val? t) (dynamic-val-type t))
(prim-numeric-type? (dynamic-val-type t)))
((dynamic-val? t) #t)
(else (or (prim-integral-type? t) (memq t `(float double))))))
;; type=?: type type -> boolean
@ -148,14 +147,15 @@
;; assignment-conversion: type type type-records -> boolean
(define (assignment-conversion to from type-recs)
(cond
((scheme-val? to)
((dynamic-val? to)
(cond
((scheme-val-type to) => (lambda (t) (assignment-conversion t from type-recs)))
(else (set-scheme-val-type! to from) #t)))
((scheme-val? from)
((dynamic-val-type to) => (lambda (t) (assignment-conversion t from type-recs)))
(else (set-dynamic-val-type! to from) #t)))
((dynamic-val? from)
(cond
((scheme-val-type from) => (lambda (t) (assignment-conversion to t type-recs)))
(else (set-scheme-val-type! from to) #t)))
((dynamic-val-type from) => (lambda (t) (assignment-conversion to t type-recs)))
(else (set-dynamic-val-type! from to) #t)))
((eq? to 'dynamic) #t)
((type=? to from) #t)
((and (prim-numeric-type? to) (prim-numeric-type? from))
(widening-prim-conversion to from))
@ -166,7 +166,7 @@
(define (type-spec-to-type ts container-class level type-recs)
(let* ((ts-name (type-spec-name ts))
(t (cond
((memq ts-name `(null string boolean char byte short int long float double void ctor)) ts-name)
((memq ts-name `(null string boolean char byte short int long float double void ctor dynamic)) ts-name)
((name? ts-name) (name->type ts-name container-class (type-spec-src ts) level type-recs)))))
(if (> (type-spec-dim ts) 0)
(make-array-type t (type-spec-dim ts))
@ -244,18 +244,21 @@
;;(make-inner-record string (list symbol) bool)
(define-struct inner-record (name modifiers class?) (make-inspector))
;;(make-scheme-record string (list string) path (list scheme-val))
;;(make-scheme-record string (list string) path (list dynamic-val))
(define-struct scheme-record (name path dir provides))
;;(make-scheme-val symbol bool bool (U #f type unknown-ref))
(define-struct scheme-val (name dynamic? instance? type))
;;(make-dynamic-val (U type method-contract unknown-ref))
(define-struct dynamic-val (type))
;;(make-unknown-ref (list method-contract) (list scheme-val))
(define-struct unknown-ref (methods fields))
;;(make-unknown-ref (U method-contract field-contract))
(define-struct unknown-ref (access))
;;(make-method-contract symbol (U type #f) (list (U type #f)))
;;(make-method-contract string type (list type))
(define-struct method-contract (name return args))
;;(make-field-contract string type)
(define-struct field-contract (name type))
;
; ;;
; ; ;
@ -577,26 +580,21 @@
(car (cadr assignable-count))) (method-conflict-fail))
(else (car assignable)))))
;lookup-scheme: scheme-record string ( -> void) -> scheme-val
;lookup-scheme may raise an exception if variable is not defined in mod-ref
(define (lookup-scheme mod-ref variable fail)
;module-has-binding?: scheme-record string (-> void) -> void
;module-has-binding raises an exception when variable is not defined in mod-ref
(define (module-has-binding? mod-ref variable fail)
(let ((var (string->symbol (java-name->scheme variable))))
(cond
((variable-member? (scheme-record-provides mod-ref) var) => (lambda (x) x))
(else
(or (memq var (scheme-record-provides mod-ref))
(let ((old-namespace (current-namespace)))
(current-namespace (make-namespace))
(namespace-require (generate-require-spec (scheme-record-name mod-ref)
(namespace-require (generate-require-spec (java-name->scheme (scheme-record-name mod-ref))
(scheme-record-path mod-ref)))
(begin0
(begin
(namespace-variable-value var #t (lambda ()
(current-namespace old-namespace)
(fail)))
(let ((val (make-scheme-val var #t #f #f)))
(set-scheme-record-provides! mod-ref (cons val (scheme-record-provides mod-ref)))
val))
(current-namespace old-namespace)))))))
(set-scheme-record-provides! mod-ref (cons var (scheme-record-provides mod-ref)))
(current-namespace old-namespace))))))
;generate-require-spec: string (list string) -> (U string (list symbol string+))
(define (generate-require-spec name path)
@ -630,35 +628,6 @@
(string-append remainder "-" (string (char-downcase char))))))))
(else name)))
;variable-member? (list scheme-val) symbol -> scheme-val
(define (variable-member? known-vars lookup)
(and (not (null? known-vars))
(or (and (eq? (scheme-val-name (car known-vars)) lookup)
(car known-vars))
(variable-member? (cdr known-vars) lookup))))
;field-contract-lookup string (list scheme-val) -> (U #f scheme-val)
(define (field-contract-lookup name fields)
(and (not (null? fields))
(or (and (equal? (scheme-val-name (car fields)) name)
(car fields))
(field-contract-lookup name (cdr fields)))))
;get-method-contracts: string unknown-ref -> (list method-contract)
(define (get-method-contracts name ref)
(letrec ((methods (unknown-ref-methods ref))
(lookup
(lambda (ms)
(and (not (null? ms))
(or (and (equal? (method-contract-name (car ms)) name)
(car ms))
(lookup name (cdr ms)))))))
(cond
((lookup methods) => (lambda (x) x))
(else
(let ((mc (make-method-contract name (make-scheme-val 'method-return #t #f #f) #f)))
(set-unknown-ref-methods! ref (cons mc (unknown-ref-methods ref)))
(list mc))))))
;
@ -676,7 +645,7 @@
;
(define type-version "version1")
(define type-version "version2")
(define type-length 10)
;; read-record: path -> (U class-record #f)
@ -737,7 +706,7 @@
(class-record-modifiers r)
(class-record-object? r)
(map field->list (class-record-fields r))
(map method->list (class-record-methods r))
(map method->list (filter (compose not method-record-override) (class-record-methods r)))
(map inner->list (class-record-inners r))
(class-record-parents r)
(class-record-ifaces r)