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

Remove units in parts of compiler, dynext, setup and create the cext-lib package.

Browse Source 
`cext-lib` contains much of the contents of `dynext`, which
is no longer very widely used.

Also moved the implementation of the `mzc` executable
to a more appropriate package.

Also, used `lazy-require` consistently for dynamically
loading implementations.
This commit is contained in:
Sam Tobin-Hochstadt 2013-09-17 09:00:42 -04:00 committed by Sam Tobin-Hochstadt
parent 162edd099d
commit 9f2755116d
56 changed files with 2987 additions and 2971 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
pkgs/compiler-lib/compiler/commands/ctool.rkt → pkgs/cext-lib/compiler/commands/ctool.rkt
View File

@ -5,8 +5,8 @@
(error-print-width 512)
(require (prefix-in compiler:option: "../option.rkt")
"../compiler.rkt"
(require (prefix-in compiler:option: compiler/option)
compiler/compiler
raco/command-name
racket/cmdline
dynext/file

4
pkgs/cext-lib/compiler/commands/info.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang info
(define raco-commands
'(("ctool" compiler/commands/ctool "compile and link C-based extensions" #f)))

0
pkgs/compiler-lib/compiler/xform.rkt → pkgs/cext-lib/compiler/xform.rkt
View File

0
racket/collects/dynext/compile-sig.rkt → pkgs/cext-lib/dynext/compile-sig.rkt
View File

0
racket/collects/dynext/compile-unit.rkt → pkgs/cext-lib/dynext/compile-unit.rkt
View File

0
racket/collects/dynext/compile.rkt → pkgs/cext-lib/dynext/compile.rkt
View File

6
pkgs/cext-lib/dynext/dynext-sig.rkt Normal file
View File

@ -0,0 +1,6 @@
(module dynext-sig racket/base
(require "compile-sig.rkt" "link-sig.rkt")
(provide (all-from-out "compile-sig.rkt")
(all-from-out "link-sig.rkt")))

6
pkgs/cext-lib/dynext/dynext-unit.rkt Normal file
View File

@ -0,0 +1,6 @@
#lang racket/base
(require "compile-unit.rkt" "link-unit.rkt")
(provide (all-from-out "compile-unit.rkt")
(all-from-out "link-unit.rkt"))

4
racket/collects/dynext/dynext.rkt → pkgs/cext-lib/dynext/dynext.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base
(require "compile.rkt" "link.rkt" "file.rkt")
(require "compile.rkt" "link.rkt" dynext/file)
(provide (all-from-out "compile.rkt")
(all-from-out "link.rkt")
(all-from-out "file.rkt"))
(all-from-out dynext/file))

0
racket/collects/dynext/file-sig.rkt → pkgs/cext-lib/dynext/file-sig.rkt
View File

7
pkgs/cext-lib/dynext/file-unit.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang racket/base
(require racket/unit "file-sig.rkt" dynext/file)
(provide dynext:file@)
(define-unit-from-context dynext:file@ dynext:file^)

0
racket/collects/dynext/link-sig.rkt → pkgs/cext-lib/dynext/link-sig.rkt
View File

2
racket/collects/dynext/link-unit.rkt → pkgs/cext-lib/dynext/link-unit.rkt
View File

@ -4,7 +4,7 @@
"private/dirs.rkt"
"private/stdio.rkt"
"private/cmdargs.rkt"
"filename-version.rkt")
dynext/filename-version)
(require "link-sig.rkt")

0
racket/collects/dynext/link.rkt → pkgs/cext-lib/dynext/link.rkt
View File

0
racket/collects/dynext/main.rkt → pkgs/cext-lib/dynext/main.rkt
View File

0
racket/collects/dynext/private/cmdargs.rkt → pkgs/cext-lib/dynext/private/cmdargs.rkt
View File

0
racket/collects/dynext/private/dirs.rkt → pkgs/cext-lib/dynext/private/dirs.rkt
View File

0
racket/collects/dynext/private/stdio.rkt → pkgs/cext-lib/dynext/private/stdio.rkt
View File

10
pkgs/cext-lib/info.rkt Normal file
View File

@ -0,0 +1,10 @@
#lang info
(define collection 'multi)
(define deps '("base"
"compiler-lib"
"scheme-lib"
"rackunit-lib"))
(define pkg-desc "Tools for managing C extensions, such as `raco ctool`")
(define pkg-authors '(mflatt))

1
pkgs/compiler-lib/compiler/commands/info.rkt
View File

@ -9,5 +9,4 @@
("test" compiler/commands/test "run tests associated with files/directories" 15)
("expand" compiler/commands/expand "macro-expand source" #f)
("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f)
("ctool" compiler/commands/ctool "compile and link C-based extensions" #f)
("demodularize" compiler/demodularizer/batch "produce a whole program from a single module" #f)))

2
pkgs/compiler-lib/compiler/commands/make.rkt
View File

@ -2,7 +2,7 @@
(require scheme/cmdline
raco/command-name
compiler/cm
"../compiler.rkt"
compiler/compiler
dynext/file
setup/parallel-build
racket/match)

5
pkgs/compiler-lib/compiler/compiler-unit.rkt Normal file
View File

@ -0,0 +1,5 @@
#lang racket/base
(require compiler/compiler compiler/sig racket/unit)
(provide compiler@)
(define-unit-from-context compiler@ compiler^)

20
pkgs/compiler-lib/compiler/compiler.rkt
View File

@ -1,20 +0,0 @@
(module compiler racket/base
(require racket/unit)
(require compiler/sig)
(require dynext/compile-sig)
(require dynext/link-sig)
(require dynext/file-sig)
;;
(require dynext/compile)
(require dynext/link)
(require dynext/file)
(require "option.rkt")
(require compiler/compiler-unit)
(define-values/invoke-unit/infer compiler@)
(provide-signature-elements compiler^))

0
racket/collects/compiler/embed-sig.rkt → pkgs/compiler-lib/compiler/embed-sig.rkt
View File

9
pkgs/compiler-lib/compiler/embed-unit.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang racket/base
(require racket/unit
racket/contract
"sig.rkt"
compiler/embed
"embed-sig.rkt")
(define-unit-from-context compiler:embed@ compiler:embed^)
(provide compiler:embed@)

7
pkgs/compiler-lib/compiler/option-unit.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang racket/base
(require racket/unit compiler/sig compiler/option)
(provide compiler:option@)
(define-unit-from-context compiler:option@ compiler:option^)

9
pkgs/compiler-lib/compiler/option.rkt
View File

@ -1,9 +0,0 @@
(module option racket/base
(require racket/unit)
(require compiler/sig
compiler/option-unit)
(define-values/invoke-unit/infer compiler:option@)
(provide-signature-elements compiler:option^))

0
racket/collects/compiler/sig.rkt → pkgs/compiler-lib/compiler/sig.rkt
View File

0
racket/collects/launcher/launcher-sig.rkt → pkgs/compiler-lib/launcher/launcher-sig.rkt
View File

7
pkgs/compiler-lib/launcher/launcher-unit.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang racket/base
(require racket/unit "launcher-sig.rkt" launcher/launcher)
(provide launcher@)
(define-unit-from-context launcher@ launcher^)

0
racket/collects/setup/option-sig.rkt → pkgs/compiler-lib/setup/option-sig.rkt
View File

6
pkgs/compiler-lib/setup/option-unit.rkt Normal file
View File

@ -0,0 +1,6 @@
#lang racket/base
(require racket/unit setup/option "option-sig.rkt")
(provide setup:option@ set-flag-params)
(define-unit-from-context setup:option@ setup-option^)

9
pkgs/compiler-lib/setup/setup-unit.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang racket/base
(require racket/unit setup/setup-core)
(provide setup@)
(define-unit setup@
(import)
(export)
(setup-core))

2
pkgs/drracket-pkgs/drracket-test/info.rkt
View File

@ -11,6 +11,8 @@
"compatibility-lib"
"gui-lib"
"htdp"
"compiler-lib"
"cext-lib"
"scribble-lib"
"string-constants-lib"))

1
pkgs/make/info.rkt
View File

@ -5,6 +5,7 @@
(define scribblings '(("make.scrbl" (multi-page) (tool-library))))
(define deps '("scheme-lib"
"base"
"cext-lib"
"compiler-lib"
"compatibility-lib"))
(define build-deps '("racket-doc"

90
pkgs/compiler-lib/compiler/main.rkt → pkgs/mzscheme/compiler/main.rkt
View File

@ -22,17 +22,30 @@
(error-print-width 512)
(require (prefix-in compiler:option: compiler/option)
"compiler.rkt")
compiler/compiler)
;; Read argv array for arguments and input file name
(require racket/cmdline
dynext/file
dynext/compile
dynext/link
scheme/pretty
setup/pack
setup/getinfo
setup/dirs)
setup/dirs
racket/lazy-require)
(lazy-require [dynext/compile (use-standard-compiler get-standard-compilers current-extension-compiler
current-extension-compiler-flags current-extension-preprocess-flags
compile-variant compile-extension)]
[dynext/link (use-standard-linker expand-for-link-variant current-extension-linker
current-extension-linker-flags current-standard-link-libraries
link-variant link-extension)]
[compiler/cm (managed-compile-zo manager-compile-notify-handler manager-trace-handler)]
[compiler/xform (xform)]
[compiler/distribute (assemble-distribution)]
[compiler/zo-parse (zo-parse)]
[compiler/private/embed (mzc:embedding-executable-add-suffix write-module-bundle
mzc:create-embedding-executable)]
[compiler/decompile (decompile)])
(define dest-dir (make-parameter #f))
(define auto-dest-dir (make-parameter #f))
@ -363,6 +376,11 @@
(define-values (mode source-files prefix)
(parse-options (current-command-line-arguments)))
(define (compiler-warning)
(eprintf "Warning: ~a\n ~a\n"
"compilation to C is usually less effective for performance"
"than relying on the bytecode just-in-time compiler."))
(when (compiler:option:somewhat-verbose)
(printf "mzc v~a [~a], Copyright (c) 2004-2013 PLT Design Inc.\n"
(version)
@ -375,11 +393,6 @@
(begin (link-variant '3m) (compile-variant '3m))
(begin (link-variant 'cgc) (compile-variant 'cgc)))
(define (compiler-warning)
(eprintf "Warning: ~a\n ~a\n"
"compilation to C is usually less effective for performance"
"than relying on the bytecode just-in-time compiler."))
(case mode
[(zo)
((compile-zos prefix #:verbose? (compiler:option:somewhat-verbose))
@ -402,34 +415,31 @@
(pretty-print (syntax->datum (expand e)))
(loop))))))))))]
[(decompile)
(let ([zo-parse (dynamic-require 'compiler/zo-parse 'zo-parse)]
[decompile (dynamic-require 'compiler/decompile 'decompile)])
(for ([zo-file source-files])
(let ([zo-file (path->complete-path zo-file)])
(let-values ([(base name dir?) (split-path zo-file)])
(let ([alt-file (build-path base "compiled" (path-add-suffix name #".zo"))])
(parameterize ([current-load-relative-directory base]
[print-graph #t])
(pretty-print
(decompile
(call-with-input-file*
(if (file-exists? alt-file) alt-file zo-file)
(lambda (in)
(zo-parse in)))))))))))]
(for ([zo-file source-files])
(let ([zo-file (path->complete-path zo-file)])
(let-values ([(base name dir?) (split-path zo-file)])
(let ([alt-file (build-path base "compiled" (path-add-suffix name #".zo"))])
(parameterize ([current-load-relative-directory base]
[print-graph #t])
(pretty-print
(decompile
(call-with-input-file*
(if (file-exists? alt-file) alt-file zo-file)
(lambda (in)
(zo-parse in))))))))))]
[(make-zo)
(let ([n (make-base-empty-namespace)]
[mc (dynamic-require 'compiler/cm 'managed-compile-zo)]
[cnh (dynamic-require 'compiler/cm 'manager-compile-notify-handler)]
[cth (dynamic-require 'compiler/cm 'manager-trace-handler)]
[did-one? #f])
(parameterize ([current-namespace n]
[cth (lambda (p)
(when (compiler:option:verbose)
(printf " ~a\n" p)))]
[cnh (lambda (p)
(set! did-one? #t)
(when (compiler:option:somewhat-verbose)
(printf " making ~s\n" (path->string p))))])
[manager-trace-handler
(lambda (p)
(when (compiler:option:verbose)
(printf " ~a\n" p)))]
[manager-compile-notify-handler
(lambda (p)
(set! did-one? #t)
(when (compiler:option:somewhat-verbose)
(printf " making ~s\n" (path->string p))))])
(for ([file source-files])
(unless (file-exists? file)
(error 'mzc "file does not exist: ~a" file))
@ -439,7 +449,7 @@
(printf "\"~a\":\n" file))
(parameterize ([compile-context-preservation-enabled
(disable-inlining)])
(mc file))
(managed-compile-zo file))
(let ([dest (append-zo-suffix
(let-values ([(base name dir?) (split-path file)])
(build-path (if (symbol? base) 'same base)
@ -487,7 +497,7 @@
[out-file (if (dest-dir)
(build-path (dest-dir) out-file)
out-file)])
((dynamic-require 'compiler/xform 'xform)
(xform
(not (compiler:option:verbose))
file
out-file
@ -498,12 +508,10 @@
(unless (= 1 (length source-files))
(error 'mzc "expected a single module source file to embed; given: ~e"
source-files))
(let ([dest ((dynamic-require 'compiler/private/embed
'mzc:embedding-executable-add-suffix)
(let ([dest (mzc:embedding-executable-add-suffix
(exe-output)
(eq? mode 'gui-exe))])
((dynamic-require 'compiler/private/embed
'mzc:create-embedding-executable)
(mzc:create-embedding-executable
dest
#:mred? (eq? mode 'gui-exe)
#:variant (if (compiler:option:3m) '3m 'cgc)
@ -531,7 +539,7 @@
(let ([dest (mods-output)])
(let-values ([(in out) (make-pipe)])
(parameterize ([current-output-port out])
((dynamic-require 'compiler/embed 'write-module-bundle)
(write-module-bundle
#:modules
(append (map (lambda (l) `(#f (file ,l))) source-files)
(map (lambda (l) `(#t (lib ,l))) (exe-embedded-libraries)))))
@ -567,7 +575,7 @@
(when (compiler:option:somewhat-verbose)
(printf " [output to \"~a\"]\n" dest)))]
[(exe-dir)
((dynamic-require 'compiler/distribute 'assemble-distribution)
(assemble-distribution
(exe-dir-output)
source-files
#:collects-path (exe-embedded-collects-path)

4
pkgs/racket-pkgs/racket-doc/info.rkt
View File

@ -16,6 +16,7 @@
"errortrace-doc"
"typed-racket-doc"
"unstable"
"compiler-lib"
"at-exp-lib"
"data-lib"
"pconvert-lib"
@ -40,7 +41,8 @@
"compatibility-lib"
"future-visualizer"
"distributed-places-doc"
"serialize-cstruct-lib"))
"serialize-cstruct-lib"
"cext-lib"))
(define pkg-desc "Base Racket documentation")

2
pkgs/racket-pkgs/racket-test/info.rkt
View File

@ -23,6 +23,8 @@
"typed-racket-lib"
"serialize-cstruct-lib"
"cext-lib"
;; for random testing:
"redex-lib"))

37
racket/collects/compiler/compiler-unit.rkt → racket/collects/compiler/compiler.rkt
View File

@ -2,41 +2,29 @@
;; Main compilation procedures
;; (c) 1997-2013 PLT Design Inc.
;; The various procedures provided by this library are implemented
;; by dynamically linking to code supplied by the MzLib, dynext, and
;; compiler collections.
(require racket/unit
"sig.rkt"
dynext/file-sig
dynext/link-sig
dynext/compile-sig
syntax/toplevel
(require syntax/toplevel
syntax/moddep
dynext/file
racket/file
compiler/compile-file
compiler/cm
compiler/option
setup/getinfo
setup/main-collects
setup/private/omitted-paths)
(provide compiler@)
(provide compile-zos
compile-collection-zos
compile-directory-zos
compile-directory-srcs
current-compiler-dynamic-require-wrapper
compile-notify-handler)
(define-namespace-anchor anchor)
(define orig-namespace (namespace-anchor->empty-namespace anchor))
;; ;;;;;;;; ----- The main compiler unit ------ ;;;;;;;;;;
(define-unit compiler@
(import compiler:option^
dynext:compile^
dynext:link^
dynext:file^)
(export compiler^)
(define compile-notify-handler
(make-parameter void))
@ -98,7 +86,7 @@
file))
source-files))
(for ([f source-files] [b file-bases])
(let ([zo (append-zo-suffix b)])
(let ([zo (path-add-suffix b #".zo")])
(compile-to-zo f zo n prefix verbose? mod?)))))
(define (compile-directory-visitor dir info worker omit-root
@ -214,4 +202,3 @@
(define compile-directory-zos compile-directory)
(define compile-directory-srcs get-compile-directory-srcs)
)

1607
racket/collects/compiler/embed-unit.rkt
View File

File diff suppressed because it is too large Load Diff

1608
racket/collects/compiler/embed.rkt
View File

File diff suppressed because it is too large Load Diff

16
racket/collects/compiler/option-unit.rkt
View File

@ -1,16 +0,0 @@
#lang racket/base
(require racket/unit)
(require "sig.rkt")
(provide compiler:option@)
(define-unit compiler:option@ (import) (export compiler:option^)
(define somewhat-verbose (make-parameter #f))
(define verbose (make-parameter #f))
(define 3m (make-parameter (eq? '3m (system-type 'gc))))
(define setup-prefix (make-parameter ""))
(define compile-subcollections (make-parameter #t)))

32
racket/collects/compiler/option.rkt Normal file
View File

@ -0,0 +1,32 @@
#lang racket/base
(provide somewhat-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 = ""
3m
;; #t => build for 3m
;; default = #f
compile-subcollections
;; #t => compile collection subdirectories
;; default = #t
)
(define somewhat-verbose (make-parameter #f))
(define verbose (make-parameter #f))
(define 3m (make-parameter (eq? '3m (system-type 'gc))))
(define setup-prefix (make-parameter ""))
(define compile-subcollections (make-parameter #t))

7
racket/collects/dynext/dynext-sig.rkt
View File

@ -1,7 +0,0 @@
(module dynext-sig racket/base
(require "compile-sig.rkt" "link-sig.rkt" "file-sig.rkt")
(provide (all-from-out "compile-sig.rkt")
(all-from-out "link-sig.rkt")
(all-from-out "file-sig.rkt")))

7
racket/collects/dynext/dynext-unit.rkt
View File

@ -1,7 +0,0 @@
#lang racket/base
(require "compile-unit.rkt" "link-unit.rkt" "file-unit.rkt")
(provide (all-from-out "compile-unit.rkt")
(all-from-out "link-unit.rkt")
(all-from-out "file-unit.rkt"))

64
racket/collects/dynext/file-unit.rkt
View File

@ -1,64 +0,0 @@
#lang racket/base
(require racket/unit "file-sig.rkt")
(provide dynext:file@)
(define-unit dynext:file@ (import) (export dynext:file^)
(define (append-zo-suffix s)
(path-add-suffix s #".zo"))
(define (append-c-suffix s)
(path-add-suffix s #".c"))
(define (append-constant-pool-suffix s)
(path-add-suffix s #".kp"))
(define (append-object-suffix s)
(path-add-suffix s (case (system-type)
[(unix beos macos macosx) #".o"]
[(windows) #".obj"])))
(define (append-extension-suffix s)
(path-add-suffix s (system-type 'so-suffix)))
(define (extract-suffix appender)
(subbytes (path->bytes (appender (bytes->path #"x"))) 1))
(define-values (extract-base-filename/ss
extract-base-filename/c
extract-base-filename/kp
extract-base-filename/o
extract-base-filename/ext)
(let ([mk
(lambda (who pat kind simple)
(define rx
(byte-pregexp (bytes-append #"^(.*)\\.(?i:" pat #")$")))
(define (extract-base-filename s [p #f])
(unless (path-string? s)
(raise-type-error who "path or valid-path string" s))
(cond [(regexp-match
rx (path->bytes (if (path? s) s (string->path s))))
=> (lambda (m) (bytes->path (cadr m)))]
[p (if simple
(error p "not a ~a filename (doesn't end with ~a): ~a"
kind simple s)
(path-replace-suffix s #""))]
[else #f]))
extract-base-filename)])
(values
(mk 'extract-base-filename/ss #"rkt|ss|scm" "Racket" #f)
(mk 'extract-base-filename/c
#"c|cc|cxx|cpp|c[+][+]|m" "C" ".c, .cc, .cxx, .cpp, .c++, or .m")
(mk 'extract-base-filename/kp #"kp" "constant pool" ".kp")
(mk 'extract-base-filename/o
(case (system-type)
[(unix beos macos macosx) #"o"]
[(windows) #"obj"])
"compiled object"
(extract-suffix append-object-suffix))
(mk 'extract-base-filename/ext
(regexp-quote (subbytes (system-type 'so-suffix) 1) #f)
"Racket extension"
(extract-suffix append-extension-suffix))))))

71
racket/collects/dynext/file.rkt
View File

@ -1,9 +1,70 @@
#lang racket/base
(require racket/unit)
(require "file-sig.rkt"
"file-unit.rkt")
(provide append-zo-suffix
append-c-suffix
append-constant-pool-suffix
append-object-suffix
append-extension-suffix
extract-base-filename/ss
extract-base-filename/c
extract-base-filename/kp
extract-base-filename/o
extract-base-filename/ext)
(define-values/invoke-unit/infer dynext:file@)
(define (append-zo-suffix s)
(path-add-suffix s #".zo"))
(provide-signature-elements dynext:file^)
(define (append-c-suffix s)
(path-add-suffix s #".c"))
(define (append-constant-pool-suffix s)
(path-add-suffix s #".kp"))
(define (append-object-suffix s)
(path-add-suffix s (case (system-type)
[(unix macosx) #".o"]
[(windows) #".obj"])))
(define (append-extension-suffix s)
(path-add-suffix s (system-type 'so-suffix)))
(define (extract-suffix appender)
(subbytes (path->bytes (appender (bytes->path #"x"))) 1))
(define-values (extract-base-filename/ss
extract-base-filename/c
extract-base-filename/kp
extract-base-filename/o
extract-base-filename/ext)
(let ([mk
(lambda (who pat kind simple)
(define (extract-base-filename s [p #f])
(define rx
(byte-pregexp (bytes-append #"^(.*)\\.(?i:" pat #")$")))
(unless (path-string? s)
(raise-type-error who "path or valid-path string" s))
(cond [(regexp-match
rx (path->bytes (if (path? s) s (string->path s))))
=> (lambda (m) (bytes->path (cadr m)))]
[p (if simple
(error p "not a ~a filename (doesn't end with ~a): ~a"
kind simple s)
(path-replace-suffix s #""))]
[else #f]))
extract-base-filename)])
(values
(mk 'extract-base-filename/ss #"rkt|ss|scm" "Racket" #f)
(mk 'extract-base-filename/c
#"c|cc|cxx|cpp|c[+][+]|m" "C" ".c, .cc, .cxx, .cpp, .c++, or .m")
(mk 'extract-base-filename/kp #"kp" "constant pool" ".kp")
(mk 'extract-base-filename/o
(case (system-type)
[(unix beos macos macosx) #"o"]
[(windows) #"obj"])
"compiled object"
(extract-suffix append-object-suffix))
(mk 'extract-base-filename/ext
(regexp-quote (subbytes (system-type 'so-suffix) 1) #f)
"Racket extension"
(extract-suffix append-extension-suffix)))))

11
racket/collects/file/gzip.rkt
View File

@ -186,10 +186,6 @@
(define head-vec-delta WSIZE)
;; The gzip code wasn't defined for threads (or even to be
;; multiply invoked), so we pack it up into a unit to
;; invoke each time we need it.
;; /* Data structure describing a single value and its code string. */
(define-struct ct_data (freq code dad len) #:mutable)
;; union {
@ -374,8 +370,13 @@
#x2d02ef8d))
(define (code)
;; The gzip code wasn't defined for threads (or even to be
;; multiply invoked), so we pack it up into a function to
;; invoke each time we need it.
;; The original code uses many `static' mutable variables, and that
;; strategy is largely intact in this port, so we group all of the
;; strategy is largely intact in this port, so we group all of it
;; here with local variables to instantiate with the functions.
;; /* ===========================================================================

945
racket/collects/launcher/launcher-unit.rkt
View File

@ -1,945 +0,0 @@
#lang racket/unit
(require racket/path
racket/file
racket/list
racket/string
compiler/embed
setup/dirs
setup/variant
"launcher-sig.rkt"
compiler/private/winutf16)
(import)
(export launcher^)
(define current-launcher-variant
(make-parameter (system-type 'gc)
(lambda (v)
(unless (memq v '(3m script-3m cgc script-cgc))
(raise-type-error
'current-launcher-variant
"variant symbol"
v))
v)))
(define (variant-available? kind cased-kind-name variant)
(cond
[(or (eq? 'unix (system-type))
(and (eq? 'macosx (system-type))
(eq? kind 'mzscheme)))
(let ([bin-dir (if (eq? kind 'mzscheme)
(find-console-bin-dir)
(find-lib-dir))])
(and bin-dir
(file-exists?
(build-path bin-dir
(format "~a~a"
(case kind
[(mzscheme) 'racket]
[(mred) 'gracket])
(variant-suffix variant #f))))))]
[(eq? 'macosx (system-type))
;; kind must be mred, because mzscheme case is caught above
(directory-exists? (build-path (find-lib-dir)
(format "~a~a.app"
cased-kind-name
(variant-suffix variant #f))))]
[(eq? 'windows (system-type))
(file-exists?
(build-path
(if (eq? kind 'mzscheme) (find-console-bin-dir) (find-lib-dir))
(format "~a~a.exe" cased-kind-name (variant-suffix variant #t))))]
[else (error "unknown system type")]))
(define (available-variants kind)
(let* ([cased-kind-name (if (eq? kind 'mzscheme)
"Racket"
"GRacket")]
[normal-kind (system-type 'gc)]
[alt-kind (if (eq? '3m normal-kind)
'cgc
'3m)]
[normal (if (variant-available? kind cased-kind-name normal-kind)
(list normal-kind)
null)]
[alt (if (variant-available? kind cased-kind-name alt-kind)
(list alt-kind)
null)]
[script (if (and (eq? 'macosx (system-type))
(eq? kind 'mred)
(pair? normal))
(if (eq? normal-kind '3m)
'(script-3m)
'(script-cgc))
null)]
[script-alt (if (and (memq alt-kind alt)
(pair? script))
(if (eq? alt-kind '3m)
'(script-3m)
'(script-cgc))
null)])
(append normal alt script script-alt)))
(define (available-gracket-variants)
(available-variants 'mred))
(define (available-mred-variants)
(available-variants 'mred))
(define (available-racket-variants)
(available-variants 'mzscheme))
(define (available-mzscheme-variants)
(available-variants 'mzscheme))
(define (install-template dest kind mz mr)
(define src (build-path (find-lib-dir)
(if (eq? kind 'mzscheme) mz mr)))
(when (or (file-exists? dest)
(directory-exists? dest)
(link-exists? dest))
(delete-directory/files dest))
(copy-file src dest)
;; make sure it's read/write/execute-able
(let* ([perms1 (file-or-directory-permissions dest 'bits)]
[perms2 (bitwise-ior user-read-bit user-write-bit user-execute-bit
perms1)])
(unless (equal? perms1 perms2)
(file-or-directory-permissions dest perms2))))
(define (script-variant? v)
(memq v '(script-3m script-cgc)))
(define (add-file-suffix path variant mred?)
(let ([s (variant-suffix
variant
(case (system-type)
[(unix) #f]
[(windows) #t]
[(macosx) (and mred? (not (script-variant? variant)))]))])
(if (string=? "" s)
path
(path-replace-suffix
path
(string->bytes/utf-8
(if (and (eq? 'windows (system-type))
(regexp-match #rx#"[.]exe$" (path->bytes path)))
(format "~a.exe" s)
s))))))
(define (string-append/spaces f flags)
(string-append* (append-map (lambda (x) (list (f x) " ")) flags)))
(define (str-list->sh-str flags)
(string-append/spaces
(lambda (s)
(string-append "'" (regexp-replace* #rx"'" s "'\"'\"'") "'"))
flags))
(define (str-list->dos-str flags)
(define (trans s)
(if (not (regexp-match? #rx"[ \n\t\r\v\"\\]" s))
s
(list->string
(let loop ([l (string->list s)] [slashes '()])
(cond [(null? l) '()]
[(char-whitespace? (car l))
`(,@slashes #\" ,(car l) #\" ,@(loop (cdr l) '()))]
[(eq? #\\ (car l))
`(#\\ ,@(loop (cdr l) (cons #\\ slashes)))]
[(eq? #\" (car l))
`(,@slashes #\" #\\ #\" #\" ,@(loop (cdr l) '()))]
[else `(,(car l) ,@(loop (cdr l) '()))])))))
(string-append/spaces trans flags))
(define one-arg-x-flags '((xa "-display")
(xb "-geometry")
(xc "-bg" "-background")
(xd "-fg" "-foregound")
(xe "-font")
(xf "-name")
(xg "-selectionTimeout")
(xh "-title")
(xi "-xnllanguage")
(xj "-xrm")))
(define no-arg-x-flags '((xk "-iconic")
(xl "-rv" "-reverse")
(xm "+rv")
(xn "-synchronous")
(xo "-singleInstance")))
(define (skip-x-flags flags)
(let ([xfmem (lambda (flag) (lambda (xf) (member flag (cdr xf))))])
(let loop ([f flags])
(cond [(null? f) null]
[(ormap (xfmem (car f)) one-arg-x-flags)
(if (null? (cdr f)) null (loop (cddr f)))]
[(ormap (xfmem (car f)) no-arg-x-flags) (loop (cdr f))]
[else f]))))
(define (output-x-arg-getter exec args)
(let ([or-flags (lambda (l) (string-append* (add-between l " | ")))])
(string-append*
(append
(list "# Find X flags and shift them to the front\n"
"findxend() {\n"
" oneargflag=''\n"
" case \"$1\" in\n")
(map
(lambda (f)
(format (string-append
" ~a)\n"
" oneargflag=\"$1\"\n"
" ~a=\"$2\"\n"
" ;;\n")
(or-flags (cdr f))
(car f)))
one-arg-x-flags)
(map
(lambda (f)
(format " ~a)\n ~a=yes\n ;;\n" (or-flags (cdr f)) (car f)))
no-arg-x-flags)
(list
(format (string-append
" *)\n ~a~a ~a ;;\n"
" esac\n"
" shift\n"
" if [ \"$oneargflag\" != '' ] ; then\n"
" if [ \"${1+n}\" != 'n' ] ; then echo $0: missing argument for standard X flag $oneargflag ; exit 1 ; fi\n"
" shift\n"
" fi\n"
" findxend ${1+\"$@\"}\n"
"}\nfindxend ${1+\"$@\"}\n")
exec
(string-append*
(append
(map (lambda (f)
(format " ${~a+\"~a\"} ${~a+\"$~a\"}"
(car f) (cadr f) (car f) (car f)))
one-arg-x-flags)
(map (lambda (f)
(format " ${~a+\"~a\"}" (car f) (cadr f)))
no-arg-x-flags)))
args))))))
(define (protect-shell-string s)
(regexp-replace*
#rx"[\"`'$\\]" (if (path? s) (path->string s) s) "\\\\&"))
(define (normalize+explode-path p)
(explode-path (normal-case-path (simple-form-path p))))
(define (relativize bindir-explode dest-explode)
(let loop ([b bindir-explode] [d dest-explode])
(if (and (pair? b) (equal? (car b) (car d)))
(loop (cdr b) (cdr d))
(let ([p (append (map (lambda (x) 'up) (cdr d)) b)])
(if (null? p) #f (apply build-path p))))))
(define (make-relative-path-header dest bindir use-librktdir?)
;; rely only on binaries in /usr/bin:/bin
(define (has-exe? exe)
(or (file-exists? (build-path "/usr/bin" exe))
(file-exists? (build-path "/bin" exe))))
(let* ([has-readlink? (and (not (eq? 'macosx (system-type)))
(has-exe? "readlink"))]
[dest-explode (normalize+explode-path dest)]
[bindir-explode (normalize+explode-path bindir)])
(if (and (has-exe? "dirname") (has-exe? "basename")
(or has-readlink? (and (has-exe? "ls") (has-exe? "sed")))
(equal? (car dest-explode) (car bindir-explode)))
(string-append
"# Make this PATH-independent\n"
"saveP=\"$PATH\"\n"
"PATH=\"/usr/bin:/bin\"\n"
"\n"
(if has-readlink? ""
(string-append
"# imitate possibly-missing readlink\n"
"readlink() {\n"
" ls -l -- \"$1\" | sed -e \"s/^.* -> //\"\n"
"}\n"
"\n"))
"# Remember current directory\n"
"saveD=`pwd`\n"
"\n"
"# Find absolute path to this script,\n"
"# resolving symbolic references to the end\n"
"# (changes the current directory):\n"
"D=`dirname \"$0\"`\n"
"F=`basename \"$0\"`\n"
"cd \"$D\"\n"
"while test "
;; On solaris, Edward Chrzanowski from Waterloo says that the man
;; page says that -L is not supported, but -h is; on other systems
;; (eg, freebsd) -h is listed as a compatibility feature
(if (regexp-match #rx"solaris" (path->string
(system-library-subpath)))
"-h" "-L")
" \"$F\"; do\n"
" P=`readlink \"$F\"`\n"
" D=`dirname \"$P\"`\n"
" F=`basename \"$P\"`\n"
" cd \"$D\"\n"
"done\n"
"D=`pwd`\n"
"\n"
"# Restore current directory\n"
"cd \"$saveD\"\n"
"\n"
"bindir=\"$D"
(if use-librktdir?
""
(let ([s (relativize bindir-explode dest-explode)])
(if s (string-append "/" (protect-shell-string s)) "")))
"\"\n"
"PATH=\"$saveP\"\n")
;; fallback to absolute path header
(make-absolute-path-header bindir))))
(define (make-absolute-path-header bindir)
(string-append "bindir=\""(protect-shell-string bindir)"\"\n"))
(define (make-unix-launcher kind variant flags dest aux)
(install-template dest kind "starter-sh" "starter-sh") ; just for something that's executable
(let* ([alt-exe (let ([m (and (eq? kind 'mred)
(script-variant? variant)
(assq 'exe-name aux))])
(and m
(format "~a~a.app/Contents/MacOS/~a~a"
(cdr m) (variant-suffix variant #t)
(cdr m) (variant-suffix variant #t))))]
[x-flags? (and (eq? kind 'mred)
(eq? (system-type) 'unix)
(not (script-variant? variant)))]
[flags (let ([m (assq 'wm-class aux)])
(if m
(list* "-J" (cdr m) flags)
flags))]
[post-flags (cond
[x-flags? (skip-x-flags flags)]
[alt-exe null]
[else flags])]
[pre-flags (cond
[(not x-flags?) null]
[else
(let loop ([f flags])
(if (eq? f post-flags)
null
(cons (car f) (loop (cdr f)))))])]
[pre-str (str-list->sh-str pre-flags)]
[post-str (str-list->sh-str post-flags)]
[header (string-append
"#!/bin/sh\n"
"# This script was created by make-"
(symbol->string kind)"-launcher\n")]
[use-librktdir? (if alt-exe
(let ([m (assq 'exe-is-gracket aux)])
(and m (cdr m)))
(eq? kind 'mred))]
[dir-finder
(let ([bindir (if alt-exe
(let ([m (assq 'exe-is-gracket aux)])
(if (and m (cdr m))
(find-lib-dir)
(let ([p (path-only dest)])
(if (eq? 'macosx (system-type))
(build-path p 'up)
p))))
(find-console-bin-dir))])
(if (let ([a (assq 'relative? aux)])
(and a (cdr a)))
(make-relative-path-header dest bindir use-librktdir?)
(make-absolute-path-header bindir)))]
[exec (format
"exec \"${~a}/~a~a\" ~a"
(if use-librktdir?
"librktdir"
"bindir")
(or alt-exe (case kind
[(mred) (if (eq? 'macosx (system-type))
(format "GRacket~a.app/Contents/MacOS/Gracket"
(variant-suffix variant #t))
"gracket")]
[(mzscheme) "racket"]))
(if alt-exe
""
(variant-suffix variant (and (eq? kind 'mred)
(eq? 'macosx (system-type)))))
pre-str)]
[args (format
"~a~a ${1+\"$@\"}\n"
(if alt-exe "" "-N \"$0\" ")
post-str)]
[assemble-exec (if (and (eq? kind 'mred)
(not (script-variant? variant))
(not (null? post-flags)))
output-x-arg-getter
string-append)])
(unless (find-console-bin-dir)
(error 'make-unix-launcher "unable to locate bin directory"))
(with-output-to-file dest
#:exists 'truncate
(lambda ()
(display header)
(newline)
;; comments needed to rehack launchers when paths change
;; (see setup/unixstyle-install.rkt)
(display "# {{{ bindir\n")
(display dir-finder)
(display "# }}} bindir\n")
(when use-librktdir?
(display "# {{{ librktdir\n")
(display "librktdir=\"$bindir/../lib\"\n")
(display "# }}} librktdir\n"))
(newline)
(display (assemble-exec exec args)))))
(check-desktop aux dest))
(define (check-registry aux dest)
(let ([im (assoc 'install-mode aux)])
(when (and im (member (cdr im) '(main user)))
;; record Windows regsistry requests, if any
(let ([m (assoc 'extension-register aux)])
(when (and m (cdr m))
(update-register (cdr im)
"extreg.rktd"
(path-element->string
(file-name-from-path dest))
(if (eq? (cdr im) 'main)
;; make icon paths relative, if possible:
(for/list ([l (in-list (cdr m))])
(for/list ([e (in-list l)]
[i (in-naturals)])
(if (= i 3)
(let ([p (find-relative-path (find-lib-dir) e)])
(if (member 'up (explode-path p))
(path->bytes e)
(path->bytes p)))
e)))
(cdr m)))))
;; record Windows start-menu requests, if any
(let ([m (assoc 'start-menu aux)])
(when (and m (cdr m))
(update-register (cdr im)
"startmenu.rktd"
(path-element->string
(file-name-from-path dest))
(cdr m)))))))
(define (installed-executable-path->desktop-path dest user?)
(unless (path-string? dest)
(raise-argument-error 'installed-executable-path->desktop-path
"path-string?"
dest))
(define dir (if user?
(find-user-apps-dir)
(find-apps-dir)))
(path-replace-suffix (build-path dir (file-name-from-path dest))
#".desktop"))
(define (installed-desktop-path->icon-path dest user? extension)
;; We put icons files in "share" so that `setup/unixstyle-install'
;; knows how to fix up the "Icon" path in a ".desktop" file.
(unless (path-string? dest)
(raise-argument-error 'installed-desktop-path->icon-path
"path-string?"
dest))
(unless (bytes? extension)
(raise-argument-error 'installed-desktop-path->icon-path
"bytes?"
extension))
(build-path (if user?
(find-user-share-dir)
(find-share-dir))
(path-replace-suffix
(file-name-from-path dest)
(bytes-append
#"-exe-icon."
extension))))
(define (check-desktop aux dest)
(when (eq? 'unix (system-type))
(let ([im (assoc 'install-mode aux)])
(when (and im (member (cdr im) '(main user)))
(define user? (eq? (cdr im) 'user))
;; create Unix ".desktop" files, if any
(let ([m (assoc 'desktop aux)])
(when (and m (cdr m))
(define file (installed-executable-path->desktop-path dest
user?))
(make-directory* (path-only file))
(define (adjust-path p)
;; A ".desktop" file is supposed to have absolute paths
;; for the executable and icon, but we don't want absolute
;; paths in an in-place build. So, the ".desktop" files
;; in an in-place build won't be usable directly, but they
;; adn be patched up by `setup/unixstyle-install'.
(let ([p (simple-form-path (path->complete-path p))])
(if (or user?
(get-absolute-installation?))
p
(find-relative-path (simple-form-path (path-only file)) p))))
(install-template file 'mzscheme "starter-sh" "starter-sh") ; for something that's executable
(call-with-output-file*
file
#:exists 'truncate
(lambda (o)
(displayln (regexp-replace #rx"\n+$" (cdr m) "") o)
(fprintf o "Exec=~a\n" (adjust-path dest))
(let ([m (or (assq 'png aux)
(assq 'ico aux))])
(when m
(define copy-dest
(installed-desktop-path->icon-path file
user?
(filename-extension (cdr m))))
(unless (file-exists? copy-dest)
(copy-file (cdr m) copy-dest))
(fprintf o "Icon=~a\n" (adjust-path copy-dest))))))))))))
(define (update-register mode filename key val)
(define dir (if (eq? mode 'main)
(find-lib-dir)
(find-user-lib-dir)))
(make-directory* dir)
(define file (build-path dir filename))
(define table (if (file-exists? file)
(call-with-input-file* file read)
(hash)))
(unless (hash? table) (error 'make-launcher "expected a hash table in ~a" file))
(call-with-output-file*
file
#:exists 'truncate/replace
(lambda (o)
(write (hash-set table key val) o)
(newline o))))
(define (utf-16-regexp b)
(byte-regexp (bytes-append (bytes->utf-16-bytes b)
#"[^>]*"
(bytes->utf-16-bytes #">"))))
(define (make-windows-launcher kind variant flags dest aux)
(if (not (and (let ([m (assq 'independent? aux)])
(and m (cdr m)))))
;; Normal launcher:
(make-embedding-executable dest (eq? kind 'mred)
#f null null null flags aux #t variant
(if (let ([a (assq 'relative? aux)])
(and a (cdr a)))
#f
(find-collects-dir)))
;; Independent launcher (needed for Setup PLT):
(begin
(install-template dest kind "mzstart.exe" "mrstart.exe")
(let ([bstr (bytes->utf-16-bytes
(string->bytes/utf-8 (str-list->dos-str flags)))]
[p (open-input-file dest)]
[m (utf-16-regexp #"<Command Line: Replace This")]
[x (utf-16-regexp #"<Executable Directory: Replace This")]
[v (utf-16-regexp #"<Executable Variant: Replace This")])
(let* ([exedir (bytes->utf-16-bytes
(bytes-append
(path->bytes (let ([bin-dir (if (eq? kind 'mred)
(find-gui-bin-dir)
(find-console-bin-dir))])
(if (let ([m (assq 'relative? aux)])
(and m (cdr m)))
(or (relativize (normalize+explode-path bin-dir)
(normalize+explode-path dest))
(build-path 'same))
bin-dir)))
;; null wchar marks end of executable directory
#"\0\0"))]
[find-it ; Find the magic start
(lambda (magic s)
(file-position p 0)
(let ([m (regexp-match-positions magic p)])
(if m
(car m)
(begin
(close-input-port p)
(when (file-exists? dest) (delete-file dest))
(error 'make-windows-launcher
"Couldn't find ~a position in template" s)))))]
[exedir-poslen (find-it x "executable path")]
[command-poslen (find-it m "command-line")]
[variant-poslen (find-it v "variant")]
[pos-exedir (car exedir-poslen)]
[len-exedir (- (cdr exedir-poslen) (car exedir-poslen))]
[pos-command (car command-poslen)]
[len-command (- (cdr command-poslen) (car command-poslen))]
[pos-variant (car variant-poslen)]
[space (char->integer #\space)]
[write-magic
(lambda (p s pos len)
(file-position p pos)
(display s p)
(display (make-bytes (- len (bytes-length s)) space) p))]
[check-len
(lambda (len s es)
(when (> (bytes-length s) len)
(when (file-exists? dest) (delete-file dest))
(error
(format
"~a exceeds limit of ~a characters with ~a characters: ~a"
es len (string-length s) s))))])
(close-input-port p)
(check-len len-exedir exedir "executable home directory")
(check-len len-command bstr "collection/file name")
(let ([p (open-output-file dest #:exists 'update)])
(write-magic p exedir pos-exedir len-exedir)
(write-magic p (bytes-append bstr #"\0\0") pos-command len-command)
(let* ([suffix (variant-suffix (current-launcher-variant) #t)]
[suffix-bytes
(bytes-append
(list->bytes
(append-map (lambda (c) (list c 0))
(bytes->list (string->bytes/latin-1 suffix))))
#"\0\0")])
(write-magic p suffix-bytes pos-variant (bytes-length suffix-bytes)))
(close-output-port p))))))
(check-registry aux dest))
;; OS X launcher code:
;; make-macosx-launcher : symbol (listof str) pathname ->
(define (make-macosx-launcher kind variant flags dest aux)
(if (or (eq? kind 'mzscheme) (script-variant? variant))
;; Racket or script launcher is the same as for Unix
(make-unix-launcher kind variant flags dest aux)
;; GRacket "launcher" is a stand-alone executable
(make-embedding-executable dest (eq? kind 'mred) #f
null null null
flags
aux
#t
variant
(if (let ([a (assq 'relative? aux)])
(and a (cdr a)))
#f
(find-collects-dir)))))
(define (make-macos-launcher kind variant flags dest aux)
(install-template dest kind "GoMr" "GoMr")
(let* ([p (open-input-file dest)]
[m (regexp-match-positions #rx#"<Insert offset here>" p)])
;; fast-forward to the end:
(let ([s (make-bytes 4096)])
(let loop ()
(if (eof-object? (read-bytes! s p)) (file-position p) (loop))))
(let ([data-fork-size (file-position p)])
(close-input-port p)
(let ([p (open-output-file dest #:exists 'update)]
[str (str-list->sh-str
(append (if (eq? kind 'mred) null '("-Z")) flags))])
(file-position p (caar m))
(display (integer->integer-bytes (string-length str) 4 #t #t) p)
(display (integer->integer-bytes data-fork-size 4 #t #t) p)
(file-position p data-fork-size)
(display str p)
(close-output-port p)))))
(define (get-maker)
(case (system-type)
[(unix) make-unix-launcher]
[(windows) make-windows-launcher]
[(macos) make-macos-launcher]
[(macosx) make-macosx-launcher]))
(define (make-gracket-launcher flags dest [aux null])
((get-maker) 'mred (current-launcher-variant) flags dest aux))
(define (make-mred-launcher flags dest [aux null])
((get-maker) 'mred (current-launcher-variant) (list* "-I" "scheme/gui/init" flags) dest aux))
(define (make-racket-launcher flags dest [aux null])
((get-maker) 'mzscheme (current-launcher-variant) flags dest aux))
(define (make-mzscheme-launcher flags dest [aux null])
((get-maker) 'mzscheme (current-launcher-variant) (list* "-I" "scheme/init" flags) dest aux))
(define (strip-suffix s)
(path-replace-suffix s #""))
(define (extract-aux-from-path path)
(define path-bytes (path->bytes (if (string? path)
(string->path path)
path)))
(define len (bytes-length path-bytes))
(define (try key suffix)
(if (and (len . > . (bytes-length suffix))
(equal? (subbytes path-bytes (- len (bytes-length suffix)))
suffix))
(list (cons key path))
null))
(define (log-fail l x)
(log-error "error using ~a for ~s: ~a"
(car l)
(cdr l)
(exn-message x)))
(append
(try 'icns #".icns")
(try 'ico #".ico")
(try 'png #".png")
(try 'independent? #".lch")
(let ([l (try 'creator #".creator")])
(if (null? l)
l
(with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)])
(with-input-from-file (cdar l)
(lambda ()
(let ([s (read-string 4)])
(if s (list (cons (caar l) s)) null)))))))
(let ([l (try 'file-types #".filetypes")])
(if (null? l)
l
(with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)])
(with-input-from-file (cdar l)
(lambda ()
(let*-values ([(d) (read)]
[(local-dir base dir?) (split-path path)]
[(icon-files)
(append-map
(lambda (spec)
(let ([m (assoc "CFBundleTypeIconFile" spec)])
(if m
(list (build-path
(if (eq? local-dir 'relative)
(current-directory)
(path->complete-path local-dir))
(format "~a.icns" (cadr m))))
null)))
d)])
(list (cons 'file-types d)
(cons 'resource-files
(remove-duplicates icon-files)))))))))
(let ([l (try 'file-types #".utiexports")])
(if (null? l)
l
(with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)])
(with-input-from-file (cdar l)
(lambda ()
(let ([d (read)])
(list (cons 'uti-exports d))))))))
(let ([l (try 'extension-register #".extreg")])
(if (null? l)
l
(with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)])
(with-input-from-file (cdar l)
(lambda ()
(let ([d (read)])
(list (cons 'extension-register
;; Make icon paths absolute:
(for/list ([l (in-list d)])
(for/list ([e (in-list l)]
[i (in-naturals)])
(if (= i 3)
(path->complete-path
e
(path-only
(path->complete-path path)))
e)))))))))))
(let ([l (try 'start-menu #".startmenu")])
(if (null? l)
l
(with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)])
(with-input-from-file (cdar l)
(lambda ()
(list
(cons 'start-menu
(let ([d (read)])
(if (real? d)
d
#t)))))))))
(let ([l (try 'wm-class #".wmclass")])
(if (null? l)
l
(with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)])
(list (cons 'wm-class
(regexp-replace #rx"(?:\r\n|\r|\n)$"
(file->string (cdar l))
""))))))
(let ([l (try 'desktop #".desktop")])
(if (null? l)
l
(with-handlers ([exn:fail:filesystem? (lambda (x) (log-fail l x) null)])
(list (cons 'desktop (file->string (cdar l)))))))))
(define (build-aux-from-path aux-root)
(let ([aux-root (if (string? aux-root) (string->path aux-root) aux-root)])
(define (try suffix)
(let ([p (path-replace-suffix aux-root suffix)])
(if (file-exists? p)
(extract-aux-from-path p)
null)))
(append
(try #".icns")
(try #".ico")
(try #".png")
(try #".lch")
(try #".creator")
(try #".filetypes")
(try #".utiexports")
(try #".extreg")
(try #".startmenu")
(try #".wmclass")
(try #".desktop"))))
(define (make-gracket-program-launcher file collection dest)
(make-mred-launcher (list "-l-" (string-append collection "/" file))
dest
(build-aux-from-path
(build-path (collection-path collection)
(strip-suffix file)))))
(define (make-mred-program-launcher file collection dest)
(make-gracket-program-launcher file collection dest))
(define (make-racket-program-launcher file collection dest)
(make-mzscheme-launcher (list "-l-" (string-append collection "/" file))
dest
(build-aux-from-path
(build-path (collection-path collection)
(strip-suffix file)))))
(define (make-mzscheme-program-launcher file collection dest)
(make-racket-program-launcher file collection dest))
(define (unix-sfx file mred?)
(string-downcase (regexp-replace* #px"\\s" file "-")))
(define (sfx file mred?)
(case (system-type)
[(unix) (unix-sfx file mred?)]
[(windows)
(string-append (if mred? file (unix-sfx file mred?)) ".exe")]
[else file]))
(define (program-launcher-path name mred? user?)
(let* ([variant (current-launcher-variant)]
[mac-script? (and (eq? (system-type) 'macosx)
(script-variant? variant))])
(let ([p (add-file-suffix
(build-path
(if (or mac-script? (not mred?))
(if user?
(find-user-console-bin-dir)
(find-console-bin-dir))
(if user?
(find-user-gui-bin-dir)
(find-gui-bin-dir)))
((if mac-script? unix-sfx sfx) name mred?))
variant
mred?)])
(if (and (eq? (system-type) 'macosx)
(not (script-variant? variant)))
(path-replace-suffix p #".app")
p))))
(define (gracket-program-launcher-path name #:user? [user? #f])
(program-launcher-path name #t user?))
(define (mred-program-launcher-path name #:user? [user? #f])
(gracket-program-launcher-path name #:user? user?))
(define (racket-program-launcher-path name #:user? [user? #f])
(case (system-type)
[(macosx)
(add-file-suffix (build-path (if user?
(find-user-console-bin-dir)
(find-console-bin-dir))
(unix-sfx name #f))
(current-launcher-variant)
#f)]
[else (program-launcher-path name #f user?)]))
(define (mzscheme-program-launcher-path name #:user? [user? #f])
(racket-program-launcher-path name #:user? user?))
(define (gracket-launcher-is-directory?)
#f)
(define (racket-launcher-is-directory?)
#f)
(define (mred-launcher-is-directory?)
#f)
(define (mzscheme-launcher-is-directory?)
#f)
(define (gracket-launcher-is-actually-directory?)
(and (eq? 'macosx (system-type))
(not (script-variant? (current-launcher-variant)))))
(define (mred-launcher-is-actually-directory?)
(gracket-launcher-is-actually-directory?))
(define (racket-launcher-is-actually-directory?)
#f)
(define (mzscheme-launcher-is-actually-directory?)
#f)
;; Helper:
(define (put-file-extension+style+filters type)
(case type
[(windows) (values "exe" null '(("Executable" "*.exe")))]
[(macosx) (values "app" '(packages) '(("App" "*.app")))]
[else (values #f null null)]))
(define (gracket-launcher-add-suffix path)
(embedding-executable-add-suffix path #t))
(define (mred-launcher-add-suffix path)
(gracket-launcher-add-suffix path))
(define (racket-launcher-add-suffix path)
(embedding-executable-add-suffix path #f))
(define (mzscheme-launcher-add-suffix path)
(racket-launcher-add-suffix path))
(define (gracket-launcher-put-file-extension+style+filters)
(put-file-extension+style+filters
(if (and (eq? 'macosx (system-type))
(script-variant? (current-launcher-variant)))
'unix
(system-type))))
(define (mred-launcher-put-file-extension+style+filters)
(gracket-launcher-put-file-extension+style+filters))
(define (racket-launcher-put-file-extension+style+filters)
(put-file-extension+style+filters
(if (eq? 'macosx (system-type)) 'unix (system-type))))
(define (mzscheme-launcher-put-file-extension+style+filters)
(racket-launcher-put-file-extension+style+filters))
(define (gracket-launcher-up-to-date? dest [aux null])
(racket-launcher-up-to-date? dest aux))
(define (mred-launcher-up-to-date? dest [aux null])
(racket-launcher-up-to-date? dest aux))
(define (mzscheme-launcher-up-to-date? dest [aux null])
(racket-launcher-up-to-date? dest aux))
(define (racket-launcher-up-to-date? dest [aux null])
(cond
;; When running Setup PLT under Windows, the
;; launcher process stays running until Racket
;; completes, which means that it cannot be
;; overwritten at that time. So we assume
;; that a Setup-PLT-style independent launcher
;; is always up-to-date.
[(eq? 'windows (system-type))
(and (let ([m (assq 'independent? aux)]) (and m (cdr m)))
(file-exists? dest))]
;; For any other setting, we could implement
;; a fancy check, but for now always re-create
;; launchers.
[else #f]))
(define (install-gracket-program-launcher file collection name)
(make-gracket-program-launcher file collection
(gracket-program-launcher-path name)))
(define (install-racket-program-launcher file collection name)
(make-racket-program-launcher file collection
(racket-program-launcher-path name)))
(define (install-mred-program-launcher file collection name)
(make-mred-program-launcher file collection
(mred-program-launcher-path name)))
(define (install-mzscheme-program-launcher file collection name)
(make-mzscheme-program-launcher file collection
(mzscheme-program-launcher-path name)))

998
racket/collects/launcher/launcher.rkt
View File

File diff suppressed because it is too large Load Diff

67
racket/collects/setup/option-unit.rkt
View File

@ -1,67 +0,0 @@
#lang racket/base
(require racket/unit
racket/future
"option-sig.rkt")
(provide setup:option@ set-flag-params)
;; a way to define a parameter that is set from an alist of names and values
(define defined-flag-params (make-parameter '()))
(define-syntax-rule (define-flag-param name default)
(define name
(let ([param (make-parameter default)])
(defined-flag-params (cons (cons 'name param) (defined-flag-params)))
param)))
(define (set-flag-params* flags flag-params)
(for ([name+param flag-params])
(cond [(assq (car name+param) flags)
=> (lambda (x) ((cdr name+param) (cadr x)))])))
;; this macro is used to actually do the setting, `more ...' is for additional
;; parameters to set
(define-syntax-rule (set-flag-params flags more ...)
(set-flag-params* flags (list* (cons 'more more) ... (defined-flag-params))))
(define-unit setup:option@
(import)
(export setup-option^)
(define setup-program-name (make-parameter "raco setup"))
(define-flag-param parallel-workers (min (processor-count)
(if (fixnum? (arithmetic-shift 1 40))
8 ; 64-bit machine
4))) ; 32-bit machine
(define-flag-param verbose #f)
(define-flag-param make-verbose #f)
(define-flag-param compiler-verbose #f)
(define-flag-param clean #f)
(define-flag-param compile-mode #f)
(define-flag-param make-only #f)
(define-flag-param make-zo #t)
(define-flag-param make-launchers #t)
(define-flag-param make-foreign-libs #t)
(define-flag-param make-info-domain #t)
(define-flag-param make-docs #t)
(define-flag-param make-user #t)
(define-flag-param make-planet #t)
(define-flag-param avoid-main-installation #f)
(define-flag-param make-tidy #f)
(define-flag-param make-doc-index #f)
(define-flag-param check-dependencies #t)
(define-flag-param fix-dependencies #f)
(define-flag-param call-install #t)
(define-flag-param call-post-install #t)
(define-flag-param pause-on-errors #f)
(define-flag-param force-unpacks #f)
(define-flag-param doc-pdf-dest #f)
(define specific-collections (make-parameter null))
(define specific-planet-dirs (make-parameter null))
(define archives (make-parameter null))
(define archive-implies-reindex (make-parameter #t))
(define current-target-directory-getter (make-parameter current-directory))
(define current-target-plt-directory-getter
(make-parameter
(lambda (preferred main-collects-parent-dir choices) preferred))))

71
racket/collects/setup/option.rkt Normal file
View File

@ -0,0 +1,71 @@
#lang racket/base
(require racket/future)
;; other params are provided by declaration
(provide set-flag-params
setup-program-name
specific-collections
specific-planet-dirs
archives
archive-implies-reindex
current-target-directory-getter
current-target-plt-directory-getter)
;; a way to define a parameter that is set from an alist of names and values
(define defined-flag-params (make-parameter '()))
(define-syntax-rule (define-flag-param name default)
(begin
(provide name)
(define name
(let ([param (make-parameter default)])
(defined-flag-params (cons (cons 'name param) (defined-flag-params)))
param))))
(define (set-flag-params* flags flag-params)
(for ([name+param flag-params])
(cond [(assq (car name+param) flags)
=> (lambda (x) ((cdr name+param) (cadr x)))])))
;; this macro is used to actually do the setting, `more ...' is for additional
;; parameters to set
(define-syntax-rule (set-flag-params flags more ...)
(set-flag-params* flags (list* (cons 'more more) ... (defined-flag-params))))
(define setup-program-name (make-parameter "raco setup"))
(define-flag-param parallel-workers (min (processor-count)
(if (fixnum? (arithmetic-shift 1 40))
8 ; 64-bit machine
4))) ; 32-bit machine
(define-flag-param verbose #f)
(define-flag-param make-verbose #f)
(define-flag-param compiler-verbose #f)
(define-flag-param clean #f)
(define-flag-param compile-mode #f)
(define-flag-param make-only #f)
(define-flag-param make-zo #t)
(define-flag-param make-launchers #t)
(define-flag-param make-foreign-libs #t)
(define-flag-param make-info-domain #t)
(define-flag-param make-docs #t)
(define-flag-param make-user #t)
(define-flag-param make-planet #t)
(define-flag-param avoid-main-installation #f)
(define-flag-param make-tidy #f)
(define-flag-param make-doc-index #f)
(define-flag-param check-dependencies #t)
(define-flag-param fix-dependencies #f)
(define-flag-param call-install #t)
(define-flag-param call-post-install #t)
(define-flag-param pause-on-errors #f)
(define-flag-param force-unpacks #f)
(define-flag-param doc-pdf-dest #f)
(define specific-collections (make-parameter null))
(define specific-planet-dirs (make-parameter null))
(define archives (make-parameter null))
(define archive-implies-reindex (make-parameter #t))
(define current-target-directory-getter (make-parameter current-directory))
(define current-target-plt-directory-getter
(make-parameter
(lambda (preferred main-collects-parent-dir choices) preferred)))

3
racket/collects/setup/plt-single-installer.rkt
View File

@ -1,6 +1,5 @@
#lang racket/base
(require racket/unit
"setup.rkt")
(require "setup.rkt")
(provide run-single-installer install-planet-package clean-planet-package reindex-user-documentation)

30
racket/collects/setup/setup-unit.rkt → racket/collects/setup/setup-core.rkt
View File

@ -3,8 +3,7 @@
#lang racket/base
(require racket/unit
racket/path
(require racket/path
racket/file
racket/port
racket/match
@ -15,10 +14,11 @@
planet/planet-archives
planet/private/planet-shared
"option-sig.rkt"
compiler/sig
launcher/launcher-sig
dynext/dynext-sig
"option.rkt"
compiler/compiler
(prefix-in compiler:option: compiler/option)
launcher/launcher
dynext/file
"unpack.rkt"
"getinfo.rkt"
@ -54,15 +54,9 @@
#:namespace info-ns
#:bootstrap? #t))))))
(provide setup@)
(provide setup-core)
(define-unit setup@
(import setup-option^
compiler^
dynext:file^
(prefix compiler:option: compiler:option^)
launcher^)
(export)
(define (setup-core)
(define name-str (setup-program-name))
(define name-sym (string->symbol name-str))
@ -247,7 +241,7 @@
(setup-printf "WARNING"
"ignoring `compile-subcollections' entry in info ~a"
path-name))
;; this check is also done in compiler/compiler-unit, in compile-directory
;; this check is also done in compiler/compiler, in compile-directory
(and (not (eq? 'all (omitted-paths path getinfo omit-root)))
(make-cc collection path
(if name
@ -1733,9 +1727,9 @@
(verbose))
(set! exit-code 1)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; setup-unit Body ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; setup Body ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setup-printf "version" "~a [~a]" (version) (system-type 'gc))
(setup-printf "installation name" "~a" (get-installation-name))

59
racket/collects/setup/setup-go.rkt
View File

@ -1,48 +1,25 @@
(module setup-go racket/base
(require "setup-cmdline.rkt"
racket/unit
"option-sig.rkt"
"setup-unit.rkt"
"option-unit.rkt"
"option.rkt"
"setup-core.rkt"
compiler/cm)
(define-values/invoke-unit/infer setup:option@)
(define-values (short-name x-flags x-specific-collections x-specific-planet-packages x-archives)
(parse-cmdline (current-command-line-arguments)))
;; Pseudo-option:
(define (all-users on?)
(when on?
(current-target-plt-directory-getter
(lambda (preferred main-collects-parent-dir choices)
main-collects-parent-dir))))
;; Converting parse-cmdline results into parameter settings:
(set-flag-params x-flags
;; these are not defined in option-unit
all-users trust-existing-zos)
(specific-collections x-specific-collections)
(archives x-archives)
(specific-planet-dirs x-specific-planet-packages)
(setup-program-name short-name)
(require launcher/launcher-sig
launcher/launcher-unit
dynext/dynext-sig
dynext/dynext-unit)
(require compiler/sig
compiler/option-unit
compiler/compiler-unit)
(invoke-unit
(compound-unit/infer
(import (SOPTION : setup-option^))
(export)
(link launcher@ dynext:compile@ dynext:link@ dynext:file@
compiler:option@ compiler@ setup@))
(import setup-option^)))
(parameterize
;; Converting parse-cmdline results into parameter settings:
([current-target-plt-directory-getter
(if (assq 'all-users x-flags)
(lambda (preferred main-collects-parent-dir choices)
main-collects-parent-dir)
(current-target-plt-directory-getter))]
[trust-existing-zos (or (assq 'trust-existing-zos x-flags)
(trust-existing-zos))]
[specific-collections x-specific-collections]
[archives x-archives]
[specific-planet-dirs x-specific-planet-packages]
[setup-program-name short-name])
(setup-core)))

108
racket/collects/setup/setup.rkt
View File

@ -1,17 +1,8 @@
#lang racket/base
(require racket/unit
;; All the rest are to get the imports for setup@:
"option-sig.rkt"
"setup-unit.rkt"
"option-unit.rkt"
launcher/launcher-sig
launcher/launcher-unit
dynext/dynext-sig
dynext/dynext-unit
compiler/sig
compiler/option-unit
compiler/compiler-unit)
(require "option.rkt"
"setup-core.rkt"
launcher/launcher
compiler/compiler)
(provide setup)
@ -26,69 +17,44 @@
#:tidy? [tidy? #f]
#:avoid-main? [avoid-main? #f]
#:jobs [parallel #f])
(define-unit set-options@
(import setup-option^ compiler^)
(export)
;; >>>>>>>>>>>>>> <<<<<<<<<<<<<<<
;; Here's where we tell setup the archive file:
(unless (or clean? (not file))
(archives (list file))
(when planet-specs
(archive-implies-reindex #f)))
(parameterize
(;; Here's where we tell setup the archive file:
[archives (if (or clean? (not file)) (archives) (list file))]
[archive-implies-reindex (if (and planet-specs (and (not clean?) file))
#f
(archive-implies-reindex))]
;; Here's where we make get a directory:
(current-target-directory-getter
get-target-dir)
[current-target-directory-getter get-target-dir]
(when planet-specs
(specific-planet-dirs planet-specs))
[specific-planet-dirs (if planet-specs planet-specs (specific-planet-dirs))]
(when collections
(specific-collections collections))
(when (or planet-specs collections)
(make-only #t))
(unless make-user?
(make-user #f))
(unless make-docs?
(make-docs #f))
(when make-doc-index?
(make-doc-index #t))
(when tidy?
(make-tidy #t))
(when avoid-main?
(avoid-main-installation #t))
[specific-collections (if collections collections (specific-collections))]
(when clean?
(clean #t)
(make-zo #f)
(make-launchers #f)
(make-info-domain #t)
(call-install #f)
(make-docs #f))
[make-only (if (or planet-specs collections) #t (make-only))]
(setup-program-name "raco setup")
[make-user (if make-user? (make-user) #f)]
(when parallel
(parallel-workers parallel)))
[make-docs (if make-docs? (make-docs) #f)]
[make-doc-index (if make-doc-index? #t (make-doc-index))]
(let/ec esc
(parameterize ([exit-handler
(lambda (v) (esc (void)))])
(invoke-unit
(compound-unit/infer
(import)
(export)
(link launcher@
dynext:compile@
dynext:link@
dynext:file@
compiler:option@
compiler@
setup:option@
set-options@
setup@))))))
[make-tidy (if tidy? #t (make-tidy))]
[avoid-main-installation (if avoid-main? #t (avoid-main-installation))]
[clean (if clean? #t (clean))]
[make-zo (if clean? #f (make-zo))]
[make-launchers (if clean? #f (make-launchers))]
[make-info-domain (if clean? #t (make-info-domain))]
[call-install (if clean? #f (call-install))]
[make-docs (if clean? #f (make-docs))]
[setup-program-name "raco setup"]
[parallel-workers (if parallel parallel (parallel-workers))])
(let/ec esc
(parameterize ([exit-handler
(lambda (v) (esc (void)))])
(setup-core)))))