Assorted inner class bug fixes
svn: r1745
This commit is contained in:
Kathy Gray
parent
3936408ea2
commit
3c6a8d5046
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user