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