Major cleanup

svn: r11237
This commit is contained in:
Eli Barzilay 2008-08-14 10:07:14 +00:00
parent 2d3dfd9d9e
commit 2ef6a23b4e
8 changed files with 534 additions and 579 deletions

View File

@ -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))

View File

@ -1,52 +1,42 @@
#lang mzscheme
(module collection-unit mzscheme
(require mzlib/unit
mzlib/list
mzlib/file)
(require mzlib/unit
mzlib/list
mzlib/file
"collection-sig.ss"
"make-sig.ss"
compiler/sig
dynext/file-sig)
(require "collection-sig.ss")
(require "make-sig.ss")
(provide make:collection@)
(require compiler/sig
dynext/file-sig)
(define-unit make:collection@
(import make^
dynext:file^
compiler^)
(export make:collection^)
(provide make:collection@)
(define-unit make:collection@
(import make^
dynext:file^
compiler^)
(export make:collection^)
(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))))]
[bases (map (lambda (src)
(extract-base-filename/ss src 'make-collection-extension))
sses)]
[zos (map
(lambda (base)
(build-path
"compiled"
(append-zo-suffix base)))
(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))))]
[bases (map (lambda (src)
(extract-base-filename/ss src
'make-collection-extension))
sses)]
[zos (map (lambda (base)
(build-path "compiled" (append-zo-suffix base)))
bases)]
[ss->zo-list
(map (lambda (ss zo)
`(,zo (,ss)
,(lambda ()
(unless zo-compiler
(set! zo-compiler (compile-zos #f)))
(zo-compiler (list ss) "compiled"))))
sses zos)])
(unless (directory-exists? "compiled") (make-directory "compiled"))
(make/proc
(append
`(("zo" ,zos))
ss->zo-list)
argv)))))
[ss->zo-list
(map (lambda (ss zo)
`(,zo (,ss)
,(lambda ()
(unless zo-compiler
(set! zo-compiler (compile-zos #f)))
(zo-compiler (list ss) "compiled"))))
sses zos)])
(unless (directory-exists? "compiled") (make-directory "compiled"))
(make/proc (append `(("zo" ,zos)) ss->zo-list) argv))))

View File

@ -1,18 +1,17 @@
#lang mzscheme
(module collection mzscheme
(require mzlib/unit)
(require mzlib/unit
dynext/file-sig
dynext/file
compiler/sig
compiler/compiler
compiler/option)
(require dynext/file-sig
dynext/file
compiler/sig
compiler/compiler
compiler/option)
(require "make-sig.ss"
"make.ss"
"collection-sig.ss"
"collection-unit.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^)

View File

@ -1,4 +1,3 @@
#lang scheme/signature
make/proc

View File

@ -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-type line (list (union path-string (list-of path-string)) (list-of path-string) thunk))
;(define-type spec (list-of line))
(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 (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)))
;; 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))))
; 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))))]))))
;; (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)))
; form-error : TST TST -> a
(define (form-error s p) (error 'make/proc "~a: ~s" s p))
;; 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)))
; 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)
(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)
(set! made (cons s made))
((make-notify-handler) s)
(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))])
""))
(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)
(exn-continuation-marks exn)
(current-continuation-marks))
(car 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)]))
;; 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 (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"
(if (make-print-checking) indent "")
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"
s (exn-message exn))
(exn-continuation-marks exn)
(line-targets line)
exn)))])
(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))

View File

@ -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
@ -52,57 +53,84 @@ a.output: a.input
b.output: b.input
make-output b.input b.output
c.output: c.input
make-output c.input c.output
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)
(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)))))
]
@; ----------------------------------------------------------------------
@ -119,9 +147,10 @@ Expands to
@schemeblock[
(make/proc
(list (list target-expr (list depend-expr ...)
(lambda () command-expr ...)) ...)
argv-expr)
(list (list target-expr (list depend-expr ...)
(lambda () command-expr ...))
...)
argv-expr)
]}
@defproc[(make/proc [spec (listof
@ -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?))]
[orig-exn any/c])]{
@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?]{

View File

@ -1,45 +1,45 @@
#lang mzscheme
(module make mzscheme
(require mzlib/unit)
(require mzlib/unit
"make-sig.ss"
"make-unit.ss")
(require "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
(lambda (stx)
(syntax-case stx ()
[(_ spec)
(syntax (make spec #()))]
[(_ spec argv)
(let ([form-error (lambda (s . p)
(apply raise-syntax-error 'make s stx p))])
(let ([sl (syntax->list (syntax spec))])
(unless (list? sl)
(form-error "illegal specification (not a sequence)"))
(unless (pair? sl)
(form-error "empty specification"))
(andmap
(lambda (line)
(let ([ll (syntax->list line)])
(unless (and (list? ll) (>= (length ll) 2))
(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))))))
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)
(lambda () . c)))]))
sl)])
(syntax (make/proc
(list line ...)
argv)))))])))
(provide make)
(provide make))
(define-syntax make
(lambda (stx)
(syntax-case stx ()
[(_ spec)
(syntax (make spec #()))]
[(_ spec argv)
(let ([form-error (lambda (s . p)
(apply raise-syntax-error 'make s stx p))])
(let ([sl (syntax->list (syntax spec))])
(unless (list? sl)
(form-error "illegal specification (not a sequence)"))
(unless (pair? sl)
(form-error "empty specification"))
(andmap
(lambda (line)
(let ([ll (syntax->list line)])
(unless (and (list? ll) (>= (length ll) 2))
(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))))))
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)
(lambda () . c)))]))
sl)])
(syntax (make/proc (list line ...) argv)))))])))

View File

@ -1,274 +1,261 @@
#lang mzscheme
(module setup-extension mzscheme
(require make
dynext/link
dynext/compile
dynext/file
mzlib/file
mzlib/list
mzlib/etc
launcher
compiler/xform
setup/dirs)
(provide pre-install
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)])
body0 body ...)]))
(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)
(if (string? s) s (path->string s)))
(define pre-install
(opt-lambda (main-collects-parent-dir
collection-dir
file.c
default-lib-dir
include-subdirs
find-unix-libs
find-windows-libs
unix-libs
windows-libs
extra-depends
last-chance-k
[3m-too? #f])
;; Compile and link one file:
(define (go file.c xform-src.c)
(pre-install/check-precompiled main-collects-parent-dir
collection-dir
file.c
default-lib-dir
include-subdirs
find-unix-libs
find-windows-libs
unix-libs
windows-libs
extra-depends
last-chance-k
xform-src.c))
(define avail (available-mzscheme-variants))
(require make
dynext/link
dynext/compile
dynext/file
mzlib/file
mzlib/list
mzlib/etc
launcher
compiler/xform
setup/dirs)
;; Maybe do CGC mode:
(when (or (memq 'cgc avail)
(and (memq 'normal avail)
(eq? 'cgc (system-type 'gc))))
(parameterize ([link-variant 'cgc])
(go file.c #f)))
;; Maybe do 3m mode:
(when (and 3m-too?
(or (memq '3m avail)
(and (memq 'normal avail)
(eq? '3m (system-type 'gc)))))
(parameterize ([link-variant '3m])
(let ([3m-dir (build-path collection-dir
"compiled" "native"
(system-library-subpath '3m))])
(provide pre-install)
;; Syntax used to add a command-line flag:
(define-syntax with-new-flags
(syntax-rules ()
[(_ ([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))])
name))
(define (string-path->string s)
(if (string? s) s (path->string s)))
(define pre-install
(opt-lambda (main-collects-parent-dir
collection-dir
file.c
default-lib-dir
include-subdirs
find-unix-libs
find-windows-libs
unix-libs
windows-libs
extra-depends
last-chance-k
[3m-too? #f])
;; Compile and link one file:
(define (go file.c xform-src.c)
(pre-install/check-precompiled main-collects-parent-dir
collection-dir
file.c
default-lib-dir
include-subdirs
find-unix-libs
find-windows-libs
unix-libs
windows-libs
extra-depends
last-chance-k
xform-src.c))
(define avail (available-mzscheme-variants))
;; Maybe do CGC mode:
(when (or (memq 'cgc avail)
(and (memq 'normal avail)
(eq? 'cgc (system-type 'gc))))
(parameterize ([link-variant 'cgc])
(go file.c #f)))
;; Maybe do 3m mode:
(when (and 3m-too?
(or (memq '3m avail)
(and (memq 'normal avail)
(eq? '3m (system-type 'gc)))))
(parameterize ([link-variant '3m])
(let ([3m-dir (build-path collection-dir
"compiled" "native"
(system-library-subpath '3m))])
(make-directory* 3m-dir)
(go (build-path 3m-dir (let-values ([(base name dir?) (split-path file.c)])
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")]
[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"
variant-dir)]
[dest-file.so (build-path dest-dir (append-extension-suffix base-file))])
(make-directory* dest-dir)
(printf " Copying ~a~n to ~a~n" file.so dest-file.so)
(when (file-exists? dest-file.so)
(delete-file dest-file.so))
(copy-file file.so dest-file.so))
;; Normal build...
(apply pre-install/normal main-collects-parent-dir collection-dir file.c rest))))
(define (pre-install/normal main-collects-parent-dir
collection-dir
file.c
default-lib-dir
include-subdirs
find-unix-libs
find-windows-libs
unix-libs
windows-libs
extra-depends
last-chance-k
xform-src.c)
(parameterize ([current-directory collection-dir])
(define mach-id (string->symbol (path->string (system-library-subpath #f))))
(define is-win? (eq? mach-id 'win32\\i386))
(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"
variant-dir)]
[dest-file.so (build-path dest-dir (append-extension-suffix base-file))])
(make-directory* dest-dir)
(printf " Copying ~a~n to ~a~n" file.so dest-file.so)
(when (file-exists? dest-file.so)
(delete-file dest-file.so))
(copy-file file.so dest-file.so))
;; Normal build...
(apply pre-install/normal main-collects-parent-dir collection-dir file.c rest))))
(define (pre-install/normal main-collects-parent-dir
collection-dir
file.c
default-lib-dir
include-subdirs
find-unix-libs
find-windows-libs
unix-libs
windows-libs
extra-depends
last-chance-k
xform-src.c)
(parameterize ([current-directory collection-dir])
(define mach-id (string->symbol (path->string (system-library-subpath #f))))
(define is-win? (eq? mach-id 'win32\\i386))
;; We look for libraries and includes in the
;; following places:
(define search-path
(append
(let ([v (getenv "PLT_EXTENSION_LIB_PATHS")])
(if v
(path-list-string->path-list v (list default-lib-dir))
(list default-lib-dir)))
(list "/usr"
"/usr/local"
"/usr/local/gnu"
;; OS X fink location:
"/sw"
;; OS X DarwinPorts location:
"/opt/local"
;; Hack for NU PLT's convenience:
"/arch/gnu/packages/readline-4.2")))
(define sys-path
(ormap (lambda (x)
(and (andmap
(lambda (sub)
(directory-exists? (build-path x "include" sub)))
include-subdirs)
(andmap (lambda (lib)
(ormap (lambda (suffix)
(file-exists?
(build-path x
"lib"
(format "~a~a.~a"
(if is-win?
""
"lib")
lib
suffix))))
'("a" "so" "dylib" "lib")))
(if is-win?
find-windows-libs
find-unix-libs))
(if (string? x)
(string->path x)
x)))
search-path))
(unless sys-path
(error 'extension-installer
"can't find needed include files and/or library; try setting the environment variable PLT_EXTENSION_LIB_PATHS"))
(parameterize ([make-print-checking #f])
;; We look for libraries and includes in the
;; following places:
(define search-path
(append
(let ([v (getenv "PLT_EXTENSION_LIB_PATHS")])
(if v
(path-list-string->path-list v (list default-lib-dir))
(list default-lib-dir)))
(list "/usr"
"/usr/local"
"/usr/local/gnu"
;; OS X fink location:
"/sw"
;; OS X DarwinPorts location:
"/opt/local"
;; Hack for NU PLT's convenience:
"/arch/gnu/packages/readline-4.2")))
;; Used as make dependencies:
(define mz-inc-dir (find-include-dir))
(define headers (map (lambda (name)
(build-path mz-inc-dir name))
'("scheme.h" "schvers.h" "schemef.h" "sconfig.h" "stypes.h")))
(define sys-path
(ormap (lambda (x)
(and (andmap
(lambda (sub)
(directory-exists? (build-path x "include" sub)))
include-subdirs)
(andmap (lambda (lib)
(ormap (lambda (suffix)
(file-exists?
(build-path x
"lib"
(format "~a~a.~a"
(if is-win?
""
"lib")
lib
suffix))))
'("a" "so" "dylib" "lib")))
(if is-win?
find-windows-libs
find-unix-libs))
(if (string? x)
(string->path x)
x)))
search-path))
(define dir (build-path "compiled" "native" (system-library-subpath (link-variant))))
(define base-file (string-append (path-element->string (extract-base-filename file.c))
"_ss"))
(define file.so (build-path dir (append-extension-suffix base-file)))
(define file.o (build-path dir (append-object-suffix base-file)))
(unless sys-path
(error 'extension-installer
"can't find needed include files and/or library; try setting the environment variable PLT_EXTENSION_LIB_PATHS"))
(parameterize ([make-print-checking #f])
;; Used as make dependencies:
(define mz-inc-dir (find-include-dir))
(define headers (map (lambda (name)
(build-path mz-inc-dir name))
'("scheme.h" "schvers.h" "schemef.h" "sconfig.h" "stypes.h")))
(define dir (build-path "compiled" "native" (system-library-subpath (link-variant))))
(define base-file (string-append (path-element->string (extract-base-filename file.c))
"_ss"))
(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"))
;; Add -L and -l for Unix:
(with-new-flags
current-extension-linker-flags
(if is-win?
null
(list (format "-L~a/lib" (path->string sys-path))))
;; Add libs for Windows:
(with-new-flags
current-standard-link-libraries
(if is-win?
(append (map
(lambda (l)
(build-path sys-path "lib" (format "~a.lib" l)))
find-windows-libs)
windows-libs)
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])
(define (delete/continue x)
(with-handlers ([(lambda (x) #t) void])
(delete-file x)))
(make-directory* dir)
(last-chance-k
(lambda ()
(make/proc
(append
(list (list file.so
(list file.o)
(lambda ()
(link-extension #f (append (list file.o)
(if is-win?
null
(map (lambda (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"
(if (string? x)
x
(path->string x))))
(expand-for-link-variant (current-standard-link-libraries)))
headers
extra-depends)
(lambda ()
(compile-extension #f file.c file.o null))))
(if xform-src.c
(list (list file.c
(append (list xform-src.c)
headers
extra-depends)
(lambda ()
(xform #f
(if (path? xform-src.c)
(path->string xform-src.c)
xform-src.c)
file.c
(list (let-values ([(base name dir?)
(split-path xform-src.c)])
(if (path? base)
base
(current-directory)))
mz-inc-dir)))))
null))
#())))))))))))))
(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:
[current-extension-linker-flags
(if is-win?
null
(list (format "-L~a/lib" (path->string sys-path))))]
;; Add libs for Windows:
[current-standard-link-libraries
(if is-win?
(append (map
(lambda (l)
(build-path sys-path "lib"
(format "~a.lib" l)))
find-windows-libs)
windows-libs)
null)]
;; Extra stuff:
[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)))
(make-directory* dir)
(last-chance-k
(lambda ()
(make/proc
(append
(list (list file.so
(list file.o)
(lambda ()
(link-extension
#f (append
(list file.o)
(if is-win?
null
(map (lambda (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"
(if (string? x)
x
(path->string x))))
(expand-for-link-variant
(current-standard-link-libraries)))
headers
extra-depends)
(lambda ()
(compile-extension #f file.c file.o null))))
(if xform-src.c
(list (list file.c
(append (list xform-src.c)
headers
extra-depends)
(lambda ()
(xform #f
(if (path? xform-src.c)
(path->string xform-src.c)
xform-src.c)
file.c
(list (let-values ([(base name dir?)
(split-path xform-src.c)])
(if (path? base)
base
(current-directory)))
mz-inc-dir)))))
null))
#())))))))