revise the way setup-plt crawls over the collection trees

svn: r8860
This commit is contained in:
Eli Barzilay 2008-03-03 22:04:28 +00:00
parent b7cfd2fd00
commit b76390a452
101 changed files with 586 additions and 614 deletions

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1 +1,3 @@
#lang setup/infotab
(define compile-omit-paths '("examples"))

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1,5 +1,5 @@
;; Main compilation procedures
;; (c) 1997-2001 PLT
;; (c) 1997-2008 PLT
;; The various procedures provided by this library are implemented
;; by dynamically linking to code supplied by the MzLib, dynext, and
@ -8,7 +8,8 @@
;; The Scheme->C compiler is loaded as either sploadr.ss (link in
;; real MrSpidey) or loadr.ss (link in trivial MrSpidey stubs).
(module compiler-unit scheme/base
#lang scheme/base
(require mzlib/unit
"sig.ss"
@ -51,19 +52,14 @@
(define (c-dynamic-require path id)
((current-compiler-dynamic-require-wrapper)
(lambda ()
(dynamic-require path id))))
(lambda () (dynamic-require path id))))
(define (c-get-info cp)
((current-compiler-dynamic-require-wrapper)
(lambda ()
(get-info cp))))
(lambda () (get-info cp))))
(define (make-extension-compiler mode prefix)
(let ([u (c-dynamic-require 'compiler/private/base
'base@)]
[init (unit
(import compiler:inner^)
(export)
(let ([u (c-dynamic-require 'compiler/private/base 'base@)]
[init (unit (import compiler:inner^) (export)
(eval-compile-prefix prefix)
(case mode
[(compile-extension) compile-extension]
@ -76,9 +72,7 @@
(DFILE : dynext:file^)
(OPTION : compiler:option^))
(export)
(link [((COMPILER : compiler:inner^))
u
COMPILE LINK DFILE OPTION]
(link [((COMPILER : compiler:inner^)) u COMPILE LINK DFILE OPTION]
[() init COMPILER]))
(import dynext:compile^
dynext:link^
@ -89,10 +83,8 @@
(lambda (prefix)
(let ([c (make-extension-compiler mode prefix)])
(lambda (source-files destination-directory)
(for-each
(lambda (source-file)
(c source-file (or destination-directory 'same)))
source-files)))))
(for ([source-file source-files])
(c source-file (or destination-directory 'same)))))))
(define (make-unprefixed-compiler mode)
(let ([f #f])
@ -117,46 +109,38 @@
(lambda (expr)
(expand-syntax-top-level-with-compile-time-evals expr))
values)))))
(printf " [output to \"~a\"]~n" dest))
(printf " [output to \"~a\"]\n" dest))
(define (compile-zos prefix)
(let ([n (if prefix
(make-base-namespace)
(current-namespace))])
(when prefix
(eval prefix n))
(define n (if prefix (make-base-namespace) (current-namespace)))
(when prefix (eval prefix n))
(lambda (source-files destination-directory)
(let ([file-bases (map
(lambda (file)
(define file-bases
(map (lambda (file)
(let ([f (extract-base-filename/ss file 'mzc)])
(if destination-directory
(let-values ([(base file dir?) (split-path f)])
(build-path (if (eq? destination-directory 'auto)
(let ([d (build-path (if (eq? base 'relative)
'same
base)
(build-path
(if (eq? destination-directory 'auto)
(let ([d (build-path (if (eq? base 'relative) 'same base)
"compiled")])
(unless (directory-exists? d)
(make-directory* d))
(unless (directory-exists? d) (make-directory* d))
d)
destination-directory)
file))
f)))
source-files)])
(for-each
(lambda (f b)
source-files))
(for ([f source-files] [b file-bases])
(let ([zo (append-zo-suffix b)])
(compile-to-zo f zo n prefix)))
source-files file-bases)))))
(compile-to-zo f zo n prefix)))))
(define (compile-directory dir info zos?)
(let ([make (c-dynamic-require 'make/make-unit 'make@)]
[coll (c-dynamic-require 'make/collection-unit 'make:collection@)]
[init (unit
(import make^ make:collection^)
(export)
(values make-collection make-notify-handler))])
(let-values ([(make-collection make-notify-handler)
(define (compile-directory dir info)
(define info* (or info (lambda (key mk-default) (mk-default))))
(define make (c-dynamic-require 'make/make-unit 'make@))
(define coll (c-dynamic-require 'make/collection-unit 'make:collection@))
(define init (unit (import make^ make:collection^) (export)
(values make-collection make-notify-handler)))
(define-values (make-collection make-notify-handler)
(invoke-unit
(compound-unit
(import (DFILE : dynext:file^)
@ -164,77 +148,45 @@
(COMPILER : compiler^))
(export)
(link [((MAKE : make^)) make]
[((COLL : make:collection^))
coll
MAKE DFILE OPTION COMPILER]
[((COLL : make:collection^)) coll MAKE DFILE OPTION COMPILER]
[() init MAKE COLL]))
(import dynext:file^
compiler:option^
compiler^))])
(let ([orig (current-directory)])
(dynamic-wind
(lambda () (current-directory dir))
(lambda ()
(parameterize ([current-load-relative-directory dir])
;; Compile the collection files via make-collection
(let ([sses (append
;; Find all .ss/.scm files:
(filter
extract-base-filename/ss
(directory-list))
;; Add specified doc sources:
(map car (info
'scribblings
(lambda () null))))])
(let ([filtered-sses
(remove*
(map string->path
(info
(if zos?
'compile-zo-omit-files
'compile-extension-omit-files)
(lambda () null)))
(remove*
(map string->path
(info 'compile-omit-files (lambda () null)))
sses))])
(if zos?
(import dynext:file^ compiler:option^ compiler^)))
(define nothing (lambda () null))
(define omit-paths (info* 'compile-omit-paths nothing))
(define omit-files (info* 'compile-omit-files nothing))
(unless (eq? 'all omit-paths)
(parameterize ([current-directory dir]
[current-load-relative-directory dir]
;; Verbose compilation manager:
(parameterize ([manager-trace-handler (lambda (s) (printf "~a~n" s))]
[manager-compile-notify-handler (lambda (path)
((compile-notify-handler) path))])
(map (make-caching-managed-compile-zo) filtered-sses))
;; Old collection compiler:
(parameterize ([make-notify-handler (lambda (path)
((compile-notify-handler) path))])
(make-collection
((or info (lambda (a f) (f)))
'name
(lambda () (error 'compile-collection "info did not provide a name in ~e"
dir)))
filtered-sses
(if zos? #("zo") #()))))))))
(lambda () (current-directory orig)))
[manager-trace-handler (lambda (s) (printf "~a\n" s))]
[manager-compile-notify-handler
(lambda (path) ((compile-notify-handler) path))])
;; Compile the collection files via make-collection
(let* ([sses (append
;; Find all .ss/.scm files:
(filter extract-base-filename/ss (directory-list))
;; Add specified doc sources:
(map car (info* 'scribblings nothing)))]
[sses (remove* (map string->path omit-paths) sses)]
[sses (remove* (map string->path omit-files) sses)])
(for-each (make-caching-managed-compile-zo) sses)))
(when (compile-subcollections)
(for-each
;; bug! planet files will do the wrong thing here
(lambda (s)
(unless (and (pair? s) (list? s) (andmap string? s))
(error 'compile-collection "bad sub-collection path: ~a" s))
(let ((p (apply build-path dir s)))
(compile-directory p (get-info/full p) zos?)))
(info 'compile-subcollections (lambda () null))))))))
(define (compile-collection cp zos?)
(let ([dir (apply collection-path cp)]
[info (c-get-info cp)])
(compile-directory dir info zos?)))
(when (info* 'compile-subcollections (lambda () #f))
(printf "Warning: ignoring `compile-subcollections' entry in info ~a\n"
dir))
(for ([p (directory-list dir)])
(let ([s (path->string p)])
;; this is the same check that setup/setup-unit is doing in
;; `make-cc*'
(unless (or (regexp-match? #rx"^[.]" s) (equal? "compiled" s)
(and (pair? omit-paths) (member s omit-paths)))
(let ([p (build-path dir p)])
(compile-directory p (get-info/full p)))))))))
(define (compile-collection-zos collection . cp)
(compile-collection (cons collection cp) #t))
(compile-directory (apply collection-path collection cp)
(c-get-info (cons collection cp))))
(define (compile-directory-zos dir info)
(compile-directory dir info #t))
(define compile-directory-zos compile-directory)
))
)

View File

@ -1,14 +1,12 @@
(module option-unit mzscheme
#lang mzscheme
(require mzlib/unit)
(require "sig.ss")
(provide compiler:option@)
(define-unit compiler:option@
(import)
(export compiler:option^)
(define-unit compiler:option@ (import) (export compiler:option^)
(define propagate-constants (make-parameter #t))
(define assume-primitives (make-parameter #f))
@ -39,4 +37,4 @@
(define compile-for-embedded (make-parameter #f))
;; Maybe #f helps for register-poor architectures?
(define unpack-environments (make-parameter #f))))
(define unpack-environments (make-parameter #f)))

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1,5 +1,5 @@
(module sig mzscheme
#lang mzscheme
(require mzlib/unit)
@ -25,8 +25,7 @@
3m ; #t => build for 3m
; default = #f
compile-subcollections ; #t => use 'compile-subcollections
; from infor for collection compiling
compile-subcollections ; #t => compile collection subdirectories
; default = #t
compile-for-embedded ; #f => make objects to be linked
@ -87,4 +86,4 @@
(compile-extension
compile-extension-to-c
compile-c-extension
eval-compile-prefix)))
eval-compile-prefix))

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -6,7 +6,3 @@
(define std-library-dir (find-lib-dir))
(provide include-dir std-library-dir))

View File

@ -0,0 +1,3 @@
#lang setup/infotab
(define compile-omit-paths '("stdio.ss" "macinc.ss"))

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -0,0 +1,3 @@
#lang setup/infotab
(define compile-omit-paths '("tests"))

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1,3 +1,5 @@
#lang setup/infotab
(define name "Sample FFIs")
(define compile-omit-paths '("examples"))

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1,3 +1,3 @@
#lang setup/infotab
(define compile-omit-files '("standard-menus.ss"))
(define compile-omit-paths '("standard-menus.ss"))

View File

@ -1,7 +1,8 @@
#lang setup/infotab
(define compile-omit-paths '("demos"))
(define scribblings '(("frtime.scrbl" ())))
(define compile-subcollections '(("frtime" "demos" "gui")))
(define tools '("frtime-tool.ss"))
(define tool-icons '(("clock.png" "frtime")))
(define tool-names '("FrTime Languages"))

View File

@ -0,0 +1,3 @@
#lang setup/infotab
(define compile-omit-paths 'all)

View File

@ -2,7 +2,7 @@
(define game "paint-by-numbers.ss")
(define game-set "Puzzle Games")
(define compile-omit-files
(define compile-omit-paths
'(;; Skipped because it's huge - lots of data-encoding units
"all-problems.ss"
;; Skipped because it requires all-problems.ss
@ -17,4 +17,9 @@
"raw-misc.ss"
"build-rows-cols.ss"
"count-missing.ss"
"main.ss"))
"main.ss"
;; directories too
"hattori"
"problems"
"raw-problems"
"solution-sets"))

View File

@ -1,3 +1,3 @@
#lang setup/infotab
(define compile-omit-files '("value-turex.ss" "value-turtle-lib.ss"))
(define compile-omit-paths '("value-turex.ss" "value-turtle-lib.ss"))

View File

@ -1,3 +1,5 @@
#lang setup/infotab
(define scribblings '(("scribblings/handin-server.scrbl" (user-doc))))
(define compile-omit-paths '("status-web-root"))

View File

@ -21,4 +21,3 @@
(javac "Canvas.java")
(javac "SillyCanvas.java")
(javac "World.java")))))

View File

@ -1,6 +1,6 @@
#cs
(module Canvas-native-methods mzscheme
(require (lib "support.scm" "htdch" "draw") mzlib/unit)
(require (lib "htdch/draw/support.scm") mzlib/unit)
(define void-or-true (void))
(define (imperative w@t+1 w@t) w@t+1)

View File

@ -1,6 +1,6 @@
#cs
(module World-native-methods mzscheme
(require (lib "support.scm" "htdch" "draw") mzlib/unit)
(require (lib "htdch/draw/support.scm") mzlib/unit)
(provide endOfTime-java.lang.String-native endOfWorld-java.lang.String-native bigBangO-double-native)

View File

@ -2,5 +2,5 @@
(define name "Imperative Drawing")
(define assume-virtual-sources #t)
(define install-collection "installer.ss")
;; FIXME: doing this leads to an error: (define install-collection "installer.ss")
;; (define pre-install-collection "pre-installer.ss")

View File

@ -1,9 +1,5 @@
#lang setup/infotab
(define name "Java Teachpacks")
(define compile-subcollections
'(("htdch" "draw")
("htdch" "geometry")
("htdch" "colors")
("htdch" "graphics")
("htdch" "idraw")))
(define compile-omit-paths '("Examples"))

View File

@ -1,5 +1,5 @@
#cs(module pingp-sig mzscheme
(require "draw-sig.ss"
(require htdp/draw-sig
mzlib/unitsig)
(provide pingpS
ping-protS-core

View File

@ -1,9 +1,10 @@
#lang setup/infotab
(define name "HtDP Teachpacks")
(define compile-omit-files
(define compile-omit-paths
'("hangman-world.ss" "hangman-world-play.ss"
;; TEMPORARY DISABLE THESE FILES UNTIL FIXED
;; "matrix.ss" "matrix-client.ss" "matrix-invisible.ss"
;; "matrix-render-sig.ss" "matrix-sig.ss" "matrix-unit.ss"
))
"Test"
"HtDPv0"))

View File

@ -1,6 +1,6 @@
#lang setup/infotab
(define scribblings '(("html.scrbl")))
(define compile-omit-files
(define compile-omit-paths
'("dtd.ss" "dtdr.ss" "dtds.ss" "dtd-ast.ss" "case.ss" "html-structs.ss"
"entity-expander.ss" "generate-code.ss" "sgml.ss"))

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -0,0 +1,5 @@
#lang setup/infotab
;; This directory should go away soon
(define compile-omit-paths 'all)

View File

@ -1,3 +1,3 @@
#lang setup/infotab
(define name "Little Helper")
(define compile-omit-paths '("web-root"))

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1,3 +1,3 @@
#lang setup/infotab
(define compile-omit-files '("browse-deriv.ss" "show-deriv.ss"))
(define compile-omit-paths '("browse-deriv.ss" "show-deriv.ss"))

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -0,0 +1,3 @@
#lang setup/infotab
(define compile-omit-paths '("tests"))

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1,3 +1,3 @@
#lang setup/infotab
(define compile-omit-files '("shared-body.ss"))
(define compile-omit-paths '("shared-body.ss"))

View File

@ -4,3 +4,5 @@
(define scribblings '(("mzscheme.scrbl" (multi-page))))
(define doc-categories '(legacy))
(define compile-omit-paths '("examples"))

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1,3 +1,5 @@
#lang setup/infotab
(define scribblings '(("parser-tools.scrbl" (multi-page))))
(define compile-omit-paths '("examples"))

View File

@ -1,3 +1,3 @@
#lang setup/infotab
(define compile-omit-files (list "error-tests.ss"))
(define compile-omit-paths '("error-tests.ss"))

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1,3 +1,5 @@
#lang setup/infotab
(define pre-install-collection "pre-installer.ss")
(define compile-omit-paths '("demos"))

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -6,12 +6,6 @@
(define tool-names '("ProfessorJ" "ProfessorJ Testing"))
(define install-collection "installer.ss")
(define pre-install-collection "pre-installer.ss")
(define compile-subcollections
'(("profj" "parsers")
("profj" "comb-parsers")
("profj" "libs" "java" "lang")
("profj" "libs" "java" "io")
("profj" "libs" "java" "util")))
(define textbook-pls
(list (list '("htdch-icon.png" "profj")
"How to Design Classes"

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -3,11 +3,8 @@
(define name "ProfessorJ Wizard")
(define tools '(("tool.ss")))
(define tool-names '("ProfessorJ Wizard"))
;; (define compile-subcollections
;; '(("profj" "parsers")
;; ("profj" "libs" "java" "lang")
;; ("profj" "libs" "java" "io")))
(define compile-omit-files
(define compile-omit-paths
'("draw-txt0.ss"
"macro-class.scm"
"view0.scm"

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1,7 +0,0 @@
#lang setup/infotab
(define scribblings '(("scribblings/r6rs.scrbl" (multi-page))))
(define doc-categories '((languages -1)))
(define mzscheme-launcher-names '("PLT R6RS"))
(define mzscheme-launcher-libraries '("run.ss"))

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -2,4 +2,4 @@
(define mzscheme-launcher-names '("scribble"))
(define mzscheme-launcher-libraries '("scribble.ss"))
(define compile-omit-files '("test-reader.ss"))
(define compile-omit-paths '("test-reader.ss"))

View File

@ -2,3 +2,5 @@
(define scribblings '(("guide.scrbl" (multi-page))))
(define doc-categories '(getting-started))
(define compile-omit-paths '("contracts-examples"))

View File

@ -74,22 +74,22 @@ following fields are used:
@item{@scheme[name] : The name of the collection as a string.}
@item{@scheme[compile-omit-paths] : A list of immediate file and
directory names; all Scheme files (and subdirectories, if
@scheme[compile-subcollections] is set) in the collection are
compiled except for ones in this list. Alternatively, the
field can be set to @scheme['all], which is equivalent to
specifying all files and directories, and effectively makes the
collection ignored completely.
Files that are required by other files that are compiled,
however, are always compiled in the process, even when listed
with this field, or when it is @scheme['all].}
@item{@scheme[compile-omit-files] : A list of filenames (without
directory paths); all Scheme files in the collection are
compiled except for the files in this list. Files that are
required by other files that are compiled, however, will get
compiled in the process, even when listed with this field.}
@item{@scheme[compile-zo-omit-files] : A List of filenames to extend
the list for @scheme[compile-omit-files]. Historically, this
list of files was not used for other compilation modes that are
no longer supported.}
@item{@scheme[compile-subcollections] : A list of collection paths,
where each path is a list of strings specifying a collection
(from the collection root, not relative).
@scheme[compile-collection-extension] is applied to
each of the collections.}
directory paths); that are not compiled, in addition to the
contents of @scheme[compile-omit-paths]. Do not use this
field: it is for backward compatibility.}
}
Only the @scheme[name] field is required from @filepath{info.ss},
@ -197,15 +197,10 @@ A @scheme[#f] value for the parameter keeps intermediate @filepath{.c}
and @filepath{.o} files generated during compilation via C. The
default is @scheme[#t].}
@defparam[compile-subcollections cols (one-of/c #t #f)]{
@defparam[compile-subcollections cols (or/c (listof (listof string?)) (one-of/c #t))]{
A parameter that specifies sub-collections for
@scheme[compile-collection-zos] to compile. A @scheme[#t] value
indicates that the collection's @filepath{info.ss} should be used, or
that sub-collections should be determined automatically by looking for
sub-directories that contain @filepath{info.ss} files. The default is
@scheme[#t].}
A parameter that specifies whether sub-collections are compiled by
@scheme[compile-collection-zos]. The default is @scheme[#t].}
@defboolparam[compile-for-embedded embed?]{

View File

@ -61,10 +61,11 @@ As illustrated in this example, an @filepath{info.ss} file can use
@hash-lang[] notation, but only with the @schememodname[setup/infotab]
language.
@;{
The @scheme[name] tag is required for @exec{setup-plt} to recognize
the collection and compile its files to bytecode. Similarly, an
@filepath{info.ss} file in a sub-directory of a collection causes the
sub-directory's files to be compiled.
;}
See also @scheme[get-info] from @schememodname[setup/getinfo].

View File

@ -100,6 +100,16 @@ accepted by the @|setup-plt| executable.
@subsection{Compiling and Setting Up All Collections}
The @|setup-plt| executable attempts to compile and set up all
collections (all directories in the collects hierarchy). Some
collections are not really libraries (e.g., the @filepath{icons}
collection); this is fine since nothing is done when there are no
source files in the directory.
Collections are compiled using the @scheme[compile-collection-zos]
procedure.
@;{
The @|setup-plt| executable attempts to compile and set up any
collection that:
@ -118,6 +128,7 @@ Collections that meet this criteria are compiled using the
@scheme[compile-collection-zos] procedure (which means that even if a
collection has no @filepath{info.ss} file, its modules will get
compiled if they are used by other compiled modules).
;}
@; ------------------------------------------------------------------------
@ -161,10 +172,7 @@ Optional @filepath{info.ss} fields trigger additional setup actions:
@scheme[mzscheme-launcher-libraries], then the flags will override
the libraries, but the libraries can still be used to specify a
name for @scheme[build-aux-from-path] (to find related information
like icon files etc).
If @scheme[compile-subcollections] mentions a subcollection with
this field, the executable is also set up for that subcollection.}
like icon files etc).}
@item{@scheme[mzscheme-launcher-libraries] : @scheme[(listof
path-string?)] --- A list of library names in parallel to

View File

@ -2,7 +2,7 @@
(define name "Setup PLT")
(define compile-omit-files '("main.ss"))
(define compile-omit-paths '("main.ss"))
(define mzscheme-launcher-libraries '("main.ss"))
(define mzscheme-launcher-names '("Setup PLT"))

View File

@ -11,6 +11,7 @@
scheme/port
scheme/match
scheme/system
scheme/list
planet/planet-archives
planet/private/planet-shared
@ -25,6 +26,16 @@
(define-namespace-anchor anchor)
;; read info files without compiling them
(define getinfo
(let ([ns (namespace-anchor->empty-namespace anchor)]
[compile (current-compile)])
(lambda (path)
(parameterize ([current-namespace ns]
[current-compile compile]
[use-compiled-file-paths '()])
(get-info/full path)))))
(provide setup@)
(define-unit setup@
@ -66,9 +77,7 @@
(setup-printf " ~a" (path->string p)))
(define (call-info info flag mk-default test)
(if info
(let ([v (info flag mk-default)]) (test v) v)
(mk-default)))
(let ([v (info flag mk-default)]) (test v) v))
(define mode-dir
(if (compile-mode)
@ -94,10 +103,7 @@
(for ([e (reverse errors)])
(match-let ([(list cc desc x) e])
(setup-fprintf port "Error during ~a for ~a"
desc
(if (cc? cc)
(format "~a (~a)" (cc-name cc) (cc-path cc))
cc))
desc (if (cc? cc) (cc-name cc) cc))
(setup-fprintf port " ~a" (exn->string x)))))
(define (done)
@ -150,43 +156,55 @@
(collection path name info root-dir info-path shadowing-policy)
#:inspector #f)
(define (make-cc* collection path root-dir info-path shadowing-policy)
(define info
(or (with-handlers ([exn:fail? (warning-handler #f)]) (getinfo path))
(lambda (flag mk-default) (mk-default))))
(define name
(call-info
info 'name (lambda () #f)
(lambda (x)
(when (and x (not (string? x)))
(error 'setup-plt
"'name' result from collection ~e is not a string: ~e"
path x)))))
(define path-string (path->string path))
(define basename
(let-values ([(base name dir?) (split-path path)])
(if (path? name)
(path-element->string name)
(error 'make-cc*
"Internal error: cc had invalid info-path: ~e" path))))
(when (info 'compile-subcollections (lambda () #f))
(setup-printf "Warning: ignoring `compile-subcollections' entry in info ~a\n"
path))
;; this check is also done in compiler/compiler-unit, in compile-directory
(and (not (or (regexp-match? #rx"^[.]" basename) (equal? "compiled" basename)
(eq? 'all (info 'compile-omit-paths void))))
(make-cc collection path
(if name (string-append path-string " (" name ")") path-string)
info root-dir info-path shadowing-policy)))
(define ((warning-handler v) exn)
(setup-printf "Warning: ~a" (exn->string exn))
v)
;; collection->cc : listof path -> cc
;; collection->cc : listof path -> cc/#f
(define (collection->cc collection-p)
(let* ([root-dir (ormap (lambda (p)
(parameterize ([current-library-collection-paths
(list p)])
(let ([root-dir
(ormap (lambda (p)
(parameterize ([current-library-collection-paths (list p)])
(and (with-handlers ([exn:fail? (lambda (x) #f)])
(apply collection-path collection-p))
p)))
(current-library-collection-paths))]
[info (with-handlers ([exn:fail? (warning-handler #f)])
(get-info collection-p))]
[name (call-info info 'name (lambda () #f)
(lambda (x)
(when (and x (not (string? x)))
(error
'setup-plt
"'name' result from collection ~e is not a string: ~e"
collection-p
x))))]
[name (string-append (path->string (apply build-path collection-p))
(if name
(string-append " (" name ")")
""))])
(and info
(make-cc collection-p
(current-library-collection-paths))])
(make-cc* collection-p
(apply collection-path collection-p)
name
info
root-dir
(build-path root-dir "info-domain" "compiled" "cache.ss")
;; by convention, all collections have "version" 1 0. This
;; forces them to conflict with each other.
(list (cons 'lib (map path->string collection-p)) 1 0)))))
(list (cons 'lib (map path->string collection-p)) 1 0))))
;; remove-falses : listof (union X #f) -> listof X
;; returns the non-false elements of l in order
@ -213,24 +231,11 @@
(define (planet->cc path owner pkg-file extra-path maj min)
(unless (path? path)
(error 'planet->cc "non-path when building package ~e" pkg-file))
(let/ec return
(let* ([info (with-handlers ([exn:fail? (warning-handler #f)])
(get-info/full path))]
[name (call-info info 'name (lambda () (return #f))
(lambda (x)
(when (and x (not (string? x)))
(error
'planet->cc
"'name' result from directory ~e is not a string: ~e"
(make-cc* #f
path
x))))])
(make-cc #f
path
name
info
#f ; don't need root-dir; absolute paths in cache.ss will be ok
(get-planet-cache-path)
(list `(planet ,owner ,pkg-file ,@extra-path) maj min)))))
(list `(planet ,owner ,pkg-file ,@extra-path) maj min)))
;; planet-cc->sub-cc : cc (listof bytes [encoded path]) -> cc
;; builds a compilation job for the given subdirectory of the given cc this
@ -245,10 +250,6 @@
maj
min)))
(define (cannot-compile c)
(error 'setup-plt "don't know how to compile collection: ~a"
(if (= (length c) 1) (car c) c)))
(define planet-dirs-to-compile
(if (make-planet)
(remove-falses (map (lambda (spec) (apply planet->cc spec))
@ -271,107 +272,124 @@
(hash-table-map ht (lambda (k v) v))))
;; Close over sub-collections
(define (collection-closure collections-to-compile)
(let loop ([l collections-to-compile])
(if (null? l)
null
(let* ([cc (car l)]
[info (cc-info cc)])
(append
(map
(lambda (subcol)
(or (collection->cc (map string->path subcol))
(cannot-compile subcol)))
(call-info info 'compile-subcollections
;; Default: subdirs with info.ss files
(lambda ()
(map (lambda (x)
(map path->string (append (cc-collection cc) (list x))))
(filter (lambda (p)
(let ([d (build-path (cc-path cc) p)])
(and (directory-exists? d)
(file-exists? (build-path d "info.ss")))))
(directory-list (cc-path cc)))))
;; Result checker:
(define (collection-closure collections-to-compile make-subs)
(define (get-subs cc)
(let* ([info (cc-info cc)]
[ccp (cc-path cc)]
;; note: `compile-omit-paths' can be the symbol `all', if this
;; happens then this collection should not have been included in
;; the first place, but we might jump in if a command-line
;; argument specifies coll/subcoll
[omit (call-info info 'compile-omit-paths (lambda () '())
(lambda (x)
(unless (list-of (list-of relative-path-string?) x)
(error "result is not a list of relative path string lists:"
x)))))
(list cc)
(loop (cdr l)))))))
(unless (or (eq? 'all x) (list-of string? x))
(error 'setup-plt
"expected a list of path strings or 'all for compile-omit-paths, got: ~s"
x))))]
[omit (if (pair? omit) omit '())]
[subs (filter (lambda (p)
(and (directory-exists? (build-path ccp p))
(not (member (path->string p) omit))))
(directory-list ccp))])
(remove-falses (make-subs cc subs))))
(remove-falses
(let loop ([l collections-to-compile])
(apply append (map (lambda (cc) (cons cc (loop (get-subs cc)))) l)))))
(define (same-collection-name? cc-1 cc-2)
(let ([split (lambda (cc)
(apply append
(map (lambda (e)
(if (path? e)
(map path-element->string (explode-path e))
(regexp-split #rx"/" e)))
(cc-collection cc))))])
(equal? (split cc-1) (split cc-2))))
(define (plt-collection-closure collections-to-compile)
(collection-closure
collections-to-compile
(lambda (cc subs)
(map (lambda (sub)
(collection->cc (append (cc-collection cc) (list sub))))
subs))))
(define (check-again-all given-ccs)
(define all-collections* (collection-closure all-collections))
#|
;; This code is better than using marker files, but an older version of it
;; relied on the obligatory existence of an "info.ss" file. That is no
;; longer required, so it needs to identify directories and that is
;; currently not available. So use the code below instead.
(define all-cc+ids
(map (lambda (cc)
(cons cc (file-or-directory-identity (cc-path cc))))
(plt-collection-closure all-collections)))
(for ([cc given-ccs])
(call-with-input-file* (build-path (cc-path cc) "info.ss")
(lambda (given-info-port)
(define given-id (port-file-identity given-info-port))
(for ([found-cc all-collections*]
#:when (not (same-collection-name? cc found-cc)))
(call-with-input-file* (build-path (cc-path found-cc) "info.ss")
(lambda (found-info-port)
(when (eq? (port-file-identity found-info-port) given-id)
(define given-id
(file-or-directory-identity (cc-path cc)))
(for ([found-cc+id all-cc+ids]
#:when (not (same-collection-name? cc (car found-cc+id))))
(when (eq? (cdr found-cc+id) given-id)
(error 'setup-plt
"given collection path: ~e refers to the same info file as another path: ~e"
(apply build-path (cc-collection cc))
(apply build-path (cc-collection found-cc))))))))))
given-ccs)
(apply build-path (cc-collection (car found-cc+id)))))))
|#
;; Note: this is not a locking mechanism; specifically, if we find a marker
;; file we assume that we generated it rather than another setup-plt
;; process
(define all-ccs (plt-collection-closure all-collections))
(define (cc->name cc) (apply build-path (cc-collection cc)))
(define all-names (map cc->name all-ccs))
(define given-names (map cc->name given-ccs))
(define (cc-mark cc) (build-path (cc-path cc) ".setup-plt-marker"))
;; For cleanup: try to remove all files, be silent
(define (cleanup)
(for ([cc (append given-ccs all-ccs)])
(let ([mark (cc-mark cc)])
(when (file-exists? mark)
(with-handlers ([void void]) (delete-file mark))))))
;; First remove all marker files if any, let it fail if we can't remove it
(define (remove-markers)
(for ([cc given-ccs])
(let ([mark (cc-mark cc)])
(when (file-exists? mark)
(setup-printf "Warning: found a marker file, deleting: ~a"
(cc-mark cc))
(delete-file mark)))))
;; Now create all marker files, signalling an error if duplicate
(define (put-markers)
(for ([cc given-ccs] [name given-names])
(let ([mark (cc-mark cc)])
(if (file-exists? mark)
(error 'setup-plt
"given collection path: ~e refers to the same directory as another given collection path"
name)
(with-output-to-file mark (lambda () (printf "~a\n" name)))))))
;; Finally scan all ccs and look for duplicates
(define (scan-all)
(for ([cc all-ccs] [name all-names])
(when (and (not (member name given-names))
(file-exists? (cc-mark cc)))
(let ([given (with-input-from-file (cc-mark cc) read-line)])
(error 'setup-plt
"given collection path: ~e refers to the same directory as another given collection path"
name)))))
(dynamic-wind
void
(lambda () (remove-markers) (put-markers) (scan-all) given-ccs)
cleanup))
(define (sort-collections ccs)
(sort ccs (lambda (a b) (string<? (cc-name a) (cc-name b)))))
(define collections-to-compile
(sort (if no-specific-collections?
(sort-collections
(plt-collection-closure
(if no-specific-collections?
all-collections
(check-again-all
(map (lambda (c)
(or (collection->cc (map string->path c))
(cannot-compile c)))
x-specific-collections)))
(lambda (a b) (string-ci<? (cc-name a) (cc-name b)))))
(set! collections-to-compile (collection-closure collections-to-compile))
(remove-falses
(map (lambda (c) (collection->cc (map string->path c)))
x-specific-collections)))))))
(set! planet-dirs-to-compile
(let loop ([l planet-dirs-to-compile])
(if (null? l)
null
(let* ([cc (car l)]
[info (cc-info cc)])
(append
(remove-falses
(map
(lambda (p)
(planet-cc->sub-cc
cc
(cond
[(path? p) (list (path->bytes p))]
[(list-of bytes? p) p]
[else (map (λ (s) (path->bytes (string->path s))) p)])))
(call-info info 'compile-subcollections
(lambda ()
(map (λ (p) (list (path->bytes p)))
(filter
(lambda (p)
(let ((d (build-path (cc-path cc) p)))
(and (directory-exists? d)
(file-exists? (build-path d "info.ss")))))
(directory-list (cc-path cc)))))
;; Result checker:
(λ (p)
(match p
[(list (list (? (λ (v) (or (string? v) (bytes? v)))) ...) ...)
(void)]
[_ (error "result is not a list of lists of strings: " p)])))))
(list cc)
(loop (cdr l)))))))
(sort-collections
(collection-closure
planet-dirs-to-compile
(lambda (cc subs)
(map (lambda (p) (planet-cc->sub-cc cc (list (path->bytes p))))
subs)))))
(define ccs-to-compile (append collections-to-compile planet-dirs-to-compile))
@ -442,10 +460,12 @@
(lambda ()
(list mode-dir
(build-path mode-dir "native")
(build-path mode-dir "native" (system-library-subpath))))
(build-path mode-dir "native"
(system-library-subpath))))
(lambda (x)
(unless (list-of path-string? x)
(error 'setup-plt "expected a list of path strings for 'clean, got: ~s"
(error 'setup-plt
"expected a list of path strings for 'clean, got: ~s"
x))))]
[printed? #f]
[print-message
@ -724,7 +744,9 @@
(unless (equal? ht (hash-table-get ht-orig info-path))
(let-values ([(base name must-be-dir?) (split-path info-path)])
(unless (path? base)
(error 'make-info-domain "Internal error: cc had invalid info-path: ~s" info-path))
(error 'make-info-domain
"Internal error: cc had invalid info-path: ~e"
info-path))
(make-directory* base)
(let ([p info-path])
(setup-printf "Updating ~a" p)

View File

@ -1,7 +1,7 @@
#lang setup/infotab
(define pre-install-collection "makefile.ss")
(define compile-omit-files (list))
(define virtual-sources '("gl-info.ss"))
(define clean (list (build-path "compiled" "native" (system-library-subpath))
"compiled"))
(define compile-omit-paths '("examples"))

View File

@ -2,5 +2,5 @@
(define mred-launcher-libraries (list "sirmail.ss"))
(define mred-launcher-names (list "SirMail"))
(define compile-omit-files '("recover.ss"))
(define compile-omit-paths '("recover.ss"))
(define requires '(("mred") ("openssl")))

View File

@ -6,4 +6,4 @@
(define tool-urls (list "http://www.plt-scheme.org/software/slideshow/"))
(define mred-launcher-libraries (list "start.ss"))
(define mred-launcher-names (list "Slideshow"))
(define compile-omit-files (list "initial-ones.ss" "pict-snipclass.ss"))
(define compile-omit-paths '("initial-ones.ss" "pict-snipclass.ss" "examples"))

View File

@ -1,6 +1,6 @@
#lang setup/infotab
(define compile-omit-files
(define compile-omit-paths
'("alist-test.ss"
"all-srfi-1-tests.ss"
"cons-test.ss"

View File

@ -1,3 +1,3 @@
#lang setup/infotab
(define compile-omit-files `("tests.ss"))
(define compile-omit-paths `("tests.ss"))

3
collects/srfi/25/info.ss Normal file
View File

@ -0,0 +1,3 @@
#lang setup/infotab
(define compile-omit-paths '("arlib.scm" "ix-ctor.scm" "op-ctor.scm"))

View File

@ -78,7 +78,7 @@
; evals expr and issues an error if it is not #t.
(define (check expr)
(if (not (eq? (eval expr (interaction-environment)) #t))
(if (not (eq? (eval expr) #t))
(error "check failed" expr)))
; Basic Tests of the Interface

3
collects/srfi/32/info.ss Normal file
View File

@ -0,0 +1,3 @@
#lang setup/infotab
(define compile-omit-paths '("test.scm"))

3
collects/srfi/67/info.ss Normal file
View File

@ -0,0 +1,3 @@
#lang setup/infotab
(define compile-omit-paths '("compare-reference.scm"))

3
collects/srfi/74/info.ss Normal file
View File

@ -0,0 +1,3 @@
#lang setup/infotab
(define compile-omit-paths '("blob.scm"))

3
collects/srfi/78/info.ss Normal file
View File

@ -0,0 +1,3 @@
#lang setup/infotab
(define compile-omit-paths '("check-reference.scm" "examples-78.scm"))

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1,4 +1,4 @@
#lang setup/infotab
;; no .zo compilation necessary, since all the real code is in C++
(define compile-omit-files '("info.ss" "srpersist.ss" "main.ss"))
(define compile-omit-paths '("info.ss" "srpersist.ss" "main.ss"))

View File

@ -12,4 +12,4 @@
;; #f
))
(define compile-omit-files `("debugger-tool.ss"))
(define compile-omit-paths '("debugger-tool.ss"))

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -0,0 +1,3 @@
#lang setup/infotab
(define compile-omit-paths 'all)

View File

@ -1,4 +1,3 @@
#lang setup/infotab
(define scribblings '(("teachpacks.scrbl" (multi-page))))
(define compile-omit-files '())

View File

@ -1,6 +1,6 @@
#lang setup/infotab
(define compile-omit-files
(define compile-omit-paths
'("config-lang-test.ss" "drscheme-jr.ss" "drscheme-test.ss"
"event-efficency.ss" ;"language-test.ss"
"launcher.ss"

View File

@ -1,3 +1,3 @@
#lang setup/infotab
(define compile-omit-files '("key-specs.ss" "utils.ss" "receive-sexps-port.ss"))
(define compile-omit-paths '("key-specs.ss" "utils.ss" "receive-sexps-port.ss"))

View File

@ -1,9 +1,7 @@
#lang setup/infotab
(define name "Test Suites")
(define doc-subcollections '("tester"))
(define compile-subcollections '(("tests" "drscheme")
("tests" "framework")
("tests" "utils")))
(define tools '(("tool.ss" "drscheme")))
(define tool-names '("DrScheme Test Suites"))
(define compile-omit-paths 'all)

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -0,0 +1,3 @@
#lang setup/infotab
(define compile-omit-paths 'all)

View File

@ -5,3 +5,5 @@
(define mzscheme-launcher-libraries '("main.ss"))
(define mzscheme-launcher-names '("PLT Web Server"))
(define compile-omit-paths '("default-web-root"))

View File

@ -1 +0,0 @@
#lang setup/infotab

View File

@ -0,0 +1,3 @@
#lang setup/infotab
(define compile-omit-paths 'all)

View File

@ -1 +0,0 @@
#lang setup/infotab

Some files were not shown because too many files have changed in this diff Show More