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

127
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
@ -52,57 +53,84 @@ a.output: a.input
b.output: b.input b.output: b.input
make-output b.input b.output make-output b.input b.output
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^)
(define-syntax make (provide 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)) (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)))))])))

517
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
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))
;; Maybe do CGC mode: (provide pre-install)
(when (or (memq 'cgc avail)
(and (memq 'normal avail) ;; Syntax used to add a command-line flag:
(eq? 'cgc (system-type 'gc)))) (define-syntax with-new-flags
(parameterize ([link-variant 'cgc]) (syntax-rules ()
(go file.c #f))) [(_ ([param flags] ...) body0 body ...)
;; Maybe do 3m mode: (parameterize* ([param (append (param) flags)] ...)
(when (and 3m-too? body0 body ...)]))
(or (memq '3m avail)
(and (memq 'normal avail) (define (extract-base-filename file.c)
(eq? '3m (system-type 'gc))))) (let-values ([(base name dir?)
(parameterize ([link-variant '3m]) (split-path (extract-base-filename/c file.c 'pre-install))])
(let ([3m-dir (build-path collection-dir name))
"compiled" "native"
(system-library-subpath '3m))]) (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) (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... (define (pre-install/normal main-collects-parent-dir
(apply pre-install/normal main-collects-parent-dir collection-dir file.c rest)))) collection-dir
file.c
(define (pre-install/normal main-collects-parent-dir default-lib-dir
collection-dir include-subdirs
file.c find-unix-libs
default-lib-dir find-windows-libs
include-subdirs unix-libs
find-unix-libs windows-libs
find-windows-libs extra-depends
unix-libs last-chance-k
windows-libs xform-src.c)
extra-depends (parameterize ([current-directory collection-dir])
last-chance-k (define mach-id (string->symbol (path->string (system-library-subpath #f))))
xform-src.c) (define is-win? (eq? mach-id 'win32\\i386))
(parameterize ([current-directory collection-dir])
(define mach-id (string->symbol (path->string (system-library-subpath #f)))) ;; We look for libraries and includes in the
(define is-win? (eq? mach-id 'win32\\i386)) ;; 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 ;; Used as make dependencies:
;; following places: (define mz-inc-dir (find-include-dir))
(define search-path (define headers (map (lambda (name)
(append (build-path mz-inc-dir name))
(let ([v (getenv "PLT_EXTENSION_LIB_PATHS")]) '("scheme.h" "schvers.h" "schemef.h" "sconfig.h" "stypes.h")))
(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 (define dir (build-path "compiled" "native" (system-library-subpath (link-variant))))
(ormap (lambda (x) (define base-file (string-append (path-element->string (extract-base-filename file.c))
(and (andmap "_ss"))
(lambda (sub) (define file.so (build-path dir (append-extension-suffix base-file)))
(directory-exists? (build-path x "include" sub))) (define file.o (build-path dir (append-object-suffix base-file)))
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 (with-new-flags ([current-extension-compiler-flags
(error 'extension-installer ((current-make-compile-include-strings)
"can't find needed include files and/or library; try setting the environment variable PLT_EXTENSION_LIB_PATHS")) (build-path sys-path "include"))]
[current-extension-preprocess-flags
(parameterize ([make-print-checking #f]) ((current-make-compile-include-strings)
(build-path sys-path "include"))]
;; Used as make dependencies: ;; Add -L and -l for Unix:
(define mz-inc-dir (find-include-dir)) [current-extension-linker-flags
(define headers (map (lambda (name) (if is-win?
(build-path mz-inc-dir name)) null
'("scheme.h" "schvers.h" "schemef.h" "sconfig.h" "stypes.h"))) (list (format "-L~a/lib" (path->string sys-path))))]
;; Add libs for Windows:
(define dir (build-path "compiled" "native" (system-library-subpath (link-variant)))) [current-standard-link-libraries
(define base-file (string-append (path-element->string (extract-base-filename file.c)) (if is-win?
"_ss")) (append (map
(define file.so (build-path dir (append-extension-suffix base-file))) (lambda (l)
(define file.o (build-path dir (append-object-suffix base-file))) (build-path sys-path "lib"
(format "~a.lib" l)))
(with-new-flags find-windows-libs)
current-extension-compiler-flags windows-libs)
((current-make-compile-include-strings) (build-path sys-path "include")) null)]
;; Extra stuff:
(with-new-flags [current-extension-linker-flags
current-extension-preprocess-flags (case mach-id [(rs6k-aix) (list "-lc")] [else null])]
((current-make-compile-include-strings) (build-path sys-path "include")) [current-standard-link-libraries
(case mach-id [(i386-cygwin) (list "-lc")] [else null])])
;; Add -L and -l for Unix: (define (delete/continue x)
(with-new-flags (with-handlers ([(lambda (x) #t) void])
current-extension-linker-flags (delete-file x)))
(if is-win?
null (make-directory* dir)
(list (format "-L~a/lib" (path->string sys-path))))
(last-chance-k
;; Add libs for Windows: (lambda ()
(with-new-flags (make/proc
current-standard-link-libraries (append
(if is-win? (list (list file.so
(append (map (list file.o)
(lambda (l) (lambda ()
(build-path sys-path "lib" (format "~a.lib" l))) (link-extension
find-windows-libs) #f (append
windows-libs) (list file.o)
null) (if is-win?
null
;; Extra stuff: (map (lambda (l)
(with-new-flags (string-append
current-extension-linker-flags "-l" (string-path->string l)))
(case mach-id (append find-unix-libs unix-libs))))
[(rs6k-aix) (list "-lc")] file.so)))
[else null])
(list file.o
(with-new-flags (append (list file.c)
current-standard-link-libraries (filter (lambda (x)
(case mach-id (regexp-match
[(i386-cygwin) (list "-lc")] #rx#"mzdyn[a-z0-9]*[.]o"
[else null]) (if (string? x)
x
(define (delete/continue x) (path->string x))))
(with-handlers ([(lambda (x) #t) void]) (expand-for-link-variant
(delete-file x))) (current-standard-link-libraries)))
headers
(make-directory* dir) extra-depends)
(lambda ()
(last-chance-k (compile-extension #f file.c file.o null))))
(lambda () (if xform-src.c
(make/proc (list (list file.c
(append (append (list xform-src.c)
(list (list file.so headers
(list file.o) extra-depends)
(lambda () (lambda ()
(link-extension #f (append (list file.o) (xform #f
(if is-win? (if (path? xform-src.c)
null (path->string xform-src.c)
(map (lambda (l) xform-src.c)
(string-append "-l" (string-path->string l))) file.c
(append find-unix-libs unix-libs)))) (list (let-values ([(base name dir?)
file.so))) (split-path xform-src.c)])
(if (path? base)
(list file.o base
(append (list file.c) (current-directory)))
(filter (lambda (x) mz-inc-dir)))))
(regexp-match #rx#"mzdyn[a-z0-9]*[.]o" null))
(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))
#())))))))))))))