suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Corrected bug in detecting inner class allocation

Browse Source 
svn: r6412
This commit is contained in:
Kathy Gray 2007-05-30 17:31:39 +00:00
parent c1b3b4ab65
commit 9123e74cfe
3 changed files with 6 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/profj/build-info.ss
View File

@ -1504,7 +1504,7 @@
;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)))
(make-inner-record (bytes->string/locale (filename-extension (id-string (def-name def))))
(id-string (def-name def))
(map modifier-kind (header-modifiers (def-header def)))
(class-def? def)))

7
collects/profj/check.ss
View File

@ -2294,8 +2294,9 @@
(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) (print-struct #t) (printf "~a~n" type)))
(methods (get-method-records (id-string (name-id name)) class-record type-recs)))
(methods (get-method-records #;(id-string (name-id name))
(car (class-record-name class-record))
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)))
(set-class-alloc-class-inner?! exp #t))
@ -2304,7 +2305,7 @@
(set-class-alloc-local-inner?! exp #t))
(unless (or (equal? (ref-type-class/iface type) (car c-class))
(equal? (car (class-record-name class-record))
(format "~a.~a" (car c-class) (ref-type-class/iface type)))
(format "~a.~a" (car c-class) (id-string (name-id name))))
(class-alloc-class-inner? exp)
(class-alloc-local-inner? exp)
(inner-alloc? exp))

1
collects/profj/types.ss
View File

@ -396,6 +396,7 @@
;; (U class-record scheme-record procedure)
(define/public get-class-record
(opt-lambda (ctype [container #f] [fail (lambda () null)])
;(printf "get-class-record: ctype->~a container->~a ~n" ctype container)
(let*-values (((key key-path) (normalize-key ctype))
((key-inner) (when (cons? container) (string-append (car container) "." key)))
((outer-record) (when (cons? container) (get-class-record container)))