Adding dynamic type and interoperability support to ProfJ; also brings profj up to date after the switch from cvs to svn
svn: r50
This commit is contained in:
Kathy Gray
parent
cb12af77ed
commit
095c8dbb87
|
|
@ -71,15 +71,17 @@
|
|||
(p-define-struct type-var (name bound src))
|
||||
|
||||
;;Code for accessing fields: var-decl and var-init
|
||||
(provide field? field-name field-modifiers field-type field-src)
|
||||
(provide field? field-name field-modifiers field-type-spec field-type set-field-type! field-src)
|
||||
(define (field? v) (or (var-decl? v) (var-init? v)))
|
||||
(define (field-name v) (var-decl-name (if (var-init? v) (var-init-var-decl v) v)))
|
||||
(define (field-modifiers v) (var-decl-modifiers (if (var-init? v) (var-init-var-decl v) v)))
|
||||
(define (field-type-spec v) (var-decl-type-spec (if (var-init? v) (var-init-var-decl v) v)))
|
||||
(define (field-type v) (var-decl-type (if (var-init? v) (var-init-var-decl v) v)))
|
||||
(define (set-field-type! v t) (set-var-decl-type! (if (var-init? v) (var-init-var-decl v) v) t))
|
||||
(define (field-src v) (var-decl-src (if (var-init? v) (var-init-var-decl v) v)))
|
||||
|
||||
;;(make-var-decl id (list modifier) type-spec src)
|
||||
(p-define-struct var-decl (name modifiers type src))
|
||||
;;(make-var-decl id (list modifier) type-spec (U #f type) src)
|
||||
(p-define-struct var-decl (name modifiers type-spec type src))
|
||||
|
||||
;;(make-var-init var-decl (U array-init expression) src)
|
||||
(p-define-struct var-init (var-decl init src))
|
||||
|
|
|
|||
|
|
@ -42,9 +42,10 @@
|
|||
((and local? (not (to-file))) name)
|
||||
(else `(file ,(path->string (build-path dir name)))))))
|
||||
(make-name (lambda ()
|
||||
(if (or (not local?) profj-lib? htdch-lib? (to-file))
|
||||
(string-append name ".ss")
|
||||
(string->symbol name)))))
|
||||
(let ((n (if scheme? (java-name->scheme name) name)))
|
||||
(if (or (not local?) profj-lib? htdch-lib? (to-file))
|
||||
(string-append n ".ss")
|
||||
(string->symbol n))))))
|
||||
(if scheme?
|
||||
(list (syn `(prefix ,(string->symbol
|
||||
(apply string-append
|
||||
|
|
@ -232,7 +233,7 @@
|
|||
loc type-recs level caller-src add-to-env))
|
||||
(append (class-record-parents record) (class-record-ifaces record)))
|
||||
))
|
||||
((and (scheme-ok?) (dir-path-scheme? in-dir) (check-scheme-file-exists? class dir))
|
||||
((and (dynamic?) (dir-path-scheme? in-dir) (check-scheme-file-exists? class dir))
|
||||
(send type-recs add-to-records class-name (make-scheme-record class (cdr path) dir null))
|
||||
(send type-recs add-require-syntax class-name (build-require-syntax class path dir #f #t)))
|
||||
(class-exists?
|
||||
|
|
@ -281,8 +282,8 @@
|
|||
|
||||
;check-scheme-file-exists? string path -> bool
|
||||
(define (check-scheme-file-exists? name path)
|
||||
(or (file-exists? (build-path path (string-append name ".ss")))
|
||||
(file-exists? (build-path path (string-append name ".scm")))))
|
||||
(or (file-exists? (build-path path (string-append (java-name->scheme name) ".ss")))
|
||||
(file-exists? (build-path path (string-append (java-name->scheme name) ".scm")))))
|
||||
|
||||
(define (create-scheme-type-rec mod-name req-path) 'scheme-types)
|
||||
|
||||
|
|
@ -326,7 +327,7 @@
|
|||
(define (find-directory path fail)
|
||||
(cond
|
||||
((null? path) (make-dir-path (build-path 'same) #f))
|
||||
((and (scheme-ok?) (equal? (car path) "scheme"))
|
||||
((and (dynamic?) (equal? (car path) "scheme"))
|
||||
(cond
|
||||
((null? (cdr path)) (make-dir-path (build-path 'same) #t))
|
||||
((not (equal? (cadr path) "lib"))
|
||||
|
|
@ -359,7 +360,7 @@
|
|||
|
||||
;get-class-list: dir-path -> (list string)
|
||||
(define (get-class-list dir)
|
||||
(if (and (scheme-ok?) (dir-path-scheme? dir))
|
||||
(if (and (dynamic?) (dir-path-scheme? dir))
|
||||
(filter (lambda (f) (or (equal? (filename-extension f) #".ss")
|
||||
(equal? (filename-extension f) #".scm")))
|
||||
(directory-list (dir-path-path dir)))
|
||||
|
|
@ -535,7 +536,7 @@
|
|||
members
|
||||
level
|
||||
type-recs)
|
||||
|
||||
|
||||
(let ((record
|
||||
(make-class-record
|
||||
cname
|
||||
|
|
@ -763,9 +764,9 @@
|
|||
(length (method-parms (car members))))
|
||||
(andmap type=?
|
||||
(method-record-atypes member-record)
|
||||
(map (lambda (t)
|
||||
(type-spec-to-type t (method-record-class member-record) level type-recs))
|
||||
(map field-type (method-parms (car members)))))
|
||||
;(map (lambda (t)
|
||||
;(type-spec-to-type t (method-record-class member-record) level type-recs))
|
||||
(map field-type-spec (method-parms (car members))));)
|
||||
(type=? (method-record-rtype member-record)
|
||||
(type-spec-to-type (method-type (car members)) (method-record-class member-record) level type-recs)))
|
||||
(car members)
|
||||
|
|
@ -794,8 +795,8 @@
|
|||
#f)
|
||||
(method-error 'repeated
|
||||
(method-name m)
|
||||
(map (lambda (t)
|
||||
(type-spec-to-type (field-type t) class level type-recs))
|
||||
(map field-type #;(lambda (t)
|
||||
(type-spec-to-type (field-type-spec t) class level type-recs))
|
||||
(method-parms m))
|
||||
(car class)
|
||||
(method-src m)
|
||||
|
|
@ -814,7 +815,7 @@
|
|||
#f)
|
||||
(method-error 'ctor-ret-value
|
||||
(method-name m)
|
||||
(map (lambda (t) (type-spec-to-type (field-type t) class level type-recs))
|
||||
(map field-type #;(lambda (t) (type-spec-to-type (field-type-spec t) class level type-recs))
|
||||
(method-parms m))
|
||||
(car class)
|
||||
(method-src m)
|
||||
|
|
@ -833,7 +834,7 @@
|
|||
#f)
|
||||
(method-error 'class-name
|
||||
(method-name m)
|
||||
(map (lambda (t) (type-spec-to-type (field-type t) class level type-recs))
|
||||
(map field-type #;(lambda (t) (type-spec-to-type (field-type-spec t) class level type-recs))
|
||||
(method-parms m))
|
||||
(car class)
|
||||
(method-src m)
|
||||
|
|
@ -908,8 +909,8 @@
|
|||
#f)
|
||||
(method-error 'conflict
|
||||
(method-name method)
|
||||
(map (lambda (t)
|
||||
(type-spec-to-type (field-type t) class level type-recs))
|
||||
(map field-type #;(lambda (t)
|
||||
(type-spec-to-type (field-type-spec t) class level type-recs))
|
||||
(method-parms method))
|
||||
(car class)
|
||||
(method-src method)
|
||||
|
|
@ -953,8 +954,8 @@
|
|||
(class (method-record-class (car methods))))
|
||||
(method-error 'illegal-abstract
|
||||
(method-name method)
|
||||
(map (lambda (t)
|
||||
(type-spec-to-type (field-type t) class level type-recs))
|
||||
(map field-type #;(lambda (t)
|
||||
(type-spec-to-type (field-type-spec t) class level type-recs))
|
||||
(method-parms method))
|
||||
(car class)
|
||||
(method-src method)
|
||||
|
|
@ -999,17 +1000,19 @@
|
|||
|
||||
;; process-field: field (string list) type-records symbol -> field-record
|
||||
(define (process-field field cname type-recs level)
|
||||
(set-field-type! field (type-spec-to-type (field-type-spec field) cname level type-recs))
|
||||
(make-field-record (id-string (field-name field))
|
||||
(check-field-modifiers level (field-modifiers field))
|
||||
(check-field-modifiers level (field-modifiers field))
|
||||
(var-init? field)
|
||||
cname
|
||||
(type-spec-to-type (field-type field) cname level type-recs)))
|
||||
(field-type field)))
|
||||
|
||||
;; process-method: method (list method-record) (list string) type-records symbol -> method-record
|
||||
(define (process-method method inherited-methods cname type-recs level . args)
|
||||
(let* ((name (id-string (method-name method)))
|
||||
(parms (map (lambda (p)
|
||||
(type-spec-to-type (field-type p) cname level type-recs))
|
||||
(set-field-type! p (type-spec-to-type (field-type-spec p) cname level type-recs))
|
||||
(field-type p))
|
||||
(method-parms method)))
|
||||
(mods (if (null? args) (method-modifiers method) (cons (car args) (method-modifiers method))))
|
||||
(ret (type-spec-to-type (method-type method) cname level type-recs))
|
||||
|
|
@ -1024,7 +1027,7 @@
|
|||
(throws-error (name-id t) (name-src t)))))
|
||||
(method-throws method))))
|
||||
(over? (overrides? name parms inherited-methods)))
|
||||
|
||||
|
||||
(when (and (memq level '(beginner intermediate))
|
||||
(member name (map method-record-name inherited-methods))
|
||||
(not over?))
|
||||
|
|
|
|||
|
|
@ -269,12 +269,14 @@
|
|||
(check-interactions-types p level loc type-recs)) prog))
|
||||
((var-init? prog)
|
||||
(let* ((name (id-string (field-name prog)))
|
||||
(check-env (remove-var-from-env name env)))
|
||||
(check-env (remove-var-from-env name env))
|
||||
(type (type-spec-to-type (field-type-spec prog) #f level type-recs)))
|
||||
(set-field-type! prog type)
|
||||
(check-var-init (var-init-init prog)
|
||||
(lambda (e env)
|
||||
(check-expr e env level type-recs c-class #f #t #t #f))
|
||||
check-env
|
||||
(type-spec-to-type (field-type prog) #f level type-recs)
|
||||
type
|
||||
(string->symbol name)
|
||||
type-recs)))
|
||||
((var-decl? prog) (void))
|
||||
|
|
@ -293,6 +295,10 @@
|
|||
(update-class-with-inner (lambda (inner)
|
||||
(set-def-members! class (cons inner (def-members class)))))
|
||||
(send type-recs set-class-reqs (def-uses class))
|
||||
|
||||
(send type-recs add-req (make-req "String" '("java" "lang")))
|
||||
(send type-recs add-req (make-req "Object" '("java" "lang")))
|
||||
|
||||
(let ((this-ref (make-ref-type name package-name)))
|
||||
(check-members (def-members class)
|
||||
(add-var-to-env "this" this-ref parm class-env)
|
||||
|
|
@ -316,6 +322,10 @@
|
|||
(update-class-with-inner (lambda (inner)
|
||||
(set-def-members! iface (cons inner (def-members iface)))))
|
||||
(send type-recs set-class-reqs (def-uses iface))
|
||||
|
||||
(send type-recs add-req (make-req "String" '("java" "lang")))
|
||||
(send type-recs add-req (make-req "Object" '("java" "lang")))
|
||||
|
||||
(check-members (def-members iface) empty-env level type-recs
|
||||
(cons (id-string (def-name iface)) p-name) #t #f (def-kind iface) #f)
|
||||
(set-def-uses! iface (send type-recs get-class-reqs))
|
||||
|
|
@ -398,7 +408,9 @@
|
|||
((field? member)
|
||||
(let ((static? (memq 'static (map modifier-kind (field-modifiers member))))
|
||||
(name (id-string (field-name member)))
|
||||
(type (type-spec-to-type (field-type member) c-class level type-recs)))
|
||||
(type (field-type member)))
|
||||
(when (ref-type? type)
|
||||
(add-required c-class (ref-type-class/iface type) (ref-type-path type) type-recs))
|
||||
(if (var-init? member)
|
||||
(check-var-init (var-init-init member)
|
||||
(lambda (e env)
|
||||
|
|
@ -690,12 +702,19 @@
|
|||
(return (if ctor?
|
||||
'void
|
||||
(type-spec-to-type (method-type method) c-class level type-recs))))
|
||||
(when (ref-type? return)
|
||||
(add-required c-class (ref-type-class/iface return) (ref-type-path return) type-recs))
|
||||
(when (eq? 'string return)
|
||||
(add-required c-class "String" '("java" "lang") type-recs))
|
||||
(when iface? (set! mods (cons 'abstract mods)))
|
||||
(when (memq 'native mods)
|
||||
(send type-recs add-req (make-req (string-append (car c-class) "-native-methods") (cdr c-class))))
|
||||
(if (or (memq 'abstract mods) (memq 'native mods))
|
||||
(when body
|
||||
(method-error (if (memq 'abstract mods) 'abstract 'native) sym-name (id-src name)))
|
||||
(begin (when body
|
||||
(method-error (if (memq 'abstract mods) 'abstract 'native) sym-name (id-src name)))
|
||||
;build the method env anyway, as that's where parametr checking happens
|
||||
(build-method-env (method-parms method) env level c-class type-recs)
|
||||
(void))
|
||||
(begin
|
||||
(when (not body) (method-error 'no-body sym-name (id-src name)))
|
||||
(when (and (not (eq? return 'void))
|
||||
|
|
@ -709,14 +728,8 @@
|
|||
(name->type n c-class (name-src n) level type-recs))
|
||||
(method-throws method))
|
||||
(build-method-env (method-parms method) env level c-class type-recs))
|
||||
level
|
||||
type-recs
|
||||
c-class
|
||||
ctor?
|
||||
static?
|
||||
#f
|
||||
#f
|
||||
#f)
|
||||
level type-recs c-class
|
||||
ctor? static? #f #f #f)
|
||||
))))
|
||||
|
||||
;build-method-env: (list field) env symbol (list string) type-records-> env
|
||||
|
|
@ -724,9 +737,14 @@
|
|||
(cond
|
||||
((null? parms) env)
|
||||
(else
|
||||
(when (ref-type? (field-type (car parms)))
|
||||
(add-required c-class (ref-type-class/iface (field-type (car parms)))
|
||||
(ref-type-path (field-type (car parms))) type-recs))
|
||||
(when (eq? 'string (field-type (car parms)))
|
||||
(add-required c-class "String" '("java" "lang") type-recs))
|
||||
(build-method-env (cdr parms)
|
||||
(add-var-to-env (id-string (field-name (car parms)))
|
||||
(type-spec-to-type (field-type (car parms)) c-class level type-recs)
|
||||
(field-type (car parms))
|
||||
(if (memq 'final (field-modifiers (car parms)))
|
||||
final-parm
|
||||
parm)
|
||||
|
|
@ -994,8 +1012,8 @@
|
|||
(unless (eq? 'boolean t)
|
||||
(kind-condition-error kind t cond-src)))))
|
||||
(cond
|
||||
((and (scheme-val? cond?) (scheme-val-type cond?)) => check)
|
||||
((scheme-val? cond?) (set-scheme-val-type! cond? 'boolean))
|
||||
((and (dynamic-val? cond?) (dynamic-val-type cond?)) => check)
|
||||
((dynamic-val? cond?) (set-dynamic-val-type! cond? 'boolean))
|
||||
(else (check cond?))))))
|
||||
|
||||
;check-ifS: type/env src (stmt env -> type/env) stmt (U stmt #f) -> type/env
|
||||
|
|
@ -1013,10 +1031,11 @@
|
|||
(define (check-throw exp/env src env interact? type-recs)
|
||||
(let ((exp-type (type/env-t exp/env)))
|
||||
(cond
|
||||
((and (scheme-val? exp-type) (scheme-val-type exp-type))
|
||||
((and (dynamic-val? exp-type) (dynamic-val-type exp-type))
|
||||
=>
|
||||
(lambda (t) (check-throw t src env interact? type-recs)))
|
||||
((scheme-val? exp-type) (set-scheme-val-type! throw-type))
|
||||
((dynamic-val? exp-type)
|
||||
(set-dynamic-val-type! exp-type throw-type))
|
||||
((or (not (ref-type? exp-type))
|
||||
(not (is-eq-subclass? exp-type throw-type type-recs)))
|
||||
(throw-error 'not-throwable exp-type src))
|
||||
|
|
@ -1082,8 +1101,13 @@
|
|||
(name (id-string (field-name local)))
|
||||
(in-env? (lookup-var-in-env name env))
|
||||
(sym-name (string->symbol name))
|
||||
(type (type-spec-to-type (field-type local) c-class level type-recs))
|
||||
(type (type-spec-to-type (field-type-spec local) c-class level type-recs))
|
||||
(new-env (lambda (extend-env) (add-var-to-env name type method-var extend-env))))
|
||||
(set-field-type! local type)
|
||||
(when (ref-type? type)
|
||||
(add-required c-class (ref-type-class/iface type) (ref-type-path type) type-recs))
|
||||
(when (eq? 'string type)
|
||||
(add-required c-class "String" '("java" "lang")))
|
||||
(when (and in-env? (not (properties-field? (var-type-properties in-env?))))
|
||||
(illegal-redefinition (field-name local) (field-src local)))
|
||||
(if is-var-init?
|
||||
|
|
@ -1100,7 +1124,7 @@
|
|||
(if (null? catches)
|
||||
new-env
|
||||
(let* ((catch (car catches))
|
||||
(type (field-type (catch-cond catch))))
|
||||
(type (field-type-spec (catch-cond catch))))
|
||||
(unless (and (ref-type? type)
|
||||
(is-eq-subclass? type throw-type type-recs))
|
||||
(catch-error type (field-src (catch-cond catch))))
|
||||
|
|
@ -1113,7 +1137,7 @@
|
|||
(if (and in-env? (not (properties-field? (var-type-properties in-env?))))
|
||||
(illegal-redefinition (field-name field) (field-src field))
|
||||
(check-s (catch-body catch)
|
||||
(add-var-to-env name (field-type field) parm env)))))
|
||||
(add-var-to-env name (field-type-spec field) parm env)))))
|
||||
catches)
|
||||
(when finally (check-s finally env)
|
||||
body-res)))
|
||||
|
|
@ -1479,9 +1503,12 @@
|
|||
((and (eq? 'boolean l) (eq? 'boolean r)) 'boolean)
|
||||
(else (bin-op-bitwise-error op l r src))))
|
||||
((&& oror) ;; 15.23, 15.24
|
||||
(prim-check (lambda (b) (eq? b 'boolean))
|
||||
(lambda (l r) 'boolean) 'bool l r op src))))
|
||||
|
||||
(prim-check (lambda (b) (or (dynamic-val? b) (eq? b 'boolean)))
|
||||
(lambda (l r)
|
||||
(when (dynamic-val? l) (set-dynamic-val-type! l 'boolean))
|
||||
(when (dynamic-val? r) (set-dynamic-val-type! r 'boolean))
|
||||
'boolean)
|
||||
'bool l r op src))))
|
||||
|
||||
;prim-check: (type -> bool) (type type -> type) type type src -> type
|
||||
(define (prim-check ok? return expt l r op src)
|
||||
|
|
@ -1495,10 +1522,10 @@
|
|||
;;unary-promotion: type -> symbol
|
||||
(define (unary-promotion t)
|
||||
(cond
|
||||
((and (scheme-val? t) (scheme-val-type t))
|
||||
(unary-promotion (scheme-val-type t)))
|
||||
((scheme-val? t)
|
||||
(set-scheme-val-type! t 'int) 'int)
|
||||
((and (dynamic-val? t) (dynamic-val-type t))
|
||||
(unary-promotion (dynamic-val-type t)))
|
||||
((dynamic-val? t)
|
||||
(set-dynamic-val-type! t 'int) 'int)
|
||||
(else
|
||||
(case t ((byte short char) 'int) (else t)))))
|
||||
|
||||
|
|
@ -1506,21 +1533,23 @@
|
|||
;; binary-promotion: type type -> type
|
||||
(define (binary-promotion t1 t2)
|
||||
(cond
|
||||
((and (scheme-val? t1) (scheme-val? t2))
|
||||
((and (dynamic-val? t1) (dynamic-val? t2))
|
||||
(cond
|
||||
((and (scheme-val-type t1) (scheme-val-type t2))
|
||||
(binary-promotion (scheme-val-type t1) (scheme-val-type t2)))
|
||||
((or (scheme-val-type t1) (scheme-val-type t2))
|
||||
(error 'internal-error "Binary promotion does not know how to handle this situation yet"))
|
||||
(else (make-scheme-val (gensym 'unnamed) #f #f #f))))
|
||||
((scheme-val? t1)
|
||||
((and (dynamic-val-type t1) (dynamic-val-type t2))
|
||||
(binary-promotion (dynamic-val-type t1) (dynamic-val-type t2)))
|
||||
((dynamic-val-type t1)
|
||||
(binary-promotion (dynamic-val-type t1) t2))
|
||||
((dynamic-val-type t2)
|
||||
(binary-promotion t1 (dynamic-val-type t2)))
|
||||
(else (make-dynamic-val #f))))
|
||||
((dynamic-val? t1)
|
||||
(cond
|
||||
((scheme-val-type t1) (binary-promotion (scheme-val-type t1) t2))
|
||||
(else (set-scheme-val-type! t1 t2) t2)))
|
||||
((scheme-val? t2)
|
||||
((dynamic-val-type t1) (binary-promotion (dynamic-val-type t1) t2))
|
||||
(else (set-dynamic-val-type! t1 t2) t2)))
|
||||
((dynamic-val? t2)
|
||||
(cond
|
||||
((scheme-val-type t2) (binary-promotion t1 (scheme-val-type t2)))
|
||||
(else (set-scheme-val-type! t2 t1) t1)))
|
||||
((dynamic-val-type t2) (binary-promotion t1 (dynamic-val-type t2)))
|
||||
(else (set-dynamic-val-type! t2 t1) t1)))
|
||||
((or (eq? 'double t1) (eq? 'double t2)) 'double)
|
||||
((or (eq? 'float t1) (eq? 'float t2)) 'float)
|
||||
((or (eq? 'long t1) (eq? 'long t2)) 'long)
|
||||
|
|
@ -1536,39 +1565,45 @@
|
|||
(fname (id-string (field-access-field acc)))
|
||||
(src (id-src (field-access-field acc)))
|
||||
(class-rec null)
|
||||
(record null))
|
||||
(set! record
|
||||
(if obj
|
||||
(field-lookup fname (type/env-t obj-type/env) obj src level type-recs)
|
||||
(let* ((name (var-access-class (field-access-access acc))))
|
||||
(set! class-rec
|
||||
;First clause: static field of a local inner class
|
||||
(or (and (or (string? name) (= 1 (length name)))
|
||||
(let ((rec? (lookup-local-inner (if (pair? name) (car name) name) env)))
|
||||
(and rec? (inner-rec-record rec?))))
|
||||
(get-record (send type-recs get-class-record
|
||||
(if (pair? name) name (list name))
|
||||
#f
|
||||
((get-importer type-recs) name type-recs level src))
|
||||
type-recs)))
|
||||
(cond
|
||||
((class-record? class-rec)
|
||||
(get-field-record fname class-rec
|
||||
(lambda ()
|
||||
(let* ((class? (member fname (send type-recs get-class-env)))
|
||||
(method? (not (null? (get-method-records fname class-rec)))))
|
||||
(field-lookup-error (if class? 'class-name
|
||||
(if method? 'method-name 'not-found))
|
||||
(string->symbol fname)
|
||||
(make-ref-type (if (pair? name) (car name) name) null)
|
||||
src)))))
|
||||
((scheme-record? class-rec)
|
||||
(lookup-scheme class-rec fname
|
||||
(lambda () (field-lookup-error 'not-found
|
||||
(string->symbol fname)
|
||||
(make-ref-type (if (pair? name) (car name) name)
|
||||
(list "scheme"))
|
||||
src))))))))
|
||||
(record
|
||||
(cond
|
||||
((and obj (dynamic-val? (expr-types obj)))
|
||||
(set-dynamic-val-type! (expr-types obj)
|
||||
(make-unknown-ref (make-field-contract fname (make-dynamic-val #f))))
|
||||
(expr-types obj))
|
||||
(obj (field-lookup fname (type/env-t obj-type/env) obj src level type-recs))
|
||||
(else
|
||||
(let* ((name (var-access-class (field-access-access acc))))
|
||||
(set! class-rec
|
||||
;First clause: static field of a local inner class
|
||||
(or (and (or (string? name) (= 1 (length name)))
|
||||
(let ((rec? (lookup-local-inner (if (pair? name) (car name) name) env)))
|
||||
(and rec? (inner-rec-record rec?))))
|
||||
(get-record (send type-recs get-class-record
|
||||
(if (pair? name) name (list name))
|
||||
#f
|
||||
((get-importer type-recs) name type-recs level src))
|
||||
type-recs)))
|
||||
(cond
|
||||
((class-record? class-rec)
|
||||
(get-field-record fname class-rec
|
||||
(lambda ()
|
||||
(let* ((class? (member fname (send type-recs get-class-env)))
|
||||
(method? (not (null? (get-method-records fname class-rec)))))
|
||||
(field-lookup-error (if class? 'class-name
|
||||
(if method? 'method-name 'not-found))
|
||||
(string->symbol fname)
|
||||
(make-ref-type (if (pair? name) (car name) name) null)
|
||||
src)))))
|
||||
((scheme-record? class-rec)
|
||||
(module-has-binding? class-rec fname
|
||||
(lambda () (field-lookup-error 'not-found
|
||||
(string->symbol fname)
|
||||
(make-ref-type (if (pair? name) (car name) name)
|
||||
(list "scheme"))
|
||||
src)))
|
||||
(set-id-string! (field-access-field acc) (java-name->scheme fname))
|
||||
(make-dynamic-val #f))))))))
|
||||
(cond
|
||||
((field-record? record)
|
||||
(let* ((field-class (if (null? (cdr (field-record-class record)))
|
||||
|
|
@ -1629,14 +1664,15 @@
|
|||
(restricted-field-access-err (field-access-field acc) field-class src)))
|
||||
(make-type/env (field-record-type record)
|
||||
(if (type/env? obj-type/env) (type/env-e obj-type/env) env))))
|
||||
((and (scheme-val? record) (scheme-val-instance? record))
|
||||
((and (dynamic-val? record) (dynamic-val-type record))
|
||||
(set-field-access-access! acc (make-var-access #f #t #t 'public 'unknown))
|
||||
(make-type/env record (type/env-e obj-type/env)))
|
||||
((scheme-val? record)
|
||||
(make-type/env (field-contract-type (unknown-ref-access (dynamic-val-type record)))
|
||||
obj-type/env))
|
||||
((dynamic-val? record)
|
||||
(add-required c-class (scheme-record-name class-rec)
|
||||
(cons "scheme" (scheme-record-path class-rec)) type-recs)
|
||||
(set-field-access-access! acc (make-var-access #t #t #t 'public (scheme-record-name class-rec)))
|
||||
(make-type/env record (type/env-e obj-type/env)))
|
||||
(make-type/env record (if obj (type/env-e obj-type/env) env)))
|
||||
(else
|
||||
(error 'internal-error "field-access given unknown form of field information")))))
|
||||
((local-access? acc)
|
||||
|
|
@ -1648,7 +1684,10 @@
|
|||
(unless (properties-parm? (var-type-properties var))
|
||||
(unless (var-set? (var-type-var var) env)
|
||||
(unset-var-error (string->symbol (var-type-var var)) (id-src (local-access-name acc)))))))
|
||||
(make-type/env (var-type-type var) env)))
|
||||
(make-type/env (if (eq? 'dynamic (var-type-type var))
|
||||
(make-dynamic-val #f)
|
||||
(var-type-type var))
|
||||
env)))
|
||||
|
||||
(else
|
||||
(let* ((first-acc (id-string (car acc)))
|
||||
|
|
@ -1738,24 +1777,11 @@
|
|||
(equal? (send type-recs get-interactions-package) (cdr class1)))
|
||||
(else (equal? (cdr class1) (cdr class2)))))
|
||||
|
||||
;; field-lookup: string type expression src symbol type-records -> (U field-record scheme-val)
|
||||
;; field-lookup: string type expression src symbol type-records -> (U field-record dynamic-val)
|
||||
(define (field-lookup fname obj-type obj src level type-recs)
|
||||
(let ((obj-src (expr-src obj))
|
||||
(name (string->symbol fname)))
|
||||
(cond
|
||||
((and (scheme-val? obj-type) (scheme-val-type obj-type))
|
||||
(field-lookup fname (scheme-val-type obj-type) obj src level type-recs))
|
||||
((scheme-val? obj-type)
|
||||
(let ((field-c (make-scheme-val fname #t #t #f)))
|
||||
(set-scheme-val-type! (make-unknown-ref null (list field-c)))
|
||||
field-c))
|
||||
((unknown-ref? obj-type)
|
||||
(cond
|
||||
((field-contract-lookup fname (unknown-ref-fields obj-type)) => (lambda (x) x))
|
||||
(else
|
||||
(let ((field-c (make-scheme-val fname #t #t #f)))
|
||||
(set-unknown-ref-fields! obj-type (cons field-c (unknown-ref-fields obj-type)))
|
||||
field-c))))
|
||||
((reference-type? obj-type)
|
||||
(let ((obj-record (get-record (send type-recs get-class-record obj-type #f
|
||||
((get-importer type-recs) obj-type type-recs level obj-src))
|
||||
|
|
@ -1860,6 +1886,7 @@
|
|||
(let* ((this (unless static? (lookup-this type-recs env)))
|
||||
(src (expr-src call))
|
||||
(name (call-method-name call))
|
||||
(name-string (when (id? name) (id-string name)))
|
||||
(expr (call-expr call))
|
||||
(exp-type #f)
|
||||
(handle-call-error
|
||||
|
|
@ -1879,27 +1906,18 @@
|
|||
(car (class-record-name record))
|
||||
(lambda () null))
|
||||
(cdr (class-record-name record))))))
|
||||
(get-method-records (id-string name) record))
|
||||
(get-method-records name-string record))
|
||||
((scheme-record? record)
|
||||
(let ((result
|
||||
(lookup-scheme record (id-string name)
|
||||
(lambda () (no-method-error 'class 'not-found
|
||||
(string->symbol (id-string name))
|
||||
(make-ref-type (if (pair? name) (car name) name)
|
||||
(list "scheme"))
|
||||
src)))))
|
||||
(if (scheme-val-type result)
|
||||
(if (method-contract? (scheme-val-type result))
|
||||
(list (scheme-val-type result))
|
||||
(no-method-error 'class 'field (string->symbol (id-string name))
|
||||
(make-ref-type (if (pair? name) (car name) name)
|
||||
(list "scheme"))
|
||||
src))
|
||||
(let ((m-c
|
||||
(make-method-contract (id-string name)
|
||||
(make-scheme-val 'method-result #t #f #f) #f)))
|
||||
(set-scheme-val-type! result m-c)
|
||||
(list m-c)))))))
|
||||
(module-has-binding? record name-string
|
||||
(lambda () (no-method-error 'class 'not-found
|
||||
(string->symbol name-string)
|
||||
(make-ref-type name (list "scheme"))
|
||||
src)))
|
||||
(cond
|
||||
((name? name) (set-id-string! (name-id name) (java-name->scheme name-string)))
|
||||
((id? name) (set-id-string! name (java-name->scheme name-string))))
|
||||
(list (make-method-contract (java-name->scheme name-string) #f #f)))))
|
||||
;Teaching languages
|
||||
(if (and (= (length (access-name expr)) 1)
|
||||
(with-handlers ((exn:fail:syntax? (lambda (exn) #f)))
|
||||
(type-exists? (id-string (car (access-name expr)))
|
||||
|
|
@ -1915,7 +1933,7 @@
|
|||
(send type-recs lookup-path
|
||||
(car (class-record-name record))
|
||||
(lambda () null)))))
|
||||
(let ((methods (get-method-records (id-string name) record)))
|
||||
(let ((methods (get-method-records name-string record)))
|
||||
(unless (andmap (lambda (x) x)
|
||||
(map (lambda (mrec) (memq 'static (method-record-modifiers mrec)))
|
||||
methods))
|
||||
|
|
@ -1935,13 +1953,13 @@
|
|||
(get-method-records (car (class-record-name this)) this))))
|
||||
(else
|
||||
(cond
|
||||
((special-name? expr)
|
||||
(if (equal? (special-name-name expr) "super")
|
||||
(let ((parent (car (class-record-parents this))))
|
||||
(set! exp-type 'super)
|
||||
(get-method-records (id-string name)
|
||||
(send type-recs get-class-record parent)))
|
||||
(get-method-records (id-string name) this)))
|
||||
((and (special-name? expr) (equal? (special-name-name expr) "super"))
|
||||
(when static?
|
||||
(super-special-error (expr-src expr) interact?))
|
||||
(let ((parent (car (class-record-parents this))))
|
||||
(set! exp-type 'super)
|
||||
(get-method-records name-string
|
||||
(send type-recs get-class-record parent))))
|
||||
(expr
|
||||
(let* ((call-exp/env
|
||||
(with-handlers ((exn:fail:syntax? handle-call-error))
|
||||
|
|
@ -1956,21 +1974,16 @@
|
|||
((list? call-exp) call-exp)
|
||||
((array-type? call-exp)
|
||||
(set! exp-type call-exp)
|
||||
(get-method-records (id-string name)
|
||||
(get-method-records name-string
|
||||
(send type-recs get-class-record object-type)))
|
||||
((and (scheme-val? call-exp) (scheme-val-type call-exp)
|
||||
(unknown-ref? (scheme-val-type call-exp)))
|
||||
(set! exp-type call-exp)
|
||||
(get-method-contracts (id-string name) (scheme-val-type call-exp)))
|
||||
((and (scheme-val? call-exp) (not (scheme-val-type call-exp)))
|
||||
(let ((m-contract (make-method-contract (id-string name)
|
||||
(make-scheme-val 'method-return #t #f #f) #f)))
|
||||
((dynamic-val? call-exp)
|
||||
(let ((m-contract (make-method-contract name-string #f #f)))
|
||||
(set-dynamic-val-type! call-exp (make-unknown-ref m-contract))
|
||||
(set! exp-type call-exp)
|
||||
(set-scheme-val-type! call-exp (make-unknown-ref (list m-contract) null))
|
||||
(list m-contract)))
|
||||
(list m-contract)))
|
||||
((reference-type? call-exp)
|
||||
(set! exp-type call-exp)
|
||||
(get-method-records (id-string name)
|
||||
(get-method-records name-string
|
||||
(get-record
|
||||
(send type-recs get-class-record call-exp #f
|
||||
((get-importer type-recs)
|
||||
|
|
@ -1982,8 +1995,14 @@
|
|||
(if (eq? level 'beginner)
|
||||
(beginner-method-access-error name (id-src name))
|
||||
(let ((rec (if static? (send type-recs get-class-record c-class) this)))
|
||||
(if (null? rec) null
|
||||
(get-method-records (id-string name) rec))))))))))
|
||||
(cond
|
||||
((and (null? rec) (dynamic?) (lookup-var-in-env name-string env)) =>
|
||||
(lambda (var-type)
|
||||
(if (eq? 'dynamic (var-type-type var-type))
|
||||
(list (make-method-contract (string-append name-string "~f") #f #f))
|
||||
null)))
|
||||
((null? rec) null)
|
||||
(else (get-method-records name-string rec)))))))))))
|
||||
|
||||
(when (null? methods)
|
||||
(let* ((rec (if exp-type
|
||||
|
|
@ -1992,33 +2011,34 @@
|
|||
(class? (member (id-string name) (send type-recs get-class-env)))
|
||||
(field? (cond
|
||||
((array-type? exp-type) (equal? (id-string name) "length"))
|
||||
((null? rec)
|
||||
(member (id-string name)
|
||||
((null? rec)
|
||||
(member name-string
|
||||
(map field-record-name (send type-recs get-interactions-fields))))
|
||||
(else (member (id-string name) (map field-record-name (get-field-records rec))))))
|
||||
(else (member name-string (map field-record-name (get-field-records rec))))))
|
||||
(sub-kind (if class? 'class-name (if field? 'field-name 'not-found))))
|
||||
(cond
|
||||
((eq? exp-type 'super) (no-method-error 'super sub-kind exp-type name src))
|
||||
(exp-type (no-method-error 'class sub-kind exp-type name src))
|
||||
(else
|
||||
(cond
|
||||
((close-to-keyword? (id-string name))
|
||||
((close-to-keyword? name-string)
|
||||
(close-to-keyword-error 'method name src))
|
||||
(interact? (interaction-call-error name src level))
|
||||
(else
|
||||
(no-method-error 'this sub-kind exp-type name src)))))))
|
||||
|
||||
(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))
|
||||
(unless (method-contract? (car methods))
|
||||
(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))
|
||||
(method-record
|
||||
(method-record
|
||||
(cond
|
||||
((method-contract? (car methods))
|
||||
(set-method-contract-args! (car methods) args)
|
||||
(set-method-contract-return! (car methods) (make-dynamic-val #f))
|
||||
(car methods))
|
||||
((memq level '(full advanced))
|
||||
(resolve-overloading methods
|
||||
|
|
@ -2031,7 +2051,7 @@
|
|||
(let ((teaching-error
|
||||
(lambda (kind)
|
||||
(if (error-file-exists? (method-record-class (car methods)) type-recs)
|
||||
(call-provided-error (id-string name) args kind)
|
||||
(call-provided-error name-string args kind)
|
||||
(teaching-call-error kind #f name args exp-type src methods)))))
|
||||
(resolve-overloading methods
|
||||
args
|
||||
|
|
@ -2076,10 +2096,14 @@
|
|||
(eq? 'void (method-record-rtype method-record)))
|
||||
(beginner-call-error name src))
|
||||
(unless (eq? level 'full)
|
||||
(when (and (id? name) (is-method-restricted? (id-string name) (method-record-class method-record)))
|
||||
(when (and (id? name) (is-method-restricted? name-string (method-record-class method-record)))
|
||||
(restricted-method-call name (method-record-class method-record) src)))
|
||||
(set-call-method-record! call method-record)
|
||||
(make-type/env (method-record-rtype method-record) (cadr args/env)))
|
||||
(make-type/env
|
||||
(if (eq? 'dynamic (method-record-rtype method-record))
|
||||
(make-dynamic-val #f)
|
||||
(method-record-rtype method-record))
|
||||
(cadr args/env)))
|
||||
((method-contract? method-record)
|
||||
(set-call-method-record! call method-record)
|
||||
(make-type/env (method-contract-return method-record) (cadr args/env)))))))
|
||||
|
|
@ -2249,8 +2273,8 @@
|
|||
(else
|
||||
(let* ((t/env (check-sub-exp (car subs) env))
|
||||
(t (type/env-t t/env)))
|
||||
(when (and (scheme-val? t) (not (scheme-val-type t)))
|
||||
(set-scheme-val-type! t 'int))
|
||||
(when (and (dynamic-val? t) (not (dynamic-val-type t)))
|
||||
(set-dynamic-val-type! t 'int))
|
||||
(unless (prim-integral-type? t)
|
||||
(array-size-error type t (expr-src (car subs))))
|
||||
(loop (cdr subs) (type/env-e t/env))))))))
|
||||
|
|
@ -2288,25 +2312,28 @@
|
|||
(then (type/env-t then/env))
|
||||
(else-t (type/env-t else/env)))
|
||||
(cond
|
||||
((and (scheme-val? test) (scheme-val-type test))
|
||||
(unless (eq? 'boolean (scheme-val-type test))
|
||||
(condition-error (scheme-val-type test) test-src)))
|
||||
((scheme-val? test) (set-scheme-val-type! test 'boolean))
|
||||
((and (dynamic-val? test) (dynamic-val-type test))
|
||||
(unless (eq? 'boolean (dynamic-val-type test))
|
||||
(condition-error (dynamic-val-type test) test-src)))
|
||||
((dynamic-val? test) (set-dynamic-val-type! test 'boolean))
|
||||
(else
|
||||
(unless (eq? 'boolean test) (condition-error test test-src))))
|
||||
(make-type/env
|
||||
(cond
|
||||
((and (or (scheme-val? then) (scheme-val? else-t))
|
||||
((and (or (dynamic-val? then) (dynamic-val? else-t))
|
||||
(or (eq? 'boolean then) (eq? 'boolean else-t)))
|
||||
(cond
|
||||
((scheme-val? then)
|
||||
((dynamic-val? then)
|
||||
(cond
|
||||
((and (scheme-val-type then) (eq? 'boolean (scheme-val-type then))) 'boolean)
|
||||
(else (set-scheme-val-type! then 'boolean) 'boolean)))
|
||||
((scheme-val? else-t)
|
||||
((and (dynamic-val-type then) (eq? 'boolean (dynamic-val-type then))) 'boolean)
|
||||
(else (set-dynamic-val-type! then 'boolean) 'boolean)))
|
||||
((dynamic-val? else-t)
|
||||
(cond
|
||||
((and (scheme-val-type else-t) (eq? 'boolean (scheme-val-type else-t))) 'boolean)
|
||||
(else (set-scheme-val-type! else-t 'boolean) 'boolean)))))
|
||||
((and (dynamic-val-type else-t) (eq? 'boolean (dynamic-val-type else-t))) 'boolean)
|
||||
(else (set-dynamic-val-type! else-t 'boolean) 'boolean)))))
|
||||
((and (dynamic-val? then) (dynamic-val? else-t)
|
||||
(not (dynamic-val-type then)) (not (dynamic-val-type else-t)))
|
||||
(make-dynamic-val #f))
|
||||
((and (eq? 'boolean then) (eq? 'boolean else-t)) 'boolean)
|
||||
((and (prim-numeric-type? then) (prim-numeric-type? else-t))
|
||||
;; This is not entirely correct, but close enough due to using scheme ints
|
||||
|
|
@ -2389,6 +2416,10 @@
|
|||
(send type-recs add-req (make-req (ref-type-class/iface type) (ref-type-path type)))))
|
||||
(make-type/env
|
||||
(cond
|
||||
((dynamic-val? exp-type)
|
||||
(set-dynamic-val-type! exp-type type)
|
||||
type)
|
||||
((eq? 'dynamic type) (make-dynamic-val #f))
|
||||
((and (reference-type? exp-type) (reference-type? type)) type)
|
||||
((and (not (reference-type? exp-type)) (not (reference-type? type))) type)
|
||||
((reference-type? exp-type) (cast-error 'from-prim exp-type type src))
|
||||
|
|
@ -2416,7 +2447,7 @@
|
|||
(send type-recs add-req (make-req (ref-type-class/iface type) (ref-type-path type)))))
|
||||
(make-type/env
|
||||
(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)
|
||||
(is-eq-subclass? type exp-type type-recs))) 'boolean)
|
||||
((and (ref-type? exp-type) (ref-type? type))
|
||||
|
|
@ -2429,6 +2460,7 @@
|
|||
((and (array-type? exp-type) (array-type? type)
|
||||
(= (array-type-dim exp-type) (array-type-dim type))
|
||||
(or (assignment-conversion exp-type type type-recs))) 'boolean)
|
||||
((dynamic-val? exp-type) 'boolean)
|
||||
((and (array-type? exp-type) (array-type? type))
|
||||
(instanceof-error 'not-related-array type exp-type src))
|
||||
((array-type? exp-type)
|
||||
|
|
@ -2676,6 +2708,13 @@
|
|||
(if interactions? "the interactions window" "static code"))
|
||||
'this src))
|
||||
|
||||
;super-special-error: src bool -> void
|
||||
(define (super-special-error src interact?)
|
||||
(raise-error 'super
|
||||
(format "use of 'super' is not allowed in ~a"
|
||||
(if interact? "the interactions window" "static code"))
|
||||
'super src))
|
||||
|
||||
;;Call errors
|
||||
|
||||
;prim-call-error type id src symbol -> void
|
||||
|
|
@ -3158,11 +3197,11 @@
|
|||
((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)))
|
||||
n (id-src name))))
|
||||
|
||||
|
||||
|
||||
;implicit import error
|
||||
;class-lookup-error: string src -> void
|
||||
(define (class-lookup-error class src)
|
||||
(if (path? class) (set! class (path->string class)))
|
||||
(raise-error (string->symbol class)
|
||||
(format "Implicit import of class ~a failed as this class does not exist at the specified location"
|
||||
class)
|
||||
|
|
|
|||
|
|
@ -34,19 +34,25 @@
|
|||
(cond
|
||||
((and (eq? src 'file) (eq? dest 'file))
|
||||
(let-values (((path-base file dir?) (split-path (path->complete-path (build-path name)))))
|
||||
(let ((compiled-path (build-path path-base "compiled" (path-replace-suffix file ".zo"))))
|
||||
(unless (and (file-exists? compiled-path)
|
||||
(> (file-or-directory-modify-seconds compiled-path)
|
||||
(file-or-directory-modify-seconds (build-path name))))
|
||||
(let ((compiled-path (build-path path-base "compiled" (path-replace-suffix file ".zo")))
|
||||
(type-path (build-path path-base "compiled" (path-replace-suffix file ".jinfo"))))
|
||||
(unless (and (and (file-exists? compiled-path)
|
||||
(> (file-or-directory-modify-seconds compiled-path)
|
||||
(file-or-directory-modify-seconds (build-path name))))
|
||||
(and (file-exists? type-path)
|
||||
(read-record type-path)))
|
||||
(call-with-input-file name (lambda (port) (compile-to-file port name level)))))))
|
||||
((eq? dest 'file)
|
||||
(compile-to-file port loc level))
|
||||
((eq? src 'file)
|
||||
(let-values (((path-base file dir?) (split-path (path->complete-path (build-path name)))))
|
||||
(let ((compiled-path (build-path path-base "compiled" (path-replace-suffix file ".zo"))))
|
||||
(unless (and (file-exists? compiled-path)
|
||||
(> (file-or-directory-modify-seconds compiled-path)
|
||||
(file-or-directory-modify-seconds (build-path name))))
|
||||
(let ((compiled-path (build-path path-base "compiled" (path-replace-suffix file ".zo")))
|
||||
(type-path (build-path path-base "compiled" (path-replace-suffix file ".jinfo"))))
|
||||
(unless (or (and (file-exists? compiled-path)
|
||||
(> (file-or-directory-modify-seconds compiled-path)
|
||||
(file-or-directory-modify-seconds (build-path name))))
|
||||
(and (file-exists? type-path)
|
||||
(read-record type-path)))
|
||||
(call-with-input-file
|
||||
name
|
||||
(lambda (port) (compile-java-internal port name type-recs #f level)))))))
|
||||
|
|
|
|||
|
|
@ -7,4 +7,4 @@
|
|||
()
|
||||
()
|
||||
()
|
||||
"version1")
|
||||
"version2")
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
(module |ArithmeticException| mzscheme
|
||||
(module ArithmeticException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |ArithmeticException|))
|
||||
(provide
|
||||
ArithmeticException
|
||||
guard-convert-ArithmeticException
|
||||
convert-assert-ArithmeticException
|
||||
wrap-convert-assert-ArithmeticException
|
||||
dynamic-ArithmeticException/c
|
||||
static-ArithmeticException/c
|
||||
ArithmeticException-ArithmeticException-constructor~generic
|
||||
ArithmeticException-ArithmeticException-constructor-java.lang.String~generic))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,12 @@
|
|||
(module |ArrayIndexOutOfBoundsException| mzscheme
|
||||
(module ArrayIndexOutOfBoundsException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |ArrayIndexOutOfBoundsException|))
|
||||
(provide
|
||||
ArrayIndexOutOfBoundsException
|
||||
guard-convert-ArrayIndexOutOfBoundsException
|
||||
convert-assert-ArrayIndexOutOfBoundsException
|
||||
wrap-convert-assert-ArrayIndexOutOfBoundsException
|
||||
dynamic-ArrayIndexOutOfBoundsException/c
|
||||
static-ArrayIndexOutOfBoundsException/c
|
||||
ArrayIndexOutOfBoundsException-ArrayIndexOutOfBoundsException-constructor~generic
|
||||
ArrayIndexOutOfBoundsException-ArrayIndexOutOfBoundsException-constructor-java.lang.String~generic
|
||||
ArrayIndexOutOfBoundsException-ArrayIndexOutOfBoundsException-constructor-int~generic))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
(module |ArrayStoreException| mzscheme
|
||||
(module ArrayStoreException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |ArrayStoreException|))
|
||||
(provide
|
||||
ArrayStoreException
|
||||
guard-convert-ArrayStoreException
|
||||
convert-assert-ArrayStoreException
|
||||
wrap-convert-assert-ArrayStoreException
|
||||
dynamic-ArrayStoreException/c
|
||||
static-ArrayStoreException/c
|
||||
ArrayStoreException-ArrayStoreException-constructor~generic
|
||||
ArrayStoreException-ArrayStoreException-constructor-java.lang.String~generic))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
(module |ClassCastException| mzscheme
|
||||
(module ClassCastException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |ClassCastException|))
|
||||
(provide
|
||||
ClassCastException
|
||||
guard-convert-ClassCastException
|
||||
convert-assert-ClassCastException
|
||||
wrap-convert-assert-ClassCastException
|
||||
dynamic-ClassCastException/c
|
||||
static-ClassCastException/c
|
||||
ClassCastException-ClassCastException-constructor~generic
|
||||
ClassCastException-ClassCastException-constructor-java.lang.String~generic))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,14 @@
|
|||
(module |ClassNotFoundException| mzscheme
|
||||
(module ClassNotFoundException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |ClassNotFoundException|))
|
||||
(provide
|
||||
ClassNotFoundException
|
||||
guard-convert-ClassNotFoundException
|
||||
convert-assert-ClassNotFoundException
|
||||
wrap-convert-assert-ClassNotFoundException
|
||||
dynamic-ClassNotFoundException/c
|
||||
static-ClassNotFoundException/c
|
||||
ClassNotFoundException-ClassNotFoundException-constructor~generic
|
||||
ClassNotFoundException-ClassNotFoundException-constructor-java.lang.String~generic
|
||||
ClassNotFoundException-ClassNotFoundException-constructor-java.lang.String-java.lang.Throwable~generic
|
||||
ClassNotFoundException-getException~generic
|
||||
ClassNotFoundException-getCause~generic))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
(module |CloneNotSupportedException| mzscheme
|
||||
(module CloneNotSupportedException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |CloneNotSupportedException|))
|
||||
(provide
|
||||
CloneNotSupportedException
|
||||
guard-convert-CloneNotSupportedException
|
||||
convert-assert-CloneNotSupportedException
|
||||
wrap-convert-assert-CloneNotSupportedException
|
||||
dynamic-CloneNotSupportedException/c
|
||||
static-CloneNotSupportedException/c
|
||||
CloneNotSupportedException-CloneNotSupportedException-constructor~generic
|
||||
CloneNotSupportedException-CloneNotSupportedException-constructor-java.lang.String~generic))
|
||||
|
|
|
|||
|
|
@ -7,4 +7,4 @@
|
|||
()
|
||||
()
|
||||
()
|
||||
"version1")
|
||||
"version2")
|
||||
|
|
|
|||
|
|
@ -1,3 +1,13 @@
|
|||
(module |Exception| mzscheme
|
||||
(module Exception mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |Exception|))
|
||||
(provide
|
||||
Exception
|
||||
guard-convert-Exception
|
||||
convert-assert-Exception
|
||||
wrap-convert-assert-Exception
|
||||
dynamic-Exception/c
|
||||
static-Exception/c
|
||||
Exception-Exception-constructor~generic
|
||||
Exception-Exception-constructor-java.lang.String~generic
|
||||
Exception-Exception-constructor-java.lang.String-java.lang.Throwable~generic
|
||||
Exception-Exception-constructor-java.lang.Throwable~generic))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
(module |IllegalAccessException| mzscheme
|
||||
(module IllegalAccessException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |IllegalAccessException|))
|
||||
(provide
|
||||
IllegalAccessException
|
||||
guard-convert-IllegalAccessException
|
||||
convert-assert-IllegalAccessException
|
||||
wrap-convert-assert-IllegalAccessException
|
||||
dynamic-IllegalAccessException/c
|
||||
static-IllegalAccessException/c
|
||||
IllegalAccessException-IllegalAccessException-constructor~generic
|
||||
IllegalAccessException-IllegalAccessException-constructor-java.lang.String~generic))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
(module |IllegalArgumentException| mzscheme
|
||||
(module IllegalArgumentException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |IllegalArgumentException|))
|
||||
(provide
|
||||
IllegalArgumentException
|
||||
guard-convert-IllegalArgumentException
|
||||
convert-assert-IllegalArgumentException
|
||||
wrap-convert-assert-IllegalArgumentException
|
||||
dynamic-IllegalArgumentException/c
|
||||
static-IllegalArgumentException/c
|
||||
IllegalArgumentException-IllegalArgumentException-constructor~generic
|
||||
IllegalArgumentException-IllegalArgumentException-constructor-java.lang.String~generic))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
(module |IllegalMonitorStateException| mzscheme
|
||||
(module IllegalMonitorStateException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |IllegalMonitorStateException|))
|
||||
(provide
|
||||
IllegalMonitorStateException
|
||||
guard-convert-IllegalMonitorStateException
|
||||
convert-assert-IllegalMonitorStateException
|
||||
wrap-convert-assert-IllegalMonitorStateException
|
||||
dynamic-IllegalMonitorStateException/c
|
||||
static-IllegalMonitorStateException/c
|
||||
IllegalMonitorStateException-IllegalMonitorStateException-constructor~generic
|
||||
IllegalMonitorStateException-IllegalMonitorStateException-constructor-java.lang.String~generic))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
(module |IllegalStateException| mzscheme
|
||||
(module IllegalStateException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |IllegalStateException|))
|
||||
(provide
|
||||
IllegalStateException
|
||||
guard-convert-IllegalStateException
|
||||
convert-assert-IllegalStateException
|
||||
wrap-convert-assert-IllegalStateException
|
||||
dynamic-IllegalStateException/c
|
||||
static-IllegalStateException/c
|
||||
IllegalStateException-IllegalStateException-constructor~generic
|
||||
IllegalStateException-IllegalStateException-constructor-java.lang.String~generic))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
(module |IllegalThreadStateException| mzscheme
|
||||
(module IllegalThreadStateException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |IllegalThreadStateException|))
|
||||
(provide
|
||||
IllegalThreadStateException
|
||||
guard-convert-IllegalThreadStateException
|
||||
convert-assert-IllegalThreadStateException
|
||||
wrap-convert-assert-IllegalThreadStateException
|
||||
dynamic-IllegalThreadStateException/c
|
||||
static-IllegalThreadStateException/c
|
||||
IllegalThreadStateException-IllegalThreadStateException-constructor~generic
|
||||
IllegalThreadStateException-IllegalThreadStateException-constructor-java.lang.String~generic))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
(module |IndexOutOfBoundsException| mzscheme
|
||||
(module IndexOutOfBoundsException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |IndexOutOfBoundsException|))
|
||||
(provide
|
||||
IndexOutOfBoundsException
|
||||
guard-convert-IndexOutOfBoundsException
|
||||
convert-assert-IndexOutOfBoundsException
|
||||
wrap-convert-assert-IndexOutOfBoundsException
|
||||
dynamic-IndexOutOfBoundsException/c
|
||||
static-IndexOutOfBoundsException/c
|
||||
IndexOutOfBoundsException-IndexOutOfBoundsException-constructor~generic
|
||||
IndexOutOfBoundsException-IndexOutOfBoundsException-constructor-java.lang.String~generic))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
(module |InstantiationException| mzscheme
|
||||
(module InstantiationException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |InstantiationException|))
|
||||
(provide
|
||||
InstantiationException
|
||||
guard-convert-InstantiationException
|
||||
convert-assert-InstantiationException
|
||||
wrap-convert-assert-InstantiationException
|
||||
dynamic-InstantiationException/c
|
||||
static-InstantiationException/c
|
||||
InstantiationException-InstantiationException-constructor~generic
|
||||
InstantiationException-InstantiationException-constructor-java.lang.String~generic))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
(module |InterruptedException| mzscheme
|
||||
(module InterruptedException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |InterruptedException|))
|
||||
(provide
|
||||
InterruptedException
|
||||
guard-convert-InterruptedException
|
||||
convert-assert-InterruptedException
|
||||
wrap-convert-assert-InterruptedException
|
||||
dynamic-InterruptedException/c
|
||||
static-InterruptedException/c
|
||||
InterruptedException-InterruptedException-constructor~generic
|
||||
InterruptedException-InterruptedException-constructor-java.lang.String~generic))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
(module |NegativeArraySizeException| mzscheme
|
||||
(module NegativeArraySizeException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |NegativeArraySizeException|))
|
||||
(provide
|
||||
NegativeArraySizeException
|
||||
guard-convert-NegativeArraySizeException
|
||||
convert-assert-NegativeArraySizeException
|
||||
wrap-convert-assert-NegativeArraySizeException
|
||||
dynamic-NegativeArraySizeException/c
|
||||
static-NegativeArraySizeException/c
|
||||
NegativeArraySizeException-NegativeArraySizeException-constructor~generic
|
||||
NegativeArraySizeException-NegativeArraySizeException-constructor-java.lang.String~generic))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
(module |NoSuchFieldException| mzscheme
|
||||
(module NoSuchFieldException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |NoSuchFieldException|))
|
||||
(provide
|
||||
NoSuchFieldException
|
||||
guard-convert-NoSuchFieldException
|
||||
convert-assert-NoSuchFieldException
|
||||
wrap-convert-assert-NoSuchFieldException
|
||||
dynamic-NoSuchFieldException/c
|
||||
static-NoSuchFieldException/c
|
||||
NoSuchFieldException-NoSuchFieldException-constructor~generic
|
||||
NoSuchFieldException-NoSuchFieldException-constructor-java.lang.String~generic))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
(module |NoSuchMethodException| mzscheme
|
||||
(module NoSuchMethodException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |NoSuchMethodException|))
|
||||
(provide
|
||||
NoSuchMethodException
|
||||
guard-convert-NoSuchMethodException
|
||||
convert-assert-NoSuchMethodException
|
||||
wrap-convert-assert-NoSuchMethodException
|
||||
dynamic-NoSuchMethodException/c
|
||||
static-NoSuchMethodException/c
|
||||
NoSuchMethodException-NoSuchMethodException-constructor~generic
|
||||
NoSuchMethodException-NoSuchMethodException-constructor-java.lang.String~generic))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
(module |NullPointerException| mzscheme
|
||||
(module NullPointerException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |NullPointerException|))
|
||||
(provide
|
||||
NullPointerException
|
||||
guard-convert-NullPointerException
|
||||
convert-assert-NullPointerException
|
||||
wrap-convert-assert-NullPointerException
|
||||
dynamic-NullPointerException/c
|
||||
static-NullPointerException/c
|
||||
NullPointerException-NullPointerException-constructor~generic
|
||||
NullPointerException-NullPointerException-constructor-java.lang.String~generic))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
(module |NumberFormatException| mzscheme
|
||||
(module NumberFormatException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |NumberFormatException|))
|
||||
(provide
|
||||
NumberFormatException
|
||||
guard-convert-NumberFormatException
|
||||
convert-assert-NumberFormatException
|
||||
wrap-convert-assert-NumberFormatException
|
||||
dynamic-NumberFormatException/c
|
||||
static-NumberFormatException/c
|
||||
NumberFormatException-NumberFormatException-constructor~generic
|
||||
NumberFormatException-NumberFormatException-constructor-java.lang.String~generic))
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
(module Object-composite mzscheme
|
||||
|
||||
(require (lib "class.ss")
|
||||
(prefix c: (lib "contract.ss"))
|
||||
(lib "errortrace-lib.ss" "errortrace")
|
||||
(lib "Comparable.ss" "profj" "libs" "java" "lang")
|
||||
(lib "Serializable.ss" "profj" "libs" "java" "io"))
|
||||
|
|
@ -35,13 +36,15 @@
|
|||
; ;;;
|
||||
|
||||
;Object.java
|
||||
(provide ObjectI Object-Mix Object)
|
||||
(provide ObjectI Object-Mix Object
|
||||
wrap-convert-assert-Object convert-assert-Object guard-convert-Object dynamic-Object/c static-Object/c)
|
||||
|
||||
;Object interface, and a mixin to create objects from.
|
||||
|
||||
(define ObjectI
|
||||
(interface () Object-constructor clone equals-java.lang.Object finalize getClass
|
||||
hashCode notify notifyAll toString wait wait-long wait-long-int my-name))
|
||||
hashCode notify notifyAll toString wait wait-long wait-long-int my-name
|
||||
equals hash-code to-string get-class))
|
||||
|
||||
(define Object-Mix
|
||||
(lambda (parent)
|
||||
|
|
@ -53,17 +56,20 @@
|
|||
(define/public clone (lambda () void))
|
||||
|
||||
(define/public (equals-java.lang.Object obj) (eq? this obj))
|
||||
(define/public (equals obj) (send this equals-java.lang.Object obj))
|
||||
|
||||
;Needs to do something
|
||||
(define/public (finalize) void)
|
||||
|
||||
(public-final getClass)
|
||||
(public-final getClass get-class)
|
||||
(define (getClass)
|
||||
(error 'ProfessorJ:getClass
|
||||
(format "ProfessorJ does not support getClass calls. ~e"
|
||||
(send this toString))))
|
||||
(define (get-class) (getClass))
|
||||
|
||||
(define/public (hashCode) (eq-hash-code this))
|
||||
(define/public (hash-code) (send this hashCode))
|
||||
|
||||
;Needs to do something when Threads more implemented
|
||||
(public-final notify |notifyAll|)
|
||||
|
|
@ -73,6 +79,7 @@
|
|||
(define/public (my-name) "Object")
|
||||
(define/public (toString)
|
||||
(make-java-string (format "~a@~a" (send this my-name) (send this hashCode))))
|
||||
(define/public (to-string) (send this toString))
|
||||
|
||||
(public-final wait wait-long wait-long-int)
|
||||
(define wait (lambda () void))
|
||||
|
|
@ -96,7 +103,153 @@
|
|||
|
||||
(define Object (Object-Mix object%))
|
||||
|
||||
(define (wrap-convert-assert-Object obj p n s c)
|
||||
(if (string? obj)
|
||||
(make-java-string string)
|
||||
(begin
|
||||
(c:contract (c:object-contract
|
||||
(clone (c:-> c:any/c))
|
||||
(equals-java.lang.Object (c:-> c:any/c c:any/c))
|
||||
(finalize (c:-> c:any/c))
|
||||
(getClass (c:-> c:any/c))
|
||||
(hashCode (c:-> c:any/c))
|
||||
(notify (c:-> c:any/c))
|
||||
(notifyAll (c:-> c:any/c))
|
||||
(toString (c:-> c:any/c))
|
||||
(wait (c:-> c:any/c))
|
||||
(wait-long (c:-> c:any/c c:any/c))
|
||||
(wait-long-int (c:-> c:any/c c:any/c c:any/c))) obj p n s)
|
||||
(make-object convert-assert-Object obj p n s c))))
|
||||
|
||||
(define convert-assert-Object
|
||||
(class object%
|
||||
|
||||
(init w p n s c)
|
||||
(define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null))
|
||||
(set! wrapped w)
|
||||
(set! pos-blame p)
|
||||
(set! neg-blame n)
|
||||
(set! src s)
|
||||
(set! cc-marks c)
|
||||
|
||||
(define/public (clone) (send wrapped clone))
|
||||
(define/public (equals-java.lang.Object obj)
|
||||
(let ((val (send wrapped equals-java.lang.Object
|
||||
(make-object guard-convert-Object obj pos-blame neg-blame src cc-marks))))
|
||||
(unless (boolean? val)
|
||||
(raise (make-exn:fail (string->immutable-string
|
||||
(format "~a broke ~a contract here; Object's equals expects boolean return, given ~a"
|
||||
pos-blame neg-blame val)) cc-marks)))
|
||||
val))
|
||||
|
||||
(define/public (finalize) (send wrapped finalize))
|
||||
(define/public (getClass) (send wrapped getClass))
|
||||
|
||||
(define/public (hashCode)
|
||||
(let ((val (send wrapped hashCode)))
|
||||
(unless (integer? val)
|
||||
(raise (make-exn:fail (string->immutable-string
|
||||
(format "~a broke ~a contract here; Object's hashCode expects int return, given ~a"
|
||||
pos-blame neg-blame val)) cc-marks)))
|
||||
val))
|
||||
|
||||
(define/public (notify) (send wrapped notify))
|
||||
(define/public (notifyAll) (send wrapped notifyAll))
|
||||
(define/public (toString)
|
||||
(let ((val (send wrapped toString)))
|
||||
(unless (string? val)
|
||||
(raise (make-exn:fail (string->immutable-string
|
||||
(format "~a broke ~a contract here: Object's toString expects String return, given ~a"
|
||||
pos-blame neg-blame val)) cc-marks)))
|
||||
(make-java-string val)))
|
||||
(define/public (wait) (send wrapped wait))
|
||||
(define/public (wait-long l) (send wrapped wait-long l))
|
||||
(define/public (wait-long-int l i) (send wrapped wait-long l i))
|
||||
(define/public (my-name) (send wrapped my-name))
|
||||
(define/public (field-names) (send wrapped field-names))
|
||||
(define/public (field-values) (send wrapped field-values))
|
||||
(define/public (fields-for-display) (send wrapped fields-for-display))
|
||||
(super-instantiate ())))
|
||||
|
||||
(define dynamic-Object/c
|
||||
(c:flat-named-contract "Object" (lambda (v) (is-a? v convert-assert-Object))))
|
||||
|
||||
(define guard-convert-Object
|
||||
(class object%
|
||||
|
||||
(init w p n s c)
|
||||
(define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null))
|
||||
(set! wrapped w)
|
||||
(set! pos-blame p)
|
||||
(set! neg-blame n)
|
||||
(set! src s)
|
||||
(set! cc-marks s)
|
||||
|
||||
(define/public (clone) (send wrapped clone))
|
||||
(define/public (equals-java.lang.Object . obj)
|
||||
(unless (= (length obj) 1)
|
||||
(raise (make-exn:fail:contract:arity
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Object's equals expects to be called with 1 argument, given ~n"
|
||||
pos-blame neg-blame (length obj))) cc-marks)))
|
||||
(send wrapped equals-java.lang.Object (wrap-convert-assert-Object (car obj) pos-blame neg-blame src cc-marks)))
|
||||
(define/public (equals . obj)
|
||||
(unless (= (length obj) 1)
|
||||
(raise (make-exn:fail:contract:arity
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Object's equals expects to be called with 1 argument, given ~n"
|
||||
pos-blame neg-blame (length obj))) cc-marks)))
|
||||
(send wrapped equals-java.lang.Object (wrap-convert-assert-Object (car obj) pos-blame neg-blame src cc-marks)))
|
||||
(define/public (finalize) (send wrapped finalize))
|
||||
(define/public (getClass) (send wrapped getClass))
|
||||
(define/public (get-class) (send wrapped getClass))
|
||||
(define/public (hashCode) (send wrapped hashCode))
|
||||
(define/public (hash-code) (send wrapped hashCode))
|
||||
(define/public (notify) (send wrapped notify))
|
||||
(define/public (notifyAll) (send wrapped notifyAll))
|
||||
(define/public (notify-all) (send wrapped notifyAll))
|
||||
(define/public (toString)
|
||||
(send (send wrapped toString) get-mzscheme-string))
|
||||
(define/public (to-string) (send (send wrapped toString) get-mzscheme-string))
|
||||
(define/public (wait) (send wrapped wait))
|
||||
(define/public (wait-long . l)
|
||||
(unless (= (length l) 1)
|
||||
(raise (make-exn:fail:contract:arity
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Object's wait-long expects to be called with 1 argument, given ~n"
|
||||
pos-blame neg-blame (length l))) cc-marks)))
|
||||
(unless (integer? (car l))
|
||||
(raise (make-exn:fail
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Object's wait that takes a long argument expected long, given ~a"
|
||||
pos-blame neg-blame (car l))) cc-marks)))
|
||||
(send wrapped wait-long (car l)))
|
||||
(define/public (wait-long-int . l)
|
||||
(unless (= (length l) 2)
|
||||
(raise (make-exn:fail:contract:arity
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Object's wait-long-int expects to be called with 2 arguments, given ~n"
|
||||
pos-blame neg-blame (length l))) cc-marks)))
|
||||
(unless (integer? (car l))
|
||||
(raise (make-exn:fail
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Object's wait-long-int expected long, given ~a"
|
||||
pos-blame neg-blame (car l))) cc-marks)))
|
||||
(unless (integer? (cadr l))
|
||||
(raise (make-exn:fail
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Object's wait-long-int expected int, given ~a"
|
||||
pos-blame neg-blame (cadr l))) cc-marks)))
|
||||
(send wrapped wait-long (car l) (cadr l)))
|
||||
(define/public (my-name) (send wrapped my-name))
|
||||
(define/public (field-names) (send wrapped field-names))
|
||||
(define/public (field-values) (send wrapped field-values))
|
||||
(define/public (fields-for-display) (send wrapped fields-for-display))
|
||||
(super-instantiate ())))
|
||||
|
||||
(define static-Object/c
|
||||
(c:flat-named-contract "Object" (lambda (v) (is-a? v guard-convert-Object))))
|
||||
|
||||
;
|
||||
;
|
||||
; ;;;
|
||||
|
|
@ -310,6 +463,7 @@
|
|||
(define/public (length) (string-length text))
|
||||
; int -> char
|
||||
(define/public (charAt-int index) (string-ref text index))
|
||||
(define/public (char-at i) (charAt-int i))
|
||||
|
||||
;-> void
|
||||
(define/public (getChars-int-int-char1-int begin end dest i)
|
||||
|
|
@ -321,6 +475,7 @@
|
|||
(send dest set index (string-ref text offset))
|
||||
(build-char-array (add1 offset) (add1 index)))))))
|
||||
(build-char-array begin i)))
|
||||
(define/public (get-chars b e d i) (getChars-int-int-char1-int b e d i))
|
||||
|
||||
;Does not mess with charset
|
||||
(define/public (getBytes)
|
||||
|
|
@ -348,6 +503,7 @@
|
|||
|
||||
(define/public (contentEquals-java.lang.StringBuffer buf)
|
||||
(equals-java.lang.Object (send buf toString)))
|
||||
(define/public (content-equals b) (contentEquals-java.lang.StringBuffer b))
|
||||
|
||||
;Object -> boolean
|
||||
(define/override (equals-java.lang.Object obj)
|
||||
|
|
@ -357,6 +513,7 @@
|
|||
;Object -> boolean
|
||||
(define/public (equalsIgnoreCase-java.lang.String str)
|
||||
(string-ci=? text (send str get-mzscheme-string)))
|
||||
(define/public (equals-ignore-case s) (equalsIgnoreCase-java.lang.String s))
|
||||
|
||||
;find-diff-chars: int int string-> (values int int)
|
||||
(define/private (find-diff-chars i stop-length compare-string)
|
||||
|
|
@ -420,6 +577,7 @@
|
|||
(let-values (((int-text int-str) (find-diff-chars 0)))
|
||||
(- int-text int-str))
|
||||
(- text-l str-l))))))
|
||||
(define/public (compare->ignore-case s) (compareToIgnoreCase-java.lang.String s))
|
||||
|
||||
;int String int int -> boolean
|
||||
(define/public (regionMatches-int-java.lang.String-int-int toffset jstr ooffset len)
|
||||
|
|
@ -458,7 +616,8 @@
|
|||
(let ((suffix (send Jsuffix get-mzscheme-string)))
|
||||
(and (<= (string-length suffix) (string-length text))
|
||||
(string=? suffix (substring text (- (string-length text) (string-length suffix)) (string-length text))))))
|
||||
|
||||
(define/public (ends-with s) (endsWith-java.lang.String s))
|
||||
|
||||
; -> int
|
||||
(define/override (hashCode)
|
||||
(let ((hash 0))
|
||||
|
|
@ -521,11 +680,13 @@
|
|||
|
||||
(define/public (subSequence-int-int begin end)
|
||||
(error 'subSequence "Internal Error: subsequence is unimplemented because charSequence is unimplemented"))
|
||||
|
||||
(define/public (sub-sequence i j) (subSequence-int-int i j))
|
||||
|
||||
;String -> String
|
||||
(define/public (concat-java.lang.String Jstr)
|
||||
(let ((str (send Jstr get-mzscheme-string)))
|
||||
(make-java-string (string-append text str))))
|
||||
(define/public (concat s) (concat-java.lang.String s))
|
||||
|
||||
; .. -> String
|
||||
(define/public (replace-char-char old new)
|
||||
|
|
@ -536,16 +697,20 @@
|
|||
(string-set! new-text pos new)
|
||||
(loop (add1 index)))))
|
||||
(make-java-string new-text)))
|
||||
(define/public (replace c1 c2) (replace-char-char c1 c2))
|
||||
|
||||
;Does not currently work. Needs to replace regex in text with replace and return new string; PROBLEM
|
||||
(define/public (replaceAll-java.lang.String-java.lang.String regex replace)
|
||||
(error 'replaceAll "Internal error: replaceAll is unimplemented at this time"))
|
||||
(define/public (replace-all s s2) (replaceAll-java.lang.String-java.lang.String s s2))
|
||||
|
||||
(define/public (replaceFirst-java.lang.String-java.lang.String regex replace)
|
||||
(error 'replaceFirst "Internal error: replaceFirst is unimplemented at this time"))
|
||||
(define/public (replace-first s s2) (replaceFirst-java.lang.String-java.lang.String s s2))
|
||||
|
||||
(define/public (matches-java.lang.String regex)
|
||||
(error 'matches "Internal error: matches is unimplemented at this time"))
|
||||
(define/public (matches s) (matches-java.lang.String s))
|
||||
|
||||
(define/public (split-java.lang.String-int regex limit)
|
||||
(error 'split "Internal error: split is unimplemented at this time"))
|
||||
|
|
@ -571,10 +736,11 @@
|
|||
;... -> String
|
||||
(define/public (trim)
|
||||
(error 'trim "Internal error: trim is unimplemented at this time."))
|
||||
|
||||
|
||||
(define/public (toCharArray) (make-java-array 'char 0 (string->list text)))
|
||||
(define/public (to-char-array) (toCharArray))
|
||||
|
||||
;PROBLEM I am not sure what the side effects of this are supposed to be! PROBLEM!
|
||||
;PROBLEM I am not sure what the side effects of this should be in context! PROBLEM!
|
||||
(define/public intern
|
||||
(lambda () this))
|
||||
|
||||
|
|
@ -632,7 +798,7 @@
|
|||
|
||||
;private fields
|
||||
;message: String
|
||||
(define message "")
|
||||
(define message (make-java-string ""))
|
||||
;stack: continuation-mark-set
|
||||
(define stack null)
|
||||
;java:exception
|
||||
|
|
@ -678,11 +844,16 @@
|
|||
(define/public (getMessage) message)
|
||||
(define/public (getCause) cause)
|
||||
(define/public (getLocalizedMessage) (send this getMessage))
|
||||
(define/public (get-message) (send this getMessage))
|
||||
(define/public (get-cause) (send this getCause))
|
||||
(define/public (get-localized-message) (send this getLocalizedMessage))
|
||||
|
||||
(define/public (setStackTrace-java.lang.StackTraceElement1 elments)
|
||||
(error 'setStackTrace "Internal error: setStackTrace will not be implemented until strack trace element s implemented"))
|
||||
(define/public (getStackTrace)
|
||||
(error 'getStackTrace "Internal error: getStackTrace will not be implemented until StackTraceElement is implemented"))
|
||||
(define/public (set-stack-trace e) (send this setStackTrace-java.lang.StackTraceElement1 e))
|
||||
(define/public (get-stack-trace) (send this getStackTrace))
|
||||
|
||||
; -> string
|
||||
(define/override (toString)
|
||||
|
|
@ -695,7 +866,7 @@
|
|||
; -> void
|
||||
(define/public (printStackTrace)
|
||||
(print-error-trace (current-output-port)
|
||||
(make-exn message stack)))
|
||||
(make-exn (string->immutable-string message) stack)))
|
||||
|
||||
;These functions do not work correctly yet, and won't until printStreams are implemented
|
||||
(define/public printStackTrace-PrintStream (lambda (printStream) void))
|
||||
|
|
@ -703,6 +874,7 @@
|
|||
|
||||
;This function does nothing at this time
|
||||
(define/public (fillInStackTrace) this)
|
||||
(define/public (fill-in-stack-trace) (send this fillInStackTrace))
|
||||
|
||||
; -> string
|
||||
(define/override (my-name) "Throwable")
|
||||
|
|
@ -731,6 +903,243 @@
|
|||
(send exn set-exception! scheme-exn)
|
||||
scheme-exn))
|
||||
|
||||
(provide convert-assert-Throwable wrap-convert-assert-Throwable dynamic-Throwable/c
|
||||
guard-convert-Throwable static-Throwable/c)
|
||||
|
||||
(define (wrap-convert-assert-Throwable obj p n s c)
|
||||
(c:contract (c:object-contract
|
||||
(initCause (c:-> c:any/c c:any/c))
|
||||
(getMessage (c:-> c:any/c))
|
||||
(getCause (c:-> c:any/c))
|
||||
(getLocalizedMessage (c:-> c:any/c))
|
||||
(setStackTrace-java.lang.StackTraceElement1 (c:-> c:any/c c:any/c))
|
||||
(getStackTrace (c:-> c:any/c))
|
||||
(printStackTrace (c:-> c:any/c))
|
||||
(printStackTrace-PrintStream (c:-> c:any/c))
|
||||
(printStackTrace-PrintWriter (c:-> c:any/c))
|
||||
(fillInStackTrace (c:-> c:any/c))
|
||||
(clone (c:-> c:any/c))
|
||||
(equals-java.lang.Object (c:-> c:any/c c:any/c))
|
||||
(finalize (c:-> c:any/c))
|
||||
(getClass (c:-> c:any/c))
|
||||
(hashCode (c:-> c:any/c))
|
||||
(notify (c:-> c:any/c))
|
||||
(notifyAll (c:-> c:any/c))
|
||||
(toString (c:-> c:any/c))
|
||||
(wait (c:-> c:any/c))
|
||||
(wait-long (c:-> c:any/c c:any/c))
|
||||
(wait-long-int (c:-> c:any/c c:any/c c:any/c))) obj p n s)
|
||||
(make-object convert-assert-Throwable obj p n s c))
|
||||
|
||||
(define convert-assert-Throwable
|
||||
(class object%
|
||||
|
||||
(init w p n s c)
|
||||
(define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null))
|
||||
(set! wrapped w)
|
||||
(set! pos-blame p)
|
||||
(set! neg-blame n)
|
||||
(set! src s)
|
||||
(set! cc-marks c)
|
||||
|
||||
(define/public (set-exception! exn) (send wrapped set-exception! exn))
|
||||
(define/public (get-mzscheme-exception) (send wrapped get-mzscheme-exception))
|
||||
(define/public (initCause-java.lang.Throwable cse)
|
||||
(wrap-convert-assert-Throwable
|
||||
(send wrapped initCause-java.lang.Throwable (make-object guard-convert-Throwable cse
|
||||
pos-blame neg-blame src cc-marks)
|
||||
pos-blame neg-blame src cc-marks)))
|
||||
(define/public (getMessage)
|
||||
(let ((val (send wrapped getMessage)))
|
||||
(if (string? val)
|
||||
(make-java-string val)
|
||||
(raise (make-exn:fail
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here; Throwable's getMessage expects string return, given ~a"
|
||||
pos-blame neg-blame val)) cc-marks)))))
|
||||
(define/public (getCause)
|
||||
(wrap-convert-assert-Throwable (send wrapped getCause)))
|
||||
(define/public (getLocalizedMessage)
|
||||
(let ((val (send wrapped getLocalizedMessage)))
|
||||
(if (string? val)
|
||||
(make-java-string val)
|
||||
(raise (make-exn:fail
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here; Throwable's getLocalizedMessage expects string return, given ~a"
|
||||
pos-blame neg-blame val)) cc-marks)))))
|
||||
(define/public (setStackTrace-java.lang.StackTraceElement1 elements)
|
||||
(send wrapped setStackTrace-java.lang.StackTraceElement1 elements))
|
||||
(define/public (getStackTrace) (send wrapped getStackTrace))
|
||||
(define/public (printStackTrace) (send wrapped printStackTrace))
|
||||
(define/public (printStackTrace-PrintStream printStream) (send wrapped printStackTrace-PrintStream))
|
||||
(define/public (printStackTrace-PrintWriter pW) (send wrapped printStackTrace-PrintWriter))
|
||||
(define/public (fillInStackTrace) (send wrapped fillInStackTrace))
|
||||
(define/public (clone) (send wrapped clone))
|
||||
(define/public (equals-java.lang.Object obj)
|
||||
(let ((val (send wrapped equals-java.lang.Object
|
||||
(make-object guard-convert-Object obj pos-blame neg-blame src cc-marks))))
|
||||
(unless (boolean? val)
|
||||
(raise (make-exn:fail
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here; Throwable's equals expects boolean return, given ~a"
|
||||
pos-blame neg-blame val)) cc-marks)))
|
||||
val))
|
||||
|
||||
(define/public (finalize) (send wrapped finalize))
|
||||
(define/public (getClass) (send wrapped getClass))
|
||||
|
||||
(define/public (hashCode)
|
||||
(let ((val (send wrapped hashCode)))
|
||||
(unless (integer? val)
|
||||
(raise (make-exn:fail
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here; Throwable's hashCode expects int return, given ~a"
|
||||
pos-blame neg-blame val)) cc-marks)))
|
||||
val))
|
||||
|
||||
(define/public (notify) (send wrapped notify))
|
||||
(define/public (notifyAll) (send wrapped notifyAll))
|
||||
(define/public (toString)
|
||||
(let ((val (send wrapped toString)))
|
||||
(unless (string? val)
|
||||
(raise (make-exn:fail
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Throwable's toString expects String return, given ~a"
|
||||
pos-blame neg-blame val)) cc-marks)))
|
||||
(make-java-string val)))
|
||||
(define/public (wait) (send wrapped wait))
|
||||
(define/public (wait-long l) (send wrapped wait-long l))
|
||||
(define/public (wait-long-int l i) (send wrapped wait-long l i))
|
||||
(define/public (my-name) (send wrapped my-name))
|
||||
(define/public (field-names) (send wrapped field-names))
|
||||
(define/public (field-values) (send wrapped field-values))
|
||||
(define/public (fields-for-display) (send wrapped fields-for-display))
|
||||
(super-instantiate ())))
|
||||
|
||||
(define dynamic-Throwable/c
|
||||
(c:flat-named-contract "Throwable" (lambda (v) (is-a? v convert-assert-Throwable))))
|
||||
|
||||
(define guard-convert-Throwable
|
||||
(class object%
|
||||
|
||||
(init w p n s c)
|
||||
(define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null))
|
||||
(set! wrapped w)
|
||||
(set! pos-blame p)
|
||||
(set! neg-blame n)
|
||||
(set! src s)
|
||||
(set! cc-marks s)
|
||||
|
||||
(define/public (set-exception! exn) (send wrapped set-exception! exn))
|
||||
(define/public (get-mzscheme-exception) (send wrapped get-mzscheme-exception))
|
||||
(define/public (initCause-java.lang.Throwable . cse)
|
||||
(unless (= 1 (length cse))
|
||||
(raise (make-exn:fail:contract:arity
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Throwable's initCause expects to be called with 1 argument, given ~n"
|
||||
pos-blame neg-blame (length cse))) cc-marks)))
|
||||
(make-object guard-convert-Throwable
|
||||
(send wrapped initCause-java.lang.Throwable (wrap-convert-assert-Throwable (car cse)))))
|
||||
(define/public (init-cause . cse)
|
||||
(unless (= 1 (length cse))
|
||||
(raise (make-exn:fail:contract:arity
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Throwable's initCause expects to be called with 1 argument, given ~n"
|
||||
pos-blame neg-blame (length cse))) cc-marks)))
|
||||
(make-object guard-convert-Throwable
|
||||
(send wrapped initCause-java.lang.Throwable (wrap-convert-assert-Throwable (car cse) pos-blame neg-blame src cc-marks))
|
||||
pos-blame neg-blame src cc-marks))
|
||||
(define/public (getMessage) (send (send wrapped getMessage) get-mzscheme-string))
|
||||
(define/public (get-message) (send (send wrapped getMessage) get-mzscheme-string))
|
||||
(define/public (getCause) (make-object guard-convert-Throwable (send wrapped getCause) pos-blame neg-blame src cc-marks))
|
||||
(define/public (get-cause) (make-object guard-convert-Throwable
|
||||
(send wrapped getCause) pos-blame neg-blame src cc-marks))
|
||||
(define/public (getLocalizedMessage) (send (send wrapped getLocalizedMessage) get-mzscheme-string))
|
||||
(define/public (get-localized-message) (send (send wrapped getLocalizedMessage) get-mzscheme-string))
|
||||
(define/public (setStackTrace-java.lang.StackTraceElement1 elements)
|
||||
(send wrapped setStackTrace-java.lang.StackTraceElement1 elements))
|
||||
(define/public (set-stack-trace t)
|
||||
(send wrapped setStackTrace-java.lang.StackTraceElement1 t))
|
||||
(define/public (getStackTrace) (send wrapped getStackTrace))
|
||||
(define/public (get-stack-trace) (send wrapped getStackTrace))
|
||||
(define/public (printStackTrace) (send wrapped printStackTrace))
|
||||
(define/public (printStackTrace-PrintStream printStream) (send wrapped printStackTrace-PrintStream))
|
||||
(define/public (printStackTrace-PrintWriter pW) (send wrapped printStackTrace-PrintWriter))
|
||||
(define/public (fillInStackTrace) (send wrapped fillInStackTrace))
|
||||
(define/public (fill-in-stack-trace) (send wrapped fillInStackTrace))
|
||||
|
||||
(define/public (clone) (send wrapped clone))
|
||||
(define/public (equals-java.lang.Object . obj)
|
||||
(unless (= (length obj) 1)
|
||||
(raise (make-exn:fail:contract:arity
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Throwable's equals expects to be called with 1 argument, given ~n"
|
||||
pos-blame neg-blame (length obj))) cc-marks)))
|
||||
(send wrapped equals-java.lang.Object (wrap-convert-assert-Object (car obj) pos-blame neg-blame src cc-marks)))
|
||||
(define/public (equals . obj)
|
||||
(unless (= (length obj) 1)
|
||||
(raise (make-exn:fail:contract:arity
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Throwable's equals expects to be called with 1 argument, given ~n"
|
||||
pos-blame neg-blame (length obj))) cc-marks)))
|
||||
(send wrapped equals-java.lang.Object (wrap-convert-assert-Object (car obj) pos-blame neg-blame src cc-marks)))
|
||||
(define/public (finalize) (send wrapped finalize))
|
||||
(define/public (getClass) (send wrapped getClass))
|
||||
(define/public (get-class) (send wrapped getClass))
|
||||
(define/public (hashCode) (send wrapped hashCode))
|
||||
(define/public (hash-code) (send wrapped hashCode))
|
||||
(define/public (notify) (send wrapped notify))
|
||||
(define/public (notifyAll) (send wrapped notifyAll))
|
||||
(define/public (notify-all) (send wrapped notifyAll))
|
||||
(define/public (my-name) (send wrapped my-name))
|
||||
(define/public (toString)
|
||||
(send (send wrapped toString) get-mzscheme-string))
|
||||
(define/public (to-string) (send (send wrapped toString) get-mzscheme-string))
|
||||
(define/public (wait) (send wrapped wait))
|
||||
(define/public (wait-long . l)
|
||||
(unless (= (length l) 1)
|
||||
(raise (make-exn:fail:contract:arity
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Throwable's wait-long expects to be called with 1 argument, given ~n"
|
||||
pos-blame neg-blame (length l))) cc-marks)))
|
||||
(unless (integer? (car l))
|
||||
(raise (make-exn:fail
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Throwable's wait that takes a long argument expected long, given ~a"
|
||||
pos-blame neg-blame (car l))) cc-marks)))
|
||||
(send wrapped wait-long (car l)))
|
||||
(define/public (wait-long-int . l)
|
||||
(unless (= (length l) 2)
|
||||
(raise (make-exn:fail:contract:arity
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Throwable's wait-long-int expects to be called with 2 arguments, given ~n"
|
||||
pos-blame neg-blame (length l))) cc-marks)))
|
||||
(unless (integer? (car l))
|
||||
(raise (make-exn:fail
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Throwable's wait-long-int expected long, given ~a"
|
||||
pos-blame neg-blame (car l))) cc-marks)))
|
||||
(unless (integer? (cadr l))
|
||||
(raise (make-exn:fail
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Throwable's wait-long-int expected int, given ~a"
|
||||
pos-blame neg-blame (cadr l))) cc-marks)))
|
||||
(send wrapped wait-long (car l) (cadr l)))
|
||||
(define/public (field-names) (send wrapped field-names))
|
||||
(define/public (field-values) (send wrapped field-values))
|
||||
(define/public (fields-for-display) (send wrapped fields-for-display))
|
||||
(super-instantiate ())))
|
||||
|
||||
(define static-Throwable/c
|
||||
(c:flat-named-contract "Throwable" (lambda (v) (is-a? v guard-convert-Throwable))))
|
||||
|
||||
(provide wrap-convert-assert-Class guard-convert-Class wrap-convert-assert-PrintString wrap-convert-assert-PrintWriter)
|
||||
|
||||
(define (wrap-convert-assert-Class . args) (void))
|
||||
(define guard-convert-Class (class object% (super-new)))
|
||||
(define (wrap-convert-assert-PrintString . args) (void))
|
||||
(define (wrap-convert-assert-PrintWriter . args) (void))
|
||||
|
||||
(compile-rest-of-lang (list "Object" "Throwable" "String" "Exception" "RuntimeException" "Comparable"))
|
||||
|
||||
)
|
||||
|
|
@ -17,5 +17,5 @@
|
|||
()
|
||||
(("Object" "java" "lang"))
|
||||
()
|
||||
"version1")
|
||||
"version2")
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,6 @@
|
|||
#cs
|
||||
(module Object mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide ObjectI Object-Mix Object))
|
||||
(provide ObjectI Object-Mix Object)
|
||||
(provide guard-convert-Object convert-assert-Object wrap-convert-assert-Object
|
||||
dynamic-Object/c static-Object/c))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,13 @@
|
|||
(module |RuntimeException| mzscheme
|
||||
(module RuntimeException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |RuntimeException|))
|
||||
(provide
|
||||
RuntimeException
|
||||
guard-convert-RuntimeException
|
||||
convert-assert-RuntimeException
|
||||
wrap-convert-assert-RuntimeException
|
||||
dynamic-RuntimeException/c
|
||||
static-RuntimeException/c
|
||||
RuntimeException-RuntimeException-constructor~generic
|
||||
RuntimeException-RuntimeException-constructor-java.lang.String~generic
|
||||
RuntimeException-RuntimeException-constructor-java.lang.String-java.lang.Throwable~generic
|
||||
RuntimeException-RuntimeException-constructor-java.lang.Throwable~generic))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
(module |SecurityException| mzscheme
|
||||
(module SecurityException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |SecurityException|))
|
||||
(provide
|
||||
SecurityException
|
||||
guard-convert-SecurityException
|
||||
convert-assert-SecurityException
|
||||
wrap-convert-assert-SecurityException
|
||||
dynamic-SecurityException/c
|
||||
static-SecurityException/c
|
||||
SecurityException-SecurityException-constructor~generic
|
||||
SecurityException-SecurityException-constructor-java.lang.String~generic))
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@
|
|||
("getChars" (public) void (int int (1 char) int) () ("String" "java" "lang"))
|
||||
("getBytes" (public) (1 byte) (("String" "java" "lang")) (("UnsupportedEncodingException" "java" "io")) ("String" "java" "lang"))
|
||||
("getBytes" (public) (1 byte) () () ("String" "java" "lang"))
|
||||
("equals" (public) boolean (("Object" "java" "lang")) () ("String" "java" "lang"))
|
||||
;("equals" (public) boolean (("Object" "java" "lang")) () ("String" "java" "lang"))
|
||||
("contentEquals" (public) boolean (("StringBuffer" "java" "lang")) () ("String" "java" "lang"))
|
||||
("equalsIgnoreCase" (public) boolean (("String" "java" "lang")) () ("String" "java" "lang"))
|
||||
("compareTo" (public) int (("String" "java" "lang")) () ("String" "java" "lang"))
|
||||
|
|
@ -54,7 +54,7 @@
|
|||
("toUpperCase" (public) ("String" "java" "lang") (("Locale" "java" "util")) () ("String" "java" "lang"))
|
||||
("toUpperCase" (public) ("String" "java" "lang") () () ("String" "java" "lang"))
|
||||
("trim" (public) ("String" "java" "lang") () () ("String" "java" "lang"))
|
||||
("toString" (public) ("String" "java" "lang") () () ("String" "java" "lang"))
|
||||
;("toString" (public) ("String" "java" "lang") () () ("String" "java" "lang"))
|
||||
("toCharArray" (public) (1 char) () () ("String" "java" "lang"))
|
||||
("valueOf" (public static) ("String" "java" "lang") (("Object" "java" "lang")) () ("String" "java" "lang"))
|
||||
("valueOf" (public static) ("String" "java" "lang") ((1 char)) () ("String" "java" "lang"))
|
||||
|
|
@ -85,4 +85,4 @@
|
|||
()
|
||||
(("Object" "java" "lang"))
|
||||
(("Serializable" "java" "io") ("Comparable" "java" "lang") ("CharSequence" "java" "lang"))
|
||||
"version1")
|
||||
"version2")
|
||||
|
|
@ -1,3 +1,12 @@
|
|||
(module |StringIndexOutOfBoundsException| mzscheme
|
||||
(module StringIndexOutOfBoundsException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |StringIndexOutOfBoundsException|))
|
||||
(provide
|
||||
StringIndexOutOfBoundsException
|
||||
guard-convert-StringIndexOutOfBoundsException
|
||||
convert-assert-StringIndexOutOfBoundsException
|
||||
wrap-convert-assert-StringIndexOutOfBoundsException
|
||||
dynamic-StringIndexOutOfBoundsException/c
|
||||
static-StringIndexOutOfBoundsException/c
|
||||
StringIndexOutOfBoundsException-StringIndexOutOfBoundsException-constructor~generic
|
||||
StringIndexOutOfBoundsException-StringIndexOutOfBoundsException-constructor-java.lang.String~generic
|
||||
StringIndexOutOfBoundsException-StringIndexOutOfBoundsException-constructor-int~generic))
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@
|
|||
("printStackTrace" (public) void (("PrintString" "java" "io")) () ("Throwable" "java" "lang"))
|
||||
("printStackTrace" (public) void (("PrintWriter" "java" "io")) () ("Throwable" "java" "lang"))
|
||||
("setStackTrace" (public) void ((1 ("StackTraceElement" "java" "lang"))) () ("Throwable" "java" "lang"))
|
||||
("toString" (public) ("String" "java" "lang") () () ("Throwable" "java" "lang"))
|
||||
;("toString" (public) ("String" "java" "lang") () () ("Throwable" "java" "lang"))
|
||||
|
||||
("Object" (public) ctor () () ("Object" "java" "lang"))
|
||||
("clone" (protected) ("Object" "java" "lang") () (("CloneNotSupportedException" "java" "lang"))("Object" "java" "lang"))
|
||||
|
|
@ -35,4 +35,4 @@
|
|||
()
|
||||
(("Object" "java" "lang"))
|
||||
(("Serializable" "java" "io"))
|
||||
"version1")
|
||||
"version2")
|
||||
|
|
|
|||
|
|
@ -2,4 +2,6 @@
|
|||
(module Throwable mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide Throwable (struct java:exception (object))
|
||||
exception-is-a? handle-exception create-java-exception))
|
||||
exception-is-a? handle-exception create-java-exception)
|
||||
(provide guard-convert-Throwable convert-assert-Throwable wrap-convert-assert-Throwable
|
||||
dynamic-Throwable/c static-Throwable/c))
|
||||
|
|
@ -1,3 +1,11 @@
|
|||
(module |UnsupportedOperationException| mzscheme
|
||||
(module UnsupportedOperationException mzscheme
|
||||
(require "Object-composite.ss")
|
||||
(provide |UnsupportedOperationException|))
|
||||
(provide
|
||||
UnsupportedOperationException
|
||||
guard-convert-UnsupportedOperationException
|
||||
convert-assert-UnsupportedOperationException
|
||||
wrap-convert-assert-UnsupportedOperationException
|
||||
dynamic-UnsupportedOperationException/c
|
||||
static-UnsupportedOperationException/c
|
||||
UnsupportedOperationException-UnsupportedOperationException-constructor~generic
|
||||
UnsupportedOperationException-UnsupportedOperationException-constructor-java.lang.String~generic))
|
||||
|
|
|
|||
|
|
@ -241,9 +241,9 @@
|
|||
|
||||
(VariableDeclaratorId
|
||||
[(IDENTIFIER)
|
||||
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f 0 (build-src 1)) (build-src 1))]
|
||||
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f 0 (build-src 1)) #f (build-src 1))]
|
||||
[(IDENTIFIER Dims)
|
||||
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f $2 (build-src 2)) (build-src 2))])
|
||||
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f $2 (build-src 2)) #f (build-src 2))])
|
||||
|
||||
(VariableInitializer
|
||||
[(Expression) $1]
|
||||
|
|
|
|||
|
|
@ -199,7 +199,7 @@
|
|||
|
||||
(VariableDeclaratorId
|
||||
[(IDENTIFIER)
|
||||
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f 0 (build-src 1)) (build-src 1))])
|
||||
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f 0 (build-src 1)) #f (build-src 1))])
|
||||
|
||||
;; 19.8.3
|
||||
(MethodDeclaration
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@
|
|||
(parser
|
||||
(start CompilationUnit Interactions VariableInitializer Type)
|
||||
;;(debug "parser.output")
|
||||
(tokens java-vals special-toks Keywords Separators EmptyLiterals Operators)
|
||||
(tokens java-vals special-toks Keywords ExtraKeywords Separators EmptyLiterals Operators)
|
||||
(error (lambda (tok-ok name val start-pos end-pos)
|
||||
(raise-read-error (format "Parse error near <~a:~a>" name val)
|
||||
(file-path)
|
||||
|
|
@ -59,7 +59,8 @@
|
|||
;; 19.4
|
||||
(Type
|
||||
[(PrimitiveType) $1]
|
||||
[(ReferenceType) $1])
|
||||
[(ReferenceType) $1]
|
||||
[(dynamic) (make-type-spec 'dynamic 0 (build-src 1))])
|
||||
|
||||
(PrimitiveType
|
||||
[(NumericType) $1]
|
||||
|
|
@ -250,9 +251,9 @@
|
|||
|
||||
(VariableDeclaratorId
|
||||
[(IDENTIFIER)
|
||||
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f 0 (build-src 1)) (build-src 1))]
|
||||
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f 0 (build-src 1)) #f (build-src 1))]
|
||||
[(IDENTIFIER Dims)
|
||||
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f $2 (build-src 2)) (build-src 2))])
|
||||
(make-var-decl (make-id $1 (build-src 1)) null (make-type-spec #f $2 (build-src 2)) #f (build-src 2))])
|
||||
|
||||
(VariableInitializer
|
||||
[(Expression) $1]
|
||||
|
|
@ -478,9 +479,10 @@
|
|||
((var-decl? d) d)
|
||||
(else (var-init-var-decl d))))
|
||||
(new-decl (make-var-decl (var-decl-name decl)
|
||||
`(final)
|
||||
(var-decl-type decl)
|
||||
(var-decl-src decl))))
|
||||
`(final)
|
||||
(var-decl-type-spec decl)
|
||||
#f
|
||||
(var-decl-src decl))))
|
||||
|
||||
(cond
|
||||
((var-decl? d) new-decl)
|
||||
|
|
@ -843,6 +845,8 @@
|
|||
$5)]
|
||||
[(O_PAREN PrimitiveType C_PAREN UnaryExpression)
|
||||
(make-cast #f (build-src 4) $2 $4)]
|
||||
[(O_PAREN dynamic C_PAREN UnaryExpression)
|
||||
(make-cast #f (build-src 4) (make-type-spec 'dynamic 0 (build-src 2 2)) $4)]
|
||||
[(O_PAREN Expression C_PAREN UnaryExpressionNotPlusMinus)
|
||||
(if (access? $2)
|
||||
(make-cast #f (build-src 4)
|
||||
|
|
|
|||
|
|
@ -78,8 +78,9 @@
|
|||
(make-type-spec
|
||||
(type-spec-name type)
|
||||
(+ (type-spec-dim type)
|
||||
(type-spec-dim (var-decl-type decl)))
|
||||
(type-spec-dim (var-decl-type-spec decl)))
|
||||
(type-spec-src type))
|
||||
#f
|
||||
(var-decl-src decl)))
|
||||
((var-init? decl)
|
||||
(make-var-init
|
||||
|
|
|
|||
|
|
@ -223,7 +223,7 @@
|
|||
[(IDENTIFIER)
|
||||
(make-var-decl (make-id $1 (build-src 1))
|
||||
(list (make-modifier 'public #f))
|
||||
(make-type-spec #f 0 (build-src 1)) (build-src 1))])
|
||||
(make-type-spec #f 0 (build-src 1)) #f (build-src 1))])
|
||||
|
||||
(VariableInitializer
|
||||
[(Expression) $1])
|
||||
|
|
|
|||
|
|
@ -7,7 +7,8 @@
|
|||
|
||||
|
||||
(require (lib "lex.ss" "parser-tools")
|
||||
(prefix re: (lib "lex-sre.ss" "parser-tools")))
|
||||
(prefix re: (lib "lex-sre.ss" "parser-tools"))
|
||||
(lib "parameters.ss" "profj"))
|
||||
|
||||
(provide (all-defined))
|
||||
(define-struct test-case (test))
|
||||
|
|
@ -39,6 +40,8 @@
|
|||
const for new switch
|
||||
continue goto package synchronized))
|
||||
|
||||
(define-empty-tokens ExtraKeywords (dynamic))
|
||||
|
||||
(define-tokens java-vals
|
||||
(STRING_LIT CHAR_LIT INTEGER_LIT LONG_LIT FLOAT_LIT DOUBLE_LIT
|
||||
IDENTIFIER STRING_ERROR NUMBER_ERROR HEX_LIT OCT_LIT HEXL_LIT OCTL_LIT))
|
||||
|
|
@ -293,6 +296,11 @@
|
|||
((re:: OctalNumeral IntegerTypeSuffix)
|
||||
(token-OCTL_LIT (string->number (trim-string lexeme 1 1) 8)))
|
||||
|
||||
("dynamic"
|
||||
(cond
|
||||
((dynamic?) (string->symbol lexeme))
|
||||
(else (token-IDENTIFIER lexeme))))
|
||||
|
||||
;; 3.9
|
||||
(Keyword (string->symbol lexeme))
|
||||
|
||||
|
|
@ -390,6 +398,12 @@
|
|||
|
||||
;; 3.10.5
|
||||
(#\" ((colorize-string start-pos) input-port))
|
||||
|
||||
("dynamic"
|
||||
(cond
|
||||
((dynamic?) (syn-val lexeme 'keyword #f start-pos end-pos))
|
||||
(else (syn-val lexeme 'identifier #f start-pos end-pos))))
|
||||
|
||||
;; 3.9
|
||||
(Keyword (syn-val lexeme 'keyword #f start-pos end-pos))
|
||||
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -114,7 +114,7 @@
|
|||
(define (phase1) void)
|
||||
;Add all the ProfessorJ languages into DrScheme
|
||||
(define (phase2)
|
||||
#;(drscheme:language-configuration:add-language
|
||||
(drscheme:language-configuration:add-language
|
||||
(make-object ((drscheme:language:get-default-mixin) dynamic-lang%)))
|
||||
(drscheme:language-configuration:add-language
|
||||
(make-object ((drscheme:language:get-default-mixin) full-lang%)))
|
||||
|
|
@ -376,7 +376,7 @@
|
|||
(val-editor (caddr example))
|
||||
(val (parse-expression (open-input-text-editor val-editor) val-editor level)))
|
||||
(compile-interactions-ast
|
||||
(make-var-init (make-var-decl name null type #f) val #f)
|
||||
(make-var-init (make-var-decl name null type #f) val #f #f)
|
||||
val-editor level type-recs)))
|
||||
contents)
|
||||
(process-extras (cdr extras) type-recs))))
|
||||
|
|
@ -474,8 +474,8 @@
|
|||
(define/public (on-execute settings run-in-user-thread)
|
||||
(dynamic-require '(lib "Object.ss" "profj" "libs" "java" "lang") #f)
|
||||
(let ([obj-path ((current-module-name-resolver) '(lib "Object.ss" "profj" "libs" "java" "lang") #f #f)]
|
||||
[string-path ((current-module-name-resolver) '(lib "String.ss" "profj" "libs" "java" "lang") #f #f)]
|
||||
[class-path ((current-module-name-resolver) '(lib "class.ss") #f #f)]
|
||||
[tool-path ((current-module-name-resolver) '(lib "tool.ss" "profj") #f #f)]
|
||||
[n (current-namespace)])
|
||||
(read-case-sensitive #t)
|
||||
(run-in-user-thread
|
||||
|
|
@ -517,9 +517,10 @@
|
|||
(with-handlers ([void (lambda (x) (printf "~a~n" (exn-message x)))])
|
||||
(namespace-require 'mzscheme)
|
||||
(namespace-attach-module n obj-path)
|
||||
(namespace-attach-module n string-path)
|
||||
(namespace-attach-module n class-path)
|
||||
(namespace-require obj-path)
|
||||
#;(namespace-require '(lib "tool.ss" "profj"))
|
||||
(namespace-require string-path)
|
||||
(namespace-require class-path)
|
||||
(namespace-require '(prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java")))
|
||||
(namespace-require '(prefix c: (lib "contract.ss"))))))))
|
||||
|
|
@ -528,7 +529,7 @@
|
|||
(let ((print-full? (profj-settings-print-full? settings))
|
||||
(style (profj-settings-print-style settings)))
|
||||
(if (is-a? value String)
|
||||
(write-special (send value get-mzscheme-string) port)
|
||||
(write-special (format "~v" (send value get-mzscheme-string)) port)
|
||||
(let ((out (format-java value print-full? style null #f 0)))
|
||||
(if (< 25 (string-length out))
|
||||
(display (format-java value print-full? style null #t 0) port)
|
||||
|
|
@ -802,7 +803,12 @@
|
|||
(namespace-syntax-introduce ((syntax-object->datum (syntax comp))
|
||||
(syntax-object->datum (syntax ast)))))))
|
||||
|
||||
|
||||
|
||||
(define (supports-printable-interface? o)
|
||||
(and (is-a? o object%)
|
||||
(method-in-interface? 'my-name (object-interface o))
|
||||
(method-in-interface? 'fields-for-display (object-interface o))))
|
||||
|
||||
(provide format-java)
|
||||
;formats a java value (number, character or Object) into a string
|
||||
;format-java: java-value bool symbol (list value) -> string
|
||||
|
|
@ -816,8 +822,9 @@
|
|||
(if full-print?
|
||||
(array->string value (send value length) -1 #t style already-printed newline? num-tabs)
|
||||
(array->string value 3 (- (send value length) 3) #f style already-printed newline? num-tabs)))
|
||||
((is-a? value String) (format "~s" (send value get-mzscheme-string)))
|
||||
((is-a? value ObjectI)
|
||||
((is-a? value String) (format "~v" (send value get-mzscheme-string)))
|
||||
((string? value) (format "~v" value))
|
||||
((or (is-a? value ObjectI) (supports-printable-interface? value))
|
||||
(case style
|
||||
((type) (send value my-name))
|
||||
((field)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
#cs
|
||||
(module types mzscheme
|
||||
|
||||
(require (lib "etc.ss")
|
||||
|
|
@ -8,16 +7,16 @@
|
|||
"ast.ss")
|
||||
|
||||
(provide (all-defined-except sort number-assign-conversions remove-dups meth-member?
|
||||
variable-member? generate-require-spec))
|
||||
generate-require-spec))
|
||||
|
||||
;; symbol-type = 'null | 'string | 'boolean | 'char | 'byte | 'short | 'int
|
||||
;; | 'long | 'float | 'double | 'void
|
||||
;; | 'long | 'float | 'double | 'void | 'dynamic
|
||||
;; reference-type = 'null | 'string | (make-ref-type string (list string))
|
||||
;; array-type = (make-array-type type int)
|
||||
;; type = symbol-type
|
||||
;; | reference-type
|
||||
;; | array-type
|
||||
;; | scheme-val
|
||||
;; | dynamic-val
|
||||
;; | unknown-ref
|
||||
|
||||
(define-struct ref-type (class/iface path) (make-inspector))
|
||||
|
|
@ -52,17 +51,17 @@
|
|||
|
||||
;; reference-type: 'a -> boolean
|
||||
(define (reference-type? x)
|
||||
(if (and (scheme-val? x) (scheme-val-type x))
|
||||
(reference-type? (scheme-val-type x))
|
||||
(or (scheme-val? x)
|
||||
(if (and (dynamic-val? x) (dynamic-val-type x))
|
||||
(reference-type? (dynamic-val-type x))
|
||||
(or (dynamic-val? x)
|
||||
(unknown-ref? x)
|
||||
(ref-type? x)
|
||||
(memq x `(null string)))))
|
||||
|
||||
;;is-string?: 'a -> boolean
|
||||
(define (is-string-type? s)
|
||||
(if (scheme-val? s)
|
||||
(is-string-type? (scheme-val-type s))
|
||||
(if (dynamic-val? s)
|
||||
(is-string-type? (dynamic-val-type s))
|
||||
(and (reference-type? s)
|
||||
(or (eq? 'string s) (type=? s string-type)))))
|
||||
|
||||
|
|
@ -70,16 +69,16 @@
|
|||
;; prim-integral-type?: 'a -> boolean
|
||||
(define (prim-integral-type? t)
|
||||
(cond
|
||||
((and (scheme-val? t) (scheme-val-type t))
|
||||
(prim-integral-type? (scheme-val-type t)))
|
||||
((scheme-val? t) #t)
|
||||
((and (dynamic-val? t) (dynamic-val-type t))
|
||||
(prim-integral-type? (dynamic-val-type t)))
|
||||
((dynamic-val? t) #t)
|
||||
(else (memq t `(byte short int long char)))))
|
||||
;; prim-numeric-type?: 'a -> boolean
|
||||
(define (prim-numeric-type? t)
|
||||
(cond
|
||||
((and (scheme-val? t) (scheme-val-type t))
|
||||
(prim-numeric-type? (scheme-val-type t)))
|
||||
((scheme-val? t) #t)
|
||||
((and (dynamic-val? t) (dynamic-val-type t))
|
||||
(prim-numeric-type? (dynamic-val-type t)))
|
||||
((dynamic-val? t) #t)
|
||||
(else (or (prim-integral-type? t) (memq t `(float double))))))
|
||||
|
||||
;; type=?: type type -> boolean
|
||||
|
|
@ -148,14 +147,15 @@
|
|||
;; assignment-conversion: type type type-records -> boolean
|
||||
(define (assignment-conversion to from type-recs)
|
||||
(cond
|
||||
((scheme-val? to)
|
||||
((dynamic-val? to)
|
||||
(cond
|
||||
((scheme-val-type to) => (lambda (t) (assignment-conversion t from type-recs)))
|
||||
(else (set-scheme-val-type! to from) #t)))
|
||||
((scheme-val? from)
|
||||
((dynamic-val-type to) => (lambda (t) (assignment-conversion t from type-recs)))
|
||||
(else (set-dynamic-val-type! to from) #t)))
|
||||
((dynamic-val? from)
|
||||
(cond
|
||||
((scheme-val-type from) => (lambda (t) (assignment-conversion to t type-recs)))
|
||||
(else (set-scheme-val-type! from to) #t)))
|
||||
((dynamic-val-type from) => (lambda (t) (assignment-conversion to t type-recs)))
|
||||
(else (set-dynamic-val-type! from to) #t)))
|
||||
((eq? to 'dynamic) #t)
|
||||
((type=? to from) #t)
|
||||
((and (prim-numeric-type? to) (prim-numeric-type? from))
|
||||
(widening-prim-conversion to from))
|
||||
|
|
@ -166,7 +166,7 @@
|
|||
(define (type-spec-to-type ts container-class level type-recs)
|
||||
(let* ((ts-name (type-spec-name ts))
|
||||
(t (cond
|
||||
((memq ts-name `(null string boolean char byte short int long float double void ctor)) ts-name)
|
||||
((memq ts-name `(null string boolean char byte short int long float double void ctor dynamic)) ts-name)
|
||||
((name? ts-name) (name->type ts-name container-class (type-spec-src ts) level type-recs)))))
|
||||
(if (> (type-spec-dim ts) 0)
|
||||
(make-array-type t (type-spec-dim ts))
|
||||
|
|
@ -244,17 +244,20 @@
|
|||
;;(make-inner-record string (list symbol) bool)
|
||||
(define-struct inner-record (name modifiers class?) (make-inspector))
|
||||
|
||||
;;(make-scheme-record string (list string) path (list scheme-val))
|
||||
;;(make-scheme-record string (list string) path (list dynamic-val))
|
||||
(define-struct scheme-record (name path dir provides))
|
||||
|
||||
;;(make-scheme-val symbol bool bool (U #f type unknown-ref))
|
||||
(define-struct scheme-val (name dynamic? instance? type))
|
||||
;;(make-dynamic-val (U type method-contract unknown-ref))
|
||||
(define-struct dynamic-val (type))
|
||||
|
||||
;;(make-unknown-ref (list method-contract) (list scheme-val))
|
||||
(define-struct unknown-ref (methods fields))
|
||||
;;(make-unknown-ref (U method-contract field-contract))
|
||||
(define-struct unknown-ref (access))
|
||||
|
||||
;;(make-method-contract symbol (U type #f) (list (U type #f)))
|
||||
(define-struct method-contract (name return args))
|
||||
;;(make-method-contract string type (list type))
|
||||
(define-struct method-contract (name return args))
|
||||
|
||||
;;(make-field-contract string type)
|
||||
(define-struct field-contract (name type))
|
||||
|
||||
;
|
||||
; ;;
|
||||
|
|
@ -577,27 +580,22 @@
|
|||
(car (cadr assignable-count))) (method-conflict-fail))
|
||||
(else (car assignable)))))
|
||||
|
||||
;lookup-scheme: scheme-record string ( -> void) -> scheme-val
|
||||
;lookup-scheme may raise an exception if variable is not defined in mod-ref
|
||||
(define (lookup-scheme mod-ref variable fail)
|
||||
;module-has-binding?: scheme-record string (-> void) -> void
|
||||
;module-has-binding raises an exception when variable is not defined in mod-ref
|
||||
(define (module-has-binding? mod-ref variable fail)
|
||||
(let ((var (string->symbol (java-name->scheme variable))))
|
||||
(cond
|
||||
((variable-member? (scheme-record-provides mod-ref) var) => (lambda (x) x))
|
||||
(else
|
||||
(let ((old-namespace (current-namespace)))
|
||||
(or (memq var (scheme-record-provides mod-ref))
|
||||
(let ((old-namespace (current-namespace)))
|
||||
(current-namespace (make-namespace))
|
||||
(namespace-require (generate-require-spec (scheme-record-name mod-ref)
|
||||
(namespace-require (generate-require-spec (java-name->scheme (scheme-record-name mod-ref))
|
||||
(scheme-record-path mod-ref)))
|
||||
(begin0
|
||||
(begin
|
||||
(namespace-variable-value var #t (lambda ()
|
||||
(current-namespace old-namespace)
|
||||
(fail)))
|
||||
(let ((val (make-scheme-val var #t #f #f)))
|
||||
(set-scheme-record-provides! mod-ref (cons val (scheme-record-provides mod-ref)))
|
||||
val))
|
||||
(current-namespace old-namespace)))))))
|
||||
|
||||
(begin
|
||||
(namespace-variable-value var #t (lambda ()
|
||||
(current-namespace old-namespace)
|
||||
(fail)))
|
||||
(set-scheme-record-provides! mod-ref (cons var (scheme-record-provides mod-ref)))
|
||||
(current-namespace old-namespace))))))
|
||||
|
||||
;generate-require-spec: string (list string) -> (U string (list symbol string+))
|
||||
(define (generate-require-spec name path)
|
||||
(let ((mod (string-append name ".ss")))
|
||||
|
|
@ -630,36 +628,7 @@
|
|||
(string-append remainder "-" (string (char-downcase char))))))))
|
||||
(else name)))
|
||||
|
||||
;variable-member? (list scheme-val) symbol -> scheme-val
|
||||
(define (variable-member? known-vars lookup)
|
||||
(and (not (null? known-vars))
|
||||
(or (and (eq? (scheme-val-name (car known-vars)) lookup)
|
||||
(car known-vars))
|
||||
(variable-member? (cdr known-vars) lookup))))
|
||||
|
||||
;field-contract-lookup string (list scheme-val) -> (U #f scheme-val)
|
||||
(define (field-contract-lookup name fields)
|
||||
(and (not (null? fields))
|
||||
(or (and (equal? (scheme-val-name (car fields)) name)
|
||||
(car fields))
|
||||
(field-contract-lookup name (cdr fields)))))
|
||||
|
||||
;get-method-contracts: string unknown-ref -> (list method-contract)
|
||||
(define (get-method-contracts name ref)
|
||||
(letrec ((methods (unknown-ref-methods ref))
|
||||
(lookup
|
||||
(lambda (ms)
|
||||
(and (not (null? ms))
|
||||
(or (and (equal? (method-contract-name (car ms)) name)
|
||||
(car ms))
|
||||
(lookup name (cdr ms)))))))
|
||||
(cond
|
||||
((lookup methods) => (lambda (x) x))
|
||||
(else
|
||||
(let ((mc (make-method-contract name (make-scheme-val 'method-return #t #f #f) #f)))
|
||||
(set-unknown-ref-methods! ref (cons mc (unknown-ref-methods ref)))
|
||||
(list mc))))))
|
||||
|
||||
|
||||
|
||||
;
|
||||
; ; ;;
|
||||
|
|
@ -676,7 +645,7 @@
|
|||
;
|
||||
|
||||
|
||||
(define type-version "version1")
|
||||
(define type-version "version2")
|
||||
(define type-length 10)
|
||||
|
||||
;; read-record: path -> (U class-record #f)
|
||||
|
|
@ -737,7 +706,7 @@
|
|||
(class-record-modifiers r)
|
||||
(class-record-object? r)
|
||||
(map field->list (class-record-fields r))
|
||||
(map method->list (class-record-methods r))
|
||||
(map method->list (filter (compose not method-record-override) (class-record-methods r)))
|
||||
(map inner->list (class-record-inners r))
|
||||
(class-record-parents r)
|
||||
(class-record-ifaces r)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user