remove obsolete distribution specs
Replaced by the package system.
This commit is contained in:
Matthew Flatt
parent
e4e268f7d5
commit
3342d54c82
|
|
@ -1,36 +0,0 @@
|
||||||
#lang scheme/base
|
|
||||||
(require "checker.rkt"
|
|
||||||
"specs.rkt"
|
|
||||||
"dist-specs.rkt")
|
|
||||||
|
|
||||||
(parameterize ([*specs* #f]
|
|
||||||
[current-namespace (namespace-anchor->namespace checker-namespace-anchor)])
|
|
||||||
(define (/-ify x)
|
|
||||||
(regexp-replace #rx"/?$" (if (path? x) (path->string x) x) "/"))
|
|
||||||
(define racket/
|
|
||||||
(/-ify (simplify-path (build-path (collection-path "scheme") 'up 'up))))
|
|
||||||
(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)))
|
|
||||||
|
|
||||||
(register-macros!)
|
|
||||||
|
|
||||||
(register-specs! *specs*)
|
|
||||||
|
|
||||||
(register-spec! 'verify! verify!)
|
|
||||||
(register-spec! 'distribute! void)
|
|
||||||
|
|
||||||
(set-racket-tree! racket/ racket-base/ racket/-name null)
|
|
||||||
|
|
||||||
(set-bin-files-delayed-lists!
|
|
||||||
;; FIXME: hard-wired list of binary-specific files;
|
|
||||||
;; we assume there are none. This value is a list of
|
|
||||||
;; lists, where a given file must appear in every list
|
|
||||||
;; to be ok for the distribution.
|
|
||||||
'(()))
|
|
||||||
|
|
||||||
(expand-spec 'distributions)
|
|
||||||
|
|
||||||
(void))
|
|
||||||
|
|
@ -1,580 +0,0 @@
|
||||||
;; Shared dependency-checking infrastructure, used by "check-dists.rkt"
|
|
||||||
;; and by the bundle script
|
|
||||||
|
|
||||||
#lang scheme/base
|
|
||||||
|
|
||||||
(require scheme/cmdline scheme/runtime-path scheme/match scheme/promise
|
|
||||||
scheme/list ; for use in specs too
|
|
||||||
(for-syntax scheme/base) ; for runtime-path
|
|
||||||
(except-in scheme/mpair mappend)
|
|
||||||
(only-in mzlib/process system)
|
|
||||||
"specs.rkt")
|
|
||||||
|
|
||||||
(define cd current-directory)
|
|
||||||
|
|
||||||
(provide current-verbose-port)
|
|
||||||
(define current-verbose-port (make-parameter current-output-port))
|
|
||||||
|
|
||||||
;;; ===========================================================================
|
|
||||||
;;; 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)
|
|
||||||
(let ([p ((current-verbose-port))])
|
|
||||||
(apply fprintf p fmt args)
|
|
||||||
(flush-output p)))
|
|
||||||
|
|
||||||
;;; ===========================================================================
|
|
||||||
;;; Object properties
|
|
||||||
|
|
||||||
(define *properties* (make-weak-hasheq))
|
|
||||||
|
|
||||||
(provide get-props
|
|
||||||
prop-get
|
|
||||||
prop-set!)
|
|
||||||
|
|
||||||
(define (get-props obj)
|
|
||||||
(hash-ref *properties* obj (lambda ()
|
|
||||||
(let ([props (mlist 'props)])
|
|
||||||
(hash-set! *properties* obj props)
|
|
||||||
props))))
|
|
||||||
|
|
||||||
(define (prop-get obj prop [default #f])
|
|
||||||
(let ([props (get-props obj)])
|
|
||||||
(cond [(massq prop (mcdr props)) => mcdr]
|
|
||||||
[(procedure? default) (default)]
|
|
||||||
[(promise? default) (force default)]
|
|
||||||
[else default])))
|
|
||||||
|
|
||||||
(define (prop-set! obj prop val)
|
|
||||||
(let ([props (get-props obj)])
|
|
||||||
(cond [(massq prop (mcdr props)) => (lambda (p) (set-mcdr! p val))]
|
|
||||||
[else (set-mcdr! props (mcons (mcons prop val) (mcdr props)))])))
|
|
||||||
|
|
||||||
;;; ===========================================================================
|
|
||||||
;;; Tree utilities
|
|
||||||
|
|
||||||
;; A directory tree structure is either a string (for a file), or a pair of a
|
|
||||||
;; string (for a directory) and its entries. Directory entries are always
|
|
||||||
;; sorted. The strings are all paths beginning where the tree was scanned
|
|
||||||
;; from, and end with a "/" iff it is a directory. Sometimes #f is used as an
|
|
||||||
;; exception "empty tree" value.
|
|
||||||
|
|
||||||
(provide get-tree)
|
|
||||||
;; path -> tree
|
|
||||||
;; Returns the tree with path (a string with no "/"s) at its root.
|
|
||||||
(define (get-tree path fake-path)
|
|
||||||
(define base (regexp-replace #rx"/$" (path->string (cd)) ""))
|
|
||||||
(let loop ([name path] [fake-name fake-path] [path ""] [fake-path ""])
|
|
||||||
(cond [(or (file-exists? name) (link-exists? name))
|
|
||||||
(let ([path (concat path name)]
|
|
||||||
[fake-path (concat fake-path fake-name)])
|
|
||||||
(prop-set! fake-path 'base base)
|
|
||||||
(prop-set! fake-path 'name name)
|
|
||||||
(prop-set! fake-path 'real path)
|
|
||||||
fake-path)]
|
|
||||||
[(directory-exists? name)
|
|
||||||
(let ([path (concat path name "/")]
|
|
||||||
[fake-path (concat fake-path fake-name "/")])
|
|
||||||
(prop-set! fake-path 'base base)
|
|
||||||
(prop-set! fake-path 'name name)
|
|
||||||
(prop-set! fake-path 'real path)
|
|
||||||
(parameterize ([cd name])
|
|
||||||
(cons fake-path (map (lambda (name) (loop name name path fake-path))
|
|
||||||
(dir-list)))))]
|
|
||||||
[else (error 'get-tree/base "strange entry: ~a/~a"
|
|
||||||
(path->string (cd)) name)])))
|
|
||||||
|
|
||||||
(provide tree-path)
|
|
||||||
;; tree -> string
|
|
||||||
;; The path of the tree root -- if a file then identity, otherwise car.
|
|
||||||
(define (tree-path tree)
|
|
||||||
(cond [(string? tree) tree]
|
|
||||||
[(pair? tree) (car tree)]
|
|
||||||
[else (error 'tree-path "got a bad tree: ~e" tree)]))
|
|
||||||
|
|
||||||
(provide tree-flatten)
|
|
||||||
;; tree [boolean] -> (list-of string)
|
|
||||||
(define (tree-flatten tree [only-files? #f])
|
|
||||||
(let loop ([l '()] [tree (list tree)])
|
|
||||||
(if (null? tree)
|
|
||||||
(reverse l)
|
|
||||||
(let ([1st (car tree)] [rest (cdr tree)])
|
|
||||||
(if (pair? 1st)
|
|
||||||
(loop (if only-files? l (cons (car 1st) l)) (append (cdr 1st) rest))
|
|
||||||
(loop (cons 1st l) rest))))))
|
|
||||||
|
|
||||||
;; tree tree -> tree
|
|
||||||
;; Both trees should have the same root. This is not a merge -- the trees
|
|
||||||
;; should not have equal files, directroy strings are taken from the first
|
|
||||||
;; tree.
|
|
||||||
(define (tree-add tree1 tree2)
|
|
||||||
(cond [(not tree1) tree2]
|
|
||||||
[(not tree2) tree1]
|
|
||||||
[(not (and (pair? tree1) (pair? tree2)))
|
|
||||||
(error 'tree-add "cannot add non-directories -- ~a and ~a"
|
|
||||||
(tree-path tree1) (tree-path tree2))]
|
|
||||||
[(not (equal? (car tree1) (car tree2)))
|
|
||||||
(error 'tree-add "got incompatible entries -- ~a and ~a"
|
|
||||||
(tree-path tree1) (tree-path tree2))]
|
|
||||||
[else (let loop ([l1 (cdr tree1)]
|
|
||||||
[l2 (cdr tree2)]
|
|
||||||
[r (list (car tree1))])
|
|
||||||
(cond [(and (null? l1) (null? l2)) (reverse r)]
|
|
||||||
[(null? l1) (loop l1 (cdr l2) (cons (car l2) r))]
|
|
||||||
[(null? l2) (loop (cdr l1) l2 (cons (car l1) r))]
|
|
||||||
[(string<? (tree-path (car l1)) (tree-path (car l2)))
|
|
||||||
(loop (cdr l1) l2 (cons (car l1) r))]
|
|
||||||
[(string>? (tree-path (car l1)) (tree-path (car l2)))
|
|
||||||
(loop l1 (cdr l2) (cons (car l2) r))]
|
|
||||||
[(and (pair? (car l1)) (pair? (car l2)))
|
|
||||||
(loop (cdr l1) (cdr l2)
|
|
||||||
(cons (tree-add (car l1) (car l2)) r))]
|
|
||||||
[(or (pair? (car l1)) (pair? (car l2)))
|
|
||||||
(error 'tree-add
|
|
||||||
"got incompatible file/dir entries -- ~a"
|
|
||||||
(tree-path (car l1)))]
|
|
||||||
[else
|
|
||||||
(error 'tree-add "a file appears in both trees -- ~a"
|
|
||||||
(tree-path (car l1)))]))]))
|
|
||||||
|
|
||||||
(provide add-trees)
|
|
||||||
;; tree list -> tree list
|
|
||||||
;; Adds up all input trees, generating a list of trees (in case of different
|
|
||||||
;; roots).
|
|
||||||
(define (add-trees trees)
|
|
||||||
(let loop ([todo trees] [done '()])
|
|
||||||
(cond [(null? todo) (reverse done)]
|
|
||||||
[(not (car todo)) (loop (cdr todo) done)]
|
|
||||||
[(assoc (caar todo) done) =>
|
|
||||||
(lambda (t)
|
|
||||||
(loop (cdr todo) (cons (tree-add t (car todo)) (remq t done))))]
|
|
||||||
[else (loop (cdr todo) (cons (car todo) done))])))
|
|
||||||
|
|
||||||
(provide tree-subtract)
|
|
||||||
;; tree tree -> tree
|
|
||||||
;; All file entries that exist in tree2 are removed from tree1.
|
|
||||||
(define (tree-subtract tree1 tree2)
|
|
||||||
(cond
|
|
||||||
[(or (not tree1) (not tree2)) tree1]
|
|
||||||
[(and (string? tree1) (string? tree2))
|
|
||||||
(and (not (equal? tree1 tree2)) tree1)]
|
|
||||||
[(and (pair? tree1) (pair? tree2))
|
|
||||||
(if (equal? (car tree1) (car tree2))
|
|
||||||
(let loop ([l1 (cdr tree1)] [l2 (cdr tree2)] [r '()])
|
|
||||||
(cond [(or (null? l1) (null? l2))
|
|
||||||
(let ([r (append (reverse r) l1)])
|
|
||||||
(and (pair? r) (cons (car tree1) r)))]
|
|
||||||
[(string<? (tree-path (car l1)) (tree-path (car l2)))
|
|
||||||
(loop (cdr l1) l2 (cons (car l1) r))]
|
|
||||||
[(string>? (tree-path (car l1)) (tree-path (car l2)))
|
|
||||||
(loop l1 (cdr l2) r)]
|
|
||||||
[else (loop (cdr l1) (cdr l2)
|
|
||||||
(let ([sub (tree-subtract (car l1) (car l2))])
|
|
||||||
(if sub (cons sub r) r)))]))
|
|
||||||
tree1)]
|
|
||||||
[else (error 'tree-subtract
|
|
||||||
"got incompatible entries -- ~a ~a and ~a ~a"
|
|
||||||
(if (string? tree1) "file" "directory") (tree-path tree1)
|
|
||||||
(if (string? tree2) "file" "directory") (tree-path tree2))]))
|
|
||||||
|
|
||||||
;; tree -> tree
|
|
||||||
;; Removes empty directories and ones that contain only empty directories.
|
|
||||||
(define (remove-empty-trees tree)
|
|
||||||
(if (string? tree)
|
|
||||||
tree
|
|
||||||
(let ([filtered (filtered-map remove-empty-trees (cdr tree))])
|
|
||||||
(and (pair? filtered) (cons (car tree) filtered)))))
|
|
||||||
|
|
||||||
(provide tree-filter)
|
|
||||||
;; (string -> any) tree -> tree
|
|
||||||
;; If the filter returns '+ or '- this qualifies or disqualifies the
|
|
||||||
;; current tree immediately, otherwise recurse down directories. If any other
|
|
||||||
;; result is returned for directories scanning continues, and for files they
|
|
||||||
;; are included if the result is not #f.
|
|
||||||
(define (tree-filter filter tree)
|
|
||||||
(let ([filter (if (procedure? filter) filter (spec->filter filter))])
|
|
||||||
(let loop ([tree tree])
|
|
||||||
(let ([r (filter tree)])
|
|
||||||
(case r
|
|
||||||
[(+) tree] [(-) #f]
|
|
||||||
[else (if (string? tree)
|
|
||||||
(and r tree)
|
|
||||||
(let ([filtered (filtered-map loop (cdr tree))])
|
|
||||||
;; directories are removed if they're empty and if the
|
|
||||||
;; predicate resulted in #f which means that we generally
|
|
||||||
;; don't want the current tree
|
|
||||||
(if (or r (pair? filtered))
|
|
||||||
(cons (car tree) filtered)
|
|
||||||
#f)))])))))
|
|
||||||
|
|
||||||
;; return the base path of a tree
|
|
||||||
(define (tree-base tree)
|
|
||||||
(prop-get (tree-path tree) 'base
|
|
||||||
(lambda ()
|
|
||||||
(error 'tree-base "no `base' property for ~e" tree))))
|
|
||||||
|
|
||||||
(provide print-tree)
|
|
||||||
(define (print-tree tree . mode)
|
|
||||||
(let ([full? (memq 'full mode)]
|
|
||||||
;; only-files is for files and empty dirs (used for untarring)
|
|
||||||
[only-files? (memq 'only-files mode)])
|
|
||||||
(let loop ([tree tree])
|
|
||||||
(when tree
|
|
||||||
(unless (and only-files? (pair? tree) (not (null? (cdr tree))))
|
|
||||||
(when full? (printf "~a/" (tree-base tree)))
|
|
||||||
(printf "~a\n" (tree-path tree)))
|
|
||||||
(when (pair? tree) (for-each loop (cdr tree)))))))
|
|
||||||
|
|
||||||
;;; ===========================================================================
|
|
||||||
;;; Spec management
|
|
||||||
|
|
||||||
(define *spec-primitives* (make-parameter '()))
|
|
||||||
(define (register-spec-primitive! sym func)
|
|
||||||
(*spec-primitives* (cons (cons sym func) (*spec-primitives*))))
|
|
||||||
(define (get-spec-primitive spec)
|
|
||||||
(cond [(assq spec (*spec-primitives*)) => cdr] [else #f]))
|
|
||||||
|
|
||||||
;; Spec primitives
|
|
||||||
|
|
||||||
;; These are transformations that will convert a *simplified* expression to a
|
|
||||||
;; filter function. Because of this, it is safe to have certain assumptions,
|
|
||||||
;; like `or' having at least two arguments etc, and it is also fine to not try
|
|
||||||
;; to do trivial optimizations (there is no need for them). Also, the input to
|
|
||||||
;; these functions are functions (there is no point in a function that needs
|
|
||||||
;; raw arguments, since these can be implemented as macros).
|
|
||||||
|
|
||||||
(begin
|
|
||||||
;; `not' negates '+ <-> '- and #f <-> #t
|
|
||||||
(register-spec-primitive!
|
|
||||||
'%not
|
|
||||||
(lambda (pred)
|
|
||||||
(lambda (t)
|
|
||||||
(let ([r (pred t)])
|
|
||||||
(case r [(+) '-] [(-) '+] [else (not r)])))))
|
|
||||||
|
|
||||||
;; `or' behaves like max for '- < #f < #t < '+
|
|
||||||
(register-spec-primitive!
|
|
||||||
'%or
|
|
||||||
(lambda preds
|
|
||||||
(lambda (t)
|
|
||||||
(let loop ([result '-] [preds preds])
|
|
||||||
(if (or (eq? result '+) (null? preds))
|
|
||||||
result
|
|
||||||
(loop (let ([r ((car preds) t)])
|
|
||||||
(case r
|
|
||||||
[(+) '+] [(-) result]
|
|
||||||
[else (if (eq? result '-) r (or result r))]))
|
|
||||||
(cdr preds)))))))
|
|
||||||
|
|
||||||
;; `and' behaves like min for '- < #f < #t < '+
|
|
||||||
(register-spec-primitive!
|
|
||||||
'%and
|
|
||||||
(lambda preds
|
|
||||||
(lambda (t)
|
|
||||||
(let loop ([result '+] [preds preds])
|
|
||||||
(if (or (eq? result '-) (null? preds))
|
|
||||||
result
|
|
||||||
(loop (let ([r ((car preds) t)])
|
|
||||||
(case r
|
|
||||||
[(-) '-] [(+) result]
|
|
||||||
[else (if (eq? result '+) r (and result r))]))
|
|
||||||
(cdr preds))))))))
|
|
||||||
|
|
||||||
;; Spec Macros
|
|
||||||
|
|
||||||
;; macros for primitive simplifications
|
|
||||||
(define (make-and/or-macro op)
|
|
||||||
(let ([null-result (if (eq? op '%and) '%all '%none)]
|
|
||||||
[best-result (if (eq? op '%and) '%none '%all)])
|
|
||||||
;; can return the same form -- expand-spec will not proceed in that case
|
|
||||||
(lambda specs
|
|
||||||
(let/ec return
|
|
||||||
(let ([specs (mappend
|
|
||||||
(lambda (s)
|
|
||||||
(cond [(and (pair? s) (eq? (car s) op)) (cdr s)]
|
|
||||||
[(eq? s null-result) '()]
|
|
||||||
[(eq? s best-result) (return best-result)]
|
|
||||||
[else (list s)]))
|
|
||||||
specs)])
|
|
||||||
(if (null? specs) null-result (cons op specs)))))))
|
|
||||||
|
|
||||||
(provide register-macros!)
|
|
||||||
(define (register-macros!)
|
|
||||||
(register-spec! 'or (make-and/or-macro '%or))
|
|
||||||
(register-spec! 'and (make-and/or-macro '%and))
|
|
||||||
(register-spec!
|
|
||||||
'not
|
|
||||||
(lambda specs
|
|
||||||
;; splice results back up, in case of (not) (which can result with a cond)
|
|
||||||
(splice (map (lambda (spec)
|
|
||||||
(case spec
|
|
||||||
[(%all) '%none] [(%none) '%all] [else `(%not ,spec)]))
|
|
||||||
specs))))
|
|
||||||
(register-spec! 'all '%all)
|
|
||||||
(register-spec! 'none '%none)
|
|
||||||
|
|
||||||
(register-spec! '+ 'or) ; `+' is `or'
|
|
||||||
(register-spec!
|
|
||||||
'- ; set difference
|
|
||||||
(lambda (spec . specs)
|
|
||||||
`(and (or ,spec) (not (or ,@specs)))))
|
|
||||||
|
|
||||||
(register-spec! 'error (lambda xs (apply error 'spec-error xs))))
|
|
||||||
|
|
||||||
;; Turns a string with globbing into a regexp string
|
|
||||||
(define (glob->regexp glob)
|
|
||||||
(define len (string-length glob))
|
|
||||||
(define range #f)
|
|
||||||
(let loop ([res '()] [i 0])
|
|
||||||
(define (next x) (loop (cons x res) (add1 i)))
|
|
||||||
(if (= i len)
|
|
||||||
(begin
|
|
||||||
(when range
|
|
||||||
(error 'glob->regexp "unterminated range in glob: ~e" glob))
|
|
||||||
(let loop ([left res] [res '()])
|
|
||||||
(if (null? left)
|
|
||||||
(list->string res)
|
|
||||||
(loop (cdr left)
|
|
||||||
((if (char? (car left)) cons append) (car left) res)))))
|
|
||||||
(let ([c (string-ref glob i)])
|
|
||||||
(if range
|
|
||||||
(begin (set! range
|
|
||||||
(case range
|
|
||||||
[(0) (case c ((#\^) 1) (else 2))]
|
|
||||||
[(1) 2]
|
|
||||||
[else (case c ((#\]) #f) (else 2))]))
|
|
||||||
(next c))
|
|
||||||
(case c
|
|
||||||
[(#\\) (set! i (add1 i))
|
|
||||||
(if (< i len)
|
|
||||||
(next (list #\\ (string-ref glob i)))
|
|
||||||
(error 'glob->regexp "glob ends in backslash: ~e" glob))]
|
|
||||||
[(#\*) (next '(#\[ #\^ #\/ #\] #\*))]
|
|
||||||
[(#\?) (next '(#\[ #\^ #\/ #\]))]
|
|
||||||
[(#\[) (set! range 0) (next #\[)]
|
|
||||||
[(#\. #\+ #\^ #\$ #\( #\) #\]) (next (list #\\ c))]
|
|
||||||
;; translate "{}" to "(?:)", "|" are left as-is "\|"
|
|
||||||
[(#\{) (next '(#\( #\? #\:))]
|
|
||||||
[(#\}) (next #\))]
|
|
||||||
[else (next c)]))))))
|
|
||||||
|
|
||||||
(provide regexpify-spec)
|
|
||||||
;; Turns a string spec into a regexp to be matched against the `path' property.
|
|
||||||
(define (regexpify-spec str . force-rx?)
|
|
||||||
(let* (;; initial "/" goes, so does a pointless initial "/**/"
|
|
||||||
[rx (glob->regexp (regexp-replace #rx"^/(\\*\\*/)?" str ""))]
|
|
||||||
;; replace translated "/**/"s (they're never a prefix)
|
|
||||||
[rx (regexp-replace* #rx"/\\[\\^/\\]\\*\\[\\^/\\]\\*/"
|
|
||||||
rx "/(?:.*/)?")]
|
|
||||||
[rx (regexp (concat (if (regexp-match? #rx"^/" str) "^" "(?:^|/)")
|
|
||||||
rx (if (regexp-match? #rx"/$" str) "$" "/?$")))]
|
|
||||||
[anchor (and (not (and (pair? force-rx?) (car force-rx?)))
|
|
||||||
(regexp-match? #rx"^/" str)
|
|
||||||
(regexp-replace #rx"^/([^][{}|*?]*)(.*)?$" str "\\1"))])
|
|
||||||
;; optimize anchored prefix strings
|
|
||||||
(if anchor
|
|
||||||
(let ([alen (string-length anchor)])
|
|
||||||
(lambda (t)
|
|
||||||
(let* ([p (tree-path t)] [plen (string-length p)])
|
|
||||||
(let loop ([i 0])
|
|
||||||
(cond
|
|
||||||
[(or (= i alen) (= i plen)) (and (regexp-match? rx p) '+)]
|
|
||||||
[(eq? (string-ref anchor i) (string-ref p i)) (loop (add1 i))]
|
|
||||||
[else '-])))))
|
|
||||||
rx)))
|
|
||||||
|
|
||||||
;; Turns a [composite] file spec into a filter function. Wrap a filter spec
|
|
||||||
;; function in a cache. This is not only for optimization, it is responsible
|
|
||||||
;; for making predicate composition behave like set operations because when a
|
|
||||||
;; directory's contents is skipped when the filter returns '+ or '-, the
|
|
||||||
;; contents is still marked.
|
|
||||||
(define (primitive-spec->filter spec)
|
|
||||||
(define (add-query-cache! t r)
|
|
||||||
(hash-set! (prop-get (tree-path t) 'queries
|
|
||||||
(lambda () (let ([ht (make-hash)])
|
|
||||||
(prop-set! (tree-path t) 'queries ht)
|
|
||||||
ht)))
|
|
||||||
spec
|
|
||||||
r))
|
|
||||||
(define (make-cached filter)
|
|
||||||
(lambda (t)
|
|
||||||
(cond [(hash-ref (prop-get (tree-path t) 'queries #hash()) spec #f)]
|
|
||||||
[else (let ([r (filter t)])
|
|
||||||
(case r
|
|
||||||
[(+ -) (let loop ([t t])
|
|
||||||
(add-query-cache! t r)
|
|
||||||
(when (pair? t) (for-each loop (cdr t))))]
|
|
||||||
[else (add-query-cache! t r)])
|
|
||||||
r)])))
|
|
||||||
(let loop ([spec spec])
|
|
||||||
(cond
|
|
||||||
[(procedure? spec) (make-cached spec)]
|
|
||||||
[(regexp? spec) (loop (lambda (t)
|
|
||||||
(and (regexp-match? spec (tree-path t)) '+)))]
|
|
||||||
[(string? spec) (loop (regexpify-spec spec))]
|
|
||||||
[(eq? spec '%none) (lambda (t) '-)] ; no need to cache
|
|
||||||
[(eq? spec '%all) (lambda (t) '+)] ; no need to cache
|
|
||||||
[(and (pair? spec) (get-spec-primitive (car spec)))
|
|
||||||
;; this is used with simplified expressions, so there is no point in
|
|
||||||
;; passing the raw arguments to the primitive, so just convert them
|
|
||||||
;; first.
|
|
||||||
=> (lambda (p)
|
|
||||||
(make-cached (apply p (map primitive-spec->filter (cdr spec)))))]
|
|
||||||
[else (error 'primitive-spec->filter "bad spec: ~.s" spec)])))
|
|
||||||
|
|
||||||
;; Toplevel entry point for converting a spec into a tree predicate function.
|
|
||||||
(define (spec->filter spec)
|
|
||||||
(let ([specs (expand-spec spec)])
|
|
||||||
(if (= 1 (length specs))
|
|
||||||
(primitive-spec->filter (car specs))
|
|
||||||
(error 'spec->filter
|
|
||||||
"spec `~.s' did not expand to a single expression: ~.s"
|
|
||||||
spec specs))))
|
|
||||||
|
|
||||||
;;; ===========================================================================
|
|
||||||
;;; Dependency checks
|
|
||||||
|
|
||||||
(define check-version
|
|
||||||
(let ([version (version)] [1st? #t])
|
|
||||||
(lambda (v file)
|
|
||||||
(if 1st?
|
|
||||||
(begin
|
|
||||||
(unless (equal? version v)
|
|
||||||
(eprintf "\nNOTE: bundling a different version from ~a\n\n"
|
|
||||||
"running process"))
|
|
||||||
(set! version v)
|
|
||||||
(set! 1st? #f))
|
|
||||||
(unless (equal? version v)
|
|
||||||
(error 'dependencies "bad version in ~s: ~s (expecting ~s)"
|
|
||||||
file v version))))))
|
|
||||||
|
|
||||||
(define (add-dependency-contents!)
|
|
||||||
(define (racketpath path)
|
|
||||||
(bytes->string/utf-8
|
|
||||||
(apply bytes-append (cdr (mappend (lambda (p) (list #"/" p))
|
|
||||||
(list* #"racket" #"collects" path))))))
|
|
||||||
(define (read-depfile file)
|
|
||||||
(let ([x (with-input-from-file file read)])
|
|
||||||
(unless (and (pair? x) (check-version (car x) file))
|
|
||||||
(error 'dependencies "bad contents in ~s: ~s" file x))
|
|
||||||
(map (lambda (x)
|
|
||||||
(match x
|
|
||||||
[`(collects ,(and (? bytes?) s) ...) (racketpath s)]
|
|
||||||
[`(ext collects ,(and (? bytes?) s) ...) (racketpath s)]
|
|
||||||
[_ (error 'dependencies "bad dependency item in ~s: ~s"
|
|
||||||
file x)]))
|
|
||||||
(cddr x))))
|
|
||||||
(dprintf "Reading dependencies...")
|
|
||||||
(let loop ([tree (tree-filter "*.dep" *racket-tree*)])
|
|
||||||
(if (pair? tree)
|
|
||||||
(for-each loop (cdr tree))
|
|
||||||
(parameterize ([cd (prop-get tree 'base)])
|
|
||||||
(prop-set! tree 'contents (read-depfile (prop-get tree 'real))))))
|
|
||||||
(dprintf " done.\n")
|
|
||||||
(set! add-dependency-contents! void))
|
|
||||||
|
|
||||||
(define bin-files-lists (delay null))
|
|
||||||
|
|
||||||
(provide set-bin-files-delayed-lists!)
|
|
||||||
(define (set-bin-files-delayed-lists! p)
|
|
||||||
(set! bin-files-lists p))
|
|
||||||
|
|
||||||
(define (add-alts l)
|
|
||||||
(if (null? l)
|
|
||||||
null
|
|
||||||
(let ([v (regexp-replace #rx"[.]ss$" (car l) ".rkt")])
|
|
||||||
(if (equal? v (car l))
|
|
||||||
(cons (car l) (add-alts (cdr l)))
|
|
||||||
(list* (car l) v (add-alts (cdr l)))))))
|
|
||||||
|
|
||||||
(define (check-dependencies spec distname)
|
|
||||||
(add-dependency-contents!)
|
|
||||||
(dprintf "Verifying dependencies for ~s..." distname)
|
|
||||||
(let* ([all-files
|
|
||||||
(sort* (add-alts (tree-flatten (tree-filter spec *racket-tree*))))]
|
|
||||||
[deps0 (or (tree-filter `(and ,spec "*.dep") *racket-tree*)
|
|
||||||
(error 'check-dependencies
|
|
||||||
"got no .dep files for ~s" distname))]
|
|
||||||
[deps0 (tree-flatten deps0 #t)])
|
|
||||||
(let* ([missing (tree-filter 'must-be-empty *racket-tree*)]
|
|
||||||
[missing (and (pair? missing) (tree-flatten missing #t))])
|
|
||||||
(when (pair? missing)
|
|
||||||
(dprintf "files missing from distribution:\n")
|
|
||||||
(for ([m missing]) (dprintf " ~a\n" m))
|
|
||||||
(error 'dependencies "got files in must-be-empty (see above)")))
|
|
||||||
(let loop ([files all-files]
|
|
||||||
[deps (sort* (foldl (lambda (x y)
|
|
||||||
(append (prop-get x 'contents) y))
|
|
||||||
'()
|
|
||||||
deps0))]
|
|
||||||
[last-dep #f])
|
|
||||||
(cond [(null? deps) #t]
|
|
||||||
[(equal? (car deps) last-dep) (loop files (cdr deps) last-dep)]
|
|
||||||
[(or (null? files) (string<? (car deps) (car files)))
|
|
||||||
;; Exception: foo.rkt might be satisified by a platform dependent
|
|
||||||
;; compiled/foo_rkt.zo (need to exist in all platform dependent
|
|
||||||
;; trees). No need to optimize since this happens very
|
|
||||||
;; infrequently.
|
|
||||||
(let ([dep (regexp-replace #rx"/([^/]+)\\.([^/]+)$" (car deps)
|
|
||||||
"/compiled/\\1_\\2.zo")]
|
|
||||||
[alt-dep (and (regexp-match #rx"[.]rkt$" (car deps))
|
|
||||||
(regexp-replace #rx"/([^/]+)\\.([^/]+)$" (car deps)
|
|
||||||
"/compiled/\\1_ss.zo"))])
|
|
||||||
(if (andmap (lambda (files) (or (member dep files)
|
|
||||||
(member alt-dep files)))
|
|
||||||
(force bin-files-lists))
|
|
||||||
(loop files (cdr deps) (car deps))
|
|
||||||
(error 'dependencies "unsatisfied dependency for ~s: ~s ~s"
|
|
||||||
distname (car deps)
|
|
||||||
(cons 'in: (filter (lambda (d)
|
|
||||||
(member (car deps)
|
|
||||||
(prop-get d 'contents)))
|
|
||||||
deps0)))))]
|
|
||||||
[(string<? (car files) (car deps))
|
|
||||||
(loop (cdr files) deps last-dep)]
|
|
||||||
[else (loop (cdr files) (cdr deps) (car deps))])))
|
|
||||||
(dprintf " done.\n"))
|
|
||||||
|
|
||||||
;;; ===========================================================================
|
|
||||||
;;; Start working
|
|
||||||
|
|
||||||
(define *platform-tree-lists* null)
|
|
||||||
(define *racket-tree* #f)
|
|
||||||
|
|
||||||
(provide get-racket-tree)
|
|
||||||
(define (get-racket-tree) *racket-tree*)
|
|
||||||
|
|
||||||
(provide verify!)
|
|
||||||
(define (verify!)
|
|
||||||
(define features (filter string? (reverse (*environment*))))
|
|
||||||
(tag (cons 'verifying (map string->symbol features))
|
|
||||||
(check-dependencies 'distribution
|
|
||||||
(apply concat (cdr (mappend (lambda (x) (list "-" x))
|
|
||||||
features)))))
|
|
||||||
'())
|
|
||||||
|
|
||||||
(provide checker-namespace-anchor)
|
|
||||||
(define-namespace-anchor checker-namespace-anchor)
|
|
||||||
|
|
||||||
(define racket/ #f)
|
|
||||||
(provide set-racket-tree!)
|
|
||||||
(define (set-racket-tree! racket/* racket-base/ racket/-name tree-lists)
|
|
||||||
(set! racket/ racket/*)
|
|
||||||
(set! *platform-tree-lists* tree-lists)
|
|
||||||
(dprintf "Scanning main tree...")
|
|
||||||
(set! *racket-tree*
|
|
||||||
(let loop ([tree (parameterize ([cd racket-base/])
|
|
||||||
(get-tree racket/-name "racket"))]
|
|
||||||
[trees (apply append *platform-tree-lists*)])
|
|
||||||
(if (null? trees)
|
|
||||||
(tree-filter '(not junk) tree)
|
|
||||||
(loop (tree-subtract tree (car trees)) (cdr trees)))))
|
|
||||||
(dprintf " done.\n"))
|
|
||||||
|
|
@ -1,801 +0,0 @@
|
||||||
#lang reader meta/spec-reader
|
|
||||||
|
|
||||||
;; -*- scheme -*-
|
|
||||||
|
|
||||||
;; ============================================================================
|
|
||||||
;; This file holds the specifications for creating Racket distributions. These
|
|
||||||
;; specifications are defined by a sequence of <sym> := <spec>... definitions
|
|
||||||
;; (note: no parens), which binds the symbol to a tree specification. In
|
|
||||||
;; addition, a definition can use `:=tag' which will go into a special space of
|
|
||||||
;; definitions that are used in `tag' forms.
|
|
||||||
;; Each <spec> is a form that can be a pattern string or a combination.
|
|
||||||
;; Pattern strings are matched recursively over path trees and they can:
|
|
||||||
;; - contain shell-glob chars ("*" (will not match "/"s), "?", ranges),
|
|
||||||
;; - the shell-globbing is extended with "{|}" which are used for alternative
|
|
||||||
;; parts (the braces are translated to regexp parens),
|
|
||||||
;; - have a "/" prefix to anchor the pattern at the path beginning,
|
|
||||||
;; - have a "/" suffix to restrict the pattern to directories,
|
|
||||||
;; - contain a "/**/" pattern to match over arbitrary directories nesting.
|
|
||||||
;; Pattens can be combined with a few primitive operators than can be taken as
|
|
||||||
;; operations over either predicates or sets:
|
|
||||||
;; - `and', `or', `not' have usual meaning (can be considered as combining
|
|
||||||
;; predicate functions or set operations),
|
|
||||||
;; - `none', `all' are an always-false and always-true (useful for `cond's).
|
|
||||||
;; Expanding specs works as if the language is always splicing-in definitions,
|
|
||||||
;; which has no effects on most expression. It does have an effect when a
|
|
||||||
;; symbol is defined as a sequence of specs, and in the conditional forms
|
|
||||||
;; below.
|
|
||||||
;; There are a few special spec forms that can be used to conditionalize
|
|
||||||
;; expressions:
|
|
||||||
;; - (cond <cond> => <spec> ...
|
|
||||||
;; ...
|
|
||||||
;; else => <spec>)
|
|
||||||
;; This is a conditional form: the condition can be a symbol which is true
|
|
||||||
;; if this spec is achieved through a usage of a `tag' form (see below).
|
|
||||||
;; `else' is the default condition. The resulting spec(s) are spliced into
|
|
||||||
;; the form they were used in -- which means that this form is used to
|
|
||||||
;; modify an embedding spec form, unlike any of the above. If no <cond>
|
|
||||||
;; holds and no `else' is used, the `cond' form just disappears. The
|
|
||||||
;; condition can contain `and', `or', and `not' expressions. A common
|
|
||||||
;; idiom is:
|
|
||||||
;; (- foo (cond (not bar) => baz))
|
|
||||||
;; meaning that `foo' is used without `baz' when `bar' doesn't hold.
|
|
||||||
;; - (cond* <cond> => <spec> ...
|
|
||||||
;; ...)
|
|
||||||
;; This is similar to the `cond' form, except that all matching branches
|
|
||||||
;; are used, so this form is equivalent to:
|
|
||||||
;; (cond <cond> => <spec> ...) ...
|
|
||||||
;; - (tag <tag> <spec>) is the same as using <spec>, except that the <tag> is
|
|
||||||
;; added to the expansion environment, so it is available for nested cond
|
|
||||||
;; clauses. Instead of a single <tag>, you can use a list of tags. The
|
|
||||||
;; tags are expanded using definitions made with :=tag, and the result is
|
|
||||||
;; added to current tag list -- this expansion is a little different from
|
|
||||||
;; the normal one in that the result contains all of the definition it went
|
|
||||||
;; through (so if x expands to y which expands to z, expanding x will
|
|
||||||
;; result in x, y, and z).
|
|
||||||
;; Finally, it is possible to define `macro' constructs by using a lambda spec:
|
|
||||||
;; - (lambda <args> <body>) if this is the only spec on a rhs of a
|
|
||||||
;; definition, it is evaluated, and the resulting function is used to
|
|
||||||
;; expand instances of what is bound to it. The body itself is almost a
|
|
||||||
;; normal lambda body, except that using multiple expressions will splice
|
|
||||||
;; them into the calling location.
|
|
||||||
;; There are a few predefined macro constructs:
|
|
||||||
;; - symbols are references to other spec definitions
|
|
||||||
;; - `+' is a synonym for `or', `-' is for set-difference
|
|
||||||
|
|
||||||
;; ============================================================================
|
|
||||||
;; Distributions
|
|
||||||
;; these are used to specify distributions, starting from the top and
|
|
||||||
;; expanding down collecting the tags and the resulting tags are used to
|
|
||||||
;; create the distribution file list. The tags and the target entry name are
|
|
||||||
;; strings to avoid expanding them prematurely. When expansion gets to the
|
|
||||||
;; `distribute!', it will use the tags to do a distribution with the given
|
|
||||||
;; name -- converting them all to symbols.
|
|
||||||
|
|
||||||
distributions := (tag "mz" bin+src+dist)
|
|
||||||
(tag "mr" bin+src-dist)
|
|
||||||
(tag "dr" bin+src-dist)
|
|
||||||
(tag "plt" bin+src+dist)
|
|
||||||
(tag ("full" "bin") (distribute!))
|
|
||||||
bin+src+dist := (tag "bin" (verify!) (distribute!))
|
|
||||||
(tag "src" (verify!) (distribute!))
|
|
||||||
bin+src-dist := (tag "bin" (verify!))
|
|
||||||
(tag "src" (verify!))
|
|
||||||
|
|
||||||
;; Platform tags, lhs are binary types, rhs are source types
|
|
||||||
i386-linux :=tag unix
|
|
||||||
i386-linux-gcc2 :=tag unix
|
|
||||||
i386-linux-fc2 :=tag unix
|
|
||||||
i386-linux-fc5 :=tag unix
|
|
||||||
i386-linux-fc6 :=tag unix
|
|
||||||
i386-linux-f7 :=tag unix
|
|
||||||
x86_64-linux-f7 :=tag unix
|
|
||||||
i386-linux-f9 :=tag unix
|
|
||||||
i386-linux-f12 :=tag unix
|
|
||||||
x86_64-linux-f14 :=tag unix
|
|
||||||
x86_64-linux-f18 :=tag unix
|
|
||||||
i386-linux-debian :=tag unix
|
|
||||||
i386-linux-debian-testing :=tag unix
|
|
||||||
i386-linux-debian-unstable :=tag unix
|
|
||||||
x86_64-linux-debian-lenny :=tag unix
|
|
||||||
x86_64-linux-debian-squeeze :=tag unix
|
|
||||||
i386-linux-ubuntu :=tag unix
|
|
||||||
i386-linux-ubuntu-dapper :=tag unix
|
|
||||||
i386-linux-ubuntu-edgy :=tag unix
|
|
||||||
i386-linux-ubuntu-feisty :=tag unix
|
|
||||||
i386-linux-ubuntu-hardy :=tag unix
|
|
||||||
i386-linux-ubuntu-intrepid :=tag unix
|
|
||||||
i386-linux-ubuntu-jaunty :=tag unix
|
|
||||||
i386-linux-ubuntu-karmic :=tag unix
|
|
||||||
x86_64-linux-ubuntu-precise :=tag unix
|
|
||||||
i386-freebsd :=tag unix
|
|
||||||
i386-win32 :=tag win
|
|
||||||
x86_64-win32 :=tag win
|
|
||||||
ppc-darwin :=tag unix
|
|
||||||
i386-darwin :=tag unix
|
|
||||||
ppc-osx-mac :=tag mac
|
|
||||||
i386-osx-mac :=tag mac
|
|
||||||
x86_64-osx-mac :=tag mac
|
|
||||||
sparc-solaris :=tag unix
|
|
||||||
|
|
||||||
;; tag specs to make each distribution a proper superset of the previous
|
|
||||||
mr :=tag mz
|
|
||||||
dr :=tag mr
|
|
||||||
plt :=tag dr
|
|
||||||
|
|
||||||
;; tag connections, mostly used for the below filtering in `distribution'
|
|
||||||
dr :+=tag docs ; include docs with dr & plt
|
|
||||||
plt :+=tag docsrc ; include doc sources with the plt distro
|
|
||||||
unix :=tag man ; man goes with unix
|
|
||||||
mac :=tag man ; ... and with mac
|
|
||||||
tests :=cond (and plt src) ; include tests when plt-src is used
|
|
||||||
docs :=cond (and plt (not src))
|
|
||||||
|
|
||||||
;; distribution main entry point, apply selected global filters
|
|
||||||
distribution := (- (cond full => all plt => plt dr => dr mr => mr mz => mz)
|
|
||||||
distribution-filters)
|
|
||||||
distribution-filters :=
|
|
||||||
(cond full => none
|
|
||||||
else => (cond* src => compiled-filter
|
|
||||||
(not src) => src-filter
|
|
||||||
(not docs) => docs-filter
|
|
||||||
(not docsrc) => docsrc-filter
|
|
||||||
(not man) => man-filter
|
|
||||||
(not tests) => tests-filter
|
|
||||||
(not mr) => gui-filter
|
|
||||||
(not dr) => tools-filter))
|
|
||||||
|
|
||||||
;; used for sanity checking: must be empty
|
|
||||||
;; (note: this rule means that we could avoid specifying docs and just include
|
|
||||||
;; the whole thing -- but this way we make sure that all doc sources are
|
|
||||||
;; included too (since they're specified together).)
|
|
||||||
must-be-empty := (cond docs => (- "/racket/doc/" distribution) else => none)
|
|
||||||
|
|
||||||
compiled-filter := (- (collects: "**/compiled/")
|
|
||||||
(cond verifying => "*.dep"))
|
|
||||||
"/racket/bin/" "/racket/lib/"
|
|
||||||
src-filter := (src: "")
|
|
||||||
docs-filter := (- (doc: "") ; all docs,
|
|
||||||
(notes: "") ; excluding basic stuff
|
|
||||||
std-docs) ; and things in git
|
|
||||||
docsrc-filter := (+ (collects: "setup/scribble.rkt") ; only with doc sources
|
|
||||||
(collects: "**/scribblings/")
|
|
||||||
(srcfile: "*.{scrbl|scribble}")
|
|
||||||
std-docs)
|
|
||||||
man-filter := (man: "*")
|
|
||||||
tests-filter := (+ (collects: "**/tests/") (srcfile: "tests.rkt"))
|
|
||||||
gui-filter := (- (+ (collects: "**/gui/") (srcfile: "gui.rkt"))
|
|
||||||
;; for use in mz code that works in mr too
|
|
||||||
(srcfile: "scheme/gui/dynamic.rkt")
|
|
||||||
(srcfile: "racket/gui/dynamic.rkt"))
|
|
||||||
tools-filter := (+ (collects: "**/tools/") (srcfile: "tools.rkt"))
|
|
||||||
|
|
||||||
;; these are in the doc directory, but are committed in git and should be
|
|
||||||
;; considered as sources
|
|
||||||
std-docs := (doc: "doc-license.txt" "keep-dirs.rktd" "*-std/")
|
|
||||||
|
|
||||||
;; ============================================================================
|
|
||||||
;; Junk
|
|
||||||
|
|
||||||
;; This is removed from the original tree only (*not* from the binary trees)
|
|
||||||
;; (the first line shouldn't be necessary, but be safe)
|
|
||||||
junk := (+ ".git*" "/.mailmap" ".svn" "CVS/" "[.#]*" "*~"
|
|
||||||
;; binary stuff should come from the platform directories
|
|
||||||
"/racket/bin/" "/racket/lib/" "/racket/src/*build*/")
|
|
||||||
|
|
||||||
;; These are handled in a special way by the bundle script: the binary trees
|
|
||||||
;; are scanned for paths that have "<pfx>{3m|cgc}<sfx>" where a "<pfx><sfx>"
|
|
||||||
;; exists too, and will choose to keep the `binary-keep' version. It will do
|
|
||||||
;; some sanity checking: allow only the patterns that are listed below
|
|
||||||
;; (otherwise: error), also throw an error if some path has all three versions
|
|
||||||
;; (3m, cgc, and none). These specs must contain a parenthesized regular
|
|
||||||
;; expressions.
|
|
||||||
|
|
||||||
;; The following three definitions are treated in a special way. They specify
|
|
||||||
;; which files to get rid of so we get a clean 3m (or cgc) distribution (used
|
|
||||||
;; in all distributions except for the `full' ones) . The first one is a set
|
|
||||||
;; of template specification -- each must have this form: "...<...!...>...".
|
|
||||||
;; The actual patterns are created by substituting "!" with the `binary-keep'
|
|
||||||
;; and `binary-throw' patters and removing the "<>"s. Both resulting patterns
|
|
||||||
;; are searched in the tree. Say that the pattern is "111<222!333>444", the
|
|
||||||
;; two patterns that will be used are "111222KEEP333444" and
|
|
||||||
;; "111222THROW333444". Also, for every found path in the tree, the "<...>"
|
|
||||||
;; part is removed to get a `plain' version. So we have possible triplet of
|
|
||||||
;; paths -- one with the throw pattern, one with the keep, and one without the
|
|
||||||
;; "<...>" part (called plain). It is an error if all three exist; otherwise,
|
|
||||||
;; keep the `keep' path (or the `plain' if there is no `keep' path in this
|
|
||||||
;; set), and throw away the `throw' path (or the `plain' if there is no
|
|
||||||
;; `throw'). There is a sanity check that verifies that all 3m/cgc paths are
|
|
||||||
;; covered by these templates.
|
|
||||||
|
|
||||||
binary-keep/throw-templates :=
|
|
||||||
"/racket/{lib|include}/**/*<!>.*"
|
|
||||||
"/racket/bin/*<!>"
|
|
||||||
(cond win => "/racket/*<!>.exe"
|
|
||||||
"/racket/lib/**/lib*<!>???????.{dll|lib|exp}"
|
|
||||||
mac => "/racket/*<!>.app/"
|
|
||||||
"/racket/lib/*Racket*.framework/Versions/*<_!>/")
|
|
||||||
"/racket/collects/**/compiled/**/<!/>*.*"
|
|
||||||
|
|
||||||
binary-keep := "3[mM]"
|
|
||||||
binary-throw := "{cgc|CGC}"
|
|
||||||
|
|
||||||
;; additional patterns that are removed from the distributions, things that
|
|
||||||
;; don't follow the above (have no 3m or cgc in the name, and no keep version
|
|
||||||
;; of the same name that will make them disappear)
|
|
||||||
binary-throw-more :=
|
|
||||||
"/racket/lib/**/libmzgc???????.{dll|lib}"
|
|
||||||
|
|
||||||
;; ============================================================================
|
|
||||||
;; Convenient macros
|
|
||||||
|
|
||||||
plt-path: := (lambda (prefix . paths)
|
|
||||||
(let* ([prefix (expand-spec-1 prefix)]
|
|
||||||
[paths (expand-specs paths)]
|
|
||||||
[prefix (regexp-replace #rx"^/?(.+?)/?$" prefix "\\1/")]
|
|
||||||
[suffix ""])
|
|
||||||
(when (and (pair? paths) (eq? ': (car paths)))
|
|
||||||
(set! suffix (cadr paths)) (set! paths (cddr paths)))
|
|
||||||
`(+ ,@(map (lambda (path)
|
|
||||||
(concat "/racket/" prefix
|
|
||||||
(regexp-replace #rx"^/" path "")
|
|
||||||
suffix))
|
|
||||||
paths))))
|
|
||||||
|
|
||||||
src: := (lambda ps `(plt-path: "src" ,@ps))
|
|
||||||
|
|
||||||
collects: := (lambda ps `(plt-path: "collects" ,@ps))
|
|
||||||
|
|
||||||
doc: := (lambda ps `(plt-path: "doc" ,@ps))
|
|
||||||
|
|
||||||
scribblings: := (lambda ps `(plt-path: "collects/scribblings" ,@ps))
|
|
||||||
|
|
||||||
doc+src: := (lambda ps `(+ (doc: ,@ps) (scribblings: ,@ps)))
|
|
||||||
|
|
||||||
bin: := (lambda ps
|
|
||||||
(let ([ps (map (lambda (p)
|
|
||||||
(regexp-replace*
|
|
||||||
#rx"[a-zA-Z]"
|
|
||||||
(regexp-replace* #rx"[ -]"
|
|
||||||
(expand-spec-1 p)
|
|
||||||
"[ -]")
|
|
||||||
(lambda (ch)
|
|
||||||
(string-append "[" (string-downcase ch)
|
|
||||||
(string-upcase ch) "]"))))
|
|
||||||
ps)])
|
|
||||||
`(+ (plt-path: "bin" : "{|3[mM]|cgc|CGC}" ,@ps)
|
|
||||||
(plt-path: "" : "{|3[mM]|cgc|CGC}.{exe|app}" ,@ps))))
|
|
||||||
|
|
||||||
notes: := (lambda ps `(plt-path: "doc/release-notes" ,@ps))
|
|
||||||
|
|
||||||
lib: := (lambda ps `(plt-path: "lib" ,@ps))
|
|
||||||
|
|
||||||
man: := (lambda ps `(plt-path: "man/man1" : ".1" ,@ps))
|
|
||||||
|
|
||||||
tests: := (lambda ps `(plt-path: "collects/tests" ,@ps))
|
|
||||||
|
|
||||||
srcfile: :=
|
|
||||||
(lambda fs
|
|
||||||
`(collects:
|
|
||||||
,@(mappend
|
|
||||||
(lambda (f)
|
|
||||||
(let* ([f (if (regexp-match #rx"\\." f) f (concat f ".*"))]
|
|
||||||
[p+n+s (regexp-match #rx"^(.*/)?([^/]+)\\.([^.]+)$" f)]
|
|
||||||
[dir (or (cadr p+n+s) "")]
|
|
||||||
[name (concat (caddr p+n+s) "_" (cadddr p+n+s))])
|
|
||||||
(list (concat "**/" f)
|
|
||||||
(concat "**/" dir "compiled/" name ".zo")
|
|
||||||
(concat "**/" dir "compiled/" name ".dep"))))
|
|
||||||
fs)))
|
|
||||||
|
|
||||||
dll: := (lambda fs
|
|
||||||
`(+ ,@(map (lambda (f)
|
|
||||||
(concat "/racket/lib/"
|
|
||||||
(regexp-replace #rx"^/" (expand-spec-1 f) "")
|
|
||||||
"{|3[mM]|cgc|CGC}{|???????}.dll"))
|
|
||||||
fs)
|
|
||||||
,@(map (lambda (f)
|
|
||||||
(concat "/racket/lib/**/"
|
|
||||||
(regexp-replace #rx"^.*/" (expand-spec-1 f) "")
|
|
||||||
"{|3[mM]|cgc|CGC}{|???????}.lib"))
|
|
||||||
fs)))
|
|
||||||
|
|
||||||
package: :=
|
|
||||||
(lambda (p . more)
|
|
||||||
(let* ([p (expand-spec-1 p)]
|
|
||||||
[getkey
|
|
||||||
(let loop ([l more] [ks '()])
|
|
||||||
(cond
|
|
||||||
[(null? l) (lambda (key [default #f])
|
|
||||||
(cond [(assq key ks) => cdr] [else default]))]
|
|
||||||
[(null? (cdr l)) (error 'package "bad args")]
|
|
||||||
[(not (keyword? (car l))) (error 'package "bad args")]
|
|
||||||
[else (loop (cddr l)
|
|
||||||
(cons (cons (car l) (expand-spec-1 (cadr l)))
|
|
||||||
ks))]))]
|
|
||||||
[p (regexp-replace #rx"/$" p "")]
|
|
||||||
[p/ (concat p "/")])
|
|
||||||
`(+ (collects: ,(getkey '#:collection p/))
|
|
||||||
(bin: ,(getkey '#:executable p))
|
|
||||||
(doc+src: ,(getkey '#:docs p/))
|
|
||||||
(notes: ,p/) (man: ,p) (tests: ,p/)
|
|
||||||
,@(if (getkey '#:src?) `((src: ,p/ ,(concat "worksp/" p/))) '()))))
|
|
||||||
|
|
||||||
;; Utility for pulling out the names of libraries
|
|
||||||
get-libs: :=
|
|
||||||
(lambda (p)
|
|
||||||
(let* ([xs (parameterize ([current-command-line-arguments '#("nothing")])
|
|
||||||
(dynamic-require (build-path racket/ "src" "get-libs.rkt")
|
|
||||||
'all-files+sizes))]
|
|
||||||
[xs (or (assq p xs) (error 'get-libs "unknown package, ~s" p))]
|
|
||||||
[xs (append-map cdr (cdr xs))]
|
|
||||||
[xs (map (lambda (x) (if (>= (length x) 3) (list-ref x 2) (car x)))
|
|
||||||
xs)]
|
|
||||||
[xs (remove-duplicates xs)])
|
|
||||||
`(lib: ,@xs)))
|
|
||||||
|
|
||||||
;; ============================================================================
|
|
||||||
;; Base distribution specs
|
|
||||||
|
|
||||||
mz := (+ mz-base mz-src mz-bins mz-manuals mz-tests mz-extras)
|
|
||||||
|
|
||||||
mr := (+ mz mr-base mr-src mr-bins mr-manuals mr-extras)
|
|
||||||
|
|
||||||
dr := (+ mr dr-base dr-manuals dr-extras)
|
|
||||||
|
|
||||||
plt := (+ dr plt-extras)
|
|
||||||
|
|
||||||
;; ============================================================================
|
|
||||||
;; Packages etc
|
|
||||||
|
|
||||||
mz-base := "/racket/README"
|
|
||||||
(package: "racket") (package: "mzscheme")
|
|
||||||
"/racket/include/"
|
|
||||||
;; configuration stuff
|
|
||||||
(cond (not src) => (collects: "info-domain/")) ; filtered
|
|
||||||
(package: "config")
|
|
||||||
;; basic code
|
|
||||||
(collects: "scheme" "s-exp" "reader")
|
|
||||||
;; include the time-stamp collection when not a public release
|
|
||||||
(cond (not release)
|
|
||||||
=> (- (collects: "repo-time-stamp/")
|
|
||||||
(cond (not dr) => (srcfile: "time-stamp.rkt"))))
|
|
||||||
mz-manuals := (scribblings: "main/") ; generates main pages (next line)
|
|
||||||
(doc: "license/" "release/" "acks/" "search/" "local-redirect/"
|
|
||||||
"getting-started/")
|
|
||||||
(notes: "COPYING*.txt")
|
|
||||||
(doc: "doc-license.txt") ; needed (when docs are included)
|
|
||||||
(doc+src: "reference/" "guide/" "quick/" "more/" "style/"
|
|
||||||
"foreign/" "inside/"
|
|
||||||
"scheme/"
|
|
||||||
"honu/")
|
|
||||||
(doc: "*.{html|css|js|sxref}")
|
|
||||||
(doc: "blueboxes.rktd")
|
|
||||||
(doc: "keep-dirs.rktd")
|
|
||||||
(doc: "docindex.sqlite")
|
|
||||||
(scribblings: "{{info|icons}.rkt|*.png}" "compiled")
|
|
||||||
|
|
||||||
mr-base := (package: "gracket") (bin: "gracket-text")
|
|
||||||
(package: "mred") (bin: "mred-text")
|
|
||||||
mr-manuals := (doc+src: "gui/") (doc+src: "draw/")
|
|
||||||
|
|
||||||
dr-base := (package: "drracket") (package: "drscheme") (package: "framework")
|
|
||||||
dr-manuals := (doc+src: "tools/")
|
|
||||||
|
|
||||||
;; Misc hooks, to be added on by package rules below
|
|
||||||
mz-extras :=
|
|
||||||
mr-extras :=
|
|
||||||
dr-extras :=
|
|
||||||
plt-extras :=
|
|
||||||
|
|
||||||
;; Tests definitions
|
|
||||||
mz-tests := (tests: "info.rkt" "racket/" "utils/" "match/"
|
|
||||||
"eli-tester.rkt" "stress.rkt")
|
|
||||||
|
|
||||||
;; ============================================================================
|
|
||||||
;; Source definitions
|
|
||||||
|
|
||||||
mz-src := (+ (- (src: "README" "configure" "Makefile.in" "lt/" "racket/"
|
|
||||||
"get-libs.rkt" "download-libs.rkt" "utils/"
|
|
||||||
(cond win => "worksp/{README|mzconfig.h}"
|
|
||||||
"worksp/{build.bat|rbuildmode.c}"
|
|
||||||
"worksp/{racket|libracket}/"
|
|
||||||
"worksp/{libmzgc|gc2|sgc}/"
|
|
||||||
"worksp/libffi/"
|
|
||||||
"worksp/{mzstart|starters}/"))
|
|
||||||
(cond (not mr) => (src: "worksp/starters/mrstart.ico")))
|
|
||||||
foreign-src)
|
|
||||||
|
|
||||||
mr-src := (src: "gracket/" (cond mac => "mac/"
|
|
||||||
win => "worksp/{gracket|mrstart}/"))
|
|
||||||
|
|
||||||
foreign-src := (src: "foreign/{Makefile.in|README}"
|
|
||||||
"foreign/{foreign.*|rktc-utils.rkt}"
|
|
||||||
"foreign/libffi")
|
|
||||||
|
|
||||||
;; ============================================================================
|
|
||||||
;; Binary definitions (`in-binary-tree' is used with binary trees, these
|
|
||||||
;; queries have no point elsewhere.)
|
|
||||||
|
|
||||||
mz-bins := (lib: "buildinfo" "**/mzdyn{|w}{|3[mM]|cgc|CGC}.{o|obj|exp|def}")
|
|
||||||
(get-libs: core)
|
|
||||||
(cond mac => (lib: "Racket*/")
|
|
||||||
win => (dll: "lib{mzgc|racket}")
|
|
||||||
(lib: "gcc/{fixup|init}.o" "bcc/mzdynb.{obj|def}")
|
|
||||||
unix => (lib: "starter"))
|
|
||||||
|
|
||||||
mr-bins := (get-libs: gui)
|
|
||||||
(cond mac => (lib: "GRacket*/")
|
|
||||||
win => (dll: "libgracket"))
|
|
||||||
|
|
||||||
;; ============================================================================
|
|
||||||
;; This filter is used on the full compiled trees to get the binary
|
|
||||||
;; (platform-dependent) portion out.
|
|
||||||
|
|
||||||
binaries := (+ "/racket/bin/"
|
|
||||||
"/racket/lib/"
|
|
||||||
"/racket/include/"
|
|
||||||
"/racket/collects/**/compiled/native/"
|
|
||||||
(cond unix => "/racket/bin/{|g}racket*"
|
|
||||||
"/racket/bin/{mzscheme|mred}*"
|
|
||||||
win => "/racket/*.exe"
|
|
||||||
"/racket/*.dll"
|
|
||||||
"/racket/collects/launcher/*.exe"
|
|
||||||
mac => "/racket/bin/racket*"
|
|
||||||
"/racket/bin/mzscheme*"
|
|
||||||
"/racket/*.app"
|
|
||||||
"/racket/collects/launcher/*.app")
|
|
||||||
platform-dependent)
|
|
||||||
|
|
||||||
platform-dependent := ; hook for package rules
|
|
||||||
|
|
||||||
;; ============================================================================
|
|
||||||
;; Package rules
|
|
||||||
|
|
||||||
;; -------------------- setup
|
|
||||||
mz-extras :+= (- (package: "setup-plt" #:collection "setup/")
|
|
||||||
(cond (not dr) => (srcfile: "plt-installer{|-sig|-unit}.rkt")))
|
|
||||||
|
|
||||||
;; -------------------- raco
|
|
||||||
mz-extras :+= (package: "raco")
|
|
||||||
|
|
||||||
;; -------------------- launcher
|
|
||||||
mz-extras :+= (- (collects: "launcher")
|
|
||||||
(cond (not mr) => "[Mm]r[Ss]tart*.exe"))
|
|
||||||
|
|
||||||
;; -------------------- make
|
|
||||||
mz-extras :+= (package: "make/")
|
|
||||||
|
|
||||||
;; -------------------- dynext
|
|
||||||
mz-extras :+= (package: "dynext")
|
|
||||||
|
|
||||||
;; -------------------- mzlib (compatibility layer)
|
|
||||||
mz-extras :+= (package: "mzlib")
|
|
||||||
|
|
||||||
;; -------------------- compiler (mzc)
|
|
||||||
mz-extras :+= (package: "mzc" #:collection "compiler/") (doc+src: "cffi/")
|
|
||||||
|
|
||||||
;; -------------------- scribble
|
|
||||||
mz-extras :+= (package: "scribble") (collects: "at-exp")
|
|
||||||
|
|
||||||
;; -------------------- scriblib
|
|
||||||
mz-extras :+= (package: "scriblib")
|
|
||||||
|
|
||||||
;; -------------------- syntax
|
|
||||||
mz-extras :+= (package: "syntax")
|
|
||||||
|
|
||||||
;; -------------------- errortrace
|
|
||||||
mz-extras :+= (package: "errortrace")
|
|
||||||
|
|
||||||
;; -------------------- trace
|
|
||||||
mz-extras :+= (package: "trace")
|
|
||||||
|
|
||||||
;; -------------------- profile
|
|
||||||
mz-extras :+= (package: "profile")
|
|
||||||
|
|
||||||
;; -------------------- contract profile
|
|
||||||
plt-extras :+= (package: "contract-profile")
|
|
||||||
|
|
||||||
;; -------------------- specific file format libraries
|
|
||||||
mz-extras :+= (package: "file")
|
|
||||||
|
|
||||||
;; -------------------- network protocols
|
|
||||||
mz-extras :+= (package: "net")
|
|
||||||
|
|
||||||
;; -------------------- openssl interface
|
|
||||||
mz-extras :+= (package: "openssl")
|
|
||||||
|
|
||||||
;; -------------------- parser
|
|
||||||
mz-extras :+= (package: "parser-tools/")
|
|
||||||
|
|
||||||
;; -------------------- html
|
|
||||||
mz-extras :+= (package: "html/")
|
|
||||||
|
|
||||||
;; -------------------- compatibility
|
|
||||||
mz-extras :+= (package: "compatibility/")
|
|
||||||
|
|
||||||
;; -------------------- r5rs
|
|
||||||
mz-extras :+= (package: "r5rs/" #:executable "plt-r5rs")
|
|
||||||
(doc: "r5rs-std")
|
|
||||||
|
|
||||||
;; -------------------- r6rs
|
|
||||||
mz-extras :+= (collects: "rnrs/")
|
|
||||||
(package: "r6rs/" #:executable "plt-r6rs")
|
|
||||||
(doc: "r6rs-std" "r6rs-lib-std")
|
|
||||||
|
|
||||||
;; -------------------- readline
|
|
||||||
mz-extras :+= (package: "readline/")
|
|
||||||
|
|
||||||
;; -------------------- xrepl
|
|
||||||
mz-extras :+= (package: "xrepl/")
|
|
||||||
|
|
||||||
;; -------------------- wxme
|
|
||||||
mz-extras :+= (collects: "wxme/")
|
|
||||||
|
|
||||||
;; -------------------- web-server
|
|
||||||
mz-extras :+=
|
|
||||||
(+ (package: "web-server" #:executable "PLT Web Server")
|
|
||||||
(doc: "continue" "web-server-internal"))
|
|
||||||
|
|
||||||
;; -------------------- srfi
|
|
||||||
mz-extras :+= (package: "srfi") (doc: "srfi-std")
|
|
||||||
|
|
||||||
;; -------------------- xml
|
|
||||||
mz-extras :+= (- (package: "xml/")
|
|
||||||
(cond* (not plt) => (srcfile: "*-{tool|snipclass}.rkt"
|
|
||||||
"xml.png")))
|
|
||||||
|
|
||||||
;; -------------------- json
|
|
||||||
mz-extras :+= (package: "json/")
|
|
||||||
|
|
||||||
;; -------------------- ffi
|
|
||||||
mz-extras :+= (collects: "ffi/") (doc: "objc")
|
|
||||||
|
|
||||||
;; -------------------- preprocessor
|
|
||||||
mz-extras :+= (package: "preprocessor/") (bin: "mzpp" "mztext")
|
|
||||||
|
|
||||||
;; -------------------- slatex
|
|
||||||
plt-extras :+= (package: "slatex")
|
|
||||||
(bin: "PDF SLaTeX")
|
|
||||||
(doc+src: "slatex-wrap/")
|
|
||||||
|
|
||||||
;; -------------------- planet
|
|
||||||
mz-extras :+= (package: "planet")
|
|
||||||
|
|
||||||
;; -------------------- pkg
|
|
||||||
mz-extras :+= (- (package: "pkg")
|
|
||||||
(collects: "pkg/gui/"))
|
|
||||||
dr-extras :+= (collects: "pkg/gui/")
|
|
||||||
|
|
||||||
;; -------------------- mrlib
|
|
||||||
mr-extras :+= (+ (- (package: "mrlib/")
|
|
||||||
(srcfile: "mrlib/terminal.rkt"))
|
|
||||||
(collects: "hierlist/")
|
|
||||||
(collects: "icons/turn-{up|down}{|-click}.png")
|
|
||||||
(tests: "aligned-pasteboard/"))
|
|
||||||
|
|
||||||
;; -------------------- pict library
|
|
||||||
mr-extras :+= (- (+ (package: "pict/")
|
|
||||||
(collects: "texpict/")
|
|
||||||
(srcfile: "slideshow/pict.rkt")
|
|
||||||
(srcfile: "slideshow/pict-convert.rkt"))
|
|
||||||
(srcfile: "texpict/slideshow-run.rkt")
|
|
||||||
(srcfile: "texpict/slideshow.rkt")
|
|
||||||
(srcfile: "texpict/symbol.rkt"))
|
|
||||||
|
|
||||||
;; -------------------- sgl
|
|
||||||
mr-extras :+= (package: "sgl/")
|
|
||||||
|
|
||||||
;; -------------------- syntax-color
|
|
||||||
mz-extras :+= (package: "syntax-color") (doc: "red-black")
|
|
||||||
|
|
||||||
;; -------------------- plt-help
|
|
||||||
dr-extras :+= (collects: "help") (doc: "help")
|
|
||||||
(bin: "Racket Documentation")
|
|
||||||
(bin: "plt-help") (man: "plt-help")
|
|
||||||
|
|
||||||
dr-extras :+= (srcfile: "mrlib/terminal.rkt")
|
|
||||||
|
|
||||||
;; -------------------- lang
|
|
||||||
plt-extras :+= (package: "lang/" #:docs "htdp-langs/")
|
|
||||||
|
|
||||||
;; -------------------- htdp, tests, teachpacks
|
|
||||||
plt-extras :+=
|
|
||||||
(package: "htdp/")
|
|
||||||
(- (package: "teachpack/") (collects: "teachpack/deinprogramm/"))
|
|
||||||
(- (package: "2htdp/")
|
|
||||||
"uchat/") ; Matthias doesn't want this in now
|
|
||||||
(package: "test-engine/")
|
|
||||||
(- (package: "realm")
|
|
||||||
"todo.txt")
|
|
||||||
|
|
||||||
;; -------------------- math
|
|
||||||
dr-extras :+= (package: "math") (get-libs: math)
|
|
||||||
|
|
||||||
;; -------------------- stepper
|
|
||||||
plt-extras :+= (package: "stepper")
|
|
||||||
|
|
||||||
;; -------------------- macro-debugger
|
|
||||||
plt-extras :+= (package: "macro-debugger")
|
|
||||||
|
|
||||||
;; -------------------- lazy
|
|
||||||
plt-extras :+= (package: "lazy")
|
|
||||||
|
|
||||||
;; -------------------- icons, images
|
|
||||||
dr-extras :+= (collects: "icons/*.{jpg|png|gif|bmp|xbm|xpm}")
|
|
||||||
dr-extras :+= (package: "images/")
|
|
||||||
|
|
||||||
plt-extras :+= (package: "icons/")
|
|
||||||
|
|
||||||
;; -------------------- string
|
|
||||||
dr-extras :+= (package: "string-constants")
|
|
||||||
|
|
||||||
;; -------------------- defaults
|
|
||||||
dr-extras :+= (collects: "defaults/")
|
|
||||||
|
|
||||||
;; -------------------- version
|
|
||||||
mz-extras :+= (- (package: "version/")
|
|
||||||
(cond* (not dr) => (srcfile: "tool.rkt")))
|
|
||||||
|
|
||||||
;; -------------------- browser
|
|
||||||
dr-extras :+= (package: "browser/")
|
|
||||||
|
|
||||||
;; -------------------- graphics
|
|
||||||
plt-extras :+= (package: "graphics/") (doc: "turtles")
|
|
||||||
|
|
||||||
;; -------------------- embedded
|
|
||||||
plt-extras :+= (package: "embedded-gui/")
|
|
||||||
|
|
||||||
;; -------------------- eopl
|
|
||||||
plt-extras :+= (package: "eopl/")
|
|
||||||
|
|
||||||
;; -------------------- picturing-programs
|
|
||||||
plt-extras :+= (package: "picturing-programs/")
|
|
||||||
|
|
||||||
;; -------------------- algol60
|
|
||||||
plt-extras :+= (package: "algol60/")
|
|
||||||
|
|
||||||
;; -------------------- games
|
|
||||||
plt-extras :+= (- (+ (package: "games/" #:executable "plt-games")
|
|
||||||
(doc+src: "gl-board-game/" "cards/"))
|
|
||||||
"paint-by-numbers/{hattori|solution-sets|raw-problems}")
|
|
||||||
|
|
||||||
;; -------------------- slideshow
|
|
||||||
plt-extras :+= (- (+ (package: "slideshow")
|
|
||||||
(srcfile: "texpict/slideshow-run.rkt")
|
|
||||||
(srcfile: "texpict/slideshow.rkt")
|
|
||||||
(srcfile: "texpict/symbol.rkt"))
|
|
||||||
(srcfile: "slideshow/pict.rkt")
|
|
||||||
(srcfile: "slideshow/pict-convert.rkt"))
|
|
||||||
|
|
||||||
;; -------------------- frtime
|
|
||||||
plt-extras :+= (package: "frtime/")
|
|
||||||
|
|
||||||
;; -------------------- typed-racket
|
|
||||||
dr-extras :+= (package: "typed-racket/" ; used in drracket
|
|
||||||
#:docs "ts-{reference|guide}/")
|
|
||||||
(- (collects: "typed/")
|
|
||||||
(cond (not plt) => (collects: "typed/test-engine/")
|
|
||||||
(srcfile: "typed/rackunit/gui.rkt")))
|
|
||||||
(collects: "typed-scheme") ; compatibility
|
|
||||||
|
|
||||||
;; -------------------- gui-debugger
|
|
||||||
plt-extras :+= (collects: "gui-debugger/")
|
|
||||||
|
|
||||||
;; -------------------- swindle
|
|
||||||
mz-extras :+= (- (package: "swindle")
|
|
||||||
(cond (not dr) => (srcfile: "tool.rkt" "swindle*.png")))
|
|
||||||
|
|
||||||
;; -------------------- plot
|
|
||||||
plt-extras :+= (package: "plot")
|
|
||||||
|
|
||||||
;; -------------------- mzcom
|
|
||||||
plt-extras :+= (- (package: "mzcom" #:src? #t)
|
|
||||||
(cond (not win) => (src: "")))
|
|
||||||
|
|
||||||
;; -------------------- com & mysterx
|
|
||||||
plt-extras :+= (- (+ (dll: "myssink")
|
|
||||||
(src: "myssink/" "worksp/myssink/")
|
|
||||||
(package: "mysterx"))
|
|
||||||
(cond (not win) => (src: "")))
|
|
||||||
|
|
||||||
;; -------------------- redex
|
|
||||||
plt-extras :+= (package: "redex")
|
|
||||||
|
|
||||||
;; -------------------- deinprogramm
|
|
||||||
plt-extras :+= (package: "deinprogramm/")
|
|
||||||
(collects: "teachpack/deinprogramm/")
|
|
||||||
(doc: "DMdA-lib")
|
|
||||||
|
|
||||||
;; -------------------- data
|
|
||||||
mz-extras :+= (package: "data")
|
|
||||||
|
|
||||||
;; -------------------- unstable
|
|
||||||
mz-extras :+= (- (package: "unstable")
|
|
||||||
;; should "gui" mean DrRacket or GRacket? It's not
|
|
||||||
;; obvious that "framework" is only in DrRacket.
|
|
||||||
(cond (not plt) => (collects: "unstable/gui")))
|
|
||||||
|
|
||||||
;; -------------------- plai
|
|
||||||
plt-extras :+= (package: "plai/")
|
|
||||||
|
|
||||||
;; -------------------- rackunit & older schemeunit compatibility
|
|
||||||
mz-extras :+= (- (package: "rackunit/")
|
|
||||||
(collects: "rackunit/private/gui/")
|
|
||||||
(srcfile: "rackunit/gui.rkt")
|
|
||||||
(srcfile: "rackunit/tool.rkt"))
|
|
||||||
plt-extras :+= (collects: "rackunit/private/gui/")
|
|
||||||
(srcfile: "rackunit/gui.rkt")
|
|
||||||
(srcfile: "rackunit/tool.rkt")
|
|
||||||
(package: "schemeunit/")
|
|
||||||
|
|
||||||
;; -------------------- racklog (aka schelog)
|
|
||||||
plt-extras :+= (package: "racklog/")
|
|
||||||
|
|
||||||
;; -------------------- datalog
|
|
||||||
plt-extras :+= (package: "datalog/")
|
|
||||||
|
|
||||||
;; -------------------- db
|
|
||||||
mz-extras :+= (package: "db/") (get-libs: db)
|
|
||||||
|
|
||||||
;; -------------------- future-visualizer
|
|
||||||
plt-extras :+= (package: "future-visualizer/")
|
|
||||||
|
|
||||||
;; ============================================================================
|
|
||||||
;; Readme header
|
|
||||||
|
|
||||||
version := (lambda () (version))
|
|
||||||
|
|
||||||
platform
|
|
||||||
:= (cond i386-linux => "Linux (i386)"
|
|
||||||
i386-linux-gcc2 => "Linux (i386/gcc2)"
|
|
||||||
i386-linux-fc2 => "Linux i386, built on Fedora Core 2"
|
|
||||||
i386-linux-fc5 => "Linux i386, built on Fedora Core 5"
|
|
||||||
i386-linux-fc6 => "Linux i386, built on Fedora Core 6"
|
|
||||||
i386-linux-f7 => "Linux i386, built on Fedora 7"
|
|
||||||
x86_64-linux-f7 => "Linux x86_64, built on Fedora 7"
|
|
||||||
i386-linux-f9 => "Linux i386, built on Fedora 9"
|
|
||||||
i386-linux-f12 => "Linux i386, built on Fedora 12"
|
|
||||||
x86_64-linux-f14 => "Linux x86_64, built on Fedora 14"
|
|
||||||
x86_64-linux-f18 => "Linux x86_64, built on Fedora 18"
|
|
||||||
i386-linux-debian => "Linux i386, built on Debian Stable"
|
|
||||||
i386-linux-debian-testing => "Linux i386, built on Debian Testing"
|
|
||||||
i386-linux-debian-unstable => "Linux i386, built on Debian Unstable"
|
|
||||||
x86_64-linux-debian-lenny => "Linux x86_64, built on Debian Lenny"
|
|
||||||
x86_64-linux-debian-squeeze => "Linux x86_64, built on Debian Squeeze"
|
|
||||||
i386-linux-ubuntu => "Linux i386, built on Ubuntu"
|
|
||||||
i386-linux-ubuntu-dapper => "Linux i386, built on Ubuntu Dapper"
|
|
||||||
i386-linux-ubuntu-edgy => "Linux i386, built on Ubuntu Edgy"
|
|
||||||
i386-linux-ubuntu-feisty => "Linux i386, built on Ubuntu Feisty"
|
|
||||||
i386-linux-ubuntu-hardy => "Linux i386, built on Ubuntu Hardy"
|
|
||||||
i386-linux-ubuntu-intrepid => "Linux i386, built on Ubuntu Intrepid"
|
|
||||||
i386-linux-ubuntu-jaunty => "Linux i386, built on Ubuntu Jaunty"
|
|
||||||
i386-linux-ubuntu-karmic => "Linux i386, built on Ubuntu Karmic"
|
|
||||||
x86_64-linux-ubuntu-precise => "Linux x86_64, built on Ubuntu Precise"
|
|
||||||
i386-freebsd => "FreeBSD (i386)"
|
|
||||||
sparc-solaris => "Solaris"
|
|
||||||
ppc-osx-mac => "Mac OS X (PPC)"
|
|
||||||
i386-osx-mac => "Mac OS X (Intel 32-bit)"
|
|
||||||
x86_64-osx-mac => "Mac OS X (Intel 64-bit)"
|
|
||||||
ppc-darwin => "Mac OS X using X11 (PPC)"
|
|
||||||
i386-darwin => "Mac OS X using X11 (Intel)"
|
|
||||||
i386-win32 => "Windows (32-bit)"
|
|
||||||
x86_64-win32 => "Windows (64-bit)"
|
|
||||||
;; generic platforms for source distributions
|
|
||||||
unix => "Unix"
|
|
||||||
mac => "Mac OS X"
|
|
||||||
win => "Windows")
|
|
||||||
|
|
||||||
readme-header
|
|
||||||
:= "This is the Racket v"(version)(cond src => " source" unix => " binary")
|
|
||||||
" package for "platform".\n"
|
|
||||||
(cond src => "\n"
|
|
||||||
"See the build instructions in \"src/README\".\n"
|
|
||||||
mac => "\n"
|
|
||||||
"Install by dragging the enclosing Racket folder to your Applications folder\n"
|
|
||||||
"--- or wherever you like. You can move the Racket folder at any time, but do not\n"
|
|
||||||
"move applications or other files within the folder. If you want to use the\n"
|
|
||||||
"Racket command-line programs, then (optionally) add the path of the \"bin\"\n"
|
|
||||||
"subdirectory to your PATH environment variable.\n")
|
|
||||||
|
|
||||||
;; ============================================================================
|
|
||||||
|
|
@ -3,8 +3,7 @@
|
||||||
(define name "Infrastructure code")
|
(define name "Infrastructure code")
|
||||||
(define compile-omit-paths '("images/taking-screenshots/racket-widget.scm"))
|
(define compile-omit-paths '("images/taking-screenshots/racket-widget.scm"))
|
||||||
(define test-omit-paths
|
(define test-omit-paths
|
||||||
'("check-dists.rkt"
|
'("drdr"
|
||||||
"drdr"
|
|
||||||
"drdr2"
|
"drdr2"
|
||||||
"images/mkheart.rkt"
|
"images/mkheart.rkt"
|
||||||
"pkg-index/official"
|
"pkg-index/official"
|
||||||
|
|
|
||||||
|
|
@ -1,10 +0,0 @@
|
||||||
#lang scheme/base
|
|
||||||
(require "specs.rkt")
|
|
||||||
|
|
||||||
(provide (rename-out [module-begin #%module-begin]))
|
|
||||||
|
|
||||||
(define-syntax-rule (module-begin . rest)
|
|
||||||
(#%module-begin
|
|
||||||
(provide register-specs!)
|
|
||||||
(define (register-specs! [param *specs*])
|
|
||||||
(process-specs 'rest param))))
|
|
||||||
|
|
@ -1,2 +0,0 @@
|
||||||
#lang s-exp syntax/module-reader
|
|
||||||
#:language 'meta/spec-lang
|
|
||||||
|
|
@ -1,238 +0,0 @@
|
||||||
;; This module defines the specs "language" . It is basically a simple
|
|
||||||
;; language of definitions that can expand to anything at all: expanding a spec
|
|
||||||
;; starts at that symbol and follows definitions until no further expansion is
|
|
||||||
;; possible. There are two major points that makes this require a new
|
|
||||||
;; language: first, expansion is lazy, second, everything is spliced. To be
|
|
||||||
;; able to have macros, `lambda' escapes back to Scheme and generates a
|
|
||||||
;; function. For more details, see the "distribution-specs" file (large
|
|
||||||
;; portions of the details there should eventually move here).
|
|
||||||
|
|
||||||
#lang scheme/base
|
|
||||||
|
|
||||||
;;; ===========================================================================
|
|
||||||
;;; Utilities etc
|
|
||||||
|
|
||||||
(provide mappend)
|
|
||||||
(define (mappend f l)
|
|
||||||
(apply append (map f l)))
|
|
||||||
|
|
||||||
(provide filtered-map)
|
|
||||||
(define (filtered-map f l)
|
|
||||||
(reverse
|
|
||||||
(foldl (lambda (x y) (let ([x (f x)]) (if x (cons x y) y))) '() l)))
|
|
||||||
|
|
||||||
;; a splicing substitution
|
|
||||||
(define (@subst expr from to)
|
|
||||||
(cond [(not (pair? expr))
|
|
||||||
(if (equal? expr from) (error '@subst "something bad happened") expr)]
|
|
||||||
[(equal? (car expr) from)
|
|
||||||
(append to (@subst (cdr expr) from to))]
|
|
||||||
[else
|
|
||||||
(cons (@subst (car expr) from to) (@subst (cdr expr) from to))]))
|
|
||||||
|
|
||||||
;; The input list is expected to be (x1 <sym1> y1 ... x2 <sym2> y2 ... ...),
|
|
||||||
;; where <symN> is some symbol in the given `syms'. The result is a list of
|
|
||||||
;; lists that are split using syms as infix tokens with one element on the
|
|
||||||
;; left. The result of the above will be
|
|
||||||
;; ((<sym1> x1 y1 ...) (<sym2> x2 y2 ...))
|
|
||||||
(define (infix-split syms lst)
|
|
||||||
(let loop ([l lst] [r '()])
|
|
||||||
(cond [(null? l) (reverse r)]
|
|
||||||
[(or (null? (cdr l)) (not (memq (cadr l) syms)))
|
|
||||||
(error 'infix-split "bad sequence near ~e in ~e" (car l) lst)]
|
|
||||||
[else (let sub-loop ([sub (list (car l) (cadr l))] [l (cddr l)])
|
|
||||||
(if (or (null? l)
|
|
||||||
(and (not (null? (cdr l))) (memq (cadr l) syms)))
|
|
||||||
(loop l (cons (reverse sub) r))
|
|
||||||
(sub-loop (cons (car l) sub) (cdr l))))])))
|
|
||||||
|
|
||||||
;; Runs the above on all input from a given file. The default is to add the
|
|
||||||
;; specs to *specs*.
|
|
||||||
(provide process-specs)
|
|
||||||
(define (process-specs input [param *specs*])
|
|
||||||
(define-values (specs tags conds)
|
|
||||||
(cond [(param) => (lambda (ls) (apply values (map reverse ls)))]
|
|
||||||
[else (values '() '() '())]))
|
|
||||||
(for-each
|
|
||||||
(lambda (b)
|
|
||||||
(define-syntax bind!
|
|
||||||
(syntax-rules ()
|
|
||||||
[(_ loc) (if (assq (cadr b) loc)
|
|
||||||
(error 'loc "got a second `~s' binding in ~s"
|
|
||||||
(cadr b) (list* (cadr b) (car b) (cddr b)))
|
|
||||||
(set! loc (cons (cdr b) loc)))]))
|
|
||||||
(define-syntax change!
|
|
||||||
(syntax-rules ()
|
|
||||||
[(_ loc how)
|
|
||||||
(cond [(assq (cadr b) loc)
|
|
||||||
=> (lambda (cur)
|
|
||||||
(set! loc (cons (cons (car cur) (how (cdr cur)))
|
|
||||||
(remq cur loc))))]
|
|
||||||
[else (error 'loc "got a `~a' for nonexistent `~s' in ~s"
|
|
||||||
(car b) (cadr b)
|
|
||||||
(list* (cadr b) (car b) (cddr b)))])]))
|
|
||||||
(define (appender x) (append x (cddr b)))
|
|
||||||
(define (rebinder x) (@subst (cddr b) (cadr b) x))
|
|
||||||
(case (car b)
|
|
||||||
[(:=) (bind! specs)]
|
|
||||||
[(:=tag) (bind! tags )]
|
|
||||||
[(:=cond) (bind! conds)]
|
|
||||||
[(:=!) (change! specs rebinder)]
|
|
||||||
[(:=!tag) (change! tags rebinder)]
|
|
||||||
[(:=!cond) (change! conds rebinder)]
|
|
||||||
[(:+=) (change! specs appender)]
|
|
||||||
[(:+=tag) (change! tags appender)]
|
|
||||||
[(:+=cond) (change! conds appender)]
|
|
||||||
[else (error 'read-spec-file "something bad happened")]))
|
|
||||||
(infix-split
|
|
||||||
'(:= :=! :+= :=tag :+=tag :=!tag :=cond :+=cond :=!cond)
|
|
||||||
input))
|
|
||||||
(param (map reverse (list specs tags conds))))
|
|
||||||
|
|
||||||
;;; ===========================================================================
|
|
||||||
;;; Spec management
|
|
||||||
|
|
||||||
;; This holds a triplet of spec, tag, and cond definitions.
|
|
||||||
(provide *specs*)
|
|
||||||
(define *specs* (make-parameter #f))
|
|
||||||
|
|
||||||
(define (check-valid s) (void))
|
|
||||||
|
|
||||||
(provide register-spec!)
|
|
||||||
(define (register-spec! sym spec)
|
|
||||||
(let ([specs (*specs*)])
|
|
||||||
(check-valid specs)
|
|
||||||
(*specs* (list (cons (list sym spec) (if specs (car specs) '()))
|
|
||||||
(if specs (cadr specs) '())
|
|
||||||
(if specs (caddr specs) '())))))
|
|
||||||
|
|
||||||
(provide get-spec)
|
|
||||||
(define (get-spec spec)
|
|
||||||
(let ([specs (*specs*)])
|
|
||||||
(check-valid specs)
|
|
||||||
(cond [(assq spec (car specs)) => cdr] [else #f])))
|
|
||||||
(provide get-tag)
|
|
||||||
(define (get-tag spec)
|
|
||||||
(let ([specs (*specs*)])
|
|
||||||
(check-valid specs)
|
|
||||||
(cond [(assq spec (cadr specs)) => cdr] [else #f])))
|
|
||||||
;; no need for get-cond
|
|
||||||
|
|
||||||
;; The initial empty tag environment, so it is possible to start with a
|
|
||||||
;; different set of initial tags.
|
|
||||||
(provide *environment*)
|
|
||||||
(define *environment* (make-parameter '()))
|
|
||||||
;; If this is true, then definitions that are used in expansions are prepended
|
|
||||||
;; to the result.
|
|
||||||
(define *collect-definitions* (make-parameter #f))
|
|
||||||
|
|
||||||
;; Expanding specs is a little tricky: specs are always a list of things, which
|
|
||||||
;; means that definitions and macro expansions are always spliced at the usage
|
|
||||||
;; point.
|
|
||||||
|
|
||||||
;; Convenient syntax, similar to the `tag' spec form
|
|
||||||
(provide tag)
|
|
||||||
(define-syntax tag
|
|
||||||
(syntax-rules ()
|
|
||||||
[(_ tags body0 body ...)
|
|
||||||
(let* ([ts tags]
|
|
||||||
[ts (expand-tags (if (list? ts) ts (list ts)))])
|
|
||||||
(parameterize ([*environment* (append (reverse ts) (*environment*))])
|
|
||||||
body0 body ...))]))
|
|
||||||
|
|
||||||
;; Use this for splicing results into the original place a macro was used
|
|
||||||
(provide splice)
|
|
||||||
(define-values (splice spliced?)
|
|
||||||
(let ([tag "splice"])
|
|
||||||
(values (lambda (list) (cons tag list))
|
|
||||||
(lambda (x) (and (pair? x) (eq? tag (car x)))))))
|
|
||||||
|
|
||||||
;; Handle cond expansion
|
|
||||||
;; spec -> spec-list, the input is always a cond spec
|
|
||||||
(define (expand-cond-spec spec)
|
|
||||||
(define (eval-cond c)
|
|
||||||
(define (bad-cond) (error 'expand-cond-spec "got a bad condition: ~.s" c))
|
|
||||||
(cond [(eq? c 'else) #t]
|
|
||||||
[(pair? c)
|
|
||||||
(case (car c)
|
|
||||||
[(and) (andmap eval-cond (cdr c))]
|
|
||||||
[(or) (ormap eval-cond (cdr c))]
|
|
||||||
[(not) (if (= 1 (length (cdr c)))
|
|
||||||
(not (eval-cond (cadr c)))
|
|
||||||
(bad-cond))]
|
|
||||||
[else (bad-cond)])]
|
|
||||||
[else (member c (*environment*))]))
|
|
||||||
(let loop ([clauses (infix-split '(=>) (cdr spec))])
|
|
||||||
(cond [(null? clauses) '()]
|
|
||||||
[(eval-cond (expand-conds (list (cadar clauses)))) (cddar clauses)]
|
|
||||||
[else (loop (cdr clauses))])))
|
|
||||||
|
|
||||||
;; Expand usages of spec definitions, macros, and conds.
|
|
||||||
;; spec -> spec-list
|
|
||||||
(provide expand-spec)
|
|
||||||
(define (expand-spec spec)
|
|
||||||
(cond [(and (symbol? spec) (get-spec spec)) => expand-specs]
|
|
||||||
[(not (pair? spec)) (list spec)]
|
|
||||||
[(eq? 'cond (car spec)) (expand-specs (expand-cond-spec spec))]
|
|
||||||
[(eq? 'cond* (car spec))
|
|
||||||
(expand-specs (map (lambda (cl) (list* 'cond (cadr cl) '=> (cddr cl)))
|
|
||||||
(infix-split '(=>) (cdr spec))))]
|
|
||||||
[(eq? 'tag (car spec))
|
|
||||||
(if (pair? (cdr spec))
|
|
||||||
(tag (cadr spec) (expand-specs (cddr spec)))
|
|
||||||
(error 'expand-spec "bad `tag' form: ~.s" spec))]
|
|
||||||
[(eq? 'lambda (car spec))
|
|
||||||
(if (pair? (cdr spec))
|
|
||||||
(list (eval `(lambda ,(cadr spec)
|
|
||||||
(splice (list ,@(cddr spec))))))
|
|
||||||
(error 'expand-spec "bad `lambda' form: ~.s" spec))]
|
|
||||||
[(procedure? (car spec))
|
|
||||||
(let ([newspec (apply (car spec) (expand-specs (cdr spec)))])
|
|
||||||
(cond [(spliced? newspec) (expand-specs (cdr newspec))]
|
|
||||||
[(equal? newspec spec) (list spec)]
|
|
||||||
[else (expand-spec newspec)]))]
|
|
||||||
[else
|
|
||||||
(let ([newspec (append (expand-spec (car spec)) (cdr spec))])
|
|
||||||
(cond [(null? newspec) newspec]
|
|
||||||
[(not (equal? spec newspec)) (expand-spec newspec)]
|
|
||||||
[else (list (cons (car spec) (expand-specs (cdr spec))))]))]))
|
|
||||||
|
|
||||||
;; spec-list -> spec-list
|
|
||||||
(provide expand-specs)
|
|
||||||
(define (expand-specs specs)
|
|
||||||
(let ([newspecs (mappend expand-spec specs)])
|
|
||||||
(cond [(equal? newspecs specs) specs]
|
|
||||||
[(*collect-definitions*)
|
|
||||||
(append specs (remove* specs (expand-specs newspecs)))]
|
|
||||||
[else (expand-specs newspecs)])))
|
|
||||||
|
|
||||||
;; spec [tag ...] -> spec
|
|
||||||
(provide expand-spec-1)
|
|
||||||
(define (expand-spec-1 spec)
|
|
||||||
(let ([r (expand-spec spec)])
|
|
||||||
(if (= 1 (length r))
|
|
||||||
(car r)
|
|
||||||
(error 'expand-spec-1 "expected a single result for ~.s, but got ~e"
|
|
||||||
spec r))))
|
|
||||||
|
|
||||||
;; Expand tags
|
|
||||||
(provide expand-tags)
|
|
||||||
(define (expand-tags tags)
|
|
||||||
(check-valid (*specs*))
|
|
||||||
(let ([tags (if (list? tags) tags (list tags))])
|
|
||||||
(parameterize ([*specs* (let ([s (*specs*)])
|
|
||||||
(list (cadr s) (cadr s) (caddr s)))]
|
|
||||||
[*collect-definitions* #t])
|
|
||||||
(expand-specs tags))))
|
|
||||||
|
|
||||||
;; Expand conditions
|
|
||||||
(define (expand-conds conds)
|
|
||||||
(check-valid (*specs*))
|
|
||||||
(let ([conds (if (list? conds) conds (list conds))])
|
|
||||||
(parameterize ([*specs* (let ([s (*specs*)])
|
|
||||||
(list (caddr s) (cadr s) (caddr s)))])
|
|
||||||
(let ([r (expand-specs conds)])
|
|
||||||
(if (= 1 (length r))
|
|
||||||
(car r)
|
|
||||||
(error 'expand-conds "expected a single result for ~.s, but got ~e"
|
|
||||||
conds r))))))
|
|
||||||
Loading…
Reference in New Issue
Block a user