From a60278a84302ab7d9636413e9211dd782c996931 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 15 Nov 2006 00:25:10 +0000 Subject: [PATCH] use current-write-relative-directory to produce .zo without absolute paths for inferred procedure names svn: r4855 --- collects/profj/compile.ss | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/collects/profj/compile.ss b/collects/profj/compile.ss index 133514fe0e..b1c1ae6c00 100644 --- a/collects/profj/compile.ss +++ b/collects/profj/compile.ss @@ -64,7 +64,7 @@ (lambda (port) (compile-java-internal port name type-recs #f level))))))) (else (compile-java-internal port loc type-recs #f level))))) - + ;compile-to-file: port location level -> void ;Should have side-effect of writing to file all files needed for compilation (define (compile-to-file port location level) @@ -86,10 +86,11 @@ (unless (= (length names) (length syntaxes)) ;(printf "Writing a composite file out~n") ;(printf "~a~n~n" (syntax-object->datum (car syntaxes))) - (call-with-output-file* (build-path (send type-recs get-compilation-location) - (file-name-from-path - (send type-recs get-composite-location (car names)))) - (lambda (port) (write (compile (car syntaxes)) port)) 'truncate/replace) + (call-with-output-zo-file* location + (build-path (send type-recs get-compilation-location) + (file-name-from-path + (send type-recs get-composite-location (car names)))) + (lambda (port) (write (compile (car syntaxes)) port)) 'truncate/replace) (set! syntaxes (cdr syntaxes))) (unless (= (length names) (length syntaxes) (length locations)) (error 'compile-to-file "Internal error: compilation unit not represented as expected")) @@ -98,9 +99,10 @@ (send type-recs set-location! location) (let ((directory (send type-recs get-compilation-location))) (unless (directory-exists? directory) (make-directory directory)) - (call-with-output-file* (build-path directory (string-append name ".zo")) - (lambda (port) (write (compile code) port)) - 'truncate/replace) + (call-with-output-zo-file* location + (build-path directory (string-append name ".zo")) + (lambda (port) (write (compile code) port)) + 'truncate/replace) (call-with-output-file* (build-path directory (string-append name ".jinfo")) (lambda (port) (write-record (send type-recs get-class-record (list name) @@ -110,6 +112,16 @@ 'truncate/replace))) names syntaxes locations))) (compile-java-internal port location type-recs #t level)))) + + ;; call-with-output-zo-file* path-string path-string proc [symbol ...] -> + ;; Like call-with-output-file*, but takes an extra initial path to use + ;; as a original location, so that marshaled paths in a generated .zo file + ;; can be written as relative paths + (define (call-with-output-zo-file* loc name proc . flags) + (let ([dir (and (path-string? loc) + (path-only (path->complete-path loc)))]) + (parameterize ([current-write-relative-directory dir]) + (apply call-with-output-file* name proc flags)))) (define (class-record-error) (error 'compile-to-file "Internal error: class record not found"))