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

51
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 ()
(if (or (not local?) profj-lib? htdch-lib? (to-file)) (let ((n (if scheme? (java-name->scheme name) name)))
(string-append name ".ss") (if (or (not local?) profj-lib? htdch-lib? (to-file))
(string->symbol name))))) (string-append n ".ss")
(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)))
@ -535,7 +536,7 @@
members members
level level
type-recs) type-recs)
(let ((record (let ((record
(make-class-record (make-class-record
cname cname
@ -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))
@ -1024,7 +1027,7 @@
(throws-error (name-id t) (name-src t))))) (throws-error (name-id t) (name-src t)))))
(method-throws method)))) (method-throws method))))
(over? (overrides? name parms inherited-methods))) (over? (overrides? name parms inherited-methods)))
(when (and (memq level '(beginner intermediate)) (when (and (memq level '(beginner intermediate))
(member name (map method-record-name inherited-methods)) (member name (map method-record-name inherited-methods))
(not over?)) (not over?))

365
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,39 +1565,45 @@
(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)
(let* ((name (var-access-class (field-access-access acc)))) (make-unknown-ref (make-field-contract fname (make-dynamic-val #f))))
(set! class-rec (expr-types obj))
;First clause: static field of a local inner class (obj (field-lookup fname (type/env-t obj-type/env) obj src level type-recs))
(or (and (or (string? name) (= 1 (length name))) (else
(let ((rec? (lookup-local-inner (if (pair? name) (car name) name) env))) (let* ((name (var-access-class (field-access-access acc))))
(and rec? (inner-rec-record rec?)))) (set! class-rec
(get-record (send type-recs get-class-record ;First clause: static field of a local inner class
(if (pair? name) name (list name)) (or (and (or (string? name) (= 1 (length name)))
#f (let ((rec? (lookup-local-inner (if (pair? name) (car name) name) env)))
((get-importer type-recs) name type-recs level src)) (and rec? (inner-rec-record rec?))))
type-recs))) (get-record (send type-recs get-class-record
(cond (if (pair? name) name (list name))
((class-record? class-rec) #f
(get-field-record fname class-rec ((get-importer type-recs) name type-recs level src))
(lambda () type-recs)))
(let* ((class? (member fname (send type-recs get-class-env))) (cond
(method? (not (null? (get-method-records fname class-rec))))) ((class-record? class-rec)
(field-lookup-error (if class? 'class-name (get-field-record fname class-rec
(if method? 'method-name 'not-found)) (lambda ()
(string->symbol fname) (let* ((class? (member fname (send type-recs get-class-env)))
(make-ref-type (if (pair? name) (car name) name) null) (method? (not (null? (get-method-records fname class-rec)))))
src))))) (field-lookup-error (if class? 'class-name
((scheme-record? class-rec) (if method? 'method-name 'not-found))
(lookup-scheme class-rec fname (string->symbol fname)
(lambda () (field-lookup-error 'not-found (make-ref-type (if (pair? name) (car name) name) null)
(string->symbol fname) src)))))
(make-ref-type (if (pair? name) (car name) name) ((scheme-record? class-rec)
(list "scheme")) (module-has-binding? class-rec fname
src)))))))) (lambda () (field-lookup-error 'not-found
(string->symbol fname)
(make-ref-type (if (pair? name) (car name) name)
(list "scheme"))
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 name-string)
(string->symbol (id-string name)) (make-ref-type name (list "scheme"))
(make-ref-type (if (pair? name) (car name) name) src)))
(list "scheme")) (cond
src))))) ((name? name) (set-id-string! (name-id name) (java-name->scheme name-string)))
(if (scheme-val-type result) ((id? name) (set-id-string! name (java-name->scheme name-string))))
(if (method-contract? (scheme-val-type result)) (list (make-method-contract (java-name->scheme name-string) #f #f)))))
(list (scheme-val-type result)) ;Teaching languages
(no-method-error 'class 'field (string->symbol (id-string name))
(make-ref-type (if (pair? name) (car name) name)
(list "scheme"))
src))
(let ((m-c
(make-method-contract (id-string name)
(make-scheme-val 'method-result #t #f #f) #f)))
(set-scheme-val-type! result m-c)
(list m-c)))))))
(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?
(let ((parent (car (class-record-parents this)))) (super-special-error (expr-src expr) interact?))
(set! exp-type 'super) (let ((parent (car (class-record-parents this))))
(get-method-records (id-string name) (set! exp-type 'super)
(send type-recs get-class-record parent))) (get-method-records name-string
(get-method-records (id-string name) this))) (send type-recs get-class-record parent))))
(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! exp-type call-exp) (set-dynamic-val-type! call-exp (make-unknown-ref m-contract))
(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! 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
@ -1992,33 +2011,34 @@
(class? (member (id-string name) (send type-recs get-class-env))) (class? (member (id-string name) (send type-recs get-class-env)))
(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)))))))
(when (and (not ctor?)
(eq? (method-record-rtype (car methods)) 'ctor))
(ctor-called-error exp-type name src))
(let* ((args/env (check-args arg-exps check-sub (unless (method-contract? (car methods))
env)) (when (and (not ctor?)
(eq? (method-record-rtype (car methods)) 'ctor))
(ctor-called-error exp-type name src)))
(let* ((args/env (check-args arg-exps check-sub 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))
@ -2416,7 +2447,7 @@
(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
((and (ref-type? exp-type) (ref-type? type) ((and (ref-type? exp-type) (ref-type? type)
(or (is-eq-subclass? exp-type type type-recs) (or (is-eq-subclass? exp-type type type-recs)
(is-eq-subclass? type exp-type type-recs))) 'boolean) (is-eq-subclass? type exp-type type-recs))) 'boolean)
((and (ref-type? exp-type) (ref-type? type)) ((and (ref-type? exp-type) (ref-type? type))
@ -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
@ -3158,11 +3197,11 @@
((static) (format "final field ~a may only be set in the containing class's static initialization" n)) ((static) (format "final field ~a may only be set in the containing class's static initialization" n))
((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)

22
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"))))
(> (file-or-directory-modify-seconds compiled-path) (unless (and (and (file-exists? compiled-path)
(file-or-directory-modify-seconds (build-path name)))) (> (file-or-directory-modify-seconds compiled-path)
(file-or-directory-modify-seconds (build-path name))))
(and (file-exists? type-path)
(read-record type-path)))
(call-with-input-file name (lambda (port) (compile-to-file port name level))))))) (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"))))
(> (file-or-directory-modify-seconds compiled-path) (unless (or (and (file-exists? compiled-path)
(file-or-directory-modify-seconds (build-path name)))) (> (file-or-directory-modify-seconds compiled-path)
(file-or-directory-modify-seconds (build-path name))))
(and (file-exists? type-path)
(read-record type-path)))
(call-with-input-file (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))

427
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,7 +103,153 @@
(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,7 +616,8 @@
(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)
(let ((hash 0)) (let ((hash 0))
@ -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"))
@ -571,10 +736,11 @@
;... -> String ;... -> String
(define/public (trim) (define/public (trim)
(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

18
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]
@ -478,9 +479,10 @@
((var-decl? d) d) ((var-decl? d) d)
(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)
(var-decl-src decl)))) #f
(var-decl-src decl))))
(cond (cond
((var-decl? d) new-decl) ((var-decl? d) new-decl)
@ -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))

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

File diff suppressed because it is too large Load Diff

23
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)
@ -802,7 +803,12 @@
(namespace-syntax-introduce ((syntax-object->datum (syntax comp)) (namespace-syntax-introduce ((syntax-object->datum (syntax comp))
(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)

127
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,17 +244,20 @@
;;(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,27 +580,22 @@
(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)) (let ((old-namespace (current-namespace)))
(else
(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))) (set-scheme-record-provides! mod-ref (cons var (scheme-record-provides mod-ref)))
(let ((val (make-scheme-val var #t #f #f))) (current-namespace old-namespace))))))
(set-scheme-record-provides! mod-ref (cons val (scheme-record-provides mod-ref)))
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)
(let ((mod (string-append name ".ss"))) (let ((mod (string-append name ".ss")))
@ -630,36 +628,7 @@
(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)