From 345307ebbe430377b213e6100055c93b10b5721f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 21 Dec 2009 20:19:03 +0000 Subject: [PATCH] move dist-specs to plt tree svn: r17381 --- collects/dist-specs/check-dists.ss | 26 ++ collects/dist-specs/checker.ss | 551 ++++++++++++++++++++++++ collects/dist-specs/dist-specs.ss | 656 +++++++++++++++++++++++++++++ collects/dist-specs/spec-lang.ss | 10 + collects/dist-specs/spec-reader.ss | 2 + collects/dist-specs/specs.ss | 238 +++++++++++ 6 files changed, 1483 insertions(+) create mode 100644 collects/dist-specs/check-dists.ss create mode 100644 collects/dist-specs/checker.ss create mode 100644 collects/dist-specs/dist-specs.ss create mode 100644 collects/dist-specs/spec-lang.ss create mode 100644 collects/dist-specs/spec-reader.ss create mode 100644 collects/dist-specs/specs.ss diff --git a/collects/dist-specs/check-dists.ss b/collects/dist-specs/check-dists.ss new file mode 100644 index 0000000000..9143b670d3 --- /dev/null +++ b/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)) diff --git a/collects/dist-specs/checker.ss b/collects/dist-specs/checker.ss new file mode 100644 index 0000000000..393ba98275 --- /dev/null +++ b/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 stringstring (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 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 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) (stringsymbol 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")) diff --git a/collects/dist-specs/dist-specs.ss b/collects/dist-specs/dist-specs.ss new file mode 100644 index 0000000000..594ade47eb --- /dev/null +++ b/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 := ... 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 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 => ... +;; ... +;; else => ) +;; 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 +;; 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* => ... +;; ...) +;; This is similar to the `cond' form, except that all matching branches +;; are used, so this form is equivalent to: +;; (cond => ...) ... +;; - (tag ) is the same as using , except that the is +;; added to the expansion environment, so it is available for nested cond +;; clauses. Instead of a single , 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 ) 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 "{3m|cgc}" where a "" +;; 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"))) + +;; ============================================================================ diff --git a/collects/dist-specs/spec-lang.ss b/collects/dist-specs/spec-lang.ss new file mode 100644 index 0000000000..6d10b54d0f --- /dev/null +++ b/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)))) diff --git a/collects/dist-specs/spec-reader.ss b/collects/dist-specs/spec-reader.ss new file mode 100644 index 0000000000..8be9f61981 --- /dev/null +++ b/collects/dist-specs/spec-reader.ss @@ -0,0 +1,2 @@ +#lang s-exp syntax/module-reader +#:language 'dist-specs/spec-lang diff --git a/collects/dist-specs/specs.ss b/collects/dist-specs/specs.ss new file mode 100644 index 0000000000..8dfc9c4f99 --- /dev/null +++ b/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 y1 ... x2 y2 ... ...), +;; where 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 +;; (( x1 y1 ...) ( 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))))))