Major cleanup
svn: r11237
This commit is contained in:
Eli Barzilay
parent
2d3dfd9d9e
commit
2ef6a23b4e
|
|
@ -1,9 +1,8 @@
|
|||
#lang mzscheme
|
||||
|
||||
(module collection-sig mzscheme
|
||||
(require mzlib/unit)
|
||||
(require mzlib/unit)
|
||||
|
||||
(provide make:collection^)
|
||||
|
||||
(define-signature make:collection^
|
||||
(make-collection)))
|
||||
(provide make:collection^)
|
||||
|
||||
(define-signature make:collection^
|
||||
(make-collection))
|
||||
|
|
|
|||
|
|
@ -1,40 +1,34 @@
|
|||
#lang mzscheme
|
||||
|
||||
(module collection-unit mzscheme
|
||||
(require mzlib/unit
|
||||
(require mzlib/unit
|
||||
mzlib/list
|
||||
mzlib/file)
|
||||
|
||||
(require "collection-sig.ss")
|
||||
(require "make-sig.ss")
|
||||
|
||||
(require compiler/sig
|
||||
mzlib/file
|
||||
"collection-sig.ss"
|
||||
"make-sig.ss"
|
||||
compiler/sig
|
||||
dynext/file-sig)
|
||||
|
||||
(provide make:collection@)
|
||||
(provide make:collection@)
|
||||
|
||||
(define-unit make:collection@
|
||||
(define-unit make:collection@
|
||||
(import make^
|
||||
dynext:file^
|
||||
compiler^)
|
||||
(export make:collection^)
|
||||
|
||||
(define (make-collection
|
||||
collection-name
|
||||
collection-files
|
||||
argv)
|
||||
(define (make-collection collection-name collection-files argv)
|
||||
(printf "building collection ~a: ~a~n" collection-name collection-files)
|
||||
(let* ([zo-compiler #f]
|
||||
[src-dir (current-directory)]
|
||||
[sses (sort collection-files
|
||||
(lambda (a b) (string-ci<? (path->string a) (path->string b))))]
|
||||
(lambda (a b)
|
||||
(string-ci<? (path->string a) (path->string b))))]
|
||||
[bases (map (lambda (src)
|
||||
(extract-base-filename/ss src 'make-collection-extension))
|
||||
(extract-base-filename/ss src
|
||||
'make-collection-extension))
|
||||
sses)]
|
||||
[zos (map
|
||||
(lambda (base)
|
||||
(build-path
|
||||
"compiled"
|
||||
(append-zo-suffix base)))
|
||||
[zos (map (lambda (base)
|
||||
(build-path "compiled" (append-zo-suffix base)))
|
||||
bases)]
|
||||
[ss->zo-list
|
||||
(map (lambda (ss zo)
|
||||
|
|
@ -45,8 +39,4 @@
|
|||
(zo-compiler (list ss) "compiled"))))
|
||||
sses zos)])
|
||||
(unless (directory-exists? "compiled") (make-directory "compiled"))
|
||||
(make/proc
|
||||
(append
|
||||
`(("zo" ,zos))
|
||||
ss->zo-list)
|
||||
argv)))))
|
||||
(make/proc (append `(("zo" ,zos)) ss->zo-list) argv))))
|
||||
|
|
|
|||
|
|
@ -1,18 +1,17 @@
|
|||
#lang mzscheme
|
||||
|
||||
(module collection mzscheme
|
||||
(require mzlib/unit)
|
||||
|
||||
(require dynext/file-sig
|
||||
(require mzlib/unit
|
||||
dynext/file-sig
|
||||
dynext/file
|
||||
compiler/sig
|
||||
compiler/compiler
|
||||
compiler/option)
|
||||
|
||||
(require "make-sig.ss"
|
||||
(require "make-sig.ss"
|
||||
"make.ss"
|
||||
"collection-sig.ss"
|
||||
"collection-unit.ss")
|
||||
|
||||
(define-values/invoke-unit/infer make:collection@)
|
||||
(define-values/invoke-unit/infer make:collection@)
|
||||
|
||||
(provide-signature-elements make:collection^))
|
||||
(provide-signature-elements make:collection^)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
|
||||
#lang scheme/signature
|
||||
|
||||
make/proc
|
||||
|
|
|
|||
|
|
@ -1,167 +1,117 @@
|
|||
|
||||
#lang scheme/unit
|
||||
|
||||
(require "make-sig.ss")
|
||||
(require "make-sig.ss")
|
||||
|
||||
(import)
|
||||
(export make^)
|
||||
(import)
|
||||
(export make^)
|
||||
|
||||
(define-struct (exn:fail:make exn:fail) (target orig-exn))
|
||||
(define make-print-checking (make-parameter #t))
|
||||
(define make-print-dep-no-line (make-parameter #t))
|
||||
(define make-print-reasons (make-parameter #t))
|
||||
(define make-notify-handler (make-parameter void))
|
||||
|
||||
(define make-print-checking (make-parameter #t))
|
||||
(define make-print-dep-no-line (make-parameter #t))
|
||||
(define make-print-reasons (make-parameter #t))
|
||||
(define make-notify-handler (make-parameter void))
|
||||
(define-struct line (targets ; (list-of string)
|
||||
dependencies ; (list-of string)
|
||||
command)) ; (union thunk #f)
|
||||
(define-struct (exn:fail:make exn:fail) (target orig-exn))
|
||||
|
||||
;(define-type line (list (union path-string (list-of path-string)) (list-of path-string) thunk))
|
||||
;(define-type spec (list-of line))
|
||||
;; check-spec : TST -> (non-empty-list-of line)
|
||||
;; throws an error on bad input
|
||||
(define (spec->lines spec)
|
||||
(define (->strings xs)
|
||||
(map (lambda (x) (if (path? x) (path->string x) x)) xs))
|
||||
(define (err s p) (error 'make/proc "~a: ~e" s p))
|
||||
(unless (and (list? spec) (pair? spec))
|
||||
(err "specification is not a non-empty list" spec))
|
||||
(for/list ([line spec])
|
||||
(unless (and (list? line) (<= 2 (length line) 3))
|
||||
(err "line is not a list with 2 or 3 parts" line))
|
||||
(let* ([name (car line)]
|
||||
[tgts (if (list? name) name (list name))]
|
||||
[deps (cadr line)]
|
||||
[thunk (and (pair? (cddr line)) (caddr line))])
|
||||
(define (err s p) (error 'make/proc "~a: ~e for line: ~a" s p name))
|
||||
(unless (andmap path-string? tgts)
|
||||
(err "line does not start with a path/string or list of paths/strings"
|
||||
line))
|
||||
(unless (list? deps) (err "second part of line is not a list" deps))
|
||||
(for ([dep deps])
|
||||
(unless (path-string? dep)
|
||||
(err "dependency item is not a path/string" dep)))
|
||||
(unless (or (not thunk)
|
||||
(and (procedure? thunk) (procedure-arity-includes? thunk 0)))
|
||||
(err "command part of line is not a thunk" thunk))
|
||||
(make-line (->strings tgts) (->strings deps) thunk))))
|
||||
|
||||
(define (path-string=? a b)
|
||||
(equal? (if (string? a) (string->path a) a)
|
||||
(if (string? b) (string->path b) b)))
|
||||
(define (path-string->string s)
|
||||
(if (string? s)
|
||||
s
|
||||
(path->string s)))
|
||||
;; (union path-string (vector-of path-string) (list-of path-string))
|
||||
;; -> (list-of string)
|
||||
;; throws an error on bad input
|
||||
(define (argv->args x)
|
||||
(let ([args (cond [(list? x) x]
|
||||
[(vector? x) (vector->list x)]
|
||||
[else (list x)])])
|
||||
(map (lambda (a)
|
||||
(cond [(string? a) a]
|
||||
[(path? a) (path->string a)]
|
||||
[else (raise-type-error
|
||||
'make/proc "path/string or path/string vector or list"
|
||||
x)]))
|
||||
args)))
|
||||
|
||||
; find-matching-line : path-string spec -> (union line #f)
|
||||
(define (find-matching-line str spec)
|
||||
(let ([match? (lambda (s) (path-string=? s str))])
|
||||
(let loop ([lines spec])
|
||||
(cond
|
||||
[(null? lines) #f]
|
||||
[else (let* ([line (car lines)]
|
||||
[names (if (path-string? (car line))
|
||||
(list (car line))
|
||||
(car line))])
|
||||
(if (ormap match? names)
|
||||
line
|
||||
(loop (cdr lines))))]))))
|
||||
;; path-date : path-string -> (union integer #f)
|
||||
(define (path-date p)
|
||||
(and (or (directory-exists? p) (file-exists? p))
|
||||
(file-or-directory-modify-seconds p)))
|
||||
|
||||
; form-error : TST TST -> a
|
||||
(define (form-error s p) (error 'make/proc "~a: ~s" s p))
|
||||
|
||||
; line-error : TST TST TST -> a
|
||||
(define (line-error s p n) (error 'make/proc "~a: ~s for line: ~a" s p n))
|
||||
|
||||
; check-spec : TST -> #t
|
||||
; effect : calls error if input is not a spec
|
||||
(define (check-spec spec)
|
||||
(and (or (list? spec) (form-error "specification is not a list" spec))
|
||||
(or (pair? spec) (form-error "specification is an empty list" spec))
|
||||
(andmap
|
||||
(lambda (line)
|
||||
(and (or (and (list? line) (<= 2 (length line) 3))
|
||||
(form-error "list is not a list with 2 or 3 parts" line))
|
||||
(or (or (path-string? (car line))
|
||||
(and (list? (car line))
|
||||
(andmap path-string? (car line))))
|
||||
(form-error "line does not start with a path/string or list of paths/strings" line))
|
||||
(let ([name (car line)])
|
||||
(or (list? (cadr line))
|
||||
(line-error "second part of line is not a list" (cadr line) name)
|
||||
(andmap (lambda (dep)
|
||||
(or (path-string? dep)
|
||||
(form-error "dependency item is not a path/string" dep name)))
|
||||
(cadr line)))
|
||||
(or (null? (cddr line))
|
||||
(and (procedure? (caddr line))
|
||||
(procedure-arity-includes? (caddr line) 0))
|
||||
(line-error "command part of line is not a thunk" (caddr line) name)))))
|
||||
spec)))
|
||||
|
||||
; check-spec : TST -> #t
|
||||
; effect : calls error if input is not a (union path-string (vector-of path-string))
|
||||
(define (check-argv argv)
|
||||
(or (path-string? argv)
|
||||
(and (vector? argv)
|
||||
(andmap path-string? (vector->list argv)))
|
||||
(raise-type-error 'make/proc "path/string or path/string vector" argv)))
|
||||
|
||||
; make/proc/helper : spec (union path-string (vector-of path-string)) -> void
|
||||
; effect : make, according to spec and argv. See docs for details
|
||||
(define (make/proc/helper spec argv)
|
||||
(check-spec spec)
|
||||
(check-argv argv)
|
||||
|
||||
(letrec ([made null]
|
||||
[make-file
|
||||
(lambda (s indent)
|
||||
(let ([line (find-matching-line s spec)]
|
||||
[date (and (or (directory-exists? s)
|
||||
(file-exists? s))
|
||||
(file-or-directory-modify-seconds s))])
|
||||
|
||||
(when (and (make-print-checking)
|
||||
(or line (make-print-dep-no-line)))
|
||||
(printf "make: ~achecking ~a~n" indent s)
|
||||
;; make/proc :
|
||||
;; spec (union path-string (vector-of path-string) (list-of path-string))
|
||||
;; -> void
|
||||
;; effect : make, according to spec and argv. See docs for details
|
||||
(define (make/proc spec [argv '()])
|
||||
(define made null)
|
||||
(define lines (spec->lines spec))
|
||||
(define args (argv->args argv))
|
||||
(define (make-file s indent)
|
||||
(define line
|
||||
(findf (lambda (line)
|
||||
(ormap (lambda (s1) (string=? s s1)) (line-targets line)))
|
||||
lines))
|
||||
(define date (path-date s))
|
||||
(when (and (make-print-checking) (or line (make-print-dep-no-line)))
|
||||
(printf "make: ~achecking ~a\n" indent s)
|
||||
(flush-output))
|
||||
|
||||
(if line
|
||||
(let ([deps (cadr line)])
|
||||
(for-each (let ([new-indent (string-append " " indent)])
|
||||
(lambda (d) (make-file d new-indent)))
|
||||
deps)
|
||||
(let ([reason
|
||||
(or (not date)
|
||||
(ormap (lambda (dep)
|
||||
(unless (or (file-exists? dep)
|
||||
(directory-exists? dep))
|
||||
(error 'make "dependancy ~a was not made~n" dep))
|
||||
(and (> (file-or-directory-modify-seconds dep) date)
|
||||
dep))
|
||||
deps))])
|
||||
(when reason
|
||||
(let ([l (cddr line)])
|
||||
(unless (null? l)
|
||||
(if (not line)
|
||||
(unless date (error 'make "don't know how to make ~a" s))
|
||||
(let* ([deps (line-dependencies line)]
|
||||
[command (line-command line)]
|
||||
[indent+ (string-append indent " ")]
|
||||
[dep-dates (for/list ([d deps])
|
||||
(make-file d indent+)
|
||||
(or (path-date d)
|
||||
(error 'make "dependancy ~a was not made\n" d)))]
|
||||
[reason (or (not date)
|
||||
(ormap (lambda (dep ddate) (and (> ddate date) dep))
|
||||
deps dep-dates))])
|
||||
(when (and reason command)
|
||||
(set! made (cons s made))
|
||||
((make-notify-handler) s)
|
||||
(printf "make: ~amaking ~a~a~n"
|
||||
(printf "make: ~amaking ~a~a\n"
|
||||
(if (make-print-checking) indent "")
|
||||
(path-string->string s)
|
||||
(if (make-print-reasons)
|
||||
(cond
|
||||
[(not date)
|
||||
(string-append " because " (path-string->string s) " does not exist")]
|
||||
[(path-string? reason)
|
||||
(string-append " because " (path-string->string reason) " changed")]
|
||||
[else
|
||||
(string-append
|
||||
(format " because (reason: ~a date: ~a)"
|
||||
reason date))])
|
||||
""))
|
||||
s
|
||||
(cond [(not (make-print-reasons)) ""]
|
||||
[(not date) (format " because ~a does not exist" s)]
|
||||
[else (format " because ~a changed" reason)]))
|
||||
(flush-output)
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (exn)
|
||||
(raise (make-exn:fail:make
|
||||
(format "make: Failed to make ~a; ~a"
|
||||
(let ([fst (car line)])
|
||||
(if (pair? fst)
|
||||
(map path-string->string fst)
|
||||
(path-string->string fst)))
|
||||
(if (exn? exn)
|
||||
(exn-message exn)
|
||||
exn))
|
||||
(if (exn? exn)
|
||||
(format "make: failed to make ~a; ~a"
|
||||
s (exn-message exn))
|
||||
(exn-continuation-marks exn)
|
||||
(current-continuation-marks))
|
||||
(car line)
|
||||
(line-targets line)
|
||||
exn)))])
|
||||
((car l))))))))
|
||||
(unless date
|
||||
(error 'make "don't know how to make ~a"
|
||||
(path-string->string s))))))])
|
||||
(cond
|
||||
[(path-string? argv) (make-file argv "")]
|
||||
[(equal? argv #()) (make-file (caar spec) "")]
|
||||
[else (for-each (lambda (f) (make-file f "")) (vector->list argv))])
|
||||
|
||||
(for-each (lambda (item)
|
||||
(printf "make: made ~a~n" (path-string->string item)))
|
||||
(reverse made))
|
||||
(flush-output)))
|
||||
|
||||
(define make/proc
|
||||
(case-lambda
|
||||
[(spec) (make/proc/helper spec #())]
|
||||
[(spec argv) (make/proc/helper spec argv)]))
|
||||
(command))))))
|
||||
(for ([f (if (null? args) (list (car (line-targets (car lines)))) args)])
|
||||
(make-file f ""))
|
||||
(for ([item (reverse made)]) (printf "make: made ~a\n" item))
|
||||
(flush-output))
|
||||
|
|
|
|||
|
|
@ -17,8 +17,8 @@
|
|||
@title{@bold{Make}: Dependency Manager}
|
||||
|
||||
The @schememodname[make] library provides a Scheme version of the
|
||||
standard Unix @exec{make} utility. Its syntax is intended to imitate
|
||||
regular Unix make, but in Scheme.
|
||||
popular @exec{make} utility. Its syntax is intended to imitate the
|
||||
syntax of @exec{make}, only in Scheme.
|
||||
|
||||
@table-of-contents[]
|
||||
|
||||
|
|
@ -33,18 +33,19 @@ dependency tracking, just use @exec{mzc} as described in
|
|||
If you are already familiar with @exec{make}, skip to the precise
|
||||
details of the @schememodname[make] library in @secref["make"]. This
|
||||
section contains a brief overview of @exec{make} for everyone
|
||||
else. The idea is to explain how to generate some project you have
|
||||
from a collection of source files that go through several stages of
|
||||
processing.
|
||||
else.
|
||||
|
||||
For example, let's say that you are writing some project that has
|
||||
three input files (that you create and maintain) called
|
||||
@filepath{a.input}, @filepath{b.input}, and
|
||||
@filepath{c.input}. Further, there are two stages of processing: first
|
||||
you run a particular tool @exec{make-output} that takes an input file
|
||||
and produces and output file, and second you combine the input files
|
||||
into a single file using @filepath{output}. Using @exec{make}, you
|
||||
might write this:
|
||||
When you use @exec{make}, the idea is that you explain how to generate
|
||||
files in a project from a collection of source files that go through
|
||||
several stages of processing.
|
||||
|
||||
For example, say that you are writing a project that has three input
|
||||
files (which you create and maintain) called @filepath{a.input},
|
||||
@filepath{b.input}, and @filepath{c.input}. Further, there are two
|
||||
stages of processing: first you run a particular tool
|
||||
@exec{make-output} that takes an input file and produces an output
|
||||
file, and then you combine the input files into a single file using
|
||||
@exec{combine-files}. Using @exec{make}, you might describe this as:
|
||||
|
||||
@verbatim[#:indent 2]{
|
||||
a.output: a.input
|
||||
|
|
@ -54,30 +55,32 @@ b.output: b.input
|
|||
c.output: c.input
|
||||
make-output c.input c.output
|
||||
total: a.output b.output c.output
|
||||
combine a.output b.output c.output
|
||||
combine-files a.output b.output c.output
|
||||
}
|
||||
|
||||
Once you've put those above lines in a file called
|
||||
@filepath{Makefile} you can issue the command:
|
||||
Once you've put this description in a file called @filepath{Makefile}
|
||||
you can issue the command:
|
||||
|
||||
@commandline{make total}
|
||||
|
||||
that builds your entire project. The @filepath{Makefile} consists of
|
||||
several lines that tell @exec{make} how to create each piece. The
|
||||
first two lines say that @filepath{a.output} depends on
|
||||
@filepath{a.input} and the command for making @filepath{a.output} from
|
||||
@filepath{a.input} is
|
||||
to build your entire project. The @filepath{Makefile} consists of
|
||||
several rules that tell @exec{make} how to create each piece of your
|
||||
project. For example, the rule that is specified in the first two
|
||||
lines say that @filepath{a.output} depends on @filepath{a.input} and
|
||||
the command for making @filepath{a.output} from @filepath{a.input} is
|
||||
|
||||
@commandline{make-output a.input a.output}
|
||||
|
||||
The point of using @exec{make} is that it looks at the file creation
|
||||
dates of the various files and only re-builds what is necessary.
|
||||
The main feature of @exec{make} is that it uses the time stamps of
|
||||
files to determine when a certain step is necessary. The @exec{make}
|
||||
utility uses existing programs to build your project --- each rule has
|
||||
a shell command line.
|
||||
|
||||
The @exec{make} utility builds things with shell programs. If, on the
|
||||
other hand, you want to build similar things with various Scheme
|
||||
programs, you can use the @schememodname[make] library.
|
||||
The @schememodname[make] library provides similar functionality,
|
||||
except that the description is in Scheme, and the steps that are
|
||||
needed to build target files are implemented as Scheme functions.
|
||||
|
||||
Here's the equivalent Scheme program:
|
||||
Here's a Scheme program that is equivalent to the above:
|
||||
|
||||
@schemeblock[
|
||||
(require make)
|
||||
|
|
@ -85,24 +88,49 @@ Here's the equivalent Scheme program:
|
|||
(define (make-output in out)
|
||||
....)
|
||||
|
||||
(define (combine-total . args)
|
||||
(define (combine-files . args)
|
||||
....)
|
||||
|
||||
(make
|
||||
(("a.output" ("a.input") (make-output "a.output" "a.input"))
|
||||
("b.output" ("b.input") (make-output "b.output" "b.input"))
|
||||
("c.output" ("c.input") (make-output "c.output" "c.input"))
|
||||
(("a.output" ("a.input") (make-output "a.input" "a.output"))
|
||||
("b.output" ("b.input") (make-output "b.input" "b.output"))
|
||||
("c.output" ("c.input") (make-output "c.input" "c.output"))
|
||||
("total" ("a.output" "b.output" "c.output")
|
||||
(combine-total "a.output" "b.output" "c.output"))))
|
||||
(combine-files "a.output" "b.output" "c.output"))))
|
||||
]
|
||||
|
||||
If you were to fill in the ellipses above with calls to
|
||||
@scheme[system], you'd have the exact same thing as the original
|
||||
@filepath{Makefile}. In addition, if you use @scheme[make/proc]], you
|
||||
can abstract over the various make lines (for example, the
|
||||
@filepath{a.output}, @filepath{b.output}, and @filepath{c.output}
|
||||
lines are similar, and it would be good to write a program to generate
|
||||
those lines).
|
||||
@scheme[system], you'd have the exact same functionality as the
|
||||
original @filepath{Makefile}. In addition, you can use
|
||||
@scheme[make/proc] to abstract over the various lines. For example,
|
||||
the @filepath{a.output}, @filepath{b.output}, and @filepath{c.output}
|
||||
lines are very similar so you can write the code that generates those
|
||||
lines:
|
||||
|
||||
@schemeblock[
|
||||
(require make)
|
||||
|
||||
(define (make-output in out)
|
||||
....)
|
||||
|
||||
(define (combine-files . args)
|
||||
....)
|
||||
|
||||
(define files '("a" "b" "c"))
|
||||
(define inputs (map (lambda (f) (string-append f ".input"))))
|
||||
(define outputs (map (lambda (f) (string-append f ".output"))))
|
||||
|
||||
(define (line file)
|
||||
(let ([i (string-append file ".input")]
|
||||
[o (string-append file ".output")])
|
||||
`(,o (,i) )
|
||||
(list o (list i) (lambda () (make-output o i)))))
|
||||
|
||||
(make/proc
|
||||
`(,@(map (lambda (i o) `(o (,i) ,(lambda () (make-output i o))))
|
||||
inputs outputs)
|
||||
("total" ,outputs ,(lambda () (apply combine-files outputs)))))
|
||||
]
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
||||
|
|
@ -120,7 +148,8 @@ Expands to
|
|||
@schemeblock[
|
||||
(make/proc
|
||||
(list (list target-expr (list depend-expr ...)
|
||||
(lambda () command-expr ...)) ...)
|
||||
(lambda () command-expr ...))
|
||||
...)
|
||||
argv-expr)
|
||||
]}
|
||||
|
||||
|
|
@ -129,7 +158,8 @@ Expands to
|
|||
(cons/c (listof path-string?)
|
||||
(or/c null?
|
||||
(list/c (-> any))))))]
|
||||
[argv (or/c string? (vectorof string?))]) void?]
|
||||
[argv (or/c string? (vectorof string?) (listof string?))])
|
||||
void?]
|
||||
|
||||
Performs a make according to @scheme[spec] and using @scheme[argv] as
|
||||
command-line arguments selecting one or more targets.
|
||||
|
|
@ -153,10 +183,11 @@ While running a command thunk, @scheme[make/proc] catches exceptions
|
|||
and wraps them in an @scheme[exn:fail:make] structure, the raises the
|
||||
resulting structure.}
|
||||
|
||||
@defstruct[(exn:fail:make exn:fail) ([target (or/c path-string? (listof path-string?))]
|
||||
@defstruct[(exn:fail:make exn:fail)
|
||||
([targets (listof path-string?)]
|
||||
[orig-exn any/c])]{
|
||||
|
||||
The @scheme[target] field is a list of list of strings naming the
|
||||
The @scheme[targets] field is a list of strings naming the
|
||||
target(s), and the @scheme[orig-exn] field is the original raised
|
||||
value.}
|
||||
|
||||
|
|
@ -254,7 +285,7 @@ options (see @schememodname[dynext/compile] and
|
|||
[unix-libs (listof string?)]
|
||||
[windows-libs (listof string?)]
|
||||
[extra-depends (listof path-string?)]
|
||||
[last-chance-k ((-> any) . > . any)]
|
||||
[last-chance-k ((-> any) . -> . any)]
|
||||
[3m-too? any/c #f])
|
||||
void?]{
|
||||
|
||||
|
|
|
|||
|
|
@ -1,15 +1,16 @@
|
|||
#lang mzscheme
|
||||
|
||||
(module make mzscheme
|
||||
(require mzlib/unit)
|
||||
|
||||
(require "make-sig.ss"
|
||||
(require mzlib/unit
|
||||
"make-sig.ss"
|
||||
"make-unit.ss")
|
||||
|
||||
(define-values/invoke-unit/infer make@)
|
||||
(define-values/invoke-unit/infer make@)
|
||||
|
||||
(provide-signature-elements make^)
|
||||
(provide-signature-elements make^)
|
||||
|
||||
(define-syntax make
|
||||
(provide make)
|
||||
|
||||
(define-syntax make
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ spec)
|
||||
|
|
@ -29,17 +30,16 @@
|
|||
(form-error "clause does not have at least 2 parts" line))
|
||||
(let ([name (car ll)])
|
||||
(unless (syntax->list (cadr ll))
|
||||
(form-error "second part of clause is not a sequence" (cadr ll))))))
|
||||
(form-error "second part of clause is not a sequence"
|
||||
(cadr ll))))))
|
||||
sl)
|
||||
(with-syntax ([(line ...)
|
||||
(map (lambda (line)
|
||||
(syntax-case line ()
|
||||
[(target deps) (syntax (list target (list . deps)))]
|
||||
[(target deps . c) (syntax (list target (list . deps)
|
||||
[(target deps)
|
||||
(syntax (list target (list . deps)))]
|
||||
[(target deps . c)
|
||||
(syntax (list target (list . deps)
|
||||
(lambda () . c)))]))
|
||||
sl)])
|
||||
(syntax (make/proc
|
||||
(list line ...)
|
||||
argv)))))])))
|
||||
|
||||
(provide make))
|
||||
(syntax (make/proc (list line ...) argv)))))])))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang mzscheme
|
||||
|
||||
(module setup-extension mzscheme
|
||||
(require make
|
||||
(require make
|
||||
dynext/link
|
||||
dynext/compile
|
||||
dynext/file
|
||||
|
|
@ -11,26 +11,24 @@
|
|||
compiler/xform
|
||||
setup/dirs)
|
||||
|
||||
(provide pre-install
|
||||
with-new-flags)
|
||||
(provide pre-install)
|
||||
|
||||
;; Syntax used to add a command-line flag:
|
||||
(define-syntax with-new-flags
|
||||
;; Syntax used to add a command-line flag:
|
||||
(define-syntax with-new-flags
|
||||
(syntax-rules ()
|
||||
[(_ param flags body0 body ...)
|
||||
(parameterize ([param (append
|
||||
(param)
|
||||
flags)])
|
||||
[(_ ([param flags] ...) body0 body ...)
|
||||
(parameterize* ([param (append (param) flags)] ...)
|
||||
body0 body ...)]))
|
||||
|
||||
(define (extract-base-filename file.c)
|
||||
(let-values ([(base name dir?) (split-path (extract-base-filename/c file.c 'pre-install))])
|
||||
(define (extract-base-filename file.c)
|
||||
(let-values ([(base name dir?)
|
||||
(split-path (extract-base-filename/c file.c 'pre-install))])
|
||||
name))
|
||||
|
||||
(define (string-path->string s)
|
||||
(define (string-path->string s)
|
||||
(if (string? s) s (path->string s)))
|
||||
|
||||
(define pre-install
|
||||
(define pre-install
|
||||
(opt-lambda (main-collects-parent-dir
|
||||
collection-dir
|
||||
file.c
|
||||
|
|
@ -80,19 +78,16 @@
|
|||
name))
|
||||
file.c))))))
|
||||
|
||||
(define (pre-install/check-precompiled main-collects-parent-dir collection-dir file.c . rest)
|
||||
(let* ([pre-dir (build-path collection-dir
|
||||
"precompiled"
|
||||
"native")]
|
||||
(define (pre-install/check-precompiled
|
||||
main-collects-parent-dir collection-dir file.c . rest)
|
||||
(let* ([pre-dir (build-path collection-dir "precompiled" "native")]
|
||||
[variant-dir (system-library-subpath (link-variant))]
|
||||
[base-file (string-append (path-element->string (extract-base-filename file.c))
|
||||
"_ss")]
|
||||
[file.so (build-path pre-dir variant-dir (append-extension-suffix base-file))])
|
||||
(if (file-exists? file.so)
|
||||
;; Just copy pre-compiled file:
|
||||
(let* ([dest-dir (build-path collection-dir
|
||||
"compiled"
|
||||
"native"
|
||||
(let* ([dest-dir (build-path collection-dir "compiled" "native"
|
||||
variant-dir)]
|
||||
[dest-file.so (build-path dest-dir (append-extension-suffix base-file))])
|
||||
(make-directory* dest-dir)
|
||||
|
|
@ -103,7 +98,7 @@
|
|||
;; Normal build...
|
||||
(apply pre-install/normal main-collects-parent-dir collection-dir file.c rest))))
|
||||
|
||||
(define (pre-install/normal main-collects-parent-dir
|
||||
(define (pre-install/normal main-collects-parent-dir
|
||||
collection-dir
|
||||
file.c
|
||||
default-lib-dir
|
||||
|
|
@ -181,45 +176,32 @@
|
|||
(define file.so (build-path dir (append-extension-suffix base-file)))
|
||||
(define file.o (build-path dir (append-object-suffix base-file)))
|
||||
|
||||
(with-new-flags
|
||||
current-extension-compiler-flags
|
||||
((current-make-compile-include-strings) (build-path sys-path "include"))
|
||||
|
||||
(with-new-flags
|
||||
current-extension-preprocess-flags
|
||||
((current-make-compile-include-strings) (build-path sys-path "include"))
|
||||
|
||||
(with-new-flags ([current-extension-compiler-flags
|
||||
((current-make-compile-include-strings)
|
||||
(build-path sys-path "include"))]
|
||||
[current-extension-preprocess-flags
|
||||
((current-make-compile-include-strings)
|
||||
(build-path sys-path "include"))]
|
||||
;; Add -L and -l for Unix:
|
||||
(with-new-flags
|
||||
current-extension-linker-flags
|
||||
[current-extension-linker-flags
|
||||
(if is-win?
|
||||
null
|
||||
(list (format "-L~a/lib" (path->string sys-path))))
|
||||
|
||||
(list (format "-L~a/lib" (path->string sys-path))))]
|
||||
;; Add libs for Windows:
|
||||
(with-new-flags
|
||||
current-standard-link-libraries
|
||||
[current-standard-link-libraries
|
||||
(if is-win?
|
||||
(append (map
|
||||
(lambda (l)
|
||||
(build-path sys-path "lib" (format "~a.lib" l)))
|
||||
(build-path sys-path "lib"
|
||||
(format "~a.lib" l)))
|
||||
find-windows-libs)
|
||||
windows-libs)
|
||||
null)
|
||||
|
||||
null)]
|
||||
;; Extra stuff:
|
||||
(with-new-flags
|
||||
current-extension-linker-flags
|
||||
(case mach-id
|
||||
[(rs6k-aix) (list "-lc")]
|
||||
[else null])
|
||||
|
||||
(with-new-flags
|
||||
current-standard-link-libraries
|
||||
(case mach-id
|
||||
[(i386-cygwin) (list "-lc")]
|
||||
[else null])
|
||||
|
||||
[current-extension-linker-flags
|
||||
(case mach-id [(rs6k-aix) (list "-lc")] [else null])]
|
||||
[current-standard-link-libraries
|
||||
(case mach-id [(i386-cygwin) (list "-lc")] [else null])])
|
||||
(define (delete/continue x)
|
||||
(with-handlers ([(lambda (x) #t) void])
|
||||
(delete-file x)))
|
||||
|
|
@ -233,22 +215,27 @@
|
|||
(list (list file.so
|
||||
(list file.o)
|
||||
(lambda ()
|
||||
(link-extension #f (append (list file.o)
|
||||
(link-extension
|
||||
#f (append
|
||||
(list file.o)
|
||||
(if is-win?
|
||||
null
|
||||
(map (lambda (l)
|
||||
(string-append "-l" (string-path->string l)))
|
||||
(string-append
|
||||
"-l" (string-path->string l)))
|
||||
(append find-unix-libs unix-libs))))
|
||||
file.so)))
|
||||
|
||||
(list file.o
|
||||
(append (list file.c)
|
||||
(filter (lambda (x)
|
||||
(regexp-match #rx#"mzdyn[a-z0-9]*[.]o"
|
||||
(regexp-match
|
||||
#rx#"mzdyn[a-z0-9]*[.]o"
|
||||
(if (string? x)
|
||||
x
|
||||
(path->string x))))
|
||||
(expand-for-link-variant (current-standard-link-libraries)))
|
||||
(expand-for-link-variant
|
||||
(current-standard-link-libraries)))
|
||||
headers
|
||||
extra-depends)
|
||||
(lambda ()
|
||||
|
|
@ -271,4 +258,4 @@
|
|||
(current-directory)))
|
||||
mz-inc-dir)))))
|
||||
null))
|
||||
#())))))))))))))
|
||||
#())))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user