80 lines
2.9 KiB
Racket
80 lines
2.9 KiB
Racket
#lang scheme/base
|
|
(require scheme/cmdline
|
|
raco/command-name
|
|
compiler/cm
|
|
"../compiler.ss"
|
|
dynext/file)
|
|
|
|
(define verbose (make-parameter #f))
|
|
(define very-verbose (make-parameter #f))
|
|
(define disable-inlining (make-parameter #f))
|
|
|
|
(define disable-deps (make-parameter #f))
|
|
(define prefixes (make-parameter null))
|
|
(define assume-primitives (make-parameter #t))
|
|
|
|
(define source-files
|
|
(command-line
|
|
#:program (short-program+command-name)
|
|
#:once-each
|
|
[("--disable-inline") "Disable procedure inlining during compilation"
|
|
(disable-inlining #t)]
|
|
[("--no-deps") "Compile immediate files without updating dependencies"
|
|
(disable-deps #t)]
|
|
[("-p" "--prefix") file "Add elaboration-time prefix file for --no-deps"
|
|
(prefixes (append (prefixes) (list file)))]
|
|
[("--no-prim") "Do not assume `scheme' bindings at top level for --no-deps"
|
|
(assume-primitives #f)]
|
|
[("-v") "Verbose mode"
|
|
(verbose #t)]
|
|
[("--vv") "Very verbose mode"
|
|
(verbose #t)
|
|
(very-verbose #t)]
|
|
#:args (file . another-file) (cons file another-file)))
|
|
|
|
(if (disable-deps)
|
|
;; Just compile one file:
|
|
(let ([prefix
|
|
`(begin
|
|
(require scheme)
|
|
,(if (assume-primitives)
|
|
'(void)
|
|
'(namespace-require/copy 'scheme))
|
|
(require compiler/cffi)
|
|
,@(map (lambda (s) `(load ,s)) (prefixes))
|
|
(void))])
|
|
((compile-zos prefix #:verbose? (verbose))
|
|
source-files
|
|
'auto))
|
|
;; Normal make:
|
|
(let ([n (make-base-empty-namespace)]
|
|
[did-one? #f])
|
|
(parameterize ([current-namespace n]
|
|
[manager-trace-handler
|
|
(lambda (p)
|
|
(when (very-verbose)
|
|
(printf " ~a\n" p)))]
|
|
[manager-compile-notify-handler
|
|
(lambda (p)
|
|
(set! did-one? #t)
|
|
(when (verbose)
|
|
(printf " making ~s\n" (path->string p))))])
|
|
(for ([file source-files])
|
|
(unless (file-exists? file)
|
|
(error 'mzc "file does not exist: ~a" file))
|
|
(set! did-one? #f)
|
|
(let ([name (extract-base-filename/ss file 'mzc)])
|
|
(when (verbose)
|
|
(printf "\"~a\":\n" file))
|
|
(parameterize ([compile-context-preservation-enabled
|
|
(disable-inlining)])
|
|
(managed-compile-zo file))
|
|
(let ([dest (append-zo-suffix
|
|
(let-values ([(base name dir?) (split-path file)])
|
|
(build-path (if (symbol? base) 'same base)
|
|
"compiled" name)))])
|
|
(when (verbose)
|
|
(printf " [~a \"~a\"]\n"
|
|
(if did-one? "output to" "already up-to-date at")
|
|
dest))))))))
|