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

Bug fixes for inheriting from a compiled class (loss of modifiers), inner class lookup in composite files, and

Browse Source 
code to recompile java files when the version number changes.

svn: r1856
This commit is contained in:
Kathy Gray 2006-01-18 05:18:15 +00:00
parent 3bdd7c603d
commit 455a1c65a7
5 changed files with 65 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -52,10 +52,6 @@
(if (or (not local?) profj-lib? htdch-lib? scheme-lib? (to-file)) (if (or (not local?) profj-lib? htdch-lib? scheme-lib? (to-file))
(string-append n ".ss") (string-append n ".ss")
(string->symbol n)))))) (string->symbol n))))))
#;(when (or htdch-lib? (equal? name "Image"))
(printf "build-require : class ~a path ~a ~a~n" name path (access (make-name))))
#;(printf "build-req of ~a profj-lib? ~a htdch-lib? ~a scheme-lib? ~a ~n"
(make-name) profj-lib? htdch-lib? scheme-lib?)
(if scheme? (if scheme?
(list (syn `(prefix ,(string->symbol (list (syn `(prefix ,(string->symbol
(apply string-append (apply string-append
@ -96,8 +92,6 @@
(import-file (car (package-imports prog))))))) (import-file (car (package-imports prog)))))))
(set-package-defs! prog defs) (set-package-defs! prog defs)
;(printf "~a~n" lang)
;Add lang to local environment ;Add lang to local environment
(for-each (lambda (class) (send type-recs add-to-env class lang-pack current-loc)) lang) (for-each (lambda (class) (send type-recs add-to-env class lang-pack current-loc)) lang)
(for-each (lambda (class) (send type-recs add-class-req (cons class lang-pack) #f current-loc)) lang) (for-each (lambda (class) (send type-recs add-class-req (cons class lang-pack) #f current-loc)) lang)
@ -187,6 +181,7 @@
(send type-recs add-to-records (send type-recs add-to-records
(cons (if (eq? (def-kind def) 'statement) unique-name (id-string (def-name def))) pname) (cons (if (eq? (def-kind def) 'statement) unique-name (id-string (def-name def))) pname)
record) record)
;(printf "~a~n" unique-name)
(send type-recs add-to-env unique-name pname current-loc) (send type-recs add-to-env unique-name pname current-loc)
(class-name #f) (class-name #f)
record)) record))
@ -506,12 +501,13 @@
(make-req (car name-list) (make-req (car name-list)
(send type-recs lookup-path (car name-list) (lambda () null))) (send type-recs lookup-path (car name-list) (lambda () null)))
(make-req (car name-list) (cdr name-list)))) (make-req (car name-list) (cdr name-list))))
(cons super-name (map name->list (header-implements info)))))) (cons super-name (map name->list (header-implements info)))))
(old-loc (send type-recs get-location)))
(set! reqs (set! reqs
(remove-dup-reqs (remove-dup-reqs
(append (get-method-reqs (class-record-methods super-record)) (append (get-method-reqs (class-record-methods super-record))
reqs))) reqs)))
(send type-recs set-location! (def-file class)) (send type-recs set-location! (def-file class))
(set-def-uses! class reqs) (set-def-uses! class reqs)
@ -572,7 +568,7 @@
members members
level level
type-recs) type-recs)
(let ((record (let ((record
(make-class-record (make-class-record
cname cname
@ -602,6 +598,7 @@
(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)
(send type-recs set-location! old-loc)
record)))))) record))))))
(cond (cond
@ -717,7 +714,8 @@
(object-methods (class-record-methods (send type-recs get-class-record object-type))) (object-methods (class-record-methods (send type-recs get-class-record object-type)))
(members (def-members iface)) (members (def-members iface))
(reqs (map (lambda (name-list) (make-req (car name-list) (cdr name-list))) (reqs (map (lambda (name-list) (make-req (car name-list) (cdr name-list)))
super-names))) super-names))
(old-loc (send type-recs get-location)))
(send type-recs set-location! (def-file iface)) (send type-recs set-location! (def-file iface))
(set-def-uses! iface reqs) (set-def-uses! iface reqs)
@ -754,6 +752,7 @@
(map class-record-parents super-records))) (map class-record-parents super-records)))
null))) null)))
(send type-recs add-class-record record) (send type-recs add-class-record record)
(send type-recs set-location! old-loc)
record)))))) record))))))
(if look-in-table? (if look-in-table?
(get-record (send type-recs get-class-record iname #f build-record) type-recs) (get-record (send type-recs get-class-record iname #f build-record) type-recs)
@ -1623,7 +1622,7 @@
(if (eq? level 'full) (if (eq? level 'full)
(format (format
"Method ~a in ~a attempts to override final method from ~a, final methods may not be overridden" "Method ~a in ~a attempts to override final method from ~a, final methods may not be overridden"
m-name (car class) parent) m-name (car class) (if (list? parent) (car parent) parent))
(format "Method ~a from ~a cannot be overridden in ~a" m-name parent (car class)))) (format "Method ~a from ~a cannot be overridden in ~a" m-name parent (car class))))
((static) ((static)
(format "Method ~a in ~a attempts to override static method from ~a, which is not allowed" (format "Method ~a in ~a attempts to override static method from ~a, which is not allowed"

2
collects/profj/check.ss
View File

@ -2225,7 +2225,7 @@
(if inner-lookup? (if inner-lookup?
(inner-rec-record inner-lookup?) (inner-rec-record inner-lookup?)
(get-record (send type-recs get-class-record type c-class) type-recs))) (get-record (send type-recs get-class-record type c-class) type-recs)))
(p (when (null? class-record) (printf "~a~n" type))) ;(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)) class-record type-recs)))
(unless (or (equal? (car (class-record-name class-record)) (ref-type-class/iface type))) (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-id-string! (name-id name) (car (class-record-name class-record)))

28
collects/profj/compile.ss
View File

@ -40,12 +40,13 @@
(let-values (((path-base file dir?) (split-path (path->complete-path (build-path name))))) (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"))) (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")))) (type-path (build-path path-base "compiled" (path-replace-suffix file ".jinfo"))))
(unless #f #;(and (and (file-exists? compiled-path) (unless
(> (file-or-directory-modify-seconds compiled-path) (and (file-exists? compiled-path)
(file-or-directory-modify-seconds (build-path name)))) (file-exists? type-path)
(and (file-exists? type-path) (equal? (version) (call-with-input-file compiled-path get-version))
(read-record type-path) (read-record type-path)
(file-exists? compiled-path))) (> (file-or-directory-modify-seconds compiled-path)
(file-or-directory-modify-seconds (build-path name))))
(call-with-input-file name (lambda (port) (compile-to-file port name level))))))) (call-with-input-file name (lambda (port) (compile-to-file port name level)))))))
((eq? dest 'file) ((eq? dest 'file)
(compile-to-file port loc level)) (compile-to-file port loc level))
@ -79,7 +80,9 @@
(let ((names (compilation-unit-contains dependents)) (let ((names (compilation-unit-contains dependents))
(syntaxes (compilation-unit-code dependents)) (syntaxes (compilation-unit-code dependents))
(locations (compilation-unit-locations dependents))) (locations (compilation-unit-locations dependents)))
;(print-struct #t)
;(printf "names ~a~n" names) ;(printf "names ~a~n" names)
;(printf "depends ~a~n~n" (compilation-unit-depends dependents))
(unless (= (length names) (length syntaxes)) (unless (= (length names) (length syntaxes))
;(printf "Writing a composite file out~n") ;(printf "Writing a composite file out~n")
;(printf "~a~n~n" (syntax-object->datum (car syntaxes))) ;(printf "~a~n~n" (syntax-object->datum (car syntaxes)))
@ -308,5 +311,18 @@
(main (list (contains-main? (def-members (car main-class))) (main (list (contains-main? (def-members (car main-class)))
(id-string (header-id (def-header (car main-class))))))))) (id-string (header-id (def-header (car main-class)))))))))
;Extracts the version from a .zo file. Will probably blow up on anything else.
;get-version port -> string
(define (get-version port)
(let get-to-count ((n 0))
(unless (= n 2)
(read-bytes 1 port)
(get-to-count (add1 n))))
(let ((count (bytes-ref (read-bytes 1 port) 0)))
(list->string (let loop ((c count))
(if (= c 0)
null
(cons (read-char port)
(loop (sub1 c))))))))
) )

22
collects/profj/to-scheme.ss
View File

@ -477,7 +477,8 @@
(old-parent-name (parent-name)) (old-parent-name (parent-name))
(old-inner-class (inner-class)) (old-inner-class (inner-class))
(old-override-table (class-override-table))) (old-override-table (class-override-table)))
(unless (> depth 0) (loc (def-file class))) (unless (> depth 0)
(loc (def-file class)) (send type-recs set-location! (loc)))
(when (> depth 0) (inner-class #t)) (when (> depth 0) (inner-class #t))
(let*-values (((header) (def-header class)) (let*-values (((header) (def-header class))
@ -525,12 +526,15 @@
(accesses-protected methods)) (accesses-protected methods))
overridden-methods)) overridden-methods))
#;(dynamic-method-defs (generate-dyn-method-defs names-for-dynamic)) #;(dynamic-method-defs (generate-dyn-method-defs names-for-dynamic))
;(p~ (printf "about to call class-record-methods : ~a ~a ~n" (class-name) (string? (class-name))))
(wrapper-classes (append (generate-wrappers (class-name) (wrapper-classes (append (generate-wrappers (class-name)
(parent-name) (parent-name)
(filter (filter
(lambda (m) (not (or (private? (method-record-modifiers m)) (lambda (m) (not (or (private? (method-record-modifiers m))
(static? (method-record-modifiers m))))) (static? (method-record-modifiers m)))))
(class-record-methods (send type-recs get-class-record (list (class-name))))) (begin0
(class-record-methods (send type-recs get-class-record (list (class-name))))
#;(printf "finished class-record-methods~n")))
(append (accesses-public fields) (accesses-package fields) (append (accesses-public fields) (accesses-package fields)
(accesses-protected fields))) (accesses-protected fields)))
(generate-contract-defs (class-name)))) (generate-contract-defs (class-name))))
@ -784,9 +788,10 @@
(let* ((field-name (id-string (field-name field))) (let* ((field-name (id-string (field-name field)))
(value `(,(create-get-name field-name) wrapped-obj))) (value `(,(create-get-name field-name) wrapped-obj)))
`(,(build-identifier (build-var-name field-name)) `(,(build-identifier (build-var-name field-name))
,(convert-value (if from-dynamic? (assert-value value (field-type field) #t 'field field-name) value) ,(convert-value
(field-type field) (if from-dynamic? (assert-value value (field-type field) #t 'field field-name) value)
from-dynamic?)))) (field-type field)
from-dynamic?))))
fields))) fields)))
;generate-wrapper-methods: (list method-record) boolean boolean -> (list sexp) ;generate-wrapper-methods: (list method-record) boolean boolean -> (list sexp)
@ -1389,9 +1394,9 @@
(let ((normal-get (class-field-accessor ,class ,quote-name)) (let ((normal-get (class-field-accessor ,class ,quote-name))
(dyn-get (class-field-accessor ,ca-class ,quote-name))) (dyn-get (class-field-accessor ,ca-class ,quote-name)))
(lambda (obj) (lambda (obj)
(if (is-a? obj ,class) (cond
(normal-get obj) ((is-a? obj ,class) (normal-get obj))
(dyn-get obj))))) ((is-a? obj ,ca-class) (dyn-get obj))))))
#f) #f)
(if (not final) (if (not final)
(list (list
@ -1836,6 +1841,7 @@
((double float) '(c:and/c number? (c:union inexact? integer?))) ((double float) '(c:and/c number? (c:union inexact? integer?)))
((boolean) 'boolean?) ((boolean) 'boolean?)
((char) 'char?) ((char) 'char?)
((null) 'null?)
((string String) ((string String)
(if from-dynamic? (if from-dynamic?
`string? `string?

34
collects/profj/types.ss
View File

@ -386,6 +386,7 @@
(let ((back-path (reverse path))) (let ((back-path (reverse path)))
(search-for-record key (car back-path) (search-for-record key (car back-path)
(reverse (cdr back-path)) (lambda () #f) fail))))))) (reverse (cdr back-path)) (lambda () #f) fail)))))))
;(printf "key ~a key-path ~a path ~a location ~a ~n" key key-path path location)
;(printf "get-class-record: ~a~n" ctype) ;(printf "get-class-record: ~a~n" ctype)
;(hash-table-for-each records (lambda (k v) (printf "~a -> ~a~n" k v))) ;(hash-table-for-each records (lambda (k v) (printf "~a -> ~a~n" k v)))
(cond (cond
@ -456,9 +457,10 @@
;lookup-path: string ( -> 'a) -> (U (list string) #f) ;lookup-path: string ( -> 'a) -> (U (list string) #f)
(define/public (lookup-path class fail) (define/public (lookup-path class fail)
;(printf "class ~a location ~a~n" class location)
;(printf "lookup ~a~n" class) ;(printf "lookup ~a~n" class)
;(hash-table-for-each (hash-table-get class-environment location) #;(hash-table-for-each (hash-table-get class-environment location)
; (lambda (k v) (printf "~a -> ~a~n" k v))) (lambda (k v) (printf "~a -> ~a~n" k v)))
(if location (if location
(hash-table-get (hash-table-get class-environment (hash-table-get (hash-table-get class-environment
location location
@ -666,18 +668,7 @@
#f))) #f)))
(with-handlers ((exn? (lambda (e) (fail)))) (with-handlers ((exn? (lambda (e) (fail))))
(expand mod-syntax)) (expand mod-syntax))
(set-scheme-record-provides! mod-ref (cons var (scheme-record-provides mod-ref)))) (set-scheme-record-provides! mod-ref (cons var (scheme-record-provides mod-ref)))))))
#;(let ((old-namespace (current-namespace)))
(current-namespace (make-namespace))
(namespace-require (generate-require-spec (java-name->scheme (scheme-record-name mod-ref))
(scheme-record-path mod-ref)))
(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+)) ;generate-require-spec: string (list string) -> (U string (list symbol string+))
(define (generate-require-spec name path) (define (generate-require-spec name path)
@ -697,7 +688,7 @@
((regexp-match "[a-zA-Z0-9]+Set$" name) ((regexp-match "[a-zA-Z0-9]+Set$" name)
(java-name->scheme (regexp-replace "Set$" name "!"))) (java-name->scheme (regexp-replace "Set$" name "!")))
((regexp-match "[a-zA-Z0-9]+Obj$" name) ((regexp-match "[a-zA-Z0-9]+Obj$" name)
(java-name->scheme (regexp-replace "Obj%" name "%"))) (java-name->scheme (regexp-replace "Obj$" name "%")))
((regexp-match "[a-z0-9]+->[A-Z]" name) => ((regexp-match "[a-z0-9]+->[A-Z]" name) =>
(lambda (substring) (lambda (substring)
(let ((char (car (regexp-match "[A-Z]" (car substring))))) (let ((char (car (regexp-match "[A-Z]" (car substring)))))
@ -791,7 +782,18 @@
(class-record-modifiers r) (class-record-modifiers r)
(class-record-object? r) (class-record-object? r)
(map field->list (class-record-fields r)) (map field->list (class-record-fields r))
(map method->list (filter (compose not method-record-override) (class-record-methods r))) (map method->list
(let* ((kept-overrides null)
(methods
(filter
(compose not
(lambda (meth-rec)
(and (method-record-override meth-rec)
(or (equal? (method-record-modifiers meth-rec)
(method-record-modifiers (method-record-override meth-rec)))
(not (set! kept-overrides (cons (method-record-override meth-rec) kept-overrides)))))))
(class-record-methods r))))
(filter (compose not (lambda (m) (memq m kept-overrides))) methods)))
(map inner->list (class-record-inners r)) (map inner->list (class-record-inners r))
(class-record-parents r) (class-record-parents r)
(class-record-ifaces r) (class-record-ifaces r)