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))
(string-append n ".ss")
(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?
(list (syn `(prefix ,(string->symbol
(apply string-append
@ -96,8 +92,6 @@
(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)
(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
(cons (if (eq? (def-kind def) 'statement) unique-name (id-string (def-name def))) pname)
record)
;(printf "~a~n" unique-name)
(send type-recs add-to-env unique-name pname current-loc)
(class-name #f)
record))
@ -506,12 +501,13 @@
(make-req (car name-list)
(send type-recs lookup-path (car name-list) (lambda () null)))
(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
(remove-dup-reqs
(append (get-method-reqs (class-record-methods super-record))
reqs)))
reqs)))
(send type-recs set-location! (def-file class))
(set-def-uses! class reqs)
@ -572,7 +568,7 @@
members
level
type-recs)
(let ((record
(make-class-record
cname
@ -602,6 +598,7 @@
(when (def? member)
(process-class/iface member package-name type-recs #f put-in-table? level)))
members)
(send type-recs set-location! old-loc)
record))))))
(cond
@ -717,7 +714,8 @@
(object-methods (class-record-methods (send type-recs get-class-record object-type)))
(members (def-members iface))
(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))
(set-def-uses! iface reqs)
@ -754,6 +752,7 @@
(map class-record-parents super-records)))
null)))
(send type-recs add-class-record record)
(send type-recs set-location! old-loc)
record))))))
(if look-in-table?
(get-record (send type-recs get-class-record iname #f build-record) type-recs)
@ -1623,7 +1622,7 @@
(if (eq? level 'full)
(format
"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))))
((static)
(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?
(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)))
;(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)))
(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)))

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 ((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-exists? compiled-path)))
(unless
(and (file-exists? compiled-path)
(file-exists? type-path)
(equal? (version) (call-with-input-file compiled-path get-version))
(read-record type-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)))))))
((eq? dest 'file)
(compile-to-file port loc level))
@ -79,7 +80,9 @@
(let ((names (compilation-unit-contains dependents))
(syntaxes (compilation-unit-code dependents))
(locations (compilation-unit-locations dependents)))
;(print-struct #t)
;(printf "names ~a~n" names)
;(printf "depends ~a~n~n" (compilation-unit-depends dependents))
(unless (= (length names) (length syntaxes))
;(printf "Writing a composite file out~n")
;(printf "~a~n~n" (syntax-object->datum (car syntaxes)))
@ -308,5 +311,18 @@
(main (list (contains-main? (def-members (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-inner-class (inner-class))
(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))
(let*-values (((header) (def-header class))
@ -525,12 +526,15 @@
(accesses-protected methods))
overridden-methods))
#;(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)
(parent-name)
(filter
(lambda (m) (not (or (private? (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)
(accesses-protected fields)))
(generate-contract-defs (class-name))))
@ -784,9 +788,10 @@
(let* ((field-name (id-string (field-name field)))
(value `(,(create-get-name field-name) wrapped-obj)))
`(,(build-identifier (build-var-name field-name))
,(convert-value (if from-dynamic? (assert-value value (field-type field) #t 'field field-name) value)
(field-type field)
from-dynamic?))))
,(convert-value
(if from-dynamic? (assert-value value (field-type field) #t 'field field-name) value)
(field-type field)
from-dynamic?))))
fields)))
;generate-wrapper-methods: (list method-record) boolean boolean -> (list sexp)
@ -1389,9 +1394,9 @@
(let ((normal-get (class-field-accessor ,class ,quote-name))
(dyn-get (class-field-accessor ,ca-class ,quote-name)))
(lambda (obj)
(if (is-a? obj ,class)
(normal-get obj)
(dyn-get obj)))))
(cond
((is-a? obj ,class) (normal-get obj))
((is-a? obj ,ca-class) (dyn-get obj))))))
#f)
(if (not final)
(list
@ -1836,6 +1841,7 @@
((double float) '(c:and/c number? (c:union inexact? integer?)))
((boolean) 'boolean?)
((char) 'char?)
((null) 'null?)
((string String)
(if from-dynamic?
`string?

34
collects/profj/types.ss
View File

@ -386,6 +386,7 @@
(let ((back-path (reverse path)))
(search-for-record key (car back-path)
(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)
;(hash-table-for-each records (lambda (k v) (printf "~a -> ~a~n" k v)))
(cond
@ -456,9 +457,10 @@
;lookup-path: string ( -> 'a) -> (U (list string) #f)
(define/public (lookup-path class fail)
;(printf "class ~a location ~a~n" class location)
;(printf "lookup ~a~n" class)
;(hash-table-for-each (hash-table-get class-environment location)
; (lambda (k v) (printf "~a -> ~a~n" k v)))
#;(hash-table-for-each (hash-table-get class-environment location)
(lambda (k v) (printf "~a -> ~a~n" k v)))
(if location
(hash-table-get (hash-table-get class-environment
location
@ -666,18 +668,7 @@
#f)))
(with-handlers ((exn? (lambda (e) (fail))))
(expand mod-syntax))
(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))))))
(set-scheme-record-provides! mod-ref (cons var (scheme-record-provides mod-ref)))))))
;generate-require-spec: string (list string) -> (U string (list symbol string+))
(define (generate-require-spec name path)
@ -697,7 +688,7 @@
((regexp-match "[a-zA-Z0-9]+Set$" name)
(java-name->scheme (regexp-replace "Set$" 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) =>
(lambda (substring)
(let ((char (car (regexp-match "[A-Z]" (car substring)))))
@ -791,7 +782,18 @@
(class-record-modifiers r)
(class-record-object? 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))
(class-record-parents r)
(class-record-ifaces r)