From 3c6a8d5046bac20b5f2a79a597a1aa9e4e141fab Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Mon, 2 Jan 2006 22:38:09 +0000 Subject: [PATCH] Assorted inner class bug fixes svn: r1745 --- collects/profj/build-info.ss | 33 ++++++---- collects/profj/check.ss | 97 ++++++++++++++++++++---------- collects/profj/compile.ss | 10 +-- collects/profj/to-scheme.ss | 6 +- collects/profj/types.ss | 24 +++++--- collects/tests/profj/full-tests.ss | 7 ++- 6 files changed, 118 insertions(+), 59 deletions(-) diff --git a/collects/profj/build-info.ss b/collects/profj/build-info.ss index 5e1199c0a5..cc88713f21 100644 --- a/collects/profj/build-info.ss +++ b/collects/profj/build-info.ss @@ -9,6 +9,8 @@ ;------------------------------------------------------------------------------- ;General helper functions for building information + (define class-name (make-parameter #f)) + ;; name->list: name -> (list string) (define (name->list n) (cons (id-string (name-id n)) (map id-string (name-path n)))) @@ -93,6 +95,8 @@ ((not (null? (package-imports prog))) (import-file (car (package-imports prog))))))) (set-package-defs! prog defs) + + ;(printf "~a~n" lang) ;Add lang to local environment (for-each (lambda (class) (send type-recs add-to-env class lang-pack current-loc)) lang) @@ -177,11 +181,14 @@ ;build-inner-info: def (U void string) (list string) symbol type-records loc bool -> class-record (define (build-inner-info def unique-name pname level type-recs current-loc look-in-table?) ;(add-def-info def pname type-recs current-loc look-in-table? level) + (class-name unique-name) (let ((record (process-class/iface def pname type-recs #f #f level))) - (when (string? unique-name) (set-class-record-name! record (list unique-name))) + (when (string? unique-name) (set-class-record-name! record (cons unique-name pname))) (send type-recs add-to-records - (if (eq? (def-kind def) 'statement) (list unique-name) (id-string (def-name def))) + (cons (if (eq? (def-kind def) 'statement) unique-name (id-string (def-name def))) pname) record) + (send type-recs add-to-env unique-name pname current-loc) + (class-name #f) record)) ;add-to-queue: (list definition) -> void @@ -227,7 +234,8 @@ (file-path (build-path dir (string-append class suffix)))) (cond ((is-import-restricted? class path level) (used-restricted-import class path caller-src)) - ((send type-recs get-class-record class-name #f (lambda () #f)) void) + ((send type-recs get-class-record class-name #f (lambda () #f)) + void ) ((and (file-exists? type-path) (or (core? class-name) (older-than? file-path type-path)) (read-record type-path)) => @@ -402,6 +410,7 @@ (filter (lambda (f) (equal? (filename-extension f) #"jinfo")) (directory-list (build-path (dir-path-path dir) "compiled")))))) (array (datum->syntax-object #f `(lib "array.ss" "profj" "libs" "java" "lang") #f))) + ;(printf "class-list ~a~n" class-list) (send type-recs add-package-contents lang class-list) (for-each (lambda (c) (import-class c lang dir #f type-recs 'full #f #f)) class-list) (send type-recs add-require-syntax (list 'array) (list array array)) @@ -563,7 +572,7 @@ members level type-recs) - + (let ((record (make-class-record cname @@ -590,9 +599,9 @@ (when put-in-table? (send type-recs add-class-record record)) (for-each (lambda (member) - (when (def? member) - (process-class/iface member package-name type-recs #f put-in-table? level))) - members) + (when (def? member) + (process-class/iface member package-name type-recs #f put-in-table? level))) + members) record)))))) (cond @@ -628,7 +637,8 @@ (not (null? (method-record-throws super-ctor)))) (default-ctor-error 'throws name (method-record-class super-ctor) (id-src name) level)) (else - (let* ((rec (make-method-record (id-string name) `(public) 'ctor null null #f (list (id-string name)))) + (let* ((rec (make-method-record (id-string name) `(public) 'ctor null null #f + (if (class-name) (list (class-name)) (list (id-string name))))) (method (make-method (list (make-modifier 'public #f)) (make-type-spec 'ctor 0 #f) null @@ -1141,7 +1151,7 @@ (make-field-record (id-string (field-name field)) (check-field-modifiers level (field-modifiers field)) (var-init? field) - cname + (if (class-name) (cons (class-name) (cdr cname)) cname) (field-type field))) ;; process-method: method (list method-record) (list string) type-records symbol -> method-record @@ -1176,7 +1186,7 @@ (when (eq? ret 'ctor) (if (regexp-match "\\." (car cname)) (begin - (unless (equal? name (filename-extension (car cname))) + (unless (equal? name (bytes->string/locale (filename-extension (car cname)))) (not-ctor-error name (car cname) (id-src (method-name method)))) (set! name (car cname)) (set-id-string! (method-name method) (car cname))) @@ -1213,13 +1223,14 @@ parms throws over? - cname))) + (if (class-name) (cons (class-name) (cdr cname)) cname)))) (set-method-rec! method record) record))) ;process-inner def (list name) type-records symbol -> inner-record (define (process-inner def cname type-recs level) (make-inner-record (filename-extension (id-string (def-name def))) + (id-string (def-name def)) (map modifier-kind (header-modifiers (def-header def))) (class-def? def))) diff --git a/collects/profj/check.ss b/collects/profj/check.ss index aa4f656856..929c514c27 100644 --- a/collects/profj/check.ss +++ b/collects/profj/check.ss @@ -7,7 +7,7 @@ "restrictions.ss" "profj-pref.ss" "build-info.ss" - (lib "class.ss") (lib "list.ss") + (lib "class.ss") (lib "list.ss") (lib "file.ss") (prefix srfi: (lib "1.ss" "srfi")) (lib "string.ss")) (provide check-defs check-interactions-types) @@ -32,8 +32,8 @@ ;; var-type => (make-var-type string type properties) (define-struct var-type (var type properties) (make-inspector)) - ;;inner-rec ==> (make-inner-rec string (U symbol void) class-rec) - (define-struct inner-rec (name unique-name record)) + ;;inner-rec ==> (make-inner-rec string (U symbol void) (list string) class-rec) + (define-struct inner-rec (name unique-name package record)) ;;Environment variable properties ;;(make-properties bool bool bool bool bool bool) @@ -211,12 +211,12 @@ (member label (environment-labels env))) ;;add-local-inner-to-env: string symbol class-rec env -> env - (define (add-local-inner-to-env name unique-name rec env) + (define (add-local-inner-to-env name unique-name package rec env) (make-environment (environment-types env) (environment-set-vars env) (environment-exns env) (environment-labels env) - (cons (make-inner-rec name unique-name rec) (environment-local-inners env)))) + (cons (make-inner-rec name unique-name package rec) (environment-local-inners env)))) ;;lookup-local-inner: string env -> (U inner-rec #f) (define (lookup-local-inner name env) @@ -305,11 +305,17 @@ ;check-class: class-def (list string) symbol type-records env -> void (define (check-class class package-name level type-recs class-env) - (let ((old-reqs (send type-recs get-class-reqs)) + (let* ((old-reqs (send type-recs get-class-reqs)) (old-update (update-class-with-inner)) - (name (id-string (def-name class)))) + (name (id-string (def-name class))) + (rec (send type-recs get-class-record (cons name package-name)))) (update-class-with-inner (lambda (inner) - (set-def-members! class (cons inner (def-members class))))) + (let ((name (id-string (def-name inner)))) + (set-def-members! class (cons inner (def-members class))) + (set-class-record-inners! rec + (cons (make-inner-record (filename-extension name) name + (map modifier-kind (header-modifiers (def-header inner))) + (class-def? inner)) (class-record-inners rec)))))) (send type-recs set-class-reqs (def-uses class)) (send type-recs add-req (make-req "String" '("java" "lang"))) @@ -334,8 +340,17 @@ ;check-interface: interface-def (list string) symbol type-recs -> void (define (check-interface iface p-name level type-recs) (let ((old-reqs (send type-recs get-class-reqs)) - (old-update (update-class-with-inner))) + (old-update (update-class-with-inner)) + (rec (send type-recs get-class-record (cons (id-string (def-name iface)) p-name)))) (update-class-with-inner (lambda (inner) + (let ((name (id-string (def-name inner)))) + (set-def-members! iface (cons inner (def-members iface))) + (set-class-record-inners! rec + (cons (make-inner-record (filename-extension name) name + (map modifier-kind (header-modifiers (def-header inner))) + (class-def? inner)) (class-record-inners rec)))))) + + #;(update-class-with-inner (lambda (inner) (set-def-members! iface (cons inner (def-members iface))))) (send type-recs set-class-reqs (def-uses iface)) @@ -352,17 +367,19 @@ (define (check-inner-def def level type-recs c-class env) (let* ((statement-inner? (eq? (def-kind def) 'statement)) (local-inner? (or (eq? (def-kind def) 'anon) statement-inner?)) - (p-name (if local-inner? null (cdr c-class))) + (p-name (cdr c-class)) (inner-env (update-env-for-inner env)) (this-type (var-type-type (lookup-var-in-env "this" env))) (unique-name (when statement-inner? (symbol->string (gensym (string-append (id-string (def-name def)) "-"))))) (inner-rec (when local-inner? - (build-inner-info def unique-name p-name level type-recs (def-file def) #t)))) - (when local-inner? (add-init-args def env)) - (when statement-inner? - (set-id-string! (header-id (def-header def)) unique-name)) + (add-init-args def env) + (begin0 + (build-inner-info def unique-name p-name level type-recs (def-file def) #t) + (when statement-inner? + (set-id-string! (header-id (def-header def)) unique-name)) + ((update-class-with-inner) def))))) (if (interface-def? def) (check-interface def p-name level type-recs) (check-class def p-name level type-recs (add-var-to-env "encl-this-1" this-type final-parm inner-env))) @@ -370,7 +387,7 @@ (for-each (lambda (use) (add-required c-class (req-class use) (req-path use) type-recs)) (def-uses def)) - (list unique-name inner-rec))) + (list unique-name p-name inner-rec))) ;add-init-args: def env -> void ;Updates the inner class with the names of the final variables visible within the class @@ -1198,12 +1215,12 @@ ;check-local-inner: def env symbol (list string) type-records -> type/env (define (check-local-inner def env level c-class type-recs) - ((update-class-with-inner) def) + ;((update-class-with-inner) def) (let ((original-name (id-string (def-name def))) (rec/new-name (check-inner-def def level type-recs c-class env))) (make-type/env (make-ref-type original-name null) - (add-local-inner-to-env original-name (car rec/new-name) (cadr rec/new-name) env)))) + (add-local-inner-to-env original-name (car rec/new-name) (cadr rec/new-name) (caddr rec/new-name) env)))) ;check-break: (U id #f) src bool bool symbol env-> type/env (define (check-break label src in-loop? in-switch? level env) @@ -1587,6 +1604,13 @@ ((or (eq? 'long t1) (eq? 'long t2)) 'long) (else 'int))) + (define (get-inners class type-recs) + (let ((rec (get-record (send type-recs get-class-record class) type-recs))) + (class-record-inners rec))) + + (define (inner-member class inners) + (member (car class) (map inner-record-full-name inners))) + ;;check-access: expression (expr env -> type/env) env symbol type-records (list string) bool bool bool -> type/env (define (check-access exp check-e env level type-recs c-class interact? static? assign-left?) (let ((acc (access-name exp))) @@ -1663,10 +1687,12 @@ (when (and (eq? level 'beginner) (eq? (car c-class) (car field-class)) (or (not obj) (and (special-name? obj) (not (expr-src obj))))) - (beginner-field-access-error (string->symbol fname) src)) - - (when (and private? (not (equal? c-class field-class))) - (illegal-field-access 'private (string->symbol fname) level (car field-class) src)) + (beginner-field-access-error (string->symbol fname) src)) + + (when private? + (unless (or (equal? c-class field-class) + (inner-member c-class (get-inners field-class type-recs))) + (illegal-field-access 'private (string->symbol fname) level (car field-class) src))) (when (and protected? (not (or (equal? c-class field-class) @@ -1674,7 +1700,7 @@ (package-members? c-class field-class type-recs)))) (illegal-field-access 'protected (string->symbol fname) level (car field-class) src)) - (when (and (not private?) (not protected?) + (when (and (not private?) (not protected?) (not public?) (not (package-members? c-class field-class type-recs))) (illegal-field-access 'package (string->symbol fname) level (car field-class) src)) @@ -2173,6 +2199,12 @@ (method-arg-error 'type (list arg) (cons atype atypes) name exp-type src))) args atypes))))) + ;find-class: string rec-type env type-records -> (values boolean type record) + #;(define (find-class name this env type-recs) + (let ((local-inner? (lookup-local-inner name env)) + ...))) + + ;; 15.9 ;;check-class-alloc: expr (U name identifier) (list exp) (exp env -> type/env) src type-records ; (list string) env symbol bool-> type/env @@ -2185,14 +2217,15 @@ (make-name (def-name name/def) null (id-src (def-name name/def)))) ((id? name/def) (make-name name/def null (id-src name/def))) (else name/def))) - (inner-lookup? (lookup-local-inner (id-string (name-id name)) env)) + (inner-lookup? (lookup-local-inner (id-string (name-id name)) env)) (type (if inner-lookup? - (make-ref-type (inner-rec-unique-name inner-lookup?) null) + (make-ref-type (inner-rec-unique-name inner-lookup?) (inner-rec-package inner-lookup?)) (name->type name c-class (name-src name) level type-recs))) (class-record (if inner-lookup? (inner-rec-record inner-lookup?) (get-record (send type-recs get-class-record type c-class) type-recs))) + (p (when (null? class-record) (printf "~a~n" type))) (methods (get-method-records (id-string (name-id name)) class-record type-recs))) (unless (or (equal? (car (class-record-name class-record)) (ref-type-class/iface type))) (set-id-string! (name-id name) (car (class-record-name class-record))) @@ -2307,9 +2340,9 @@ (if inner-lookup? (if (> (type-spec-dim elt-type) 0) (make-array-type - (make-ref-type (inner-rec-unique-name inner-lookup?) null) + (make-ref-type (inner-rec-unique-name inner-lookup?) (inner-rec-package inner-lookup?)) (type-spec-dim elt-type)) - (make-ref-type (inner-rec-unique-name inner-lookup?) null)) + (make-ref-type (inner-rec-unique-name inner-lookup?) (inner-rec-package inner-lookup?))) (type-spec-to-type elt-type c-class level type-recs)))) (when (and (ref-type? type) (not inner-lookup?)) (add-required c-class (ref-type-class/iface type) (ref-type-path type) type-recs)) @@ -2339,9 +2372,9 @@ (if inner-lookup? (if (> (type-spec-dim elt-type) 0) (make-array-type - (make-ref-type (inner-rec-unique-name inner-lookup?) null) + (make-ref-type (inner-rec-unique-name inner-lookup?) (inner-rec-package inner-lookup?)) (type-spec-dim elt-type)) - (make-ref-type (inner-rec-unique-name inner-lookup?) null)) + (make-ref-type (inner-rec-unique-name inner-lookup?) (inner-rec-package inner-lookup?))) (type-spec-to-type elt-type c-class level type-recs))) (a-type/env (check-array-init (array-init-vals init) check-sub-exp env type type-recs)) (a-type (type/env-t a-type/env))) @@ -2455,9 +2488,9 @@ (if inner-lookup? (if (> (type-spec-dim cast-type) 0) (make-array-type - (make-ref-type (inner-rec-unique-name inner-lookup?) null) + (make-ref-type (inner-rec-unique-name inner-lookup?) (inner-rec-package inner-lookup?)) (type-spec-dim cast-type)) - (make-ref-type (inner-rec-unique-name inner-lookup?) null)) + (make-ref-type (inner-rec-unique-name inner-lookup?) (inner-rec-package inner-lookup?))) (type-spec-to-type cast-type current-class level type-recs)))) (when (and (reference-type? type) (not inner-lookup?)) (unless (equal? (car current-class) (ref-type-class/iface type)) @@ -2496,9 +2529,9 @@ (if inner-lookup? (if (> (type-spec-dim inst-type) 0) (make-array-type - (make-ref-type (inner-rec-unique-name inner-lookup?) null) + (make-ref-type (inner-rec-unique-name inner-lookup?) (inner-rec-package inner-lookup?)) (type-spec-dim inst-type)) - (make-ref-type (inner-rec-unique-name inner-lookup?) null)) + (make-ref-type (inner-rec-unique-name inner-lookup?) (inner-rec-package inner-lookup?))) (type-spec-to-type inst-type current-class level type-recs)))) (when (and (ref-type? type) (not inner-lookup?)) (unless (equal? (car current-class) (ref-type-class/iface type)) diff --git a/collects/profj/compile.ss b/collects/profj/compile.ss index 13337190ca..fb6ee83546 100644 --- a/collects/profj/compile.ss +++ b/collects/profj/compile.ss @@ -41,10 +41,11 @@ (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 #f #;(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))) + (> (file-or-directory-modify-seconds compiled-path) + (file-or-directory-modify-seconds (build-path name)))) + (and (file-exists? type-path) + (read-record type-path) + (file-exists? compiled-path))) (call-with-input-file name (lambda (port) (compile-to-file port name level))))))) ((eq? dest 'file) (compile-to-file port loc level)) @@ -78,6 +79,7 @@ (let ((names (compilation-unit-contains dependents)) (syntaxes (compilation-unit-code dependents)) (locations (compilation-unit-locations dependents))) + ;(printf "names ~a~n" names) (unless (= (length names) (length syntaxes)) ;(printf "Writing a composite file out~n") ;(printf "~a~n~n" (syntax-object->datum (car syntaxes))) diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index f89d8a0052..3c8905a5d0 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -475,8 +475,10 @@ ;Let's grab onto the enclosing class-specific info incase depth > 0 (let ((old-class-name (class-name)) (old-parent-name (parent-name)) + (old-inner-class (inner-class)) (old-override-table (class-override-table))) (unless (> depth 0) (loc (def-file class))) + (when (> depth 0) (inner-class #t)) (let*-values (((header) (def-header class)) ((kind) (def-kind class)) @@ -713,6 +715,7 @@ (when (> depth 0) (class-name old-class-name) (parent-name old-parent-name) + (inner-class old-inner-class) (class-override-table old-override-table)))))))) ;generate-contract-defs: string -> (list sexp) @@ -1303,6 +1306,7 @@ (create-static-methods (cdr names) (cdr methods) type-recs))))) (define static-method (make-parameter #f)) + (define inner-class (make-parameter #f)) ;translate-method-body: string (list field) statement (list symbol) type-spec bool bool bool int type-record -> syntax (define (translate-method-body method-name parms block modifiers rtype all-tail? ctor? inner? depth type-recs) @@ -2184,7 +2188,7 @@ (javaRuntime:nullError 'field) (send ,expr ,(translate-id field-string field-src))) (build-src src)))) - ((and (eq? (var-access-access access) 'private) (static-method)) + ((and (eq? (var-access-access access) 'private) (or (static-method) (inner-class))) (let* ((id (create-get-name field-string (var-access-class access))) (getter `(send ,expr ,id ,expr)) (get-syntax (if cant-be-null? diff --git a/collects/profj/types.ss b/collects/profj/types.ss index 2105c7a9a9..b6a11c93f7 100644 --- a/collects/profj/types.ss +++ b/collects/profj/types.ss @@ -308,8 +308,8 @@ ;; (make-method-record string (list symbol) type (list type) (list type) (U bool method-record) string) (define-struct method-record (name modifiers rtype atypes throws override class) (make-inspector)) - ;;(make-inner-record string (list symbol) bool) - (define-struct inner-record (name modifiers class?) (make-inspector)) + ;;(make-inner-record string string (list symbol) bool) + (define-struct inner-record (name full-name modifiers class?) (make-inspector)) ;;(make-scheme-record string (list string) path (list dynamic-val)) (define-struct scheme-record (name path dir provides)) @@ -380,11 +380,12 @@ ((inner-path) (if (null? key-path) (lookup-path key-inner (lambda () null)) key-path)) ((new-search) (lambda () - (if (null? path) - (fail) - (let ((back-path (reverse path))) - (search-for-record key (car back-path) - (reverse (cdr back-path)) (lambda () #f) fail)))))) + (cond + ((null? path) (fail)) + (else + (let ((back-path (reverse path))) + (search-for-record key (car back-path) + (reverse (cdr back-path)) (lambda () #f) fail))))))) ;(printf "get-class-record: ~a~n" ctype) ;(hash-table-for-each records (lambda (k v) (printf "~a -> ~a~n" k v))) (cond @@ -710,7 +711,8 @@ (string-append remainder "-" (string (char-downcase char)))))))) (else name))) - + (define (inner-rec-member name inners) + (member name (map inner-record-name inners))) ; ; ; ;; @@ -765,7 +767,8 @@ (lambda (input) (make-inner-record (car input) (cadr input) - (symbol=? 'class (caddr input))))) + (caddr input) + (symbol=? 'class (cadddr input))))) (parse-type (lambda (input) (cond @@ -774,7 +777,7 @@ (make-array-type (parse-type (cadr input)) (car input))) (else (make-ref-type (car input) (cdr input))))))) - (parse-class/iface (call-with-input-file filename read)))) + (parse-class/iface (call-with-input-file filename read)))) ;; write-record: class-record port-> (define (write-record rec port) @@ -812,6 +815,7 @@ (inner->list (lambda (i) (list (inner-record-name i) + (inner-record-full-name i) (inner-record-modifiers i) (if (inner-record-class? i) 'class 'interface)))) (type->list diff --git a/collects/tests/profj/full-tests.ss b/collects/tests/profj/full-tests.ss index 59245a5171..736735d6db 100644 --- a/collects/tests/profj/full-tests.ss +++ b/collects/tests/profj/full-tests.ss @@ -3,6 +3,11 @@ (lib "parameters.ss" "profj")) (prepare-for-tests "Full") + + (execute-test + "package a; class a { int x; + Object get() { class b { int y() { return a.this.x; } } return new b(); }}" + 'full #f "Statement inner class accessing package field") (parameterize ((dynamic? #t)) (interact-test "class A { }" @@ -154,7 +159,7 @@ B() { } A m = A.this; } - B b = new B(); + //B b = new B(); }" 'full (list "A a = new A();" "A.B b = a.new B();" "a.new B().m")