From 2ef6a23b4e30be82794dad93fcc88b18a994e809 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 14 Aug 2008 10:07:14 +0000 Subject: [PATCH] Major cleanup svn: r11237 --- collects/make/collection-sig.ss | 11 +- collects/make/collection-unit.ss | 84 +++-- collects/make/collection.ss | 27 +- collects/make/make-sig.ss | 1 - collects/make/make-unit.ss | 266 +++++++--------- collects/make/make.scrbl | 127 +++++--- collects/make/make.ss | 80 ++--- collects/make/setup-extension.ss | 517 +++++++++++++++---------------- 8 files changed, 534 insertions(+), 579 deletions(-) diff --git a/collects/make/collection-sig.ss b/collects/make/collection-sig.ss index 05e96cf805..01be5c88b0 100644 --- a/collects/make/collection-sig.ss +++ b/collects/make/collection-sig.ss @@ -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)) diff --git a/collects/make/collection-unit.ss b/collects/make/collection-unit.ss index 4e71522cc9..230610a16c 100644 --- a/collects/make/collection-unit.ss +++ b/collects/make/collection-unit.ss @@ -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-cistring 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-cistring 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)))) diff --git a/collects/make/collection.ss b/collects/make/collection.ss index 5716940a56..fceb40b9c1 100644 --- a/collects/make/collection.ss +++ b/collects/make/collection.ss @@ -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^) diff --git a/collects/make/make-sig.ss b/collects/make/make-sig.ss index dc1664a470..6f8601754e 100644 --- a/collects/make/make-sig.ss +++ b/collects/make/make-sig.ss @@ -1,4 +1,3 @@ - #lang scheme/signature make/proc diff --git a/collects/make/make-unit.ss b/collects/make/make-unit.ss index 4936a2ea64..12338e6c2a 100644 --- a/collects/make/make-unit.ss +++ b/collects/make/make-unit.ss @@ -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)) diff --git a/collects/make/make.scrbl b/collects/make/make.scrbl index 19993b7f01..205073f1ce 100644 --- a/collects/make/make.scrbl +++ b/collects/make/make.scrbl @@ -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?]{ diff --git a/collects/make/make.ss b/collects/make/make.ss index d832388d1a..b3314f40c8 100644 --- a/collects/make/make.ss +++ b/collects/make/make.ss @@ -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)))))]))) diff --git a/collects/make/setup-extension.ss b/collects/make/setup-extension.ss index 2c51563776..b307668cb7 100644 --- a/collects/make/setup-extension.ss +++ b/collects/make/setup-extension.ss @@ -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)) + #())))))))