diff --git a/collects/profj/build-info.ss b/collects/profj/build-info.ss index cc88713f21..bcebc5cf02 100644 --- a/collects/profj/build-info.ss +++ b/collects/profj/build-info.ss @@ -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" diff --git a/collects/profj/check.ss b/collects/profj/check.ss index 929c514c27..4671687984 100644 --- a/collects/profj/check.ss +++ b/collects/profj/check.ss @@ -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))) diff --git a/collects/profj/compile.ss b/collects/profj/compile.ss index fb6ee83546..9c10e4db30 100644 --- a/collects/profj/compile.ss +++ b/collects/profj/compile.ss @@ -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)))))))) ) diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index 3c8905a5d0..eb6ef913da 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -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? diff --git a/collects/profj/types.ss b/collects/profj/types.ss index b6a11c93f7..c350c72e82 100644 --- a/collects/profj/types.ss +++ b/collects/profj/types.ss @@ -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)