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

add --multi mode for -o/-g

Browse Source 
svn: r2888
This commit is contained in:
Matthew Flatt 2006-05-09 16:58:37 +00:00
parent 92838554ff
commit 2e944e3e2e
4 changed files with 60 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/compiler/compiler-unit.ss
View File

@ -117,13 +117,15 @@
(define compile-c-extension-parts
(make-unprefixed-compiler 'compile-c-extension-part))
(define (link/glue-extension-parts link? source-files destination-directory)
(define (link/glue-extension-parts link? compile? source-files destination-directory)
(let ([u (c-dynamic-require '(lib "ld-unit.ss" "compiler") 'ld@)]
[init (unit/sig ()
(import compiler:linker^)
(if link?
link-extension
glue-extension))])
(if compile?
glue-extension
glue-extension-source)))])
(let ([f (invoke-unit/sig
(compound-unit/sig
(import (COMPILE : dynext:compile^)
@ -143,10 +145,13 @@
(f source-files destination-directory))))
(define (link-extension-parts source-files destination-directory)
(link/glue-extension-parts #t source-files destination-directory))
(link/glue-extension-parts #t #t source-files destination-directory))
(define (glue-extension-parts source-files destination-directory)
(link/glue-extension-parts #f source-files destination-directory))
(link/glue-extension-parts #f #t source-files destination-directory))
(define (glue-extension-parts-to-c source-files destination-directory)
(link/glue-extension-parts #f #f source-files destination-directory))
(define (compile-to-zo src dest namespace eval?)
((if eval? (lambda (t) (t)) with-module-reading-parameterization)

67
collects/compiler/ld-unit.ss
View File

@ -34,15 +34,21 @@
(define (link-extension*
files
dest-dir)
(do-link-extension #t files dest-dir))
(do-link-extension #t #t files dest-dir))
(define (glue-extension
files
dest-dir)
(do-link-extension #f files dest-dir))
(do-link-extension #f #t files dest-dir))
(define (glue-extension-source
files
dest-dir)
(do-link-extension #f #f files dest-dir))
(define (do-link-extension
link?
compile?
files
dest-dir)
@ -273,32 +279,33 @@
(printf "Scheme_Object * scheme_module_name() { return NULL; }~n"))
'truncate)
(let ([tmp-dir (let ([d (getenv "PLTLDTMPDIR")])
(and d (directory-exists? d) d))])
(compile-extension (not (compiler:option:verbose))
(build-path dest-dir _loader.c)
(build-path dest-dir _loader.o)
(list (collection-path "compiler")))
(when (compiler:option:clean-intermediate-files)
(delete-file (build-path dest-dir _loader.c)))
(when compile?
(let ([tmp-dir (let ([d (getenv "PLTLDTMPDIR")])
(and d (directory-exists? d) d))])
(compile-extension (not (compiler:option:verbose))
(build-path dest-dir _loader.c)
(build-path dest-dir _loader.o)
(list (collection-path "compiler")))
(when (compiler:option:clean-intermediate-files)
(delete-file (build-path dest-dir _loader.c)))
(if link?
(begin
(link-extension (not (compiler:option:verbose))
(cons (build-path dest-dir _loader.o) o-files)
(build-path (if tmp-dir
tmp-dir
dest-dir)
_loader.so))
(when tmp-dir
(copy-file (build-path tmp-dir _loader.so)
(build-path dest-dir _loader.so))
(delete-file (build-path tmp-dir _loader.so)))
(when (compiler:option:clean-intermediate-files)
(delete-file (build-path dest-dir _loader.o)))
(printf " [output to \"~a\"]~n" (build-path dest-dir _loader.so)))
(printf " [output to \"~a\"]~n" (build-path dest-dir _loader.o))))))))
(if link?
(begin
(link-extension (not (compiler:option:verbose))
(cons (build-path dest-dir _loader.o) o-files)
(build-path (if tmp-dir
tmp-dir
dest-dir)
_loader.so))
(when tmp-dir
(copy-file (build-path tmp-dir _loader.so)
(build-path dest-dir _loader.so))
(delete-file (build-path tmp-dir _loader.so)))
(when (compiler:option:clean-intermediate-files)
(delete-file (build-path dest-dir _loader.o)))
(printf " [output to \"~a\"]~n" (build-path dest-dir _loader.so)))
(printf " [output to \"~a\"]~n" (build-path dest-dir _loader.o)))))))))

4
collects/compiler/sig.ss
View File

@ -81,6 +81,7 @@
link-extension-parts
glue-extension-parts
glue-extension-parts-to-c
compile-zos
@ -106,4 +107,5 @@
;; Low-level multi-file extension linker interface
(define-signature compiler:linker^
(link-extension
glue-extension)))
glue-extension
glue-extension-source)))

13
collects/compiler/start.ss
View File

@ -57,6 +57,8 @@
(define plt-setup-collections (make-parameter null))
(define plt-include-compiled (make-parameter #f))
(define stop-at-source (make-parameter #f))
(define (extract-suffix appender)
(bytes->string/latin-1
(subbytes
@ -148,6 +150,11 @@
[("--embedded")
,(lambda (f) (compiler:option:compile-for-embedded #t))
("Compile for embedded run-time engine, with -c/-o/-g")]
[("--multi")
,(lambda (f) (stop-at-source #t))
(,(format "Stop at ~a instead of ~a for -o/-g"
(extract-suffix append-c-suffix)
(extract-suffix append-object-suffix)))]
[("-p" "--prefix")
,(lambda (f v) v)
("Add elaboration-time prefix file for -e/-c/-o/-z" "file")]
@ -415,12 +422,14 @@
[(compile-c)
((compile-extensions-to-c prefix) source-files (dest-dir))]
[(compile-o)
((compile-extension-parts prefix) source-files (dest-dir))]
(((if (stop-at-source) compile-extension-parts-to-c compile-extension-parts) prefix)
source-files (dest-dir))]
[(link)
(never-embedded "link")
(link-extension-parts source-files (or (dest-dir) (current-directory)))]
[(link-glue)
(glue-extension-parts source-files (or (dest-dir) (current-directory)))]
((if (stop-at-source) glue-extension-parts-to-c glue-extension-parts)
source-files (or (dest-dir) (current-directory)))]
[(zo)
((compile-zos prefix) source-files (if (auto-dest-dir)
'auto