move dist-specs to plt tree

svn: r17381

collects/dist-specs/check-dists.ss

@@ -0,0 +1,26 @@
+#lang scheme/base
+(require "checker.ss"
+         "specs.ss"
+         "dist-specs.ss")
+
+(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 plt/      (/-ify (simplify-path (build-path (collection-path "scheme") 'up 'up))))
+  (define plt-base/ (/-ify (simplify-path (build-path plt/ 'up) #f)))
+  (define plt/-name (let-values ([(base name dir?) (split-path plt/)])
+                      (path-element->string name)))
+
+  (register-macros!)
+
+  (register-specs! *specs*)
+
+  (register-spec! 'verify! verify!)
+  (register-spec! 'distribute! void)
+
+  (set-plt-tree! plt-base/ plt/-name null)
+
+  (expand-spec 'distributions)
+
+  (void))

collects/dist-specs/checker.ss

@@ -0,0 +1,551 @@
+;; Shared dependency-checking infrastructure, used by "check-dists.ss"
+;; and by bundle script
+
+#lang scheme/base
+
+(require scheme/cmdline scheme/runtime-path scheme/match scheme/promise
+         (for-syntax scheme/base) ; for runtime-path
+         (except-in scheme/mpair mappend)
+         (only-in (lib "process.ss") system)
+         "specs.ss")
+
+(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))
+
+(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)
+  (define base (regexp-replace #rx"/$" (path->string (cd)) ""))
+  (let loop ([name path] [path ""])
+    (cond [(or (file-exists? name) (link-exists? name))
+           (let ([path (concat path name)])
+             (prop-set! path 'base base)
+             (prop-set! path 'name name)
+             path)]
+          [(directory-exists? name)
+           (let ([path (concat path name "/")])
+             (prop-set! path 'base base)
+             (prop-set! path 'name name)
+             (parameterize ([cd name])
+               (cons path (map (lambda (name) (loop name path))
+                               (dir-list)))))]
+          [else (error 'get-tree "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 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)
+    (prop-set! (tree-path t) 'queries
+               (cons (cons spec r) (prop-get (tree-path t) 'queries '()))))
+  (define (make-cached filter)
+    (lambda (t)
+      (cond [(assoc spec (prop-get (tree-path t) 'queries '())) => cdr]
+            [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: ~e" 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 `~e' did not expand to a single expression: ~e"
+             spec specs))))
+
+;;; ===========================================================================
+;;; Dependency checks
+
+(define check-version
+  (let ([version (version)] [1st? #t])
+    (lambda (v file)
+      (if 1st?
+        (begin
+          (unless (equal? version v)
+            (fprintf (current-error-port)
+                     "\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 (pltpath path)
+    (bytes->string/utf-8
+     (apply bytes-append (cdr (mappend (lambda (p) (list #"/" p))
+                                       (list* #"plt" #"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) ...) (pltpath s)]
+               [`(ext collects ,(and (? bytes?) s) ...) (pltpath s)]
+               [_ (error 'dependencies "bad dependency item in ~s: ~s"
+                         file x)]))
+           (cdr x))))
+  (dprintf "Reading dependencies...")
+  (let loop ([tree (tree-filter "*.dep" *plt-tree*)])
+    (if (pair? tree)
+      (for-each loop (cdr tree))
+      (parameterize ([cd (prop-get tree 'base)])
+        (prop-set! tree 'contents (read-depfile tree)))))
+  (dprintf " done.\n")
+  (set! add-dependency-contents! void))
+
+(define bin-files-lists
+  ;; FIXME: hard-wired list of binary-specific files
+  '(("plt/collects/sgl/compiled/gl-info_ss.zo"))
+  #;
+  (delay (map (lambda (trees)
+                (sort* (mappend tree-flatten (add-trees trees))))
+              *platform-tree-lists*)))
+
+(define (check-dependencies spec distname)
+  (add-dependency-contents!)
+  (dprintf "Verifying dependencies for ~s..." distname)
+  (let* ([all-files (sort* (tree-flatten (tree-filter spec *plt-tree*)))]
+         [deps0 (or (tree-filter `(and ,spec "*.dep") *plt-tree*)
+                    (error 'check-dependencies
+                           "got no .dep files for ~s" distname))]
+         [deps0 (tree-flatten deps0 #t)])
+    (let* ([missing (tree-filter 'must-be-empty *plt-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.ss might be satisified by a platform dependent
+             ;; compiled/foo_ss.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")])
+               (if (andmap (lambda (files) (member 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 *plt-tree* #f)
+
+(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)
+
+(provide set-plt-tree!)
+(define (set-plt-tree! plt-base/ plt/-name tree-lists)
+  (set! *platform-tree-lists* tree-lists)
+  (dprintf "Scanning main tree...")
+  (set! *plt-tree*
+        (let loop ([tree  (parameterize ([cd plt-base/]) (get-tree plt/-name))]
+                   [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"))

collects/dist-specs/dist-specs.ss

@@ -0,0 +1,656 @@
+#lang reader dist-specs/spec-reader
+
+;; -*- scheme -*-
+
+;; ============================================================================
+;; This file holds the specifications for creating PLT 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 defintion 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-debian :=tag unix
+i386-linux-debian-testing  :=tag unix
+i386-linux-debian-unstable :=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-freebsd      :=tag unix
+i386-win32        :=tag win
+ppc-darwin        :=tag unix
+i386-darwin       :=tag unix
+ppc-osx-mac       :=tag mac
+i386-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 => (- "/plt/doc/" distribution) else => none)
+
+compiled-filter := (- (collects: "**/compiled/")
+                      (cond verifying => "*.dep"))
+                   "/plt/bin/" "/plt/lib/"
+src-filter      := (src: "")
+docs-filter     := (- (doc: "")   ; all docs,
+                      (notes: "") ; excluding basic stuff
+                      std-docs)   ; and things in svn
+docsrc-filter   := (+ (collects: "setup/scribble.ss") ; only with doc sources
+                      (collects: "**/scribblings/")
+                      (srcfile: "*.{scrbl|scribble}")
+                      std-docs)
+man-filter      := (man: "*")
+tests-filter    := (+ (collects: "**/tests/") (srcfile: "tests.ss"))
+gui-filter      := (- (+ (collects: "**/gui/") (srcfile: "gui.ss"))
+                      ;; for use in mz code that works in mr too
+                      (srcfile: "scheme/gui/dynamic.ss"))
+tools-filter    := (+ (collects: "**/tools/") (srcfile: "tools.ss"))
+
+;; these are in the doc directory, but are comitted in svn and should be
+;; considered like sources
+std-docs        := (doc: "doc-license.txt" "*-std/")
+
+;; ============================================================================
+;; Junk
+
+;; This is removed from the original tree only (*not* from the binary trees)
+junk := (+ "CVS/" "[.#]*" "*~"
+           ;; binary stuff should come from the platform directories
+           "/plt/bin/" "/plt/lib/" "/plt/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 :=
+  "/plt/{lib|include}/**/*<!>.*"
+  "/plt/bin/*<!>"
+  (cond win => "/plt/*<!>.exe"
+               "/plt/lib/**/lib*<!>???????.{dll|lib|exp}"
+        mac => "/plt/*<!>.app/"
+               "/plt/lib/PLT_*.framework/Versions/*<_!>/")
+  "/plt/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 :=
+  "/plt/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 "/plt/" 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 "/plt/lib/" (regexp-replace
+                                            #rx"^/" (expand-spec-1 f) "")
+                               "{|3[mM]|cgc|CGC}{|???????}.dll"))
+                     fs)
+              ,@(map (lambda (f)
+                       (concat "/plt/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/))) '()))))
+
+;; ============================================================================
+;; 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 := "/plt/readme.txt"          ; generated
+           (package: "mzscheme")
+           "/plt/include/"
+           ;; configuration stuff
+           (cond (not src) => (collects: "info-domain/")) ; filtered
+           (package: "config")
+           ;; basic code
+           (collects: "scheme")
+           (collects: "s-exp")
+           ;; include the time-stamp collection when not a public release
+           (cond (not release)
+                 => (- (collects: "repos-time-stamp/")
+                       (cond (not dr) => (srcfile: "time-stamp.ss"))))
+mz-manuals := (scribblings: "main/") ; generates main pages (next line)
+              (doc: "license/" "release/" "acks/" "search/" "master-index/"
+                    "getting-started/")
+              (notes: "COPYING.LIB" "COPYING-libscheme.txt")
+              (doc: "doc-license.txt") ; needed (when docs are included)
+              (doc+src: "reference/" "guide/" "quick/" "more/"
+                        "foreign/" "inside/" "futures/"
+                        "honu/")
+              (doc: "*.{html|css|js|sxref}")
+              (scribblings: "{{info|icons}.ss|*.png}" "compiled")
+
+mr-base := (package: "mred") (bin: "mred-text") (collects: "afm/")
+mr-manuals := (doc+src: "gui/")
+
+dr-base := (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: "mzscheme/" "info.ss" "utils/" "match/" "eli-tester.ss")
+
+;; ============================================================================
+;; Source definitions
+
+mz-src := (+ (- (src: "README" "Makefile.in" "configure" "lt/" "mzscheme/"
+                      (cond win => "worksp/{README|mzconfig.h}"
+                                   "worksp/{mzscheme|libmzsch|libmzgc|gc2}/"
+                                   "worksp/{mzstart|starters}/"
+                                   "worksp/extradlls/"))
+                (cond (not mr) => (src: "worksp/starters/mrstart.ico")))
+             foreign-src)
+
+mr-src := (src: "mred/" "wxcommon/"
+                (cond unix => "wxxt/"
+                      mac  => "mac/" "a-list/" "wxmac/"
+                      win  => "wxwindow/"
+                              "worksp/{jpeg|libmred|mred|mrstart}/"
+                              "worksp/{png|wxme|wxs|wxutils|wxwin|zlib}/"))
+
+foreign-src := (src: "foreign/{Makefile.in|README}"
+                     "foreign/{foreign.*|ssc-utils.ss}"
+                     (cond win  => "foreign/libffi_msvc"
+                           else => "foreign/gcc"))
+
+;; ============================================================================
+;; 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}")
+           (cond mac => (lib: "PLT_MzScheme*/")
+                 win => (dll: "libmz{gc|sch}" "UnicoWS" "iconv")
+                        (lib: "gcc/{fixup|init}.o" "bcc/mzdynb.{obj|def}")
+                 unix => (lib: "starter"))
+           extra-dynlibs
+
+mr-bins := (cond mac => (lib: "PLT_MrEd*/")
+                 win => (dll: "libmred"))
+
+extra-dynlibs := (cond win => (dll: "{ssl|lib}eay32"))
+
+;; ============================================================================
+;; This filter is used on the full compiled trees to get the binary
+;; (platform-dependent) portion out.
+
+binaries := (+ "/plt/bin/"
+               "/plt/lib/"
+               "/plt/include/"
+               "/plt/collects/**/compiled/native/"
+               (cond unix => "/plt/bin/{mzscheme|mred}*"
+                     win  => "/plt/*.exe"
+                             "/plt/*.dll"
+                             "/plt/collects/launcher/*.exe"
+                     mac  => "/plt/bin/mzscheme*"
+                             "/plt/*.app"
+                             "/plt/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}.ss")))
+
+;; -------------------- 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")
+
+;; -------------------- 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/")
+
+;; -------------------- 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/")
+
+;; -------------------- 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}.ss"
+                                               "xml.png")))
+
+;; -------------------- ffi
+mz-extras :+= (collects: "ffi/") (doc: "objc")
+
+;; -------------------- preprocessor
+mz-extras :+= (package: "preprocessor/") (bin: "mzpp" "mztext")
+
+;; -------------------- tex2page & slatex
+plt-extras :+= (package: "tex2page")
+               (package: "slatex")
+               (bin: "PDF SLaTeX")
+               (doc+src: "slatex-wrap/")
+
+;; -------------------- planet
+mz-extras :+= (package: "planet")
+
+;; -------------------- mrlib
+mr-extras :+= (- (+ (package: "mrlib/")
+                    (collects: "hierlist/")
+                    (collects: "icons/turn-{up|down}{|-click}.png")
+                    (tests: "aligned-pasteboard/")))
+
+;; -------------------- sgl
+mr-extras :+= (package: "sgl/")
+;; gl-info.ss doesn't exist, but gl-info.zo holds platform-dependent data
+platform-dependent :+= (and (collects: "sgl/")
+                            (srcfile: "sgl/gl-info"))
+
+;; -------------------- syntax-color
+dr-extras :+= (package: "syntax-color")
+
+;; -------------------- plt-help
+dr-extras :+= (package: "plt-help" #:collection "help")
+
+;; -------------------- lang
+plt-extras :+= (package: "lang/" #:docs "htdp-langs/")
+
+;; -------------------- htdp, tests, teachpacks
+plt-extras :+=
+  (collects: "htdp/")
+  (doc: "htdp-lib")
+  (- (package: "teachpack/") (collects: "teachpack/deinprogramm/"))
+  (- (package: "2htdp/")
+     "uchat/") ; Matthias doesn't want this in now
+  (package: "test-engine/")
+
+;; -------------------- stepper
+plt-extras :+= (package: "stepper")
+
+;; -------------------- macro-debugger
+plt-extras :+= (package: "macro-debugger")
+
+;; -------------------- lazy
+plt-extras :+= (package: "lazy")
+
+;; -------------------- combinator-parser
+plt-extras :+= (collects: "combinator-parser")
+
+;; -------------------- icons
+dr-extras :+= (collects: "icons/")
+
+;; -------------------- string
+dr-extras :+= (package: "string-constants")
+
+;; -------------------- defaults
+dr-extras :+= (collects: "defaults/")
+
+;; -------------------- version
+mz-extras :+= (- (package: "version/")
+                 (cond* (not dr) => (srcfile: "tool.ss")))
+
+;; -------------------- browser
+dr-extras :+= (package: "browser/")
+
+;; -------------------- graphics
+plt-extras :+= (package: "graphics/") (doc: "turtles")
+
+;; -------------------- embedded
+plt-extras :+= (package: "embedded-gui/")
+
+;; -------------------- eopl
+plt-extras :+= (package: "eopl/")
+
+;; -------------------- algol60
+plt-extras :+= (package: "algol60/")
+
+;; -------------------- games
+plt-extras :+= (- (+ (package: "games/" #:executable "plt-games")
+                     (doc+src: "gl-board-game/" "cards/"))
+                  "loa/"
+                  "paint-by-numbers/{hattori|solution-sets|raw-problems}")
+
+;; -------------------- texpict & slideshow
+plt-extras :+= (collects: "texpict/")
+               (package: "slideshow")
+
+;; -------------------- frtime
+plt-extras :+= (package: "frtime/")
+
+;; -------------------- typed-scheme
+dr-extras :+= (package: "typed-scheme/" ; used in drscheme
+                        #:docs "ts-{reference|guide}/")
+              (collects: "typed/")
+
+;; -------------------- gui-debugger
+plt-extras :+= (collects: "gui-debugger/")
+
+;; -------------------- swindle
+mz-extras :+= (- (package: "swindle")
+                 (cond (not dr) => (srcfile: "tool.ss" "swindle*.png")))
+
+;; -------------------- plot
+plt-extras :+=
+  (- (package: "plot")
+     ;; src should be included, otherwise it will be impossible to recompile it
+     ;; (cond (not src) => "src/")
+     )
+
+;; -------------------- mzcom
+plt-extras :+= (- (package: "mzcom" #:src? #t)
+                  (cond (not win) => (src: "")))
+
+;; -------------------- mysterx
+plt-extras :+= (- (+ (package: "mysterx" #:src? #t)
+                     (src: "worksp/libmysterx/")
+                     (dll: "myspage" "myssink"))
+                  (cond (not win) => (src: "")))
+
+;; -------------------- srpersist
+;; not included
+;; plt-extras :+= (package: "srpersist" #:src? #t)
+
+;; -------------------- temporary tool for converting old files
+plt-extras :+= (package: "test-box-recovery")
+
+;; -------------------- redex
+plt-extras :+= (package: "redex")
+
+;; -------------------- deinprogramm
+plt-extras :+= (package: "deinprogramm/")
+               (collects: "teachpack/deinprogramm/")
+               (doc: "DMdA-lib")
+
+;; -------------------- unstable
+mz-extras :+= (- (package: "unstable")
+                 ;; should "gui" mean DrScheme or MrEd? It's not
+                 ;; obvious that "framework" is only in DrScheme.
+                 (cond (not dr) => (collects: "unstable/gui")))
+
+;; ============================================================================

collects/dist-specs/spec-lang.ss

@@ -0,0 +1,10 @@
+#lang scheme/base
+(require "specs.ss")
+
+(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))))

collects/dist-specs/spec-reader.ss

@@ -0,0 +1,2 @@
+#lang s-exp syntax/module-reader
+#:language 'dist-specs/spec-lang

collects/dist-specs/specs.ss

@@ -0,0 +1,238 @@
+;; 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: ~e" 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: ~e" spec))]
+        [(eq? 'lambda (car spec))
+         (if (pair? (cdr spec))
+           (list (eval `(lambda ,(cadr spec)
+                          (splice (list ,@(cddr spec))))))
+           (error 'expand-spec "bad `lambda' form: ~e" 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))))))