suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

revise the way setup-plt crawls over the collection trees

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/browser/private/info.ss
View File

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

2
collects/combinator-parser/info.ss
View File

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

1
collects/combinator-parser/private-combinator/info.ss
View File

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

380
collects/compiler/compiler-unit.ss
View File

@ -1,5 +1,5 @@
;; Main compilation procedures ;; Main compilation procedures
;; (c) 1997-2001 PLT ;; (c) 1997-2008 PLT
;; The various procedures provided by this library are implemented ;; The various procedures provided by this library are implemented
;; by dynamically linking to code supplied by the MzLib, dynext, and ;; by dynamically linking to code supplied by the MzLib, dynext, and
@ -8,233 +8,185 @@
;; The Scheme->C compiler is loaded as either sploadr.ss (link in ;; The Scheme->C compiler is loaded as either sploadr.ss (link in
;; real MrSpidey) or loadr.ss (link in trivial MrSpidey stubs). ;; real MrSpidey) or loadr.ss (link in trivial MrSpidey stubs).
(module compiler-unit scheme/base #lang scheme/base
(require mzlib/unit
"sig.ss" (require mzlib/unit
dynext/file-sig
dynext/link-sig
dynext/compile-sig
make/make-sig
make/collection-sig
syntax/toplevel "sig.ss"
syntax/moddep dynext/file-sig
dynext/link-sig
dynext/compile-sig
mzlib/list make/make-sig
scheme/file make/collection-sig
mzlib/compile ; gets compile-file
mzlib/cm
setup/getinfo)
(provide compiler@) syntax/toplevel
syntax/moddep
(define-namespace-anchor anchor) mzlib/list
(define orig-namespace (namespace-anchor->empty-namespace anchor)) scheme/file
mzlib/compile ; gets compile-file
mzlib/cm
setup/getinfo)
;; ;;;;;;;; ----- The main compiler unit ------ ;;;;;;;;;; (provide compiler@)
(define-unit compiler@
(import compiler:option^
dynext:compile^
dynext:link^
dynext:file^)
(export compiler^)
(define compile-notify-handler (define-namespace-anchor anchor)
(make-parameter void)) (define orig-namespace (namespace-anchor->empty-namespace anchor))
(define current-compiler-dynamic-require-wrapper ;; ;;;;;;;; ----- The main compiler unit ------ ;;;;;;;;;;
(make-parameter (lambda (thunk) (define-unit compiler@
(parameterize ([current-namespace orig-namespace]) (import compiler:option^
(thunk))))) dynext:compile^
dynext:link^
dynext:file^)
(export compiler^)
(define (c-dynamic-require path id) (define compile-notify-handler
((current-compiler-dynamic-require-wrapper) (make-parameter void))
(lambda ()
(dynamic-require path id))))
(define (c-get-info cp)
((current-compiler-dynamic-require-wrapper)
(lambda ()
(get-info cp))))
(define (make-extension-compiler mode prefix) (define current-compiler-dynamic-require-wrapper
(let ([u (c-dynamic-require 'compiler/private/base (make-parameter (lambda (thunk)
'base@)] (parameterize ([current-namespace orig-namespace])
[init (unit (thunk)))))
(import compiler:inner^)
(export)
(eval-compile-prefix prefix)
(case mode
[(compile-extension) compile-extension]
[(compile-extension-to-c) compile-extension-to-c]
[(compile-c-extension) compile-c-extension]))])
(invoke-unit
(compound-unit
(import (COMPILE : dynext:compile^)
(LINK : dynext:link^)
(DFILE : dynext:file^)
(OPTION : compiler:option^))
(export)
(link [((COMPILER : compiler:inner^))
u
COMPILE LINK DFILE OPTION]
[() init COMPILER]))
(import dynext:compile^
dynext:link^
dynext:file^
compiler:option^))))
(define (make-compiler mode) (define (c-dynamic-require path id)
(lambda (prefix) ((current-compiler-dynamic-require-wrapper)
(let ([c (make-extension-compiler mode prefix)]) (lambda () (dynamic-require path id))))
(lambda (source-files destination-directory) (define (c-get-info cp)
(for-each ((current-compiler-dynamic-require-wrapper)
(lambda (source-file) (lambda () (get-info cp))))
(c source-file (or destination-directory 'same)))
source-files)))))
(define (make-unprefixed-compiler mode) (define (make-extension-compiler mode prefix)
(let ([f #f]) (let ([u (c-dynamic-require 'compiler/private/base 'base@)]
(lambda (source-files destination-directory) [init (unit (import compiler:inner^) (export)
(unless f (eval-compile-prefix prefix)
(set! f ((make-compiler mode) '(void)))) (case mode
(f source-files destination-directory)))) [(compile-extension) compile-extension]
[(compile-extension-to-c) compile-extension-to-c]
[(compile-c-extension) compile-c-extension]))])
(invoke-unit
(compound-unit
(import (COMPILE : dynext:compile^)
(LINK : dynext:link^)
(DFILE : dynext:file^)
(OPTION : compiler:option^))
(export)
(link [((COMPILER : compiler:inner^)) u COMPILE LINK DFILE OPTION]
[() init COMPILER]))
(import dynext:compile^
dynext:link^
dynext:file^
compiler:option^))))
(define compile-extensions (define (make-compiler mode)
(make-compiler 'compile-extension)) (lambda (prefix)
(define compile-extensions-to-c (let ([c (make-extension-compiler mode prefix)])
(make-compiler 'compile-extension-to-c)) (lambda (source-files destination-directory)
(define compile-c-extensions (for ([source-file source-files])
(make-unprefixed-compiler 'compile-c-extension)) (c source-file (or destination-directory 'same)))))))
(define (compile-to-zo src dest namespace eval?) (define (make-unprefixed-compiler mode)
((if eval? (lambda (t) (t)) with-module-reading-parameterization) (let ([f #f])
(lambda () (lambda (source-files destination-directory)
(parameterize ([current-namespace namespace]) (unless f
(compile-file src dest (set! f ((make-compiler mode) '(void))))
(if eval? (f source-files destination-directory))))
(lambda (expr)
(expand-syntax-top-level-with-compile-time-evals expr))
values)))))
(printf " [output to \"~a\"]~n" dest))
(define (compile-zos prefix) (define compile-extensions
(let ([n (if prefix (make-compiler 'compile-extension))
(make-base-namespace) (define compile-extensions-to-c
(current-namespace))]) (make-compiler 'compile-extension-to-c))
(when prefix (define compile-c-extensions
(eval prefix n)) (make-unprefixed-compiler 'compile-c-extension))
(lambda (source-files destination-directory)
(let ([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)
"compiled")])
(unless (directory-exists? d)
(make-directory* d))
d)
destination-directory)
file))
f)))
source-files)])
(for-each
(lambda (f b)
(let ([zo (append-zo-suffix b)])
(compile-to-zo f zo n prefix)))
source-files file-bases)))))
(define (compile-directory dir info zos?) (define (compile-to-zo src dest namespace eval?)
(let ([make (c-dynamic-require 'make/make-unit 'make@)] ((if eval? (lambda (t) (t)) with-module-reading-parameterization)
[coll (c-dynamic-require 'make/collection-unit 'make:collection@)] (lambda ()
[init (unit (parameterize ([current-namespace namespace])
(import make^ make:collection^) (compile-file src dest
(export) (if eval?
(values make-collection make-notify-handler))]) (lambda (expr)
(let-values ([(make-collection make-notify-handler) (expand-syntax-top-level-with-compile-time-evals expr))
(invoke-unit values)))))
(compound-unit (printf " [output to \"~a\"]\n" dest))
(import (DFILE : dynext:file^)
(OPTION : compiler:option^)
(COMPILER : compiler^))
(export)
(link [((MAKE : make^)) make]
[((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?
;; 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)))
(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?)))
(define (compile-collection-zos collection . cp) (define (compile-zos prefix)
(compile-collection (cons collection cp) #t)) (define n (if prefix (make-base-namespace) (current-namespace)))
(when prefix (eval prefix n))
(define (compile-directory-zos dir info) (lambda (source-files destination-directory)
(compile-directory dir info #t)) (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)
"compiled")])
(unless (directory-exists? d) (make-directory* d))
d)
destination-directory)
file))
f)))
source-files))
(for ([f source-files] [b file-bases])
(let ([zo (append-zo-suffix b)])
(compile-to-zo f zo n prefix)))))
(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^)
(OPTION : compiler:option^)
(COMPILER : compiler^))
(export)
(link [((MAKE : make^)) make]
[((COLL : make:collection^)) coll MAKE DFILE OPTION COMPILER]
[() init MAKE COLL]))
(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:
[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)
(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-directory (apply collection-path collection cp)
(c-get-info (cons collection cp))))
(define compile-directory-zos compile-directory)
)

66
collects/compiler/option-unit.ss
View File

@ -1,42 +1,40 @@
(module option-unit mzscheme #lang mzscheme
(require mzlib/unit)
(require "sig.ss") (require mzlib/unit)
(require "sig.ss")
(provide compiler:option@) (provide compiler:option@)
(define-unit compiler:option@ (define-unit compiler:option@ (import) (export compiler:option^)
(import)
(export compiler:option^)
(define propagate-constants (make-parameter #t))
(define assume-primitives (make-parameter #f))
(define stupid (make-parameter #f))
(define vehicles (make-parameter 'vehicles:automatic))
(define vehicles:monoliths (make-parameter 1))
(define seed (make-parameter 2001))
(define max-monoliths 32)
(define max-inline-size (make-parameter 50))
(define unsafe (make-parameter #f)) (define propagate-constants (make-parameter #t))
(define disable-interrupts (make-parameter #f)) (define assume-primitives (make-parameter #f))
(define fixnum-arithmetic (make-parameter #f)) (define stupid (make-parameter #f))
(define verbose (make-parameter #f)) (define vehicles (make-parameter 'vehicles:automatic))
(define debug (make-parameter #f)) (define vehicles:monoliths (make-parameter 1))
(define test (make-parameter #f)) (define seed (make-parameter 2001))
(define clean-intermediate-files (make-parameter #t)) (define max-monoliths 32)
(define 3m (make-parameter (eq? '3m (system-type 'gc))))
(define max-exprs-per-top-level-set (make-parameter 25)) (define max-inline-size (make-parameter 50))
(define setup-prefix (make-parameter ""))
(define compile-subcollections (make-parameter #t)) (define unsafe (make-parameter #f))
(define compile-for-embedded (make-parameter #f)) (define disable-interrupts (make-parameter #f))
(define fixnum-arithmetic (make-parameter #f))
;; Maybe #f helps for register-poor architectures?
(define unpack-environments (make-parameter #f)))) (define verbose (make-parameter #f))
(define debug (make-parameter #f))
(define test (make-parameter #f))
(define clean-intermediate-files (make-parameter #t))
(define 3m (make-parameter (eq? '3m (system-type 'gc))))
(define max-exprs-per-top-level-set (make-parameter 25))
(define setup-prefix (make-parameter ""))
(define compile-subcollections (make-parameter #t))
(define compile-for-embedded (make-parameter #f))
;; Maybe #f helps for register-poor architectures?
(define unpack-environments (make-parameter #f)))

1
collects/compiler/private/info.ss
View File

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

157
collects/compiler/sig.ss
View File

@ -1,90 +1,89 @@
(module sig mzscheme #lang mzscheme
(require mzlib/unit) (require mzlib/unit)
(provide compiler:option^ (provide compiler:option^
compiler^ compiler^
compiler:inner^) compiler:inner^)
;; Compiler options ;; Compiler options
(define-signature compiler:option^ (define-signature compiler:option^
(verbose ; default = #f (verbose ; default = #f
setup-prefix ; string to embed in public names;
; used mainly for compiling extensions
; with the collection name so that
; cross-extension conflicts are less
; likely in architectures that expose
; the public names of loaded extensions
; default = ""
clean-intermediate-files ; #t => keep intermediate .c/.o files
; default = #f
3m ; #t => build for 3m setup-prefix ; string to embed in public names;
; default = #f ; used mainly for compiling extensions
; with the collection name so that
compile-subcollections ; #t => use 'compile-subcollections ; cross-extension conflicts are less
; from infor for collection compiling ; likely in architectures that expose
; default = #t ; the public names of loaded extensions
; default = ""
compile-for-embedded ; #f => make objects to be linked
clean-intermediate-files ; #t => keep intermediate .c/.o files
; default = #f
3m ; #t => build for 3m
; default = #f
compile-subcollections ; #t => compile collection subdirectories
; default = #t
compile-for-embedded ; #f => make objects to be linked
; directly with MzScheme, not dynamically ; directly with MzScheme, not dynamically
; loaded; default = #f ; loaded; default = #f
max-inline-size ; max size of inlined procedures
disable-interrupts ; #t => UNSAFE: turn off breaking, stack
; overflow, and thread switching;
; default = #f
unsafe ; #t => UNSAFE: omit some type checks
; default = #f
fixnum-arithmetic ; #t => UNSAFE: don't check for overflow or
; underflow for fixnum arithmetic;
; default = #f
propagate-constants ; default = #t
assume-primitives ; #t => car = #%car; default = #f
stupid ; allow obvious non-syntactic errors;
; e.g.: ((lambda () 0) 1 2 3)
vehicles ; Controls how closures are compiled:
; 'vehicles:automatic,
; 'vehicles:functions,
; 'vechicles:units, or
; 'vehicles:monolithic.
; default = 'vehicles:automatic
vehicles:monoliths ; Size for 'vehicles:monolithic
seed ; Randomizer seed for 'vehicles:monolithic
max-exprs-per-top-level-set ; Number of top-level Scheme expressions
; crammed into one C function; default = 25
unpack-environments ; default = #t
; Maybe #f helps for register-poor architectures?
debug ; #t => creates debug.txt debugging file
test ; #t => ignores top-level expressions with syntax errors
))
;; Compiler procedures max-inline-size ; max size of inlined procedures
(define-signature compiler^
(compile-extensions
compile-extensions-to-c
compile-c-extensions
compile-zos disable-interrupts ; #t => UNSAFE: turn off breaking, stack
; overflow, and thread switching;
; default = #f
unsafe ; #t => UNSAFE: omit some type checks
; default = #f
fixnum-arithmetic ; #t => UNSAFE: don't check for overflow or
; underflow for fixnum arithmetic;
; default = #f
compile-collection-zos propagate-constants ; default = #t
compile-directory-zos assume-primitives ; #t => car = #%car; default = #f
stupid ; allow obvious non-syntactic errors;
current-compiler-dynamic-require-wrapper ; e.g.: ((lambda () 0) 1 2 3)
compile-notify-handler))
;; Low-level extension compiler interface vehicles ; Controls how closures are compiled:
(define-signature compiler:inner^ ; 'vehicles:automatic,
(compile-extension ; 'vehicles:functions,
compile-extension-to-c ; 'vechicles:units, or
compile-c-extension ; 'vehicles:monolithic.
eval-compile-prefix))) ; default = 'vehicles:automatic
vehicles:monoliths ; Size for 'vehicles:monolithic
seed ; Randomizer seed for 'vehicles:monolithic
max-exprs-per-top-level-set ; Number of top-level Scheme expressions
; crammed into one C function; default = 25
unpack-environments ; default = #t
; Maybe #f helps for register-poor architectures?
debug ; #t => creates debug.txt debugging file
test ; #t => ignores top-level expressions with syntax errors
))
;; Compiler procedures
(define-signature compiler^
(compile-extensions
compile-extensions-to-c
compile-c-extensions
compile-zos
compile-collection-zos
compile-directory-zos
current-compiler-dynamic-require-wrapper
compile-notify-handler))
;; Low-level extension compiler interface
(define-signature compiler:inner^
(compile-extension
compile-extension-to-c
compile-c-extension
eval-compile-prefix))

1
collects/drscheme/private/info.ss
View File

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

4
collects/dynext/private/dirs.ss
View File

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

3
collects/dynext/private/info.ss Normal file
View File

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

1
collects/embedded-gui/info.ss
View File

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

3
collects/embedded-gui/private/info.ss Normal file
View File

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

1
collects/eopl/private/info.ss
View File

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

1
collects/errortrace/info.ss
View File

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

2
collects/ffi/info.ss
View File

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

1
collects/file/info.ss
View File

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

1
collects/framework/info.ss
View File

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

2
collects/framework/private/info.ss
View File

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

3
collects/frtime/info.ss
View File

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

3
collects/games/loa/info.ss Normal file
View File

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

9
collects/games/paint-by-numbers/info.ss
View File

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

2
collects/graphics/info.ss
View File

@ -1,3 +1,3 @@
#lang setup/infotab #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"))

2
collects/handin-server/info.ss
View File

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

1
collects/htdch/draw/installer.ss
View File

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

2
collects/htdch/idraw/Canvas-native-methods.ss
View File

@ -1,6 +1,6 @@
#cs #cs
(module Canvas-native-methods mzscheme (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 void-or-true (void))
(define (imperative w@t+1 w@t) w@t+1) (define (imperative w@t+1 w@t) w@t+1)

2
collects/htdch/idraw/World-native-methods.ss
View File

@ -1,6 +1,6 @@
#cs #cs
(module World-native-methods mzscheme (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) (provide endOfTime-java.lang.String-native endOfWorld-java.lang.String-native bigBangO-double-native)

2
collects/htdch/idraw/info.ss
View File

@ -2,5 +2,5 @@
(define name "Imperative Drawing") (define name "Imperative Drawing")
(define assume-virtual-sources #t) (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") ;; (define pre-install-collection "pre-installer.ss")

8
collects/htdch/info.ss
View File

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

2
collects/htdp/HtDPv0/pingp-sig.ss
View File

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

5
collects/htdp/info.ss
View File

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

2
collects/html/info.ss
View File

@ -1,6 +1,6 @@
#lang setup/infotab #lang setup/infotab
(define scribblings '(("html.scrbl"))) (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" '("dtd.ss" "dtdr.ss" "dtds.ss" "dtd-ast.ss" "case.ss" "html-structs.ss"
"entity-expander.ss" "generate-code.ss" "sgml.ss")) "entity-expander.ss" "generate-code.ss" "sgml.ss"))

1
collects/lang/private/info.ss
View File

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

1
collects/launcher/info.ss
View File

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

5
collects/little-helper/indexer/planet/info.ss Normal file
View File

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

2
collects/little-helper/info.ss
View File

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

1
collects/macro-debugger/syntax-browser/info.ss
View File

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

2
collects/macro-debugger/view/info.ss
View File

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

1
collects/make/info.ss
View File

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

1
collects/mred/lang/info.ss
View File

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

1
collects/mred/private/info.ss
View File

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

1
collects/mrlib/info.ss
View File

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

3
collects/mrlib/private/aligned-pasteboard/info.ss Normal file
View File

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

1
collects/mrlib/private/info.ss
View File

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

1
collects/mzlib/info.ss
View File

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

2
collects/mzlib/private/info.ss
View File

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

2
collects/mzscheme/info.ss
View File

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

1
collects/mzscheme/lang/info.ss
View File

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

1
collects/net/info.ss
View File

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

2
collects/parser-tools/info.ss
View File

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

2
collects/parser-tools/private-lex/info.ss
View File

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

1
collects/parser-tools/private-yacc/info.ss
View File

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

2
collects/plot/info.ss
View File

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

1
collects/profj/comb-parsers/info.ss
View File

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

6
collects/profj/info.ss
View File

@ -6,12 +6,6 @@
(define tool-names '("ProfessorJ" "ProfessorJ Testing")) (define tool-names '("ProfessorJ" "ProfessorJ Testing"))
(define install-collection "installer.ss") (define install-collection "installer.ss")
(define pre-install-collection "pre-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 (define textbook-pls
(list (list '("htdch-icon.png" "profj") (list (list '("htdch-icon.png" "profj")
"How to Design Classes" "How to Design Classes"

1
collects/profj/parsers/info.ss
View File

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

7
collects/profjWizard/info.ss
View File

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

1
collects/r5rs/lang/info.ss
View File

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

7
collects/r6rs/info.ss
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"))

1
collects/rnrs/arithmetic/info.ss
View File

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

1
collects/rnrs/info.ss
View File

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

1
collects/rnrs/io/info.ss
View File

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

1
collects/rnrs/records/info.ss
View File

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

1
collects/s-exp/lang/info.ss
View File

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

1
collects/scheme/info.ss
View File

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

2
collects/scribble/info.ss
View File

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

2
collects/scribblings/guide/info.ss
View File

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

41
collects/scribblings/mzc/api.scrbl
View File

@ -74,22 +74,22 @@ following fields are used:
@item{@scheme[name] : The name of the collection as a string.} @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 @item{@scheme[compile-omit-files] : A list of filenames (without
directory paths); all Scheme files in the collection are directory paths); that are not compiled, in addition to the
compiled except for the files in this list. Files that are contents of @scheme[compile-omit-paths]. Do not use this
required by other files that are compiled, however, will get field: it is for backward compatibility.}
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.}
} }
Only the @scheme[name] field is required from @filepath{info.ss}, 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 and @filepath{.o} files generated during compilation via C. The
default is @scheme[#t].} 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 whether sub-collections are compiled by
@scheme[compile-collection-zos]. The default is @scheme[#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].}
@defboolparam[compile-for-embedded embed?]{ @defboolparam[compile-for-embedded embed?]{

3
collects/scribblings/setup-plt/info.scrbl
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] @hash-lang[] notation, but only with the @schememodname[setup/infotab]
language. language.
@;{
The @scheme[name] tag is required for @exec{setup-plt} to recognize The @scheme[name] tag is required for @exec{setup-plt} to recognize
the collection and compile its files to bytecode. Similarly, an the collection and compile its files to bytecode. Similarly, an
@filepath{info.ss} file in a sub-directory of a collection causes the @filepath{info.ss} file in a sub-directory of a collection causes the
sub-directory's files to be compiled. sub-directory's files to be compiled.
;}
See also @scheme[get-info] from @schememodname[setup/getinfo]. See also @scheme[get-info] from @schememodname[setup/getinfo].

18
collects/scribblings/setup-plt/setup-plt.scrbl
View File

@ -100,6 +100,16 @@ accepted by the @|setup-plt| executable.
@subsection{Compiling and Setting Up All Collections} @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 The @|setup-plt| executable attempts to compile and set up any
collection that: 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 @scheme[compile-collection-zos] procedure (which means that even if a
collection has no @filepath{info.ss} file, its modules will get collection has no @filepath{info.ss} file, its modules will get
compiled if they are used by other compiled modules). compiled if they are used by other compiled modules).
;}
@; ------------------------------------------------------------------------ @; ------------------------------------------------------------------------
@ -144,7 +155,7 @@ Optional @filepath{info.ss} fields trigger additional setup actions:
of the @filepath{info.ss} file. of the @filepath{info.ss} file.
In addition, In addition,
@schemeblock[ @schemeblock[
(build-aux-from-path (build-aux-from-path
(build-path (collection-path #,(nonterm "colls") _...) #,(nonterm "suffixless-file"))) (build-path (collection-path #,(nonterm "colls") _...) #,(nonterm "suffixless-file")))
@ -161,10 +172,7 @@ Optional @filepath{info.ss} fields trigger additional setup actions:
@scheme[mzscheme-launcher-libraries], then the flags will override @scheme[mzscheme-launcher-libraries], then the flags will override
the libraries, but the libraries can still be used to specify a the libraries, but the libraries can still be used to specify a
name for @scheme[build-aux-from-path] (to find related information name for @scheme[build-aux-from-path] (to find related information
like icon files etc). like icon files etc).}
If @scheme[compile-subcollections] mentions a subcollection with
this field, the executable is also set up for that subcollection.}
@item{@scheme[mzscheme-launcher-libraries] : @scheme[(listof @item{@scheme[mzscheme-launcher-libraries] : @scheme[(listof
path-string?)] --- A list of library names in parallel to path-string?)] --- A list of library names in parallel to

2
collects/setup/info.ss
View File

@ -2,7 +2,7 @@
(define name "Setup PLT") (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-libraries '("main.ss"))
(define mzscheme-launcher-names '("Setup PLT")) (define mzscheme-launcher-names '("Setup PLT"))

336
collects/setup/setup-unit.ss
View File

@ -11,6 +11,7 @@
scheme/port scheme/port
scheme/match scheme/match
scheme/system scheme/system
scheme/list
planet/planet-archives planet/planet-archives
planet/private/planet-shared planet/private/planet-shared
@ -25,6 +26,16 @@
(define-namespace-anchor anchor) (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@) (provide setup@)
(define-unit setup@ (define-unit setup@
@ -66,9 +77,7 @@
(setup-printf " ~a" (path->string p))) (setup-printf " ~a" (path->string p)))
(define (call-info info flag mk-default test) (define (call-info info flag mk-default test)
(if info (let ([v (info flag mk-default)]) (test v) v))
(let ([v (info flag mk-default)]) (test v) v)
(mk-default)))
(define mode-dir (define mode-dir
(if (compile-mode) (if (compile-mode)
@ -94,10 +103,7 @@
(for ([e (reverse errors)]) (for ([e (reverse errors)])
(match-let ([(list cc desc x) e]) (match-let ([(list cc desc x) e])
(setup-fprintf port "Error during ~a for ~a" (setup-fprintf port "Error during ~a for ~a"
desc desc (if (cc? cc) (cc-name cc) cc))
(if (cc? cc)
(format "~a (~a)" (cc-name cc) (cc-path cc))
cc))
(setup-fprintf port " ~a" (exn->string x))))) (setup-fprintf port " ~a" (exn->string x)))))
(define (done) (define (done)
@ -150,43 +156,55 @@
(collection path name info root-dir info-path shadowing-policy) (collection path name info root-dir info-path shadowing-policy)
#:inspector #f) #: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) (define ((warning-handler v) exn)
(setup-printf "Warning: ~a" (exn->string exn)) (setup-printf "Warning: ~a" (exn->string exn))
v) v)
;; collection->cc : listof path -> cc ;; collection->cc : listof path -> cc/#f
(define (collection->cc collection-p) (define (collection->cc collection-p)
(let* ([root-dir (ormap (lambda (p) (let ([root-dir
(parameterize ([current-library-collection-paths (ormap (lambda (p)
(list p)]) (parameterize ([current-library-collection-paths (list p)])
(and (with-handlers ([exn:fail? (lambda (x) #f)]) (and (with-handlers ([exn:fail? (lambda (x) #f)])
(apply collection-path collection-p)) (apply collection-path collection-p))
p))) p)))
(current-library-collection-paths))] (current-library-collection-paths))])
[info (with-handlers ([exn:fail? (warning-handler #f)]) (make-cc* collection-p
(get-info collection-p))] (apply collection-path collection-p)
[name (call-info info 'name (lambda () #f) root-dir
(lambda (x) (build-path root-dir "info-domain" "compiled" "cache.ss")
(when (and x (not (string? x))) ;; by convention, all collections have "version" 1 0. This
(error ;; forces them to conflict with each other.
'setup-plt (list (cons 'lib (map path->string collection-p)) 1 0))))
"'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
(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)))))
;; remove-falses : listof (union X #f) -> listof X ;; remove-falses : listof (union X #f) -> listof X
;; returns the non-false elements of l in order ;; returns the non-false elements of l in order
@ -213,24 +231,11 @@
(define (planet->cc path owner pkg-file extra-path maj min) (define (planet->cc path owner pkg-file extra-path maj min)
(unless (path? path) (unless (path? path)
(error 'planet->cc "non-path when building package ~e" pkg-file)) (error 'planet->cc "non-path when building package ~e" pkg-file))
(let/ec return (make-cc* #f
(let* ([info (with-handlers ([exn:fail? (warning-handler #f)]) path
(get-info/full path))] #f ; don't need root-dir; absolute paths in cache.ss will be ok
[name (call-info info 'name (lambda () (return #f)) (get-planet-cache-path)
(lambda (x) (list `(planet ,owner ,pkg-file ,@extra-path) maj min)))
(when (and x (not (string? x)))
(error
'planet->cc
"'name' result from directory ~e is not a string: ~e"
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)))))
;; planet-cc->sub-cc : cc (listof bytes [encoded path]) -> cc ;; planet-cc->sub-cc : cc (listof bytes [encoded path]) -> cc
;; builds a compilation job for the given subdirectory of the given cc this ;; builds a compilation job for the given subdirectory of the given cc this
@ -245,10 +250,6 @@
maj maj
min))) 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 (define planet-dirs-to-compile
(if (make-planet) (if (make-planet)
(remove-falses (map (lambda (spec) (apply planet->cc spec)) (remove-falses (map (lambda (spec) (apply planet->cc spec))
@ -271,107 +272,124 @@
(hash-table-map ht (lambda (k v) v)))) (hash-table-map ht (lambda (k v) v))))
;; Close over sub-collections ;; Close over sub-collections
(define (collection-closure collections-to-compile) (define (collection-closure collections-to-compile make-subs)
(let loop ([l collections-to-compile]) (define (get-subs cc)
(if (null? l) (let* ([info (cc-info cc)]
null [ccp (cc-path cc)]
(let* ([cc (car l)] ;; note: `compile-omit-paths' can be the symbol `all', if this
[info (cc-info cc)]) ;; happens then this collection should not have been included in
(append ;; the first place, but we might jump in if a command-line
(map ;; argument specifies coll/subcoll
(lambda (subcol) [omit (call-info info 'compile-omit-paths (lambda () '())
(or (collection->cc (map string->path subcol)) (lambda (x)
(cannot-compile subcol))) (unless (or (eq? 'all x) (list-of string? x))
(call-info info 'compile-subcollections (error 'setup-plt
;; Default: subdirs with info.ss files "expected a list of path strings or 'all for compile-omit-paths, got: ~s"
(lambda () x))))]
(map (lambda (x) [omit (if (pair? omit) omit '())]
(map path->string (append (cc-collection cc) (list x)))) [subs (filter (lambda (p)
(filter (lambda (p) (and (directory-exists? (build-path ccp p))
(let ([d (build-path (cc-path cc) p)]) (not (member (path->string p) omit))))
(and (directory-exists? d) (directory-list ccp))])
(file-exists? (build-path d "info.ss"))))) (remove-falses (make-subs cc subs))))
(directory-list (cc-path cc))))) (remove-falses
;; Result checker: (let loop ([l collections-to-compile])
(lambda (x) (apply append (map (lambda (cc) (cons cc (loop (get-subs cc)))) l)))))
(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)))))))
(define (same-collection-name? cc-1 cc-2) (define (plt-collection-closure collections-to-compile)
(let ([split (lambda (cc) (collection-closure
(apply append collections-to-compile
(map (lambda (e) (lambda (cc subs)
(if (path? e) (map (lambda (sub)
(map path-element->string (explode-path e)) (collection->cc (append (cc-collection cc) (list sub))))
(regexp-split #rx"/" e))) subs))))
(cc-collection cc))))])
(equal? (split cc-1) (split cc-2))))
(define (check-again-all given-ccs) (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]) (for ([cc given-ccs])
(call-with-input-file* (build-path (cc-path cc) "info.ss") (define given-id
(lambda (given-info-port) (file-or-directory-identity (cc-path cc)))
(define given-id (port-file-identity given-info-port)) (for ([found-cc+id all-cc+ids]
(for ([found-cc all-collections*] #:when (not (same-collection-name? cc (car found-cc+id))))
#:when (not (same-collection-name? cc found-cc))) (when (eq? (cdr found-cc+id) given-id)
(call-with-input-file* (build-path (cc-path found-cc) "info.ss") (error 'setup-plt
(lambda (found-info-port) "given collection path: ~e refers to the same info file as another path: ~e"
(when (eq? (port-file-identity found-info-port) given-id) (apply build-path (cc-collection cc))
(error 'setup-plt (apply build-path (cc-collection (car found-cc+id)))))))
"given collection path: ~e refers to the same info file as another path: ~e" |#
(apply build-path (cc-collection cc)) ;; Note: this is not a locking mechanism; specifically, if we find a marker
(apply build-path (cc-collection found-cc)))))))))) ;; file we assume that we generated it rather than another setup-plt
given-ccs) ;; 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 (define collections-to-compile
(sort (if no-specific-collections? (sort-collections
all-collections (plt-collection-closure
(check-again-all (if no-specific-collections?
(map (lambda (c) all-collections
(or (collection->cc (map string->path c)) (check-again-all
(cannot-compile c))) (remove-falses
x-specific-collections))) (map (lambda (c) (collection->cc (map string->path c)))
(lambda (a b) (string-ci<? (cc-name a) (cc-name b))))) x-specific-collections)))))))
(set! collections-to-compile (collection-closure collections-to-compile))
(set! planet-dirs-to-compile (set! planet-dirs-to-compile
(let loop ([l planet-dirs-to-compile]) (sort-collections
(if (null? l) (collection-closure
null planet-dirs-to-compile
(let* ([cc (car l)] (lambda (cc subs)
[info (cc-info cc)]) (map (lambda (p) (planet-cc->sub-cc cc (list (path->bytes p))))
(append subs)))))
(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)))))))
(define ccs-to-compile (append collections-to-compile planet-dirs-to-compile)) (define ccs-to-compile (append collections-to-compile planet-dirs-to-compile))
@ -442,10 +460,12 @@
(lambda () (lambda ()
(list mode-dir (list mode-dir
(build-path mode-dir "native") (build-path mode-dir "native")
(build-path mode-dir "native" (system-library-subpath)))) (build-path mode-dir "native"
(system-library-subpath))))
(lambda (x) (lambda (x)
(unless (list-of path-string? 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))))] x))))]
[printed? #f] [printed? #f]
[print-message [print-message
@ -724,7 +744,9 @@
(unless (equal? ht (hash-table-get ht-orig info-path)) (unless (equal? ht (hash-table-get ht-orig info-path))
(let-values ([(base name must-be-dir?) (split-path info-path)]) (let-values ([(base name must-be-dir?) (split-path info-path)])
(unless (path? base) (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) (make-directory* base)
(let ([p info-path]) (let ([p info-path])
(setup-printf "Updating ~a" p) (setup-printf "Updating ~a" p)

2
collects/sgl/info.ss
View File

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

2
collects/sirmail/info.ss
View File

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

2
collects/slideshow/info.ss
View File

@ -6,4 +6,4 @@
(define tool-urls (list "http://www.plt-scheme.org/software/slideshow/")) (define tool-urls (list "http://www.plt-scheme.org/software/slideshow/"))
(define mred-launcher-libraries (list "start.ss")) (define mred-launcher-libraries (list "start.ss"))
(define mred-launcher-names (list "Slideshow")) (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"))

2
collects/srfi/1/info.ss
View File

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

2
collects/srfi/19/info.ss
View File

@ -1,3 +1,3 @@
#lang setup/infotab #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"))

2
collects/srfi/27/random-bits-examples.ss
View File

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

1
collects/srfi/info.ss
View File

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

2
collects/srpersist/info.ss
View File

@ -1,4 +1,4 @@
#lang setup/infotab #lang setup/infotab
;; no .zo compilation necessary, since all the real code is in C++ ;; 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"))

2
collects/stepper/info.ss
View File

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

1
collects/stepper/private/info.ss
View File

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

3
collects/teachpack/htdc/info.ss Normal file
View File

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

1
collects/teachpack/info.ss
View File

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

2
collects/tests/drscheme/info.ss
View File

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

2
collects/tests/framework/info.ss
View File

@ -1,3 +1,3 @@
#lang setup/infotab #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"))

6
collects/tests/info.ss
View File

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

1
collects/tests/utils/info.ss
View File

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

1
collects/texpict/info.ss
View File

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

1
collects/texpict/private/info.ss
View File

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

1
collects/waterworld/info.ss
View File

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

3
collects/web-server/bench/info.ss Normal file
View File

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

2
collects/web-server/info.ss
View File

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

1
collects/web-server/scribblings/info.ss
View File

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

3
collects/web-server/tests/info.ss Normal file
View File

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

1
collects/wxme/info.ss
View File

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

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