From 095c8dbb87e6f38988a89d8a15e6a1026acd7b02 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Thu, 2 Jun 2005 04:36:59 +0000 Subject: [PATCH] Adding dynamic type and interoperability support to ProfJ; also brings profj up to date after the switch from cvs to svn svn: r50 --- collects/profj/ast.ss | 8 +- collects/profj/build-info.ss | 51 +- collects/profj/check.ss | 365 +++++---- collects/profj/compile.ss | 22 +- .../profj/libs/java/io/Serializable.jinfo | 2 +- .../libs/java/lang/ArithmeticException.ss | 12 +- .../lang/ArrayIndexOutOfBoundsException.ss | 13 +- .../libs/java/lang/ArrayStoreException.ss | 12 +- .../libs/java/lang/ClassCastException.ss | 12 +- .../libs/java/lang/ClassNotFoundException.ss | 15 +- .../java/lang/CloneNotSupportedException.ss | 12 +- .../profj/libs/java/lang/Comparable.jinfo | 2 +- collects/profj/libs/java/lang/Exception.ss | 14 +- .../libs/java/lang/IllegalAccessException.ss | 12 +- .../java/lang/IllegalArgumentException.ss | 12 +- .../java/lang/IllegalMonitorStateException.ss | 12 +- .../libs/java/lang/IllegalStateException.ss | 12 +- .../java/lang/IllegalThreadStateException.ss | 12 +- .../java/lang/IndexOutOfBoundsException.ss | 12 +- .../libs/java/lang/InstantiationException.ss | 12 +- .../libs/java/lang/InterruptedException.ss | 12 +- .../java/lang/NegativeArraySizeException.ss | 12 +- .../libs/java/lang/NoSuchFieldException.ss | 12 +- .../libs/java/lang/NoSuchMethodException.ss | 12 +- .../libs/java/lang/NullPointerException.ss | 12 +- .../libs/java/lang/NumberFormatException.ss | 12 +- .../profj/libs/java/lang/Object-composite.ss | 427 +++++++++- collects/profj/libs/java/lang/Object.jinfo | 2 +- collects/profj/libs/java/lang/Object.ss | 4 +- .../profj/libs/java/lang/RuntimeException.ss | 14 +- .../profj/libs/java/lang/SecurityException.ss | 12 +- collects/profj/libs/java/lang/String.jinfo | 6 +- .../lang/StringIndexOutOfBoundsException.ss | 13 +- collects/profj/libs/java/lang/Throwable.jinfo | 4 +- collects/profj/libs/java/lang/Throwable.ss | 4 +- .../lang/UnsupportedOperationException.ss | 12 +- collects/profj/parsers/advanced-parser.ss | 4 +- collects/profj/parsers/beginner-parser.ss | 2 +- collects/profj/parsers/full-parser.ss | 18 +- collects/profj/parsers/general-parsing.ss | 3 +- collects/profj/parsers/intermediate-parser.ss | 2 +- collects/profj/parsers/lexer.ss | 16 +- collects/profj/to-scheme.ss | 775 ++++++++++++++---- collects/profj/tool.ss | 23 +- collects/profj/types.ss | 127 ++- 45 files changed, 1617 insertions(+), 547 deletions(-) diff --git a/collects/profj/ast.ss b/collects/profj/ast.ss index 2b4702234c..841e27c922 100644 --- a/collects/profj/ast.ss +++ b/collects/profj/ast.ss @@ -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)) diff --git a/collects/profj/build-info.ss b/collects/profj/build-info.ss index 3e48c2d7da..367d607d67 100644 --- a/collects/profj/build-info.ss +++ b/collects/profj/build-info.ss @@ -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?)) diff --git a/collects/profj/check.ss b/collects/profj/check.ss index 0569ff31fb..e759e76952 100644 --- a/collects/profj/check.ss +++ b/collects/profj/check.ss @@ -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) diff --git a/collects/profj/compile.ss b/collects/profj/compile.ss index 63de7e4d9d..e66bc076b3 100644 --- a/collects/profj/compile.ss +++ b/collects/profj/compile.ss @@ -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))))))) diff --git a/collects/profj/libs/java/io/Serializable.jinfo b/collects/profj/libs/java/io/Serializable.jinfo index aca22f9926..a737953c0f 100644 --- a/collects/profj/libs/java/io/Serializable.jinfo +++ b/collects/profj/libs/java/io/Serializable.jinfo @@ -7,4 +7,4 @@ () () () - "version1") + "version2") diff --git a/collects/profj/libs/java/lang/ArithmeticException.ss b/collects/profj/libs/java/lang/ArithmeticException.ss index 1bb311f43c..ac80f5f75e 100644 --- a/collects/profj/libs/java/lang/ArithmeticException.ss +++ b/collects/profj/libs/java/lang/ArithmeticException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/ArrayIndexOutOfBoundsException.ss b/collects/profj/libs/java/lang/ArrayIndexOutOfBoundsException.ss index 0a33efaef9..82fb20a963 100644 --- a/collects/profj/libs/java/lang/ArrayIndexOutOfBoundsException.ss +++ b/collects/profj/libs/java/lang/ArrayIndexOutOfBoundsException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/ArrayStoreException.ss b/collects/profj/libs/java/lang/ArrayStoreException.ss index eebe194219..16feeff90a 100644 --- a/collects/profj/libs/java/lang/ArrayStoreException.ss +++ b/collects/profj/libs/java/lang/ArrayStoreException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/ClassCastException.ss b/collects/profj/libs/java/lang/ClassCastException.ss index 374b9a4b92..76e8cf911f 100644 --- a/collects/profj/libs/java/lang/ClassCastException.ss +++ b/collects/profj/libs/java/lang/ClassCastException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/ClassNotFoundException.ss b/collects/profj/libs/java/lang/ClassNotFoundException.ss index 450915c05f..e312b3c80f 100644 --- a/collects/profj/libs/java/lang/ClassNotFoundException.ss +++ b/collects/profj/libs/java/lang/ClassNotFoundException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/CloneNotSupportedException.ss b/collects/profj/libs/java/lang/CloneNotSupportedException.ss index 46d81e6c46..cccadc754f 100644 --- a/collects/profj/libs/java/lang/CloneNotSupportedException.ss +++ b/collects/profj/libs/java/lang/CloneNotSupportedException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/Comparable.jinfo b/collects/profj/libs/java/lang/Comparable.jinfo index 69eb8a1a11..a43d6b13d1 100644 --- a/collects/profj/libs/java/lang/Comparable.jinfo +++ b/collects/profj/libs/java/lang/Comparable.jinfo @@ -7,4 +7,4 @@ () () () - "version1") + "version2") diff --git a/collects/profj/libs/java/lang/Exception.ss b/collects/profj/libs/java/lang/Exception.ss index 9dfce4283d..b9b3c283ed 100644 --- a/collects/profj/libs/java/lang/Exception.ss +++ b/collects/profj/libs/java/lang/Exception.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/IllegalAccessException.ss b/collects/profj/libs/java/lang/IllegalAccessException.ss index 5c7571e39a..79e24edbd2 100644 --- a/collects/profj/libs/java/lang/IllegalAccessException.ss +++ b/collects/profj/libs/java/lang/IllegalAccessException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/IllegalArgumentException.ss b/collects/profj/libs/java/lang/IllegalArgumentException.ss index 01156d1bd9..e94941baf0 100644 --- a/collects/profj/libs/java/lang/IllegalArgumentException.ss +++ b/collects/profj/libs/java/lang/IllegalArgumentException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/IllegalMonitorStateException.ss b/collects/profj/libs/java/lang/IllegalMonitorStateException.ss index bebea04583..201498358d 100644 --- a/collects/profj/libs/java/lang/IllegalMonitorStateException.ss +++ b/collects/profj/libs/java/lang/IllegalMonitorStateException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/IllegalStateException.ss b/collects/profj/libs/java/lang/IllegalStateException.ss index bfa2e66973..fb38dff596 100644 --- a/collects/profj/libs/java/lang/IllegalStateException.ss +++ b/collects/profj/libs/java/lang/IllegalStateException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/IllegalThreadStateException.ss b/collects/profj/libs/java/lang/IllegalThreadStateException.ss index bbe6fd1397..8fa611d8a7 100644 --- a/collects/profj/libs/java/lang/IllegalThreadStateException.ss +++ b/collects/profj/libs/java/lang/IllegalThreadStateException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/IndexOutOfBoundsException.ss b/collects/profj/libs/java/lang/IndexOutOfBoundsException.ss index 9f63adda94..86984cb7b1 100644 --- a/collects/profj/libs/java/lang/IndexOutOfBoundsException.ss +++ b/collects/profj/libs/java/lang/IndexOutOfBoundsException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/InstantiationException.ss b/collects/profj/libs/java/lang/InstantiationException.ss index 7a08b897a6..ce12dcd69b 100644 --- a/collects/profj/libs/java/lang/InstantiationException.ss +++ b/collects/profj/libs/java/lang/InstantiationException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/InterruptedException.ss b/collects/profj/libs/java/lang/InterruptedException.ss index b0a1c123bd..94d6e51ec0 100644 --- a/collects/profj/libs/java/lang/InterruptedException.ss +++ b/collects/profj/libs/java/lang/InterruptedException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/NegativeArraySizeException.ss b/collects/profj/libs/java/lang/NegativeArraySizeException.ss index 29cedb05df..c962d6462e 100644 --- a/collects/profj/libs/java/lang/NegativeArraySizeException.ss +++ b/collects/profj/libs/java/lang/NegativeArraySizeException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/NoSuchFieldException.ss b/collects/profj/libs/java/lang/NoSuchFieldException.ss index fa56513f75..3958dfdd79 100644 --- a/collects/profj/libs/java/lang/NoSuchFieldException.ss +++ b/collects/profj/libs/java/lang/NoSuchFieldException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/NoSuchMethodException.ss b/collects/profj/libs/java/lang/NoSuchMethodException.ss index 3f72c10d92..bcab9e56ee 100644 --- a/collects/profj/libs/java/lang/NoSuchMethodException.ss +++ b/collects/profj/libs/java/lang/NoSuchMethodException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/NullPointerException.ss b/collects/profj/libs/java/lang/NullPointerException.ss index b6bfcbf020..5e6b890619 100644 --- a/collects/profj/libs/java/lang/NullPointerException.ss +++ b/collects/profj/libs/java/lang/NullPointerException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/NumberFormatException.ss b/collects/profj/libs/java/lang/NumberFormatException.ss index 35f956bcf9..64bfaa0064 100644 --- a/collects/profj/libs/java/lang/NumberFormatException.ss +++ b/collects/profj/libs/java/lang/NumberFormatException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/Object-composite.ss b/collects/profj/libs/java/lang/Object-composite.ss index 5a24585a49..bfb2979d08 100644 --- a/collects/profj/libs/java/lang/Object-composite.ss +++ b/collects/profj/libs/java/lang/Object-composite.ss @@ -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")) ) \ No newline at end of file diff --git a/collects/profj/libs/java/lang/Object.jinfo b/collects/profj/libs/java/lang/Object.jinfo index b55c994e50..cd097a9551 100644 --- a/collects/profj/libs/java/lang/Object.jinfo +++ b/collects/profj/libs/java/lang/Object.jinfo @@ -17,5 +17,5 @@ () (("Object" "java" "lang")) () - "version1") + "version2") diff --git a/collects/profj/libs/java/lang/Object.ss b/collects/profj/libs/java/lang/Object.ss index d60c0776e7..41486fdb6e 100644 --- a/collects/profj/libs/java/lang/Object.ss +++ b/collects/profj/libs/java/lang/Object.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/RuntimeException.ss b/collects/profj/libs/java/lang/RuntimeException.ss index 848281a771..6634e9ffe8 100644 --- a/collects/profj/libs/java/lang/RuntimeException.ss +++ b/collects/profj/libs/java/lang/RuntimeException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/SecurityException.ss b/collects/profj/libs/java/lang/SecurityException.ss index e072022ae0..7b1f22b6ec 100644 --- a/collects/profj/libs/java/lang/SecurityException.ss +++ b/collects/profj/libs/java/lang/SecurityException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/String.jinfo b/collects/profj/libs/java/lang/String.jinfo index 9f7e3b8e1b..37f90130a4 100644 --- a/collects/profj/libs/java/lang/String.jinfo +++ b/collects/profj/libs/java/lang/String.jinfo @@ -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") \ No newline at end of file + "version2") \ No newline at end of file diff --git a/collects/profj/libs/java/lang/StringIndexOutOfBoundsException.ss b/collects/profj/libs/java/lang/StringIndexOutOfBoundsException.ss index 9fcf79dcd6..3b891f2e8e 100644 --- a/collects/profj/libs/java/lang/StringIndexOutOfBoundsException.ss +++ b/collects/profj/libs/java/lang/StringIndexOutOfBoundsException.ss @@ -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)) diff --git a/collects/profj/libs/java/lang/Throwable.jinfo b/collects/profj/libs/java/lang/Throwable.jinfo index 7540682bc6..c5920eb6bb 100644 --- a/collects/profj/libs/java/lang/Throwable.jinfo +++ b/collects/profj/libs/java/lang/Throwable.jinfo @@ -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") diff --git a/collects/profj/libs/java/lang/Throwable.ss b/collects/profj/libs/java/lang/Throwable.ss index da1f1a5faf..b68773cd53 100644 --- a/collects/profj/libs/java/lang/Throwable.ss +++ b/collects/profj/libs/java/lang/Throwable.ss @@ -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)) \ No newline at end of file + 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)) \ No newline at end of file diff --git a/collects/profj/libs/java/lang/UnsupportedOperationException.ss b/collects/profj/libs/java/lang/UnsupportedOperationException.ss index b79ccb2d6c..5e528688d7 100644 --- a/collects/profj/libs/java/lang/UnsupportedOperationException.ss +++ b/collects/profj/libs/java/lang/UnsupportedOperationException.ss @@ -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)) diff --git a/collects/profj/parsers/advanced-parser.ss b/collects/profj/parsers/advanced-parser.ss index 05b616d620..2ea2b3369b 100644 --- a/collects/profj/parsers/advanced-parser.ss +++ b/collects/profj/parsers/advanced-parser.ss @@ -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] diff --git a/collects/profj/parsers/beginner-parser.ss b/collects/profj/parsers/beginner-parser.ss index b3a51b192b..7dac197ccf 100644 --- a/collects/profj/parsers/beginner-parser.ss +++ b/collects/profj/parsers/beginner-parser.ss @@ -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 diff --git a/collects/profj/parsers/full-parser.ss b/collects/profj/parsers/full-parser.ss index 155ef83707..391048465c 100644 --- a/collects/profj/parsers/full-parser.ss +++ b/collects/profj/parsers/full-parser.ss @@ -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) diff --git a/collects/profj/parsers/general-parsing.ss b/collects/profj/parsers/general-parsing.ss index 59e6dedac0..91068324fe 100644 --- a/collects/profj/parsers/general-parsing.ss +++ b/collects/profj/parsers/general-parsing.ss @@ -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 diff --git a/collects/profj/parsers/intermediate-parser.ss b/collects/profj/parsers/intermediate-parser.ss index 73790b4514..99bb02338c 100644 --- a/collects/profj/parsers/intermediate-parser.ss +++ b/collects/profj/parsers/intermediate-parser.ss @@ -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]) diff --git a/collects/profj/parsers/lexer.ss b/collects/profj/parsers/lexer.ss index 8e49b84c85..7a166d05b9 100644 --- a/collects/profj/parsers/lexer.ss +++ b/collects/profj/parsers/lexer.ss @@ -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)) diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index 080080fe10..203af59c6a 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -3,7 +3,8 @@ "types.ss" "parameters.ss" (lib "class.ss") - (lib "list.ss")) + (lib "list.ss") + (lib "etc.ss")) (provide translate-program translate-interactions (struct compilation-unit (contains code locations depends))) @@ -16,7 +17,7 @@ ;NOTE! Abstract classes are treated no differently than any class. ;Parameters for information about each class - (define class-name (make-parameter #f)) + (define class-name (make-parameter "interactions")) (define loc (make-parameter #f)) (define interactions? (make-parameter #f)) (define class-override-table (make-parameter null)) @@ -175,7 +176,7 @@ #f)) ((field? prog) (translate-field `(private) - (field-type prog) + (field-type-spec prog) (field-name prog) (and (var-init? prog) prog) (if (var-init? prog) @@ -615,6 +616,14 @@ (accesses-protected methods)) overridden-methods)) (dynamic-method-defs (generate-dyn-method-defs names-for-dynamic)) + (wrapper-classes (append (generate-wrappers (class-name) + (filter + (lambda (m) (not (or (private? (method-record-modifiers m)) + (static? (method-record-modifiers m))))) + (class-record-methods (send type-recs get-class-record (list (class-name))))) + (append (accesses-public fields) (accesses-package fields) + (accesses-protected fields))) + (generate-contract-defs (class-name)))) (static-method-names (make-static-method-names (accesses-static methods) type-recs)) (static-field-names (make-static-field-names (accesses-static fields))) (static-field-setters (make-static-field-setters-names @@ -625,6 +634,11 @@ (accesses-package fields) (accesses-protected fields)))) (provides `(provide ,(build-identifier (class-name)) + ,@(map build-identifier (list (format "guard-convert-~a" (class-name)) + (format "convert-assert-~a" (class-name)) + (format "wrap-convert-assert-~a" (class-name)) + (format "dynamic-~a/c" (class-name)) + (format "static-~a/c" (class-name)))) ;,@restricted-methods ,@(map build-identifier static-method-names) ,@(map build-identifier static-field-names) @@ -669,7 +683,7 @@ (else (cons (string->symbol (format "~a~~f" (car args))) (loop (cdr args))))))))) ,@(map (lambda (f) (translate-field (map modifier-kind (field-modifiers f)) - (field-type f) + (field-type-spec f) (field-name f) (and (var-init? f) f) (if (var-init? f) @@ -764,7 +778,8 @@ (initialize-block i) (initialize-src i) type-recs)) - (members-static-init class-members)) + (members-static-init class-members)) + ,@wrapper-classes ) #f))) @@ -781,16 +796,193 @@ (class-name old-class-name) (parent-name old-parent-name) (class-override-table old-override-table)))))))) + + ;generate-contract-defs: string -> (list sexp) + (define (generate-contract-defs class-name) + `((define ,(build-identifier (string-append "dynamic-" class-name "/c")) + (c:flat-named-contract ,class-name + (lambda (v) (is-a? v ,(build-identifier (string-append "convert-assert-" class-name)))))) + (define ,(build-identifier (string-append "static-" class-name "/c")) + (c:flat-named-contract ,class-name + (lambda (v) (is-a? v ,(build-identifier (string-append "guard-convert-" class-name)))))))) + ;generate-wrappers: string (list method-record) (list field) -> (list sexp) + (define (generate-wrappers class-name methods fields) + (let* ((normal-methods (filter + (lambda (m) + (not (or (eq? (method-record-rtype m) 'ctor) + (method-record-override m)))) methods)) + (class-text + (lambda (name from-dynamic? extra-methods) + `(define ,name + (class object% + (super-new) + (init w p n s c) + (define-values (wrapped-obj pos-blame neg-blame src cc-marks) (values null null null null null)) + (set! wrapped-obj w) + (set! pos-blame p) + (set! neg-blame n) + (set! src s) + (set! cc-marks c) + + ,(generate-wrapper-fields fields from-dynamic?) + + ,@(generate-wrapper-methods (filter (lambda (m) (not (eq? (method-record-rtype m) 'ctor))) + normal-methods) #f from-dynamic?) + ,@extra-methods + + (define/public (my-name) (send wrapped-obj my-name)) + (define/public (field-names) (send wrapped-obj field-names)) + (define/public (field-values) (send wrapped-obj field-values)) + (define/public (fields-for-display) (send wrapped-obj fields-for-display)) + + )))) + (dynamic-callables (refine-method-list methods))) + (list + `(define (,(build-identifier (string-append "wrap-convert-assert-" class-name)) obj p n s c) + (c:contract ,(methods->contract normal-methods) obj p n s) + (make-object ,(build-identifier (string-append "convert-assert-" class-name)) obj p n s c)) + (class-text (build-identifier (string-append "convert-assert-" class-name)) #t null) + (class-text (build-identifier (string-append "guard-convert-" class-name)) #f + (generate-wrapper-methods dynamic-callables #t #f))))) + + ;generate-wrapper-fields: (list field) boolean -> sexp + (define (generate-wrapper-fields fields from-dynamic?) + `(field ,@(map (lambda (field) + (let* ((field-name (id-string (field-name field))) + (value `(,(create-get-name field-name) wrapped-obj))) + `(,(build-identifier (build-var-name field-name)) + ,(convert-value (if from-dynamic? (assert-value value (field-type field) #t) value) + (field-type field) + from-dynamic?)))) + fields))) + + ;generate-wrapper-methods: (list method-record) boolean boolean -> (list sexp) + ;When is dynamic-callable?, will define methods callable from a dynamic context + (define (generate-wrapper-methods methods dynamic-callable? from-dynamic?) + (map (lambda (method) + (let* ((call-name (mangle-method-name (method-record-name method) + (method-record-atypes method))) + (define-name (if dynamic-callable? (java-name->scheme (method-record-name method)) call-name)) + (list-of-args (map (lambda (a) (gensym "arg-")) (method-record-atypes method)))) + (cond + ((and dynamic-callable? (equal? define-name call-name)) + `(void)) + (from-dynamic? + `(define/public (,(build-identifier define-name) ,@list-of-args) + ,(convert-value (assert-value `(send wrapped-obj ,(build-identifier call-name) + ,@(map (lambda (arg type) + (convert-value (assert-value arg type #f) type #f)) + list-of-args (method-record-atypes method))) + (method-record-rtype method) from-dynamic?) + (method-record-rtype method) + from-dynamic?))) + (else + `(define/public (,(build-identifier define-name) . args) + (unless (= (length args) ,(length list-of-args)) + (raise (make-exn:fail:contract:arity + (string->immutable-string + (format "~a broke the contract with ~a here, method ~a called with ~a args, instead of ~a" + pos-blame neg-blame ,(method-record-name method) (length args) ,(length list-of-args))) + cc-marks))) + (let (,@(map (lambda (arg type ref) + `(,arg ,(convert-value (assert-value `(list-ref args ,ref) type #t) type #t))) + list-of-args (method-record-atypes method) (list-from 0 (length list-of-args)))) + ,(convert-value `(send wrapped-obj ,(build-identifier call-name) + ,@list-of-args) (method-record-rtype method) #f))))))) + methods)) + + (define (list-from from to) + (cond + ((= from to) null) + (else (cons from (list-from (add1 from) to))))) + + ;methods->contract: (list method-record) -> sexp + (define (methods->contract methods) + `(c:object-contract ,@(map (lambda (m) + `(,(build-identifier (mangle-method-name (method-record-name m) + (method-record-atypes m))) + (c:-> ,@(map (lambda (a) 'c:any/c) (method-record-atypes m)) c:any/c))) + methods))) + + ;convert-value: sexp type boolean -> sexp + (define (convert-value value type from-dynamic?) + (cond + ((symbol? type) + (case type + ((int byte short long float double char boolean dynamic void) value) + ((string) (if from-dynamic? + `(make-java-string ,value) + `(send ,value get-mzscheme-string))))) + ((dynamic-val? type) value) + ((array-type? type) value + #;(if from-dynamic? + `(wrap-convert-assert-array ,value pos-blame neg-blame src cc-marks) + `(make-object guard-convert-array ,value pos-blame neg-blame src cc-marks))) + ((ref-type? type) + (cond + ((and (equal? string-type type) from-dynamic?) `(make-java-string ,value)) + ((equal? string-type type) `(send ,value get-mzscheme-string)) + ((equal? type (make-ref-type "Class" '("java" "lang"))) value) + (from-dynamic? `(,(build-identifier (string-append "wrap-convert-assert-" (ref-type-class/iface type))) + ,value pos-blame neg-blame src cc-marks)) + (else `(make-object ,(build-identifier (string-append "guard-convert-" (ref-type-class/iface type))) + ,value pos-blame neg-blame src cc-marks)))) + (else value))) + + ;assert-value: sexp type boolean -> sexp + (define (assert-value value type from-dynamic?) + (cond + ((symbol? type) + (let ((check + (lambda (ok?) + `(let ((v-1 ,value)) + (if (,ok? v-1) v-1 + (raise (make-exn:fail (string->immutable-string + (format "~a broke the contract with ~a here, type-mismatch expected ~a given ~a" + pos-blame neg-blame (quote ,type) v-1)) cc-marks))))))) + (case type + ((int byte short long) (check 'integer?)) + ((float double) (check 'real?)) + ((char) (check 'character?)) + ((string) (check 'string?)) + ((boolean) (check 'boolean?)) + ((dynamic) value)))) + ((and (ref-type? type) (equal? string-type type)) + (assert-value value 'string from-dynamic?)) + (else value))) + + + + ;Removes from the list all methods that are not callable from a dynamic context + ;refine-method-list: (list method-record) -> (list method-record) + (define (refine-method-list methods) + (cond + ((null? methods) methods) + ((method-record-override (car methods)) + (refine-method-list (cdr methods))) + ((eq? 'ctor (method-record-rtype (car methods))) + (refine-method-list (cdr methods))) + (else + (let ((overloaded-removed + (filter (lambda (m) (not (equal? (method-record-name (car methods)) + (method-record-name m)))) + (cdr methods)))) + (if (> (length (cdr methods)) + (length overloaded-removed)) + (refine-method-list overloaded-removed) + (cons (car methods) (refine-method-list (cdr methods)))))))) + + ;generate-dynamic-names: (list method) (list method)-> (list (list string method)) (define (generate-dynamic-names methods overridden-methods) (map (lambda (method) (list (java-name->scheme (id-string (method-name method))) method)) - (refine-method-list methods overridden-methods))) + (refine-method-list-old methods overridden-methods))) - ;refine-method-list: (list method) (list method) -> (list method) - (define (refine-method-list methods overridden-methods) + ;refine-method-list-old: (list method) (list method) -> (list method) + (define (refine-method-list-old methods overridden-methods) (if (null? methods) methods (let ((overloaded-removed @@ -801,12 +993,12 @@ (cond ((> (length (cdr methods)) (length overloaded-removed)) - (refine-method-list overloaded-removed overridden-methods)) + (refine-method-list-old overloaded-removed overridden-methods)) ((memq (car methods) overridden-methods) - (refine-method-list (cdr methods) overridden-methods)) + (refine-method-list-old (cdr methods) overridden-methods)) ((eq? 'ctor (method-record-rtype (method-rec (car methods)))) - (refine-method-list (cdr methods) overridden-methods)) - (else (cons (car methods) (refine-method-list (cdr methods) overridden-methods))))))) + (refine-method-list-old (cdr methods) overridden-methods)) + (else (cons (car methods) (refine-method-list-old (cdr methods) overridden-methods))))))) ;generate-dyn-method-defs: (list (list string method)) -> (list syntax) (define (generate-dyn-method-defs methods) @@ -884,7 +1076,7 @@ ((= d 0) null) (else (cons (string->symbol (format "encl-this-~a~~f" d)) (loop (sub1 d)))))))) - (parm-types (map (lambda (p) (type-spec-to-type (field-type p) #f 'full type-recs)) parms))) + (parm-types (map field-type #;(lambda (p) (type-spec-to-type (field-type-spec p) #f 'full type-recs)) parms))) (make-syntax #f `(define/public (,(build-identifier (mangle-method-name ctor-name parm-types)) ,@translated-parms) (let ((temp-obj (make-object ,(build-identifier class-name) @@ -1255,7 +1447,7 @@ (f (car fields))) (cons (make-syntax #f `(define ,(translate-id name (id-src (field-name f))) - ,(translate-field-body (and (var-init? f) f) (field-type f))) + ,(translate-field-body (and (var-init? f) f) (field-type-spec f))) (build-src (if (var-init? f) (var-init-src f) (var-decl-src f)))) (create-static-fields (cdr names) (cdr fields)))))) @@ -1268,14 +1460,22 @@ (make-syntax #f `(define ,field-name ,value) (build-src src)) (make-syntax #f `(field (,field-name ,value)) (build-src src))))) - ;translate-field-body (U bool var-init) type -> syntax + ;translate-field-body (U bool var-init) type-spec -> syntax (define (translate-field-body init? type) - (if init? - (if (array-init? (var-init-init init?)) - (initialize-array (array-init-vals (var-init-init init?)) - type) - (translate-expression (var-init-init init?))) - (get-default-value type))) + (cond + (init? + (let ((actual-type (if (array-init? (var-init-init init?)) + 'dynamic ;Problem: array type needed here + (expr-types (var-init-init init?)))) + (body-syntax (if (array-init? (var-init-init init?)) + (initialize-array (array-init-vals (var-init-init init?)) + type) + (translate-expression (var-init-init init?))))) + (if (or (eq? 'dynamic (field-type init?)) + (dynamic-val? (field-type init?))) + (make-syntax #f (guard-convert-value body-syntax actual-type) body-syntax) + body-syntax))) + (else (get-default-value type)))) ;translate-initialize: bool block src string type-records -> syntax (define (translate-initialize static? body src type-recs) @@ -1373,10 +1573,10 @@ (lambda (expr key src) (create-syntax #f `(let* ((obj ,expr) (exn (make-java:exception - (send (send obj |getMessage|) get-mzscheme-string) + (string->immutable-string (send (send obj |getMessage|) get-mzscheme-string)) (current-continuation-marks) obj))) (send obj set-exception! exn) - (,(create-syntax #f 'raise (build-src key)) exn)) + (,(create-syntax #f 'raise (build-src key)) exn)) (build-src src)))) ;return -> call to a continuation @@ -1405,11 +1605,11 @@ (build-src src))) ;translate-for: (U (list statement) (list field)) syntax (list syntax) syntax src type-records-> syntax - (define (translate-for init cond incr body src type-recs) + (define (translate-for init condi incr body src type-recs) (let ((loop `(let/ec loop-k (let loop ((continue? #f)) (when continue? ,@(if (null? incr) '((void)) incr)) - (when ,cond + (when ,condi ,body ,@incr (loop #f))))) @@ -1418,12 +1618,22 @@ (make-syntax #f `(letrec (,@(map (lambda (var) `(,(translate-id (build-var-name (id-string (field-name var))) (id-src (field-name var))) - ,(if (var-init? var) - (if (array-init? (var-init-init var)) - (initialize-array (array-init-vals (var-init-init var)) - (field-type var)) - (translate-expression (var-init-init var))) - (get-default-value (field-type var))))) + ,(cond + ((var-init? var) + (let ((actual-type + (if (array-init? (var-init-init var)) + 'dynamic ;Problem: need array-type here + (expr-types (var-init-init var)))) + (var-value + (if (array-init? (var-init-init var)) + (initialize-array (array-init-vals (var-init-init var)) + (field-type-spec var)) + (translate-expression (var-init-init var))))) + (if (or (eq? 'dynamic (field-type var)) + (dynamic-val? (field-type var))) + (make-syntax #f (guard-convert-value var-value actual-type) var-value) + var-value))) + (else (get-default-value (field-type-spec var)))))) init)) ,loop) source) (make-syntax #f `(begin @@ -1478,8 +1688,8 @@ (map (lambda (catch) (let* ((catch-var (catch-cond catch)) (var-src (var-decl-src catch-var)) - (class-name (get-class-name (field-type catch-var))) - (isRuntime? (descendent-Runtime? (field-type catch-var) type-recs)) + (class-name (get-class-name (field-type-spec catch-var))) + (isRuntime? (descendent-Runtime? (field-type-spec catch-var) type-recs)) (type (if isRuntime? (make-syntax #f `exn? (build-src var-src)) @@ -1546,12 +1756,20 @@ (id (translate-id (build-var-name (id-string (field-name var))) (id-src (field-name var))))) (list (make-syntax #f `(letrec - ((,id ,(if is-var-init? - (if (array-init? (var-init-init var)) - (initialize-array (array-init-vals (var-init-init var)) - (field-type var)) - (translate-expression (var-init-init var))) - (get-default-value (field-type var))))) + ((,id ,(cond + (is-var-init? + (let ((actual-type (if (array-init? (var-init-init var)) + 'dynamic ;Problem: need array type here + (expr-types (var-init-init var)))) + (var-value (if (array-init? (var-init-init var)) + (initialize-array (array-init-vals (var-init-init var)) + (field-type-spec var)) + (translate-expression (var-init-init var))))) + (if (or (eq? 'dynamic (field-type var)) + (dynamic-val? (field-type var))) + (guard-convert-value var-value actual-type) + var-value))) + (else (get-default-value (field-type-spec var)))))) ,@(if (null? statements) (list `(void)) (translate statements))) @@ -1600,39 +1818,95 @@ ;translate-contract ;translates types into contracts - ;type->contract: type -> sexp - (define (type->contract type) + ;type->contract: type boolean -> sexp + (define (type->contract type from-dynamic? . stop?) (cond + ((dynamic-val? type) + (if (null? stop?) + (type->contract (dynamic-val-type type) from-dynamic?) + (type->contract (dynamic-val-type type) from-dynamic? #t))) ((symbol? type) (case type ((int short long byte) 'integer?) - ((long float) '(c:and/c number? inexact?)) + ((double float) '(c:and/c number? inexact?)) ((boolean) 'boolean?) ((char) 'char?) - ((string) `(c:is-a?/c ,(if (send (types) require-prefix '("String" "java" "lang") (lambda () #f)) - 'java.lang.String 'String))))) - ((ref-type? type) - (let ((class-name (cons (ref-type-class/iface type) (ref-type-path type)))) - `(c:is-a?/c - ,(build-identifier (if (send (types) require-prefix class-name (lambda () #f)) - (format "~a~a" (apply string-append (map (lambda (s) (string-append s ".")) - (map id-string (ref-type-path type)))) - (ref-type-class/iface type)) - (ref-type-class/iface type)))))) + ((string String) + (if from-dynamic? + `string? + `(c:is-a?/c ,(if (send (types) require-prefix? '("String" "java" "lang") (lambda () #f)) + 'java.lang.String 'String)))) + ((dynamic void) 'c:any/c))) + ((ref-type? type) + (if (equal? type string-type) + (type->contract 'string from-dynamic?) + `(c:union (c:is-a?/c object%) string?))) ((unknown-ref? type) - `(c:object-contract ,@(map (lambda (m) - `(,(string->symbol (java-name->scheme (method-contract-name m))) - ,(type->contract m))) - (unknown-ref-methods type)) - ,@(map (lambda (f) `(field ,(string->symbol (java-name->scheme (scheme-val-name f))) - ,(type->contract (scheme-val-type f)))) - (unknown-ref-fields type)))) + (if (not (null? stop?)) + `(c:union (c:is-a?/c object%) string?) + (cond + ((method-contract? (unknown-ref-access type)) + `(c:object-contract (,(string->symbol (java-name->scheme (method-contract-name (unknown-ref-access type)))) + ,(type->contract (unknown-ref-access type) from-dynamic?)))) + ((field-contract? (unknown-ref-access type)) + `(c:object-contract (field ,(build-identifier (string-append (field-contract-name (unknown-ref-access type)) "~f")) + ,(type->contract (field-contract-type (unknown-ref-access type)) from-dynamic?))))))) ((method-contract? type) - `(c:-> ,@(map type->contract (map scheme-val-type (method-contract-args type))) - ,(type->contract (scheme-val-type (method-contract-return type))))) + `(c:-> ,@(map (lambda (a) (type->contract a from-dynamic?)) (method-contract-args type)) + ,(type->contract (method-contract-return type) from-dynamic? #t))) ((not type) 'c:any/c) )) + ;guard-convert-value syntax type -> sexp + (define (guard-convert-value val type) + (cond + ((dynamic-val? type) val) + ((symbol? type) + (case type + ((int short long byte float double boolean char dynamic void) val) + ((string String) `(send ,val get-mzscheme-string)))) + ((ref-type? type) + (if (equal? type string-type) + `(send ,val get-mzscheme-string) + (let ((prefix (if (send (types) require-prefix? (cons (ref-type-class/iface type) (ref-type-path type)) + (lambda () #f)) + (apply string-append (map (lambda (s) (string-append s ".")) (ref-type-path type))) + ""))) + `(make-object ,(build-identifier (string-append prefix "guard-convert-" (ref-type-class/iface type))) + ,val (quote ,(string->symbol (class-name))) '|infered contract| #`,val (current-continuation-marks))))) + (else val))) + ;convert-assert-value: syntax type -> sexp + (define (convert-assert-value val type) + (cond + ((dynamic-val? type) (convert-assert-value val (dynamic-val-type type))) + ((symbol? type) + (case type + ((int short long byte float double boolean char dynamic void) val) + ((string String) + `(let ((val ,val)) + (if (string? val) + (make-java-string val) + (raise (make-exn:fail (string->immutable-string + (format "~a broke infered contract here: expected String received ~a" + ,(class-name) val)) (current-continuation-marks)))))))) + ((unknown-ref? type) + `(let ((val ,val)) + (if (string? val) + (make-java-string val) + val))) + ((ref-type? type) + (cond + ((equal? type string-type) + (convert-assert-value val 'string)) + (else + (let ((prefix (if (send (types) require-prefix? (cons (ref-type-class/iface type) (ref-type-path type)) + (lambda () #f)) + (apply string-append (map (lambda (s) (string-append s ".")) (ref-type-path type))) + ""))) + `(,(build-identifier (string-append prefix "wrap-convert-assert-" (ref-type-class/iface type))) + ,val (quote ,(string->symbol (class-name))) '|infered contract| #`,val (current-continuation-marks)))))) + (else val))) + ;------------------------------------------------------------------------------------------------------------------------ ;translate-expression ;translates a Java expression into a Scheme expression. @@ -1662,7 +1936,9 @@ ((call? expr) (translate-call (call-expr expr) (call-method-name expr) (map translate-expression (call-args expr)) + (map expr-types (call-args expr)) (call-method-record expr) + (expr-types expr) (expr-src expr))) ((class-alloc? expr) (translate-class-alloc (class-alloc-name expr) (map expr-types (class-alloc-args expr)) @@ -1704,6 +1980,7 @@ (expr-src expr))) ((cast? expr) (translate-cast (cast-type expr) (translate-expression (cast-expr expr)) + (expr-types expr) (expr-src expr))) ((instanceof? expr) (translate-instanceof (translate-expression (instanceof-expr expr)) (instanceof-type expr) @@ -1740,8 +2017,8 @@ ;;make-is-test sym -> (type -> bool) (define (make-is-test kind) (lambda (type) - (if (scheme-val? type) - (eq? (scheme-val-type type) kind) + (if (dynamic-val? type) + (eq? (dynamic-val-type type) kind) (eq? type kind)))) ;;is-string? type -> bool @@ -1751,65 +2028,107 @@ ;;is-char? type -> bool (define is-char? (make-is-test 'char)) - ;Converted ;translate-bin-op: symbol syntax type syntax type src src type-> syntax (define (translate-bin-op op left left-type right right-type key src type) (let* ((source (build-src src)) - (op-syntax (create-syntax #f op (build-src key))) - (left (if (is-char? left-type) - (make-syntax #f `(char->integer ,left) #f) - left)) - (right (if (is-char? right-type) - (make-syntax #f `(char->integer ,right) #f) - right)) + (key-src (build-src key)) + (op-syntax (create-syntax #f op key-src)) + (left (cond + ((is-char? left-type) + (make-syntax #f `(char->integer ,left) #f)) + ((and (dynamic-val? type) (not (memq op '(== != & ^ or && oror)))) + (create-syntax #f `(c:contract number? ,left (quote ,(string->symbol (class-name))) '|infered contract|) left)) + (else left))) + (right (cond + ((is-char? right-type) + (make-syntax #f `(char->integer ,right) #f)) + ((and (dynamic-val? type) (not (memq op '(== != & ^ or && oror)))) + (create-syntax #f `(c:contract number? ,right (quote ,(string->symbol (class-name))) '|infered contract|) right)) + (else right))) (result (case op ;Mathematical operations ;PROBLEM! + and - do not take into account the possibility of overflow ((+) - (cond - ((and (is-string-type? type) (is-string-type? left-type)) - (make-syntax #f `(send ,left concat-java.lang.String (javaRuntime:convert-to-string ,right)) source)) - ((and (is-string-type? type) (is-string-type? right-type)) - (make-syntax #f `(send (javaRuntime:convert-to-string ,left) concat-java.lang.String ,right) source)) - ((is-string-type? type) - (make-syntax #f - `(send (javaRuntime:convert-to-string ,left) concat-java.lang.String - (javaRuntime:convert-to-string ,right)) - source)) - (else - (create-syntax #f `(,op-syntax ,left ,right) source)))) - ((- *) (make-syntax #f `(,op-syntax ,left ,right) source)) - ((/) (if (is-int? type) - (make-syntax #f `(,(create-syntax #f 'javaRuntime:divide-int (build-src key)) ,left ,right) source) - (make-syntax #f `(,(create-syntax #f 'javaRuntime:divide-float (build-src key)) ,left ,right) source))) - ((%) (make-syntax #f `(,(create-syntax #f 'javaRuntime:mod (build-src key)) ,left ,right) source)) + (create-syntax #f + (cond + ((and (is-string-type? type) (is-string-type? left-type)) + `(send ,left concat-java.lang.String (javaRuntime:convert-to-string ,right))) + ((and (is-string-type? type) (is-string-type? right-type)) + `(send (javaRuntime:convert-to-string ,left) concat-java.lang.String ,right)) + ((is-string-type? type) + `(send (javaRuntime:convert-to-string ,left) concat-java.lang.String + (javaRuntime:convert-to-string ,right))) + (else + `(,op-syntax ,left ,right))) source)) + ((- *) + (create-syntax #f `(,op-syntax ,left ,right) source)) + ((/) + (make-syntax + #f + (cond + ((or (is-int? type) (and (dynamic-val? type) (is-int? (dynamic-val-type type)))) + `(,(create-syntax #f 'javaRuntime:divide-int key-src) ,left ,right)) + (else + `(,(create-syntax #f 'javaRuntime:divide-float key-src) ,left ,right))) source)) + ((%) (make-syntax #f `(,(create-syntax #f 'javaRuntime:mod key-src) ,left ,right) source)) ;Shift operations - ((<< >> >>>) (make-syntax #f `(,(create-syntax #f 'javaRuntime:shift (build-src key)) (quote ,op) ,left ,right) source)) + ((<< >> >>>) + (make-syntax #f + `(,(create-syntax #f 'javaRuntime:shift key-src) (quote ,op) ,left ,right) source)) ;comparisons ((< > <= >=) (make-syntax #f `(,op-syntax ,left ,right) source)) ((==) - (if (and (prim-numeric-type? left-type) (prim-numeric-type? right-type)) - (make-syntax #f `(,(create-syntax #f '= (build-src key)) ,left ,right) source) - (make-syntax #f `(,(create-syntax #f 'eq? (build-src key)) ,left ,right) source))) - ((!=) (make-syntax #f `(,(create-syntax #f 'javaRuntime:not-equal (build-src key)) ,left ,right) source)) + (make-syntax #f + (cond + ((or (dynamic-val? left-type) (dynamic-val? right-type)) + `(,(create-syntax #f 'eq? key-src) ,left ,right)) + ((and (prim-numeric-type? left-type) (prim-numeric-type? right-type)) + `(,(create-syntax #f '= key-src) ,left ,right)) + (else + `(,(create-syntax #f 'eq? key-src) ,left ,right))) source)) + ((!=) + (make-syntax #f `(,(create-syntax #f 'javaRuntime:not-equal key-src) ,left ,right) source)) ;logicals - ((& ^ or) (make-syntax #f `(,(create-syntax #f 'javaRuntime:bitwise (build-src key)) (quote ,op) ,left ,right) source)) + ((& ^ or) + (make-syntax #f + `(,(create-syntax #f 'javaRuntime:bitwise key-src) (quote ,op) ,left ,right) source)) ;boolean - ((&&) (make-syntax #f `(,(create-syntax #f 'javaRuntime:and (build-src key)) ,left ,right) source)) - ((oror) (make-syntax #f `(,(create-syntax #f 'javaRuntime:or (build-src key)) ,left ,right) source)) + ((&&) (make-syntax #f `(,(create-syntax #f 'javaRuntime:and key-src) ,left ,right) source)) + ((oror) (make-syntax #f `(,(create-syntax #f 'javaRuntime:or key-src) ,left ,right) source)) (else (error 'translate-op (format "Translate op given unknown operation ~s" op)))))) - (if (scheme-val? type) - (make-syntax #f `(contract ,(type->contract (scheme-val-type type)) ,result 'scheme 'java) source) + (if (dynamic-val? type) + (make-syntax #f + (convert-assert-value + (make-syntax #f `(c:contract ,(type->contract (dynamic-val-type type)) ,result + (quote ,(string->symbol (class-name))) '|infered contract|) source) + type) + source) result))) ;translate-access: (U field-access local-access) type src -> syntax (define (translate-access name type src) (cond ((local-access? name) - (translate-id (build-var-name (id-string (local-access-name name))) - (id-src (local-access-name name)))) + (let ((var (translate-id (build-var-name (id-string (local-access-name name))) + (id-src (local-access-name name))))) + (if (dynamic-val? type) + (let ((local-syntax (cond + ((unknown-ref? (dynamic-val-type type)) + `(let ((val-1 ,var)) + (if (string? val-1) + (make-java-string val-1) + val-1))) + (else var)))) + (make-syntax #f + (convert-assert-value + (make-syntax #f + `(c:contract ,(type->contract (dynamic-val-type type) #t) + ,local-syntax (quote ,(string->symbol (class-name))) '|infered contract|) + (build-src (id-src (local-access-name name)))) + (dynamic-val-type type)) (build-src (id-src (local-access-name name))))) + var))) ((field-access? name) (let* ((field-string (id-string (field-access-field name))) (field-src (id-src (field-access-field name))) @@ -1819,14 +2138,24 @@ (expr (if obj (translate-expression obj)))) (cond ((var-access-static? access) - (if (scheme-val? type) - (make-syntax #f - `(c:contract ,(type->contract (scheme-val-type type)) - ,(translate-id (build-static-name field-string (var-access-class access)) field-src) - 'scheme 'java) - (build-src field-src)) - (translate-id (build-var-name (build-static-name field-string (var-access-class access))) - field-src))) + (let ((static-name (build-static-name field-string (var-access-class access)))) + (if (dynamic-val? type) + (let ((access-syntax (cond + ((unknown-ref? (dynamic-val-type type)) + `(let ((val-1 ,(translate-id static-name))) + (if (string? val-1) + (make-java-string val-1) + val-1))) + (else (translate-id static-name))))) + (make-syntax #f + (convert-assert-value + (make-syntax #f + `(c:contract ,(type->contract (dynamic-val-type type) #t) + ,access-syntax + (quote ,(string->symbol (class-name))) '|infered contract|) + (build-src field-src)) + (dynamic-val-type type)) (build-src field-src))) + (translate-id (build-var-name static-name) field-src)))) ((eq? 'array (var-access-class access)) (if cant-be-null? (make-syntax #f `(send ,expr ,(translate-id field-string field-src)) (build-src src)) @@ -1836,22 +2165,56 @@ (send ,expr ,(translate-id field-string field-src))) (build-src src)))) ((and (eq? (var-access-access access) 'private) (static-method)) - (let ((id (create-get-name field-string (var-access-class access)))) - (if cant-be-null? - (make-syntax #f `(send ,expr ,id ,expr) (build-src src)) - (make-syntax #f `(if (null? ,expr) - (javaRuntime:nullError 'field) - (send ,expr ,id ,expr)) - (build-src src))))) - (else - (let ((id (create-get-name field-string (var-access-class access)))) - (if cant-be-null? - (make-syntax #f `(,id ,expr) (build-src src)) + (let* ((id (create-get-name field-string (var-access-class access))) + (getter `(send ,expr ,id ,expr)) + (get-syntax (if cant-be-null? + (make-syntax #f getter (build-src src)) + (make-syntax #f `(if (null? ,expr) + (javaRuntime:nullError 'field) + ,getter) + (build-src src))))) + (if (dynamic-val? type) + (let ((access-syntax (cond + ((unknown-ref? (dynamic-val-type type)) + `(let ((val-1 ,get-syntax)) + (if (string? val-1) + (make-java-string val-1) + val-1))) + (else get-syntax)))) (make-syntax #f - `(if (null? ,expr) - (javaRuntime:nullError 'field) - (,id ,expr)) - (build-src src)))))))))) + (convert-assert-value + (make-syntax #f + `(c:contract ,(type->contract (dynamic-val-type type) #t) + ,access-syntax (quote ,(string->symbol (class-name))) '|infered contract|) + (build-src field-src)) + (dynamic-val-type type)) (build-src field-src))) + get-syntax))) + (else + (let* ((id (create-get-name field-string (var-access-class access))) + (get-syntax + (if cant-be-null? + (make-syntax #f `(,id ,expr) (build-src src)) + (make-syntax #f + `(if (null? ,expr) + (javaRuntime:nullError 'field) + (,id ,expr)) + (build-src src))))) + (if (dynamic-val? type) + (let ((access-syntax (cond + ((unknown-ref? (dynamic-val-type type)) + `(let ((val-1 ,get-syntax)) + (if (string? val-1) + (make-java-string val-1) + val-1))) + (else get-syntax)))) + (make-syntax #f + (convert-assert-value + (make-syntax #f + `(c:contract ,(type->contract (dynamic-val-type type) #t) + ,access-syntax (quote ,(string->symbol (class-name))) '|infered contract|) + (build-src field-src)) + (dynamic-val-type type)) (build-src field-src))) + get-syntax)))))))) ;translate-special-name: string src -> syntax (define (translate-special-name name src) @@ -1862,11 +2225,21 @@ (define (translate-specified-this var src) (make-syntax #f (build-identifier (string-append var "~f")) (build-src src))) - ;translate-call: (U expression #f) (U special-name id) (list syntax) method-record src-> syntax - (define (translate-call expr method-name args method-record src) + ;translate-call: (U expression #f) (U special-name id) (list syntax) (list type) method-record type src-> syntax + (define (translate-call expr method-name args arg-types method-record rtype src) (let ((cant-be-null? (never-null? expr)) (expression (if expr (translate-expression expr) #f)) - (unique-name (gensym))) + (unique-name (gensym)) + (translated-args + (if (method-contract? method-record) + (map (lambda (arg type) + (guard-convert-value arg type)) + args arg-types) + (map (lambda (arg type call-type) + (if (eq? 'dynamic call-type) + (guard-convert-value arg type) + arg)) + args arg-types (method-record-atypes method-record))))) (cond ;Constructor case ((special-name? method-name) @@ -1894,63 +2267,86 @@ (build-src src)) (if cant-be-null? - (create-syntax #f `(send ,(if expr expression 'this) ,c-name ,@args) (build-src src)) + (create-syntax #f `(send ,(if expr expression 'this) ,c-name ,@translated-args) (build-src src)) (create-syntax #f `(let ((,unique-name ,expression)) (if (null? ,unique-name) (javaRuntime:nullError 'method) - (send ,unique-name ,c-name ,@args))) + (send ,unique-name ,c-name ,@translated-args))) (build-src src))))) ;Normal case ((id? method-name) - (let* ((static? (unless (method-contract? method-record) - (memq 'static (method-record-modifiers method-record)))) + (let* ((static? (and (not (method-contract? method-record)) + (memq 'static (method-record-modifiers method-record)))) (temp (unless (method-contract? method-record) (mangle-method-name (method-record-name method-record) (method-record-atypes method-record)))) - (m-name (unless (method-contract? method-record) - (if static? - (build-static-name temp (car (method-record-class method-record))) - temp))) + (m-name (cond + ((method-contract? method-record) (java-name->scheme (method-contract-name method-record))) + (static? + (build-static-name temp (car (method-record-class method-record)))) + (else temp))) (generic-name (unless (method-contract? method-record) (build-generic-name (car (method-record-class method-record)) m-name)))) (cond ((special-name? expr) (let* ((over? (overridden? (string->symbol m-name))) - (name (translate-id m-name - #;(if (and (equal? (special-name-name expr) "super") over?) - (format "super.~a" m-name) - m-name) - (id-src method-name)))) - (cond - (static? (create-syntax #f `(,name ,@args) (build-src src))) - (over? (create-syntax #f `(super ,name ,@args) (build-src src))) - (else (create-syntax #f `(send this ,name ,@args) (build-src src)))))) + (name (translate-id m-name (id-src method-name))) + (new-exp (cond + (static? (create-syntax #f `(,name ,@translated-args) (build-src src))) + (over? (create-syntax #f `(super ,name ,@translated-args) (build-src src))) + (else (create-syntax #f `(send this ,name ,@translated-args) (build-src src)))))) + (if (or (method-contract? method-record) + (dynamic-val? rtype)) + (make-syntax #f (convert-assert-value new-exp (if (method-contract? method-record) + (method-contract-return method-record) + (dynamic-val-type rtype))) (build-src src)) + new-exp))) ((not expr) (cond ((method-contract? method-record) - (create-syntax #f `((contract ,(type->contract method-record) - ,(java-name->scheme (method-contract-name method-record))) - ,@args) (build-src src))) + (make-syntax #f (convert-assert-value + (create-syntax #f `((c:contract ,(type->contract method-record #t) + ,(build-identifier (java-name->scheme (method-contract-name method-record))) + (quote ,(string->symbol (class-name))) '|infered contract|) + ,@translated-args) (build-src src)) + (method-contract-return method-record)) + (build-src src))) ((or static? (memq 'private (method-record-modifiers method-record))) - (create-syntax #f `(,(translate-id m-name (id-src method-name)) ,@args) (build-src src))) + (let ((call-syn + (create-syntax #f `(,(translate-id m-name (id-src method-name)) ,@translated-args) (build-src src)))) + (if (dynamic-val? rtype) + (make-syntax #f (convert-assert-value call-syn (dynamic-val-type rtype)) (build-src src)) + call-syn))) (else - (create-syntax #f `(send this ,(translate-id m-name (id-src method-name)) ,@args) (build-src src))))) + (let ((call-syn + (create-syntax #f `(send this ,(translate-id m-name (id-src method-name)) ,@translated-args) + (build-src src)))) + (if (dynamic-val? rtype) + (make-syntax #f (convert-assert-value call-syn (dynamic-val-type rtype)) (build-src src)) + call-syn))))) (else - (let ((name (translate-id m-name (id-src method-name)))) - (cond - ((and cant-be-null? (not static?)) - (create-syntax #f `(send ,expression ,name ,@args) (build-src src))) - (static? (create-syntax #f `(,name ,@args) (build-src src))) - (else - (create-syntax #f - `(let ((,unique-name ,expression)) - (if (null? ,unique-name) - (javaRuntime:nullError 'method) - (send ,unique-name ,name ,@args))) - (build-src src))))))))) - + (let* ((name (translate-id m-name (id-src method-name))) + (call + (cond + ((and cant-be-null? (not static?)) + (create-syntax #f `(send ,expression ,name ,@translated-args) (build-src src))) + (static? (create-syntax #f `(,name ,@translated-args) (build-src src))) + (else + (create-syntax #f + `(let ((,unique-name ,expression)) + (if (null? ,unique-name) + (javaRuntime:nullError 'method) + (send ,unique-name ,name ,@translated-args))) + (build-src src)))))) + (if (or (method-contract? method-record) + (dynamic-val? rtype)) + (make-syntax #f (convert-assert-value call + (if (method-contract? method-record) + (method-contract-return method-record) + (dynamic-val-type rtype))) (build-src src)) + call)))))) (else (error 'translate-call (format "Translate call given ~s as method-name" method-name)))))) ;Add more checks perhaps to see in other cases if it can be null @@ -2114,15 +2510,25 @@ (build-src src)))) ;converted - ;translate-cast: type-spec syntax src - (define (translate-cast type expr src) - (if (symbol? (type-spec-name type)) - (make-syntax #f `(javaRuntime:cast-primitive ,expr (quote ,(type-spec-name type)) ,(type-spec-dim type)) - (build-src src)) - (make-syntax #f `(javaRuntime:cast-reference ,expr ,(get-class-name type) - ,(type-spec-dim type) - (quote ,(get-class-name type))) - (build-src src)))) + ;translate-cast: type-spec syntax type src + (define (translate-cast type expr expr-type src) + (cond + ((eq? 'dynamic (type-spec-name type)) + (make-syntax #f (guard-convert-value expr expr-type) (build-src src))) + ((dynamic-val? expr-type) + (make-syntax #f (convert-assert-value + (create-syntax #f `(c:contract ,(type->contract expr-type #t) ,expr + (quote ,(string->symbol (class-name))) '|infered contract|) + (build-src src)) expr-type) + (build-src src))) + ((symbol? (type-spec-name type)) + (make-syntax #f `(javaRuntime:cast-primitive ,expr (quote ,(type-spec-name type)) ,(type-spec-dim type)) + (build-src src))) + (else + (make-syntax #f `(javaRuntime:cast-reference ,expr ,(get-class-name type) + ,(type-spec-dim type) + (quote ,(get-class-name type))) + (build-src src))))) ;translate-instanceof: syntax type-spec src -> syntax (define (translate-instanceof expr type src) @@ -2137,19 +2543,24 @@ (make-syntax #f `(is-a? ,expr ObjectI) (build-src src)) (make-syntax #f `(is-a? ,expr ,syntax-type) (build-src src)))))) - ;translate-assignment: (U access array-access) symbol syntax expression ?? src src -> syntax + ;translate-assignment: (U access array-access) symbol syntax expression type src src -> syntax (define (translate-assignment name op expr assign-to type key src) - (let ((expression (lambda (name) (case op - ((=) expr) - ((*=) `(* ,name ,expr)) - ((/=) `(/ ,name ,expr)) - ((+=) `(+ ,name ,expr)) - ((-=) `(- ,name ,expr)) - ((>>=) `(javaRuntime:shift '>> ,name ,expr)) - ((<<=) `(javaRuntime:shift '<< ,name ,expr)) - ((>>>=) `(javaRuntime:shift '>>> ,name ,expr)) - ((%= &= ^= or=) - (error 'translate-assignment "Only supports =, +=, -=, *=, & /= >>= <<= >>>= at this time")))))) + (let ((expression (lambda (name) + (let ((expanded-expr + (case op + ((=) expr) + ((*=) `(* ,name ,expr)) + ((/=) `(/ ,name ,expr)) + ((+=) `(+ ,name ,expr)) + ((-=) `(- ,name ,expr)) + ((>>=) `(javaRuntime:shift '>> ,name ,expr)) + ((<<=) `(javaRuntime:shift '<< ,name ,expr)) + ((>>>=) `(javaRuntime:shift '>>> ,name ,expr)) + ((%= &= ^= or=) + (error 'translate-assignment "Only supports =, +=, -=, *=, & /= >>= <<= >>>= at this time"))))) + (if (or (eq? type 'dynamic) (dynamic-val? type)) + (guard-convert-value (make-syntax #f expanded-expr (build-src src)) (expr-types assign-to)) + expanded-expr))))) (cond ((array-access? name) (translate-array-mutation name expression assign-to src)) diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index e8c68ae950..4488b62999 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -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) diff --git a/collects/profj/types.ss b/collects/profj/types.ss index 94cab848c7..b1c9eb9b24 100644 --- a/collects/profj/types.ss +++ b/collects/profj/types.ss @@ -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)