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

Major cleanup

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/make/collection-sig.ss
View File

@ -1,9 +1,8 @@
#lang mzscheme
(module collection-sig mzscheme (require mzlib/unit)
(require mzlib/unit)
(provide make:collection^) (provide make:collection^)
(define-signature make:collection^
(make-collection)))
(define-signature make:collection^
(make-collection))

84
collects/make/collection-unit.ss
View File

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

27
collects/make/collection.ss
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 (require "make-sig.ss"
dynext/file "make.ss"
compiler/sig "collection-sig.ss"
compiler/compiler "collection-unit.ss")
compiler/option)
(require "make-sig.ss" (define-values/invoke-unit/infer make:collection@)
"make.ss"
"collection-sig.ss"
"collection-unit.ss")
(define-values/invoke-unit/infer make:collection@) (provide-signature-elements make:collection^)
(provide-signature-elements make:collection^))

1
collects/make/make-sig.ss
View File

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

266
collects/make/make-unit.ss
View File

@ -1,167 +1,117 @@
#lang scheme/unit #lang scheme/unit
(require "make-sig.ss") (require "make-sig.ss")
(import) (import)
(export make^) (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-struct line (targets ; (list-of string)
(define make-print-dep-no-line (make-parameter #t)) dependencies ; (list-of string)
(define make-print-reasons (make-parameter #t)) command)) ; (union thunk #f)
(define make-notify-handler (make-parameter void)) (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)) ;; check-spec : TST -> (non-empty-list-of line)
;(define-type spec (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) ;; (union path-string (vector-of path-string) (list-of path-string))
(equal? (if (string? a) (string->path a) a) ;; -> (list-of string)
(if (string? b) (string->path b) b))) ;; throws an error on bad input
(define (path-string->string s) (define (argv->args x)
(if (string? s) (let ([args (cond [(list? x) x]
s [(vector? x) (vector->list x)]
(path->string s))) [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) ;; path-date : path-string -> (union integer #f)
(define (find-matching-line str spec) (define (path-date p)
(let ([match? (lambda (s) (path-string=? s str))]) (and (or (directory-exists? p) (file-exists? p))
(let loop ([lines spec]) (file-or-directory-modify-seconds p)))
(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))))]))))
; form-error : TST TST -> a ;; make/proc :
(define (form-error s p) (error 'make/proc "~a: ~s" s p)) ;; spec (union path-string (vector-of path-string) (list-of path-string))
;; -> void
; line-error : TST TST TST -> a ;; effect : make, according to spec and argv. See docs for details
(define (line-error s p n) (error 'make/proc "~a: ~s for line: ~a" s p n)) (define (make/proc spec [argv '()])
(define made null)
; check-spec : TST -> #t (define lines (spec->lines spec))
; effect : calls error if input is not a spec (define args (argv->args argv))
(define (check-spec spec) (define (make-file s indent)
(and (or (list? spec) (form-error "specification is not a list" spec)) (define line
(or (pair? spec) (form-error "specification is an empty list" spec)) (findf (lambda (line)
(andmap (ormap (lambda (s1) (string=? s s1)) (line-targets line)))
(lambda (line) lines))
(and (or (and (list? line) (<= 2 (length line) 3)) (define date (path-date s))
(form-error "list is not a list with 2 or 3 parts" line)) (when (and (make-print-checking) (or line (make-print-dep-no-line)))
(or (or (path-string? (car line)) (printf "make: ~achecking ~a\n" indent s)
(and (list? (car line)) (flush-output))
(andmap path-string? (car line)))) (if (not line)
(form-error "line does not start with a path/string or list of paths/strings" line)) (unless date (error 'make "don't know how to make ~a" s))
(let ([name (car line)]) (let* ([deps (line-dependencies line)]
(or (list? (cadr line)) [command (line-command line)]
(line-error "second part of line is not a list" (cadr line) name) [indent+ (string-append indent " ")]
(andmap (lambda (dep) [dep-dates (for/list ([d deps])
(or (path-string? dep) (make-file d indent+)
(form-error "dependency item is not a path/string" dep name))) (or (path-date d)
(cadr line))) (error 'make "dependancy ~a was not made\n" d)))]
(or (null? (cddr line)) [reason (or (not date)
(and (procedure? (caddr line)) (ormap (lambda (dep ddate) (and (> ddate date) dep))
(procedure-arity-includes? (caddr line) 0)) deps dep-dates))])
(line-error "command part of line is not a thunk" (caddr line) name))))) (when (and reason command)
spec))) (set! made (cons s made))
((make-notify-handler) s)
; check-spec : TST -> #t (printf "make: ~amaking ~a~a\n"
; effect : calls error if input is not a (union path-string (vector-of path-string)) (if (make-print-checking) indent "")
(define (check-argv argv) s
(or (path-string? argv) (cond [(not (make-print-reasons)) ""]
(and (vector? argv) [(not date) (format " because ~a does not exist" s)]
(andmap path-string? (vector->list argv))) [else (format " because ~a changed" reason)]))
(raise-type-error 'make/proc "path/string or path/string vector" argv))) (flush-output)
(with-handlers ([exn:fail?
; make/proc/helper : spec (union path-string (vector-of path-string)) -> void (lambda (exn)
; effect : make, according to spec and argv. See docs for details (raise (make-exn:fail:make
(define (make/proc/helper spec argv) (format "make: failed to make ~a; ~a"
(check-spec spec) s (exn-message exn))
(check-argv argv) (exn-continuation-marks exn)
(line-targets line)
(letrec ([made null] exn)))])
[make-file (command))))))
(lambda (s indent) (for ([f (if (null? args) (list (car (line-targets (car lines)))) args)])
(let ([line (find-matching-line s spec)] (make-file f ""))
[date (and (or (directory-exists? s) (for ([item (reverse made)]) (printf "make: made ~a\n" item))
(file-exists? s)) (flush-output))
(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)]))

125
collects/make/make.scrbl
View File

@ -17,8 +17,8 @@
@title{@bold{Make}: Dependency Manager} @title{@bold{Make}: Dependency Manager}
The @schememodname[make] library provides a Scheme version of the The @schememodname[make] library provides a Scheme version of the
standard Unix @exec{make} utility. Its syntax is intended to imitate popular @exec{make} utility. Its syntax is intended to imitate the
regular Unix make, but in Scheme. syntax of @exec{make}, only in Scheme.
@table-of-contents[] @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 If you are already familiar with @exec{make}, skip to the precise
details of the @schememodname[make] library in @secref["make"]. This details of the @schememodname[make] library in @secref["make"]. This
section contains a brief overview of @exec{make} for everyone section contains a brief overview of @exec{make} for everyone
else. The idea is to explain how to generate some project you have else.
from a collection of source files that go through several stages of
processing.
For example, let's say that you are writing some project that has When you use @exec{make}, the idea is that you explain how to generate
three input files (that you create and maintain) called files in a project from a collection of source files that go through
@filepath{a.input}, @filepath{b.input}, and several stages of processing.
@filepath{c.input}. Further, there are two stages of processing: first
you run a particular tool @exec{make-output} that takes an input file For example, say that you are writing a project that has three input
and produces and output file, and second you combine the input files files (which you create and maintain) called @filepath{a.input},
into a single file using @filepath{output}. Using @exec{make}, you @filepath{b.input}, and @filepath{c.input}. Further, there are two
might write this: 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]{ @verbatim[#:indent 2]{
a.output: a.input a.output: a.input
@ -54,55 +55,82 @@ b.output: b.input
c.output: c.input c.output: c.input
make-output c.input c.output make-output c.input c.output
total: a.output b.output 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 Once you've put this description in a file called @filepath{Makefile}
@filepath{Makefile} you can issue the command: you can issue the command:
@commandline{make total} @commandline{make total}
that builds your entire project. The @filepath{Makefile} consists of to build your entire project. The @filepath{Makefile} consists of
several lines that tell @exec{make} how to create each piece. The several rules that tell @exec{make} how to create each piece of your
first two lines say that @filepath{a.output} depends on project. For example, the rule that is specified in the first two
@filepath{a.input} and the command for making @filepath{a.output} from lines say that @filepath{a.output} depends on @filepath{a.input} and
@filepath{a.input} is the command for making @filepath{a.output} from @filepath{a.input} is
@commandline{make-output a.input a.output} @commandline{make-output a.input a.output}
The point of using @exec{make} is that it looks at the file creation The main feature of @exec{make} is that it uses the time stamps of
dates of the various files and only re-builds what is necessary. 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 The @schememodname[make] library provides similar functionality,
other hand, you want to build similar things with various Scheme except that the description is in Scheme, and the steps that are
programs, you can use the @schememodname[make] library. 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[ @schemeblock[
(require make) (require make)
(define (make-output in out) (define (make-output in out)
....) ....)
(define (combine-total . args) (define (combine-files . args)
....) ....)
(make (make
(("a.output" ("a.input") (make-output "a.output" "a.input")) (("a.output" ("a.input") (make-output "a.input" "a.output"))
("b.output" ("b.input") (make-output "b.output" "b.input")) ("b.output" ("b.input") (make-output "b.input" "b.output"))
("c.output" ("c.input") (make-output "c.output" "c.input")) ("c.output" ("c.input") (make-output "c.input" "c.output"))
("total" ("a.output" "b.output" "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 If you were to fill in the ellipses above with calls to
@scheme[system], you'd have the exact same thing as the original @scheme[system], you'd have the exact same functionality as the
@filepath{Makefile}. In addition, if you use @scheme[make/proc]], you original @filepath{Makefile}. In addition, you can use
can abstract over the various make lines (for example, the @scheme[make/proc] to abstract over the various lines. For example,
@filepath{a.output}, @filepath{b.output}, and @filepath{c.output} 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 lines are very similar so you can write the code that generates those
those lines). 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[ @schemeblock[
(make/proc (make/proc
(list (list target-expr (list depend-expr ...) (list (list target-expr (list depend-expr ...)
(lambda () command-expr ...)) ...) (lambda () command-expr ...))
argv-expr) ...)
argv-expr)
]} ]}
@defproc[(make/proc [spec (listof @defproc[(make/proc [spec (listof
@ -129,7 +158,8 @@ Expands to
(cons/c (listof path-string?) (cons/c (listof path-string?)
(or/c null? (or/c null?
(list/c (-> any))))))] (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 Performs a make according to @scheme[spec] and using @scheme[argv] as
command-line arguments selecting one or more targets. 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 and wraps them in an @scheme[exn:fail:make] structure, the raises the
resulting structure.} resulting structure.}
@defstruct[(exn:fail:make exn:fail) ([target (or/c path-string? (listof path-string?))] @defstruct[(exn:fail:make exn:fail)
[orig-exn any/c])]{ ([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 target(s), and the @scheme[orig-exn] field is the original raised
value.} value.}
@ -254,7 +285,7 @@ options (see @schememodname[dynext/compile] and
[unix-libs (listof string?)] [unix-libs (listof string?)]
[windows-libs (listof string?)] [windows-libs (listof string?)]
[extra-depends (listof path-string?)] [extra-depends (listof path-string?)]
[last-chance-k ((-> any) . > . any)] [last-chance-k ((-> any) . -> . any)]
[3m-too? any/c #f]) [3m-too? any/c #f])
void?]{ void?]{

80
collects/make/make.ss
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" (define-values/invoke-unit/infer make@)
"make-unit.ss")
(define-values/invoke-unit/infer make@) (provide-signature-elements make^)
(provide-signature-elements make^) (provide make)
(define-syntax make (define-syntax make
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ spec) [(_ spec)
(syntax (make spec #()))] (syntax (make spec #()))]
[(_ spec argv) [(_ spec argv)
(let ([form-error (lambda (s . p) (let ([form-error (lambda (s . p)
(apply raise-syntax-error 'make s stx p))]) (apply raise-syntax-error 'make s stx p))])
(let ([sl (syntax->list (syntax spec))]) (let ([sl (syntax->list (syntax spec))])
(unless (list? sl) (unless (list? sl)
(form-error "illegal specification (not a sequence)")) (form-error "illegal specification (not a sequence)"))
(unless (pair? sl) (unless (pair? sl)
(form-error "empty specification")) (form-error "empty specification"))
(andmap (andmap
(lambda (line) (lambda (line)
(let ([ll (syntax->list line)]) (let ([ll (syntax->list line)])
(unless (and (list? ll) (>= (length ll) 2)) (unless (and (list? ll) (>= (length ll) 2))
(form-error "clause does not have at least 2 parts" line)) (form-error "clause does not have at least 2 parts" line))
(let ([name (car ll)]) (let ([name (car ll)])
(unless (syntax->list (cadr 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"
sl) (cadr ll))))))
(with-syntax ([(line ...) sl)
(map (lambda (line) (with-syntax ([(line ...)
(syntax-case line () (map (lambda (line)
[(target deps) (syntax (list target (list . deps)))] (syntax-case line ()
[(target deps . c) (syntax (list target (list . deps) [(target deps)
(lambda () . c)))])) (syntax (list target (list . deps)))]
sl)]) [(target deps . c)
(syntax (make/proc (syntax (list target (list . deps)
(list line ...) (lambda () . c)))]))
argv)))))]))) sl)])
(syntax (make/proc (list line ...) argv)))))])))
(provide make))

499
collects/make/setup-extension.ss
View File

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