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

support multiples collects paths embedded in an executable

Browse Source 
svn: r2943
This commit is contained in:
Matthew Flatt 2006-05-15 16:14:55 +00:00
parent 9840aaf47c
commit f7553f617b
7 changed files with 777 additions and 684 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/compiler/doc.txt
View File

@ -402,6 +402,7 @@ _embedr-sig.ss_ library provides the signature, _compiler:embed^_.
[#:mred? mred?]
[#:variant variant]
[#:aux aux]
[#:lib-path lib-path-or-list]
[#:launcher? launcher?]
[#:verbose? verbose?])
- Copies the MzScheme (if `mred?' is #f) or MrEd (otherwise) binary,
@ -533,12 +534,29 @@ _embedr-sig.ss_ library provides the signature, _compiler:embed^_.
See also `build-aux-from-path' in the "launcher" collection. The
default `aux' is `null'.
If `lib-path-or-list' is #f, then the created executable maintains
its built-in (relative) path to the main "collects" directory ---
which will be the result of `(find-system-path 'collects-dir)' when
the executable is run --- plus a potential list of other
directories for finding library collections --- which are used to
initialize the `current-library-collection-paths' list in
combination with "PLTCOLLECTS" environment variable. Otherwise,
`lib-path-or-list' specifies a replacement; it must be either a
path, string, or non-empty list of paths and strings. In the last
case, the first path or string specifies the main collection
directory, and the rest are additional directories for the
collection search path (placed, in order, after the user-specific
"collects" directory, but before the main "collects" directory;
then the search list is combined with "PLTCOLLECTS", if it is
defined).
If `launcher?' is #t, then no `modules' should be null,
`literal-file-list' should be null, `literal-sexp' should be #f,
and the platform should be Windows or Mac OS X. The embedding
executable is created in such a way that `(find-system-path
'exec-file)' produces the source MzScheme or MrEd path instead of
the embedding executable.
the embedding executable (but the result of `(find-system-path
'run-file)' is still the embedding executable).
The `variant' argument indicates which variant of the original
binary to use for embedding. The default is 'normal, and typically

65
collects/compiler/embed-unit.ss
View File

@ -496,6 +496,11 @@
literal-files)
(when literal-expression
(write literal-expression))))
(define (write-lib out libpos lib-path-bytes)
(file-position out libpos)
(write-bytes lib-path-bytes out)
(write-byte 0 out))
;; The old interface:
(define make-embedding-executable
@ -539,21 +544,35 @@
(define relative? (let ([m (assq 'relative? aux)])
(and m (cdr m))))
(define lib-path-bytes (and lib-path
(if (path? lib-path)
(path->bytes lib-path)
(if (string? lib-path)
(string->bytes/locale lib-path)
#f))))
(cond
[(path? lib-path) (path->bytes lib-path)]
[(string? lib-path) (string->bytes/locale lib-path)]
[(and (list? lib-path)
(pair? lib-path))
(let ([l (map (lambda (p)
(cond
[(path? p) (path->bytes p)]
[(string? p) (string->bytes/locale p)]
[else #""]))
lib-path)])
(let loop ([l l])
(if (null? (cdr l))
(car l)
(bytes-append (car l) #"\0" (loop (cdr l))))))]
[else #""])))
(unless (or long-cmdline?
((apply + (length cmdline) (map (lambda (s)
(bytes-length (string->bytes/utf-8 s)))
cmdline)) . < . 50))
(error 'create-embedding-executable "command line too long"))
(when lib-path
(unless (path-string? lib-path)
(raise-type-error 'create-embedding-executable "path, string, or #f" lib-path))
(unless ((bytes-length lib-path-bytes) . <= . 512)
(error 'create-embedding-executable "'collects-path value is too long")))
(unless (or (path-string? lib-path)
(and (list? lib-path)
(pair? lib-path)
(andmap path-string? lib-path)))
(raise-type-error 'create-embedding-executable "path, string, non-empty list of paths and strings, or #f" lib-path))
(unless ((bytes-length lib-path-bytes) . <= . 1024)
(error 'create-embedding-executable "collects path list is too long")))
(let ([exe (find-exe mred? variant)])
(when verbose?
(fprintf (current-error-port) "Copying to ~s~n" dest))
@ -641,20 +660,26 @@
;; No argv[0]:
null)
(list "-k" start-s end-s))
cmdline)])
cmdline)]
[libpos (and lib-path
(let ([tag #"coLLECTs dIRECTORy:"])
(+ (with-input-from-file dest-exe
(lambda () (find-cmdline
"collects path"
tag)))
(bytes-length tag))))])
(if osx?
(finish-osx-mred dest full-cmdline exe keep-exe? relative?)
(begin
(finish-osx-mred dest full-cmdline exe keep-exe? relative?)
(when libpos
(call-with-output-file* dest-exe
(lambda (out)
(write-lib out libpos lib-path-bytes))
'update)))
(let ([cmdpos (with-input-from-file dest-exe
(lambda () (find-cmdline
"cmdline"
#"\\[Replace me for EXE hack")))]
[libpos (and lib-path
(let ([tag #"coLLECTs dIRECTORy:"])
(+ (with-input-from-file dest-exe
(lambda () (find-cmdline
"collects path"
tag)))
(bytes-length tag))))]
[anotherpos (and mred?
(eq? 'windows (system-type))
(let ([m (assq 'single-instance? aux)])
@ -671,9 +696,7 @@
(file-position out anotherpos)
(write-bytes #"no," out))
(when libpos
(file-position out libpos)
(write-bytes lib-path-bytes out)
(write-byte 0 out))
(write-lib out libpos lib-path-bytes))
(if long-cmdline?
;; write cmdline at end:
(file-position out end)

42
src/mzscheme/cmdline.inc
View File

@ -17,8 +17,17 @@ char *binary_type_hack = "bINARy tYPe:" INITIAL_BIN_TYPE;
#endif
static char *_coldir = "coLLECTs dIRECTORy:" /* <- this tag stays, so we can find it again */
INITIAL_COLLECTS_DIRECTORY "\0"
/* Pad with at least 512 bytes: */
INITIAL_COLLECTS_DIRECTORY
"\0\0" /* <- 1st nul terminates path, 2nd terminates path list */
/* Pad with at least 1024 bytes: */
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
"****************************************************************"
@ -391,7 +400,7 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
}
#ifndef NO_FILE_SYSTEM_UTILS
static void init_collection_paths(Scheme_Env *global_env)
static void init_collection_paths(Scheme_Env *global_env, Scheme_Object *extra_dirs)
{
mz_jmp_buf * volatile save, newbuf;
Scheme_Thread * volatile p;
@ -405,7 +414,8 @@ static void init_collection_paths(Scheme_Env *global_env)
flcp = scheme_builtin_value("find-library-collection-paths");
if (clcp && flcp) {
a[0] = _scheme_apply(flcp, 0, NULL);
a[0] = extra_dirs;
a[0] = _scheme_apply(flcp, 1, a);
_scheme_apply(clcp, 1, a);
}
}
@ -1069,10 +1079,32 @@ static int run_from_cmd_line(int argc, char *_argv[],
#ifndef NO_FILE_SYSTEM_UTILS
/* Setup path for "collects" collection directory: */
if (!no_lib_path) {
Scheme_Object *l, *r;
int len, offset;
if (!collects_path)
collects_path = scheme_make_path(_coldir XFORM_OK_PLUS _coldir_offset);
scheme_set_collects_path(collects_path);
init_collection_paths(global_env);
/* Make list of additional collection paths: */
l = scheme_make_null();
offset = _coldir_offset;
while (1) {
len = strlen(_coldir XFORM_OK_PLUS offset);
offset += len + 1;
if (!_coldir[offset])
break;
l = scheme_make_pair(scheme_make_path(_coldir XFORM_OK_PLUS offset),
l);
}
/* Reverse list */
r = scheme_make_null();
while (SCHEME_PAIRP(l)) {
r = scheme_make_pair(SCHEME_CAR(l), r);
l = SCHEME_CDR(l);
}
init_collection_paths(global_env, r);
}
#endif /* NO_FILE_SYSTEM_UTILS */

1
src/mzscheme/collects-path.ss
View File

@ -19,6 +19,7 @@
(file-position o (cdar m))
(write-bytes (path->bytes path) o)
(write-byte 0 o)
(write-byte 0 o)
(close-input-port i)
(close-output-port o)))))

1269
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

17
src/mzscheme/src/startup.inc
View File

@ -3048,14 +3048,22 @@
" ht)))))"
"(hash-table-put! ht relto 'attach))))))"
" standard-module-name-resolver)"
"(define(find-library-collection-paths)"
"(define find-library-collection-paths"
"(case-lambda"
"(()(find-library-collection-paths null))"
"((extra-collects-dirs)"
"(path-list-string->path-list"
" (or (getenv \"PLTCOLLECTS\") \"\")"
"(cons"
"(build-path(find-system-path 'addon-dir)"
"(version)"
" \"collects\")"
"(let*((collects-path(find-system-path 'collects-dir))"
"(let loop((l(append"
" extra-collects-dirs"
"(list(find-system-path 'collects-dir)))))"
"(if(null? l)"
" null"
"(let*((collects-path(car l))"
"(v"
"(cond"
"((complete-path? collects-path) collects-path)"
@ -3065,8 +3073,9 @@
"(else"
"(find-executable-path(find-system-path 'exec-file) collects-path #t)))))"
"(if v"
"(list(simplify-path(path->complete-path v(current-directory))))"
" null)))))"
"(cons(simplify-path(path->complete-path v(current-directory)))"
"(loop(cdr l)))"
"(loop(cdr l)))))))))))"
"(define(port? x)(or(input-port? x)(output-port? x)))"
"(define-values(struct:guard make-guard guard? guard-ref guard-set!)"
"(make-struct-type 'evt #f 1 0 #f(list(cons prop:evt 0))(current-inspector) #f '(0)))"

47
src/mzscheme/src/startup.ss
View File

@ -3497,25 +3497,34 @@
(hash-table-put! ht relto 'attach))])))
standard-module-name-resolver)
(define (find-library-collection-paths)
(path-list-string->path-list
(or (getenv "PLTCOLLECTS") "")
(cons
(build-path (find-system-path 'addon-dir)
(version)
"collects")
(let* ([collects-path (find-system-path 'collects-dir)]
[v
(cond
[(complete-path? collects-path) collects-path]
[(absolute-path? collects-path)
(path->complete-path collects-path
(find-executable-path (find-system-path 'exec-file) #f #t))]
[else
(find-executable-path (find-system-path 'exec-file) collects-path #t)])])
(if v
(list (simplify-path (path->complete-path v (current-directory))))
null)))))
(define find-library-collection-paths
(case-lambda
[() (find-library-collection-paths null)]
[(extra-collects-dirs)
(path-list-string->path-list
(or (getenv "PLTCOLLECTS") "")
(cons
(build-path (find-system-path 'addon-dir)
(version)
"collects")
(let loop ([l (append
extra-collects-dirs
(list (find-system-path 'collects-dir)))])
(if (null? l)
null
(let* ([collects-path (car l)]
[v
(cond
[(complete-path? collects-path) collects-path]
[(absolute-path? collects-path)
(path->complete-path collects-path
(find-executable-path (find-system-path 'exec-file) #f #t))]
[else
(find-executable-path (find-system-path 'exec-file) collects-path #t)])])
(if v
(cons (simplify-path (path->complete-path v (current-directory)))
(loop (cdr l)))
(loop (cdr l))))))))]))
;; -------------------------------------------------------------------------