526 lines
23 KiB
Scheme
Executable File
526 lines
23 KiB
Scheme
Executable File
#!/bin/env racket
|
|
;; -*- scheme -*-
|
|
|
|
#lang racket/base
|
|
|
|
(require racket/cmdline racket/runtime-path racket/match racket/promise
|
|
racket/list ; for use in specs too
|
|
racket/string
|
|
racket/file (only-in racket/system system)
|
|
(except-in compatibility/mlist mappend)
|
|
meta/checker (prefix-in dist: meta/dist-specs) meta/specs)
|
|
|
|
(define (/-ify x)
|
|
(regexp-replace #rx"/?$" (if (path? x) (path->string x) x) "/"))
|
|
(define home/ (/-ify (expand-user-path "~scheme")))
|
|
(define binaries/ (/-ify (build-path home/ "binaries")))
|
|
(define target/ (/-ify (build-path home/ "pre-installers")))
|
|
(define racket/ (/-ify (or (getenv "PLTHOME")
|
|
(error 'bundle "PLTHOME is not defined"))))
|
|
(define racket-base/ (/-ify (simplify-path (build-path racket/ 'up) #f)))
|
|
(define racket/-name (let-values ([(base name dir?) (split-path racket/)])
|
|
(path-element->string name)))
|
|
|
|
(define cd current-directory)
|
|
|
|
(define *readme-file*
|
|
(build-path racket/ "README"))
|
|
(define *info-domain-file*
|
|
(build-path racket/ "collects" "info-domain" "compiled" "cache.rktd"))
|
|
|
|
(define *readme-cache* #f)
|
|
(define *info-domain-cache* #f)
|
|
|
|
(define-runtime-path *spec-file* "distribution-specs")
|
|
|
|
(define *verify?* #t)
|
|
(define *btgz?* #t)
|
|
(define *pack?* #t)
|
|
(define *release?* #f)
|
|
(define *verbose?* 'yes) ; #t, #f, or else -- show stderr stuff but not stdout
|
|
|
|
;;; ===========================================================================
|
|
;;; Utilities etc
|
|
|
|
(define concat string-append)
|
|
|
|
(define (sort* l)
|
|
(sort l string<?))
|
|
|
|
(define (dir-list . args)
|
|
(sort* (map path->string (apply directory-list args))))
|
|
|
|
(define (dprintf fmt . args)
|
|
(when *verbose?*
|
|
(apply fprintf (current-error-port) fmt args)
|
|
(flush-output (current-error-port))))
|
|
|
|
;;; ===========================================================================
|
|
;;; Tree utilities
|
|
|
|
;; path -> tree
|
|
;; Same as get-tree, but lists the contents of a tgz file via tar.
|
|
(define (get-tgz-tree tgz)
|
|
(define base (regexp-replace #rx"/$" (path->string (cd)) ""))
|
|
(define tgz-name
|
|
(regexp-replace #rx"^.*/" (if (path? tgz) (path->string tgz) tgz) ""))
|
|
(define (tree+rest paths curdir)
|
|
(define cur-rx (regexp (concat "^" (regexp-quote curdir))))
|
|
(define m
|
|
(let ([m (and (pair? paths)
|
|
(regexp-match-positions cur-rx (car paths)))])
|
|
(and m (regexp-match-positions #rx"/.*/" (car paths) (cdar m)))))
|
|
(if m
|
|
;; we have too many "/"s => need to reconstruct a fake intermediate dir
|
|
(tree+rest (cons (substring (car paths) 0 (add1 (caar m))) paths) curdir)
|
|
(let loop ([paths paths] [contents '()])
|
|
(when (pair? paths)
|
|
(prop-set! (car paths) 'tgz tgz-name)
|
|
(prop-set! (car paths) 'base base)
|
|
(prop-set!
|
|
(car paths) 'name
|
|
(cond [(regexp-match #rx"^(?:.*/)?([^/]+)/?$" (car paths)) => cadr]
|
|
[else (error 'get-tgz-tree
|
|
"bad path name: ~s" (car paths))])))
|
|
(if (and (pair? paths) (regexp-match? cur-rx (car paths)))
|
|
;; still in the same subtree
|
|
(if (regexp-match? #rx"/$" (car paths))
|
|
;; new directory
|
|
(let-values ([(tree rest) (tree+rest (cdr paths) (car paths))])
|
|
(loop rest (cons tree contents)))
|
|
;; new file
|
|
(loop (cdr paths) (cons (car paths) contents)))
|
|
;; in a new subtree
|
|
(values (cons curdir (reverse contents)) paths)))))
|
|
(define-values (p pout pin perr)
|
|
(subprocess #f /dev/null-in (current-error-port) /tar "tzf" tgz))
|
|
(parameterize ([current-input-port pout])
|
|
(let loop ([lines '()])
|
|
(let ([line (read-line)])
|
|
(if (eof-object? line)
|
|
(let ([paths (sort* (reverse lines))])
|
|
(subprocess-wait p)
|
|
(unless (eq? 0 (subprocess-status p))
|
|
(error 'get-tgz-tree "`tar' failed."))
|
|
(let-values ([(tree rest) (tree+rest paths "")])
|
|
(if (null? rest)
|
|
(cdr tree)
|
|
(error 'get-tgz-tree "something bad happened (~s...)"
|
|
(car paths)))))
|
|
(loop (cons line lines)))))))
|
|
|
|
;;; ===========================================================================
|
|
;;; Start working
|
|
|
|
(register-macros!)
|
|
|
|
(define *platforms* #f)
|
|
(define *bin-types* #f)
|
|
(define *src-types* #f)
|
|
(define *platform-tree-lists* #f)
|
|
(define /pax #f)
|
|
(define /tar #f)
|
|
(define /fakeroot #f)
|
|
(define /dev/null-out #f)
|
|
(define /dev/null-in #f)
|
|
|
|
(define (process-command-line)
|
|
(command-line
|
|
#:multi
|
|
["+d" "Verify dependencies (default)" (set! *verify?* #t)]
|
|
["-d" "Don't verify dependencies" (set! *verify?* #f)]
|
|
["+v" "Verbose mode (on stdout)" (set! *verbose?* #t)]
|
|
["-v" "Normal output (only stderr) (default)" (set! *verbose?* 'yes)]
|
|
["-q" "Quiet mode" (set! *verbose?* #f)]
|
|
["+b" "Create binary tgzs (default)" (set! *btgz?* #t)]
|
|
["-b" "Skip binary tgzs, re-use binary trees" (set! *btgz?* #f)]
|
|
["+p" "Pack distributions (default)" (set! *pack?* #t)]
|
|
["-p" "Skip packing" (set! *pack?* #f)]
|
|
["++release" "Build for a release" (set! *release?* #t)]
|
|
["-o" dest "Destination directory" (set! target/ (/-ify dest))]
|
|
["--text" "Stands for -d +v -b -p -r (useful for debugging)"
|
|
(set!-values (*verify?* *verbose?* *btgz?* *pack?*) (values #f #t #f #f))])
|
|
(current-verbose-port (and *verbose?* current-error-port)))
|
|
|
|
;; specs can have `lambda' expressions to evaluate, do it in this context
|
|
(define-namespace-anchor bundle-specs)
|
|
|
|
(define (read-spec-file file [param *specs*])
|
|
(process-specs
|
|
(with-input-from-file file
|
|
(lambda ()
|
|
(let loop ([xs '()])
|
|
(let ([x (read)])
|
|
(if (eof-object? x) (reverse xs) (loop (cons x xs)))))))
|
|
param))
|
|
|
|
(define (read-specs)
|
|
(current-namespace (namespace-anchor->namespace bundle-specs))
|
|
(dprintf "Reading specs...")
|
|
(dist:register-specs!)
|
|
(dprintf " done.\n"))
|
|
|
|
(define (input-tgz-name? f)
|
|
(let ([f (if (path? f) (path->string f) f)])
|
|
;; names of tgzs that are not the generated binary ones
|
|
(and (regexp-match? #rx"\\.tgz$" f)
|
|
(not (regexp-match? #rx"-binaries\\.tgz$" f)))))
|
|
|
|
(define (initialize)
|
|
(when *release?* (*environment* (cons 'release (*environment*))))
|
|
(define (find-exe name)
|
|
(path->string
|
|
(or (find-executable-path name #f)
|
|
(error (format "error: couldn't find a `~a' executable" name)))))
|
|
(set! /pax (find-exe "pax"))
|
|
(set! /tar (find-exe "gtar"))
|
|
(set! /fakeroot (find-exe "fakeroot"))
|
|
(set! /dev/null-out (open-output-file "/dev/null" #:exists 'append))
|
|
(set! /dev/null-in (open-input-file "/dev/null"))
|
|
(unless (directory-exists? target/) (make-directory target/))
|
|
(let ([d (ormap (lambda (x) (and (not (directory-exists? x)) x))
|
|
(list home/ racket/ binaries/ target/))])
|
|
(when d (error 'bundle "directory not found: ~a" d)))
|
|
(set! *platforms*
|
|
(parameterize ([cd binaries/])
|
|
(filter (lambda (x)
|
|
(and (not (regexp-match? #rx"^[.]" x))
|
|
(directory-exists? x)))
|
|
(dir-list))))
|
|
(set! *bin-types* (map string->symbol *platforms*))
|
|
(set! *src-types*
|
|
(let loop ([bins *bin-types*] [r '()])
|
|
(if (null? bins)
|
|
(reverse r)
|
|
(let* ([bin (car bins)] [src (get-tag bin)])
|
|
(cond
|
|
[(not src) (error 'binaries "no type assigned to `~.s'" bin)]
|
|
[(not (= 1 (length src)))
|
|
(error 'binaries "bad type assignment for `~.s': ~.s" bin src)]
|
|
[else (loop (cdr bins)
|
|
(if (memq (car src) r) r (cons (car src) r)))])))))
|
|
(dprintf "Scanning full tgzs")
|
|
(set! *platform-tree-lists*
|
|
(parameterize ([cd binaries/])
|
|
(map (lambda (platform)
|
|
(dprintf ".")
|
|
(parameterize ([cd platform])
|
|
;; if no btgz *and* "racket" already created then use
|
|
;; get-tree (useful when debugging stuff so re-use pre made
|
|
;; ones) should work the same with an old tree
|
|
(if (and (directory-exists? "racket") (not *btgz?*))
|
|
(filtered-map
|
|
(lambda (x) ; only directories contain stuff we need
|
|
(and (directory-exists? x) (get-tree x "racket")))
|
|
(dir-list))
|
|
(let ([trees (filtered-map
|
|
(lambda (x)
|
|
(and (file-exists? x) (input-tgz-name? x)
|
|
(get-tgz-tree x)))
|
|
(dir-list))])
|
|
(tag (list (string->symbol platform))
|
|
(map (lambda (tree) (tree-filter 'binaries tree))
|
|
(apply append trees)))))))
|
|
*platforms*)))
|
|
(dprintf " done.\n")
|
|
(for-each (lambda (platform trees)
|
|
(when (null? trees)
|
|
(error 'binaries "no binaries found for ~s" platform)))
|
|
*platforms* *platform-tree-lists*)
|
|
;; Get the racket tree, remove junk and binary stuff
|
|
(set-racket-tree! racket/ racket-base/ racket/-name *platform-tree-lists*)
|
|
(set-bin-files-delayed-lists!
|
|
(delay (map (lambda (trees)
|
|
(sort* (mappend tree-flatten (add-trees trees))))
|
|
*platform-tree-lists*))))
|
|
|
|
(define (make-info-domain trees)
|
|
(unless (= 1 (length trees))
|
|
(error 'make-info-domain "got zero or multiple trees: ~e" trees))
|
|
(let* ([collects (or (tree-filter "/racket/collects/" (car trees))
|
|
(error 'make-info-domain "got no collects in tree"))]
|
|
[info (filter (lambda (x)
|
|
(define p (car x))
|
|
(unless (and (list? p)
|
|
((length p) . >= . 2)
|
|
(eq? 'info (car p))
|
|
(andmap bytes? (cdr p)))
|
|
(error 'bundle "unexpected path form in cache.rktd: ~e" p))
|
|
(let ([x (string-join (map bytes->string/utf-8 (cdr p)) "/")])
|
|
(pair? (tree-filter (concat "/racket/collects/" x)
|
|
collects))))
|
|
*info-domain-cache*)])
|
|
(lambda () (write info) (newline))))
|
|
|
|
(define readme-skeleton
|
|
(delay (let ([m (regexp-match #rx"^(.*?\n====+\n)\n*(.*)$" *readme-cache*)])
|
|
;; title, rest (without generic source reference)
|
|
(if m
|
|
(list (cadr m)
|
|
(regexp-replace #rx"\nInstructions for building[^\n]*\n"
|
|
(caddr m)
|
|
""))
|
|
(error 'readme-skeleton "unexpected toplevel README")))))
|
|
(define (make-readme)
|
|
(for-each
|
|
;; convert to CRLF on Windows
|
|
(if (memq 'win (*environment*))
|
|
(lambda (x) (display (regexp-replace* #rx"\r?\n" x "\r\n")))
|
|
display)
|
|
`(,(car (force readme-skeleton))
|
|
"\n"
|
|
,@(expand-spec 'readme-header)
|
|
"\n"
|
|
,(cadr (force readme-skeleton)))))
|
|
|
|
(define (create-binaries platform trees)
|
|
(parameterize ([cd (build-path binaries/ platform)])
|
|
(let ([full-tgz (concat "racket-"platform"-full.tgz")]
|
|
[bin-tgz (concat "racket-"platform"-binaries.tgz")]
|
|
[all-tgzs (filter input-tgz-name?
|
|
(map path->string (directory-list)))])
|
|
(unless (and (directory-exists? "racket") (not *btgz?*))
|
|
(dprintf "Unpacking binaries in ~s ~a\n" platform all-tgzs)
|
|
;; even if a "racket" directory exists, we just overwrite the same
|
|
;; stuff
|
|
(unless (member full-tgz all-tgzs)
|
|
(error 'create-binaries "~a/~a not found" (cd) full-tgz))
|
|
(for ([tgz all-tgzs]) (unpack tgz trees)))
|
|
(when *btgz?*
|
|
(dprintf "Creating ~s\n" bin-tgz)
|
|
(when (file-exists? bin-tgz) (delete-file bin-tgz))
|
|
(let-values ([(p pout pin perr)
|
|
(subprocess
|
|
(current-output-port) /dev/null-in (current-error-port)
|
|
/fakeroot "--"
|
|
;; see below for flag explanations
|
|
/pax "-w" "-x" "ustar" "-z" "-f" bin-tgz
|
|
;; only pack the racket dir (only exception is Libraries
|
|
;; on OSX, but that has its own dir)
|
|
"racket")])
|
|
(subprocess-wait p))))))
|
|
|
|
(define (pack archive trees prefix)
|
|
;; `pax' is used to create the tgz archives -- the main reasons for using it
|
|
;; is the fact that it can generate portable "ustar" tar files, and that it
|
|
;; is flexible enough to allow replacing file names, so we can collect files
|
|
;; from different directories and make them all appear in a single one in the
|
|
;; resulting archive.
|
|
(when (eq? #t *verbose?*) (printf "~a:\n" archive))
|
|
(cond [*pack?*
|
|
(dprintf " packing...")
|
|
(when (file-exists? archive) (delete-file archive))
|
|
(let*-values ([(output) (if (eq? #t *verbose?*)
|
|
(current-output-port) /dev/null-out)]
|
|
[(p pout pin perr)
|
|
;; Note: pax prints converted paths on stderr, so
|
|
;; silence it too unless verbose. Use only for
|
|
;; debugging.
|
|
(subprocess
|
|
output #f output
|
|
/fakeroot "--"
|
|
/pax
|
|
"-w" ; write
|
|
"-x" "ustar" ; create a POSIX ustar format
|
|
"-z" ; gzip the archive
|
|
"-d" ; dont go down directories implicitly
|
|
"-s" (format ",^~a,,p" prefix) ; delete base paths
|
|
"-f" archive ; pack to this file
|
|
)])
|
|
(parameterize ([current-output-port pin])
|
|
(for ([t trees]) (print-tree t 'full)))
|
|
(close-output-port pin)
|
|
(subprocess-wait p)
|
|
(unless (eq? 0 (subprocess-status p))
|
|
(error 'pack "`pax' failed.")))]
|
|
[(eq? #t *verbose?*) (for ([t trees]) (print-tree t))])
|
|
(when (eq? #t *verbose?*) (newline))
|
|
(flush-output))
|
|
|
|
(define (unpack archive trees)
|
|
;; unpack using tar (doesn't look like there's a way to unpack according to
|
|
;; files from stdin with pax, and it uses gnu format with @LongLinks).
|
|
(let-values
|
|
([(p pout pin perr)
|
|
(subprocess
|
|
(current-output-port) #f (current-error-port) /tar
|
|
"x" ; extract
|
|
"-z" ; gunzip the archive
|
|
"-p" ; preserve permissions
|
|
"--files-from=-" ; read files from stdin
|
|
"-f" archive ; unpack this file
|
|
)]
|
|
[(trees)
|
|
(map (lambda (t)
|
|
(tree-filter
|
|
(lambda (t)
|
|
;; Problem: if this returns #t/#f only, then the sources can
|
|
;; come from multiple tgz since each file will be identified
|
|
;; by itself. But if this is done, then no empty directories
|
|
;; will be included (see `tree-filter' comment) and this will
|
|
;; later be a problem (to have an empty dir in the tree but
|
|
;; not on disk) -- so return '+ and as soon as a root is
|
|
;; identified with the tgz, all of it will be used.
|
|
(and
|
|
(equal? archive
|
|
(prop-get (tree-path t) 'tgz
|
|
(lambda ()
|
|
(error 'unpack
|
|
"no `tgz' property for ~e" t))))
|
|
'+))
|
|
t))
|
|
trees)])
|
|
(parameterize ([current-output-port pin])
|
|
(for ([t trees]) (print-tree t 'only-files)))
|
|
(close-output-port pin)
|
|
(subprocess-wait p)
|
|
(unless (eq? 0 (subprocess-status p)) (error 'unpack "`tar' failed."))))
|
|
|
|
;; This code implements the binary filtering of 3m/cgc files, see
|
|
;; `binary-keep/throw-templates' in "distribution-specs.ss".
|
|
;; Careful when editing!
|
|
(define (filter-bintree tree)
|
|
(define (get-pattern spec)
|
|
(let ([rx (expand-spec spec)])
|
|
(if (and (pair? rx) (null? (cdr rx)) (string? (car rx)))
|
|
(car rx)
|
|
(error 'filter-bintree "bad value for ~.s: ~e" spec rx))))
|
|
(define keep-pattern (get-pattern 'binary-keep))
|
|
(define throw-pattern (get-pattern 'binary-throw))
|
|
(define keep-rx (regexpify-spec (string-append "*" keep-pattern "*")))
|
|
(define throw-rx (regexpify-spec (string-append "*" throw-pattern "*")))
|
|
(define templates
|
|
(let ([ts (expand-spec 'binary-keep/throw-templates)])
|
|
(for ([t ts])
|
|
(unless (and (string? t)
|
|
;; verify that it has exactly one "<...!...>" pattern
|
|
(regexp-match? #rx"^[^<!>]*<[^<!>]*![^<!>]*>[^<!>]*$" t))
|
|
(error 'filter-bintree "bad keep/throw template: ~e" t)))
|
|
ts))
|
|
(define (make-matcher x) ; matchers return match-positions or #f
|
|
(let ([rxs (map (lambda (t)
|
|
(let* ([x (regexp-replace #rx"!" t x)]
|
|
[x (object-name (regexpify-spec x #t))]
|
|
[x (regexp-replace #rx"<(.*)>" x "(\\1)")])
|
|
(regexp x)))
|
|
templates)])
|
|
(lambda (p) (ormap (lambda (rx) (regexp-match-positions rx p)) rxs))))
|
|
(define (rassoc x l)
|
|
(and (pair? l) (if (equal? x (cdar l)) (car l) (rassoc x (cdr l)))))
|
|
(define keep? (make-matcher keep-pattern))
|
|
(define throw? (make-matcher throw-pattern))
|
|
(define existing-paths (tree-flatten tree))
|
|
;; The two `*-paths' values are association lists: ((<path> . <plain>) ...)
|
|
;; both sides are unique in each list, the lhs is always an existing path
|
|
(define (find-paths pred? mode rx)
|
|
(define res '())
|
|
(let loop ([t tree])
|
|
(let ([p (tree-path t)])
|
|
(cond [(pred? p)
|
|
=> (lambda (m)
|
|
(let ([plain (string-append (substring p 0 (caadr m))
|
|
(substring p (cdadr m)))])
|
|
(when (rassoc plain res)
|
|
(error 'filter-bintree
|
|
"two ~s templates have the same plain: ~e -> ~e"
|
|
mode p plain))
|
|
(set! res `((,p . ,plain) ,@res)))
|
|
#t)]
|
|
[(regexp-match? rx p)
|
|
;; other matches are not allowed, unless on a directory where
|
|
;; all files are selected
|
|
(when (or (not (pair? t))
|
|
(memq #f (map loop (cdr t))))
|
|
(error 'filter-bintree
|
|
"~s path uncovered by patterns: ~e" mode p))
|
|
#t]
|
|
[(pair? t) (not (memq #f (map loop (cdr t))))]
|
|
[else #f])))
|
|
res)
|
|
(define keep-paths (find-paths keep? 'keep keep-rx))
|
|
(define throw-paths (find-paths throw? 'throw throw-rx))
|
|
(for ([k keep-paths])
|
|
(when (assoc (car k) throw-paths)
|
|
(error 'filter-bintree
|
|
"a path matched both keep and throw patterns: ~s" (car k))))
|
|
(let* ([ps (map cdr keep-paths)]
|
|
[ps (append ps (remove* ps (map cdr throw-paths)))]
|
|
[scan (lambda (f paths)
|
|
(map (lambda (p) (cond [(f p paths) => car] [else #f])) ps))]
|
|
[plain (scan member existing-paths)]
|
|
[keep (scan rassoc keep-paths)]
|
|
[throw (scan rassoc throw-paths)])
|
|
(define del
|
|
(map (lambda (p k t)
|
|
(cond
|
|
[(and p k t) (error 'filter-bintree "got keep+throw+plain")]
|
|
[(or k t) (or t p)]
|
|
[else (error 'filter-bintree "internal error")]))
|
|
plain keep throw))
|
|
(tree-filter `(not (or ,(lambda (t) (and (memq (tree-path t) del) '+))
|
|
binary-throw-more))
|
|
tree)))
|
|
|
|
;; This is hooked below as a `distribute!' spec macro, and invoked through
|
|
;; expand-spec.
|
|
(define (distribute!)
|
|
(define (distribute tree) (tree-filter 'distribution tree))
|
|
(let* ([features (filter string? (reverse (*environment*)))]
|
|
[name (apply concat (cdr (mappend (lambda (x) (list "-" x))
|
|
features)))]
|
|
[features (map string->symbol features)]
|
|
[bin? (memq 'bin features)]
|
|
[src? (memq 'src features)]
|
|
[full? (memq 'full features)])
|
|
(when (and bin? src?)
|
|
(error 'distribute! "bad configuration (both bin & src): ~e" features))
|
|
(unless (or bin? src?)
|
|
(error 'distribute! "bad configuration (both bin & src): ~e" features))
|
|
(for ([type (if bin? *bin-types* *src-types*)]
|
|
;; this is unused if bin? is false
|
|
[bin-trees (if bin? *platform-tree-lists* *src-types*)])
|
|
(tag (cons type features)
|
|
(let ([name (format "~a-~a.tgz" name type)])
|
|
(dprintf "Creating ~s: filtering..." name)
|
|
(let ([trees (add-trees
|
|
(cons (distribute (get-racket-tree))
|
|
(if bin?
|
|
(tag 'in-binary-tree
|
|
(map (if full?
|
|
distribute
|
|
(lambda (t)
|
|
(distribute (filter-bintree t))))
|
|
bin-trees))
|
|
'())))])
|
|
(with-output-to-file *readme-file* #:exists 'truncate make-readme)
|
|
(with-output-to-file *info-domain-file* #:exists 'truncate
|
|
(make-info-domain trees))
|
|
(pack (concat target/ name) trees
|
|
(if bin?
|
|
(format "\\(~a\\|~a~a/\\)" racket-base/ binaries/ type)
|
|
racket-base/)))
|
|
(dprintf " done.\n")))))
|
|
'())
|
|
(register-spec! 'distribute!
|
|
(lambda () (when (or *pack?* (eq? #t *verbose?*)) (distribute!))))
|
|
|
|
(register-spec! 'verify! (lambda () (when *verify?* (verify!))))
|
|
|
|
(define (read-orig-files)
|
|
(set! *readme-cache* (file->string *readme-file*))
|
|
(set! *info-domain-cache* (with-input-from-file *info-domain-file* read)))
|
|
(define (write-orig-files)
|
|
(display-to-file *readme-cache* *readme-file* #:exists 'truncate)
|
|
(with-output-to-file *info-domain-file* #:exists 'truncate
|
|
(lambda () (write *info-domain-cache*) (newline))))
|
|
|
|
(process-command-line)
|
|
(read-specs)
|
|
(initialize)
|
|
(for-each create-binaries *platforms* *platform-tree-lists*)
|
|
(dynamic-wind
|
|
(lambda () (read-orig-files))
|
|
;; Start the verification and distribution
|
|
(lambda () (expand-spec 'distributions) (void))
|
|
(lambda () (write-orig-files)))
|