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

14
collects/profj/compile.ss
View File

@ -34,19 +34,25 @@
(cond (cond
((and (eq? src 'file) (eq? dest 'file)) ((and (eq? src 'file) (eq? dest 'file))
(let-values (((path-base file dir?) (split-path (path->complete-path (build-path name))))) (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")))) (let ((compiled-path (build-path path-base "compiled" (path-replace-suffix file ".zo")))
(unless (and (file-exists? compiled-path) (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 compiled-path)
(file-or-directory-modify-seconds (build-path name)))) (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))))))) (call-with-input-file name (lambda (port) (compile-to-file port name level)))))))
((eq? dest 'file) ((eq? dest 'file)
(compile-to-file port loc level)) (compile-to-file port loc level))
((eq? src 'file) ((eq? src 'file)
(let-values (((path-base file dir?) (split-path (path->complete-path (build-path name))))) (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")))) (let ((compiled-path (build-path path-base "compiled" (path-replace-suffix file ".zo")))
(unless (and (file-exists? compiled-path) (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 compiled-path)
(file-or-directory-modify-seconds (build-path name)))) (file-or-directory-modify-seconds (build-path name))))
(and (file-exists? type-path)
(read-record type-path)))
(call-with-input-file (call-with-input-file
name name
(lambda (port) (compile-java-internal port name type-recs #f level))))))) (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") (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") (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") (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") (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") (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") (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") (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") (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") (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") (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") (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") (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") (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") (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") (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") (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") (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") (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") (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") (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 (module Object-composite mzscheme
(require (lib "class.ss") (require (lib "class.ss")
(prefix c: (lib "contract.ss"))
(lib "errortrace-lib.ss" "errortrace") (lib "errortrace-lib.ss" "errortrace")
(lib "Comparable.ss" "profj" "libs" "java" "lang") (lib "Comparable.ss" "profj" "libs" "java" "lang")
(lib "Serializable.ss" "profj" "libs" "java" "io")) (lib "Serializable.ss" "profj" "libs" "java" "io"))
@ -35,13 +36,15 @@
; ;;; ; ;;;
;Object.java ;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. ;Object interface, and a mixin to create objects from.
(define ObjectI (define ObjectI
(interface () Object-constructor clone equals-java.lang.Object finalize getClass (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 (define Object-Mix
(lambda (parent) (lambda (parent)
@ -53,17 +56,20 @@
(define/public clone (lambda () void)) (define/public clone (lambda () void))
(define/public (equals-java.lang.Object obj) (eq? this obj)) (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 ;Needs to do something
(define/public (finalize) void) (define/public (finalize) void)
(public-final getClass) (public-final getClass get-class)
(define (getClass) (define (getClass)
(error 'ProfessorJ:getClass (error 'ProfessorJ:getClass
(format "ProfessorJ does not support getClass calls. ~e" (format "ProfessorJ does not support getClass calls. ~e"
(send this toString)))) (send this toString))))
(define (get-class) (getClass))
(define/public (hashCode) (eq-hash-code this)) (define/public (hashCode) (eq-hash-code this))
(define/public (hash-code) (send this hashCode))
;Needs to do something when Threads more implemented ;Needs to do something when Threads more implemented
(public-final notify |notifyAll|) (public-final notify |notifyAll|)
@ -73,6 +79,7 @@
(define/public (my-name) "Object") (define/public (my-name) "Object")
(define/public (toString) (define/public (toString)
(make-java-string (format "~a@~a" (send this my-name) (send this hashCode)))) (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) (public-final wait wait-long wait-long-int)
(define wait (lambda () void)) (define wait (lambda () void))
@ -96,6 +103,152 @@
(define Object (Object-Mix object%)) (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)) (define/public (length) (string-length text))
; int -> char ; int -> char
(define/public (charAt-int index) (string-ref text index)) (define/public (charAt-int index) (string-ref text index))
(define/public (char-at i) (charAt-int i))
;-> void ;-> void
(define/public (getChars-int-int-char1-int begin end dest i) (define/public (getChars-int-int-char1-int begin end dest i)
@ -321,6 +475,7 @@
(send dest set index (string-ref text offset)) (send dest set index (string-ref text offset))
(build-char-array (add1 offset) (add1 index))))))) (build-char-array (add1 offset) (add1 index)))))))
(build-char-array begin i))) (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 ;Does not mess with charset
(define/public (getBytes) (define/public (getBytes)
@ -348,6 +503,7 @@
(define/public (contentEquals-java.lang.StringBuffer buf) (define/public (contentEquals-java.lang.StringBuffer buf)
(equals-java.lang.Object (send buf toString))) (equals-java.lang.Object (send buf toString)))
(define/public (content-equals b) (contentEquals-java.lang.StringBuffer b))
;Object -> boolean ;Object -> boolean
(define/override (equals-java.lang.Object obj) (define/override (equals-java.lang.Object obj)
@ -357,6 +513,7 @@
;Object -> boolean ;Object -> boolean
(define/public (equalsIgnoreCase-java.lang.String str) (define/public (equalsIgnoreCase-java.lang.String str)
(string-ci=? text (send str get-mzscheme-string))) (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) ;find-diff-chars: int int string-> (values int int)
(define/private (find-diff-chars i stop-length compare-string) (define/private (find-diff-chars i stop-length compare-string)
@ -420,6 +577,7 @@
(let-values (((int-text int-str) (find-diff-chars 0))) (let-values (((int-text int-str) (find-diff-chars 0)))
(- int-text int-str)) (- int-text int-str))
(- text-l str-l)))))) (- text-l str-l))))))
(define/public (compare->ignore-case s) (compareToIgnoreCase-java.lang.String s))
;int String int int -> boolean ;int String int int -> boolean
(define/public (regionMatches-int-java.lang.String-int-int toffset jstr ooffset len) (define/public (regionMatches-int-java.lang.String-int-int toffset jstr ooffset len)
@ -458,6 +616,7 @@
(let ((suffix (send Jsuffix get-mzscheme-string))) (let ((suffix (send Jsuffix get-mzscheme-string)))
(and (<= (string-length suffix) (string-length text)) (and (<= (string-length suffix) (string-length text))
(string=? suffix (substring text (- (string-length text) (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 ; -> int
(define/override (hashCode) (define/override (hashCode)
@ -521,11 +680,13 @@
(define/public (subSequence-int-int begin end) (define/public (subSequence-int-int begin end)
(error 'subSequence "Internal Error: subsequence is unimplemented because charSequence is unimplemented")) (error 'subSequence "Internal Error: subsequence is unimplemented because charSequence is unimplemented"))
(define/public (sub-sequence i j) (subSequence-int-int i j))
;String -> String ;String -> String
(define/public (concat-java.lang.String Jstr) (define/public (concat-java.lang.String Jstr)
(let ((str (send Jstr get-mzscheme-string))) (let ((str (send Jstr get-mzscheme-string)))
(make-java-string (string-append text str)))) (make-java-string (string-append text str))))
(define/public (concat s) (concat-java.lang.String s))
; .. -> String ; .. -> String
(define/public (replace-char-char old new) (define/public (replace-char-char old new)
@ -536,16 +697,20 @@
(string-set! new-text pos new) (string-set! new-text pos new)
(loop (add1 index))))) (loop (add1 index)))))
(make-java-string new-text))) (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 ;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) (define/public (replaceAll-java.lang.String-java.lang.String regex replace)
(error 'replaceAll "Internal error: replaceAll is unimplemented at this time")) (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) (define/public (replaceFirst-java.lang.String-java.lang.String regex replace)
(error 'replaceFirst "Internal error: replaceFirst is unimplemented at this time")) (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) (define/public (matches-java.lang.String regex)
(error 'matches "Internal error: matches is unimplemented at this time")) (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) (define/public (split-java.lang.String-int regex limit)
(error 'split "Internal error: split is unimplemented at this time")) (error 'split "Internal error: split is unimplemented at this time"))
@ -573,8 +738,9 @@
(error 'trim "Internal error: trim is unimplemented at this time.")) (error 'trim "Internal error: trim is unimplemented at this time."))
(define/public (toCharArray) (make-java-array 'char 0 (string->list text))) (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 (define/public intern
(lambda () this)) (lambda () this))
@ -632,7 +798,7 @@
;private fields ;private fields
;message: String ;message: String
(define message "") (define message (make-java-string ""))
;stack: continuation-mark-set ;stack: continuation-mark-set
(define stack null) (define stack null)
;java:exception ;java:exception
@ -678,11 +844,16 @@
(define/public (getMessage) message) (define/public (getMessage) message)
(define/public (getCause) cause) (define/public (getCause) cause)
(define/public (getLocalizedMessage) (send this getMessage)) (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) (define/public (setStackTrace-java.lang.StackTraceElement1 elments)
(error 'setStackTrace "Internal error: setStackTrace will not be implemented until strack trace element s implemented")) (error 'setStackTrace "Internal error: setStackTrace will not be implemented until strack trace element s implemented"))
(define/public (getStackTrace) (define/public (getStackTrace)
(error 'getStackTrace "Internal error: getStackTrace will not be implemented until StackTraceElement is implemented")) (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 ; -> string
(define/override (toString) (define/override (toString)
@ -695,7 +866,7 @@
; -> void ; -> void
(define/public (printStackTrace) (define/public (printStackTrace)
(print-error-trace (current-output-port) (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 ;These functions do not work correctly yet, and won't until printStreams are implemented
(define/public printStackTrace-PrintStream (lambda (printStream) void)) (define/public printStackTrace-PrintStream (lambda (printStream) void))
@ -703,6 +874,7 @@
;This function does nothing at this time ;This function does nothing at this time
(define/public (fillInStackTrace) this) (define/public (fillInStackTrace) this)
(define/public (fill-in-stack-trace) (send this fillInStackTrace))
; -> string ; -> string
(define/override (my-name) "Throwable") (define/override (my-name) "Throwable")
@ -731,6 +903,243 @@
(send exn set-exception! scheme-exn) (send exn set-exception! scheme-exn)
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")) (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")) (("Object" "java" "lang"))
() ()
"version1") "version2")

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

@ -1,4 +1,6 @@
#cs #cs
(module Object mzscheme (module Object mzscheme
(require "Object-composite.ss") (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") (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") (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")) ("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")) (("UnsupportedEncodingException" "java" "io")) ("String" "java" "lang"))
("getBytes" (public) (1 byte) () () ("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")) ("contentEquals" (public) boolean (("StringBuffer" "java" "lang")) () ("String" "java" "lang"))
("equalsIgnoreCase" (public) boolean (("String" "java" "lang")) () ("String" "java" "lang")) ("equalsIgnoreCase" (public) boolean (("String" "java" "lang")) () ("String" "java" "lang"))
("compareTo" (public) int (("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") (("Locale" "java" "util")) () ("String" "java" "lang"))
("toUpperCase" (public) ("String" "java" "lang") () () ("String" "java" "lang")) ("toUpperCase" (public) ("String" "java" "lang") () () ("String" "java" "lang"))
("trim" (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")) ("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") (("Object" "java" "lang")) () ("String" "java" "lang"))
("valueOf" (public static) ("String" "java" "lang") ((1 char)) () ("String" "java" "lang")) ("valueOf" (public static) ("String" "java" "lang") ((1 char)) () ("String" "java" "lang"))
@ -85,4 +85,4 @@
() ()
(("Object" "java" "lang")) (("Object" "java" "lang"))
(("Serializable" "java" "io") ("Comparable" "java" "lang") ("CharSequence" "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") (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 (("PrintString" "java" "io")) () ("Throwable" "java" "lang"))
("printStackTrace" (public) void (("PrintWriter" "java" "io")) () ("Throwable" "java" "lang")) ("printStackTrace" (public) void (("PrintWriter" "java" "io")) () ("Throwable" "java" "lang"))
("setStackTrace" (public) void ((1 ("StackTraceElement" "java" "lang"))) () ("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")) ("Object" (public) ctor () () ("Object" "java" "lang"))
("clone" (protected) ("Object" "java" "lang") () (("CloneNotSupportedException" "java" "lang"))("Object" "java" "lang")) ("clone" (protected) ("Object" "java" "lang") () (("CloneNotSupportedException" "java" "lang"))("Object" "java" "lang"))
@ -35,4 +35,4 @@
() ()
(("Object" "java" "lang")) (("Object" "java" "lang"))
(("Serializable" "java" "io")) (("Serializable" "java" "io"))
"version1") "version2")

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

@ -2,4 +2,6 @@
(module Throwable mzscheme (module Throwable mzscheme
(require "Object-composite.ss") (require "Object-composite.ss")
(provide Throwable (struct java:exception (object)) (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") (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 (VariableDeclaratorId
[(IDENTIFIER) [(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) [(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 (VariableInitializer
[(Expression) $1] [(Expression) $1]

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

@ -199,7 +199,7 @@
(VariableDeclaratorId (VariableDeclaratorId
[(IDENTIFIER) [(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 ;; 19.8.3
(MethodDeclaration (MethodDeclaration

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

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

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

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

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

@ -223,7 +223,7 @@
[(IDENTIFIER) [(IDENTIFIER)
(make-var-decl (make-id $1 (build-src 1)) (make-var-decl (make-id $1 (build-src 1))
(list (make-modifier 'public #f)) (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 (VariableInitializer
[(Expression) $1]) [(Expression) $1])

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

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

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

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

21
collects/profj/tool.ss
View File

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

111
collects/profj/types.ss
View File

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