Assorted inner class bug fixes

svn: r1745

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)
+                                 (when (def? member)
-			       (process-class/iface member package-name type-recs #f put-in-table? level)))
+                                   (process-class/iface member package-name type-recs #f put-in-table? level)))
-			   members)
+                               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)))
 

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)
+  ;;inner-rec ==> (make-inner-rec string (U symbol void) (list string) class-rec)
-  (define-struct inner-rec (name unique-name record))
+  (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))))
+              (add-init-args def env)
-      (when local-inner? (add-init-args def env))
+              (begin0
-      (when statement-inner?
+                (build-inner-info def unique-name p-name level type-recs (def-file def) #t)
-        (set-id-string! (header-id (def-header def)) unique-name))
+                (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))
+                  (beginner-field-access-error (string->symbol fname) src))                    
-           
+                
-                (when (and private? (not (equal? c-class field-class)))
+                (when private?
-                  (illegal-field-access 'private (string->symbol fname) level (car field-class) src))
+                  (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))

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 compiled-path)
-                                 (file-or-directory-modify-seconds (build-path name))))
+                                       (file-or-directory-modify-seconds (build-path name))))
-                         (and (file-exists? type-path)
+                               (and (file-exists? type-path)
-                              (read-record 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)))

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?

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)
+  ;;(make-inner-record string string (list symbol) bool)
-  (define-struct inner-record (name modifiers class?) (make-inspector))
+  (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) 
+                           (cond
-                               (fail)
+                             ((null? path) (fail))
-                               (let ((back-path (reverse path)))
+                             (else
-                                 (search-for-record key (car back-path) 
+                              (let ((back-path (reverse path)))
-                                                    (reverse (cdr back-path)) (lambda () #f) fail))))))
+                                (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

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