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

369.10

Browse Source 
svn: r6003
This commit is contained in:
Matthew Flatt 2007-04-20 01:16:15 +00:00
parent 38d5a4f8c6
commit a45251d272
30 changed files with 6228 additions and 5551 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

202
collects/compiler/distribute.ss
View File

@ -109,7 +109,7 @@
[sub-dir
(build-path 'up relative-dir)]
[(and (eq? 'macosx (system-type))
(memq type '(mred mredx))
(memq type '(mredcgc mred3m))
(not single-mac-app?))
(build-path 'up 'up 'up relative-dir)]
[else
@ -126,6 +126,11 @@
exts-dir
relative-exts-dir
relative->binary-relative)
;; Copy over runtime files and adjust embedded paths:
(copy-runtime-files-and-patch-binaries orig-binaries binaries types sub-dirs
exts-dir
relative-exts-dir
relative->binary-relative)
;; Done!
(void)))))
@ -355,27 +360,30 @@
(flush-output o)))
'update)))))
(define (copy-extensions-and-patch-binaries orig-binaries binaries types sub-dirs
exts-dir relative-exts-dir
relative->binary-relative)
(define (copy-and-patch-binaries copy? magic
extract-src construct-dest transform-entry
init-counter inc-counter
orig-binaries binaries types sub-dirs
exts-dir relative-exts-dir
relative->binary-relative)
(let loop ([orig-binaries orig-binaries]
[binaries binaries]
[types types]
[sub-dirs sub-dirs]
[counter 0])
[counter init-counter])
(unless (null? binaries)
(let-values ([(exts start-pos end-pos)
(with-input-from-file (car binaries)
(lambda ()
(let* ([i (current-input-port)]
[m (regexp-match-positions #rx#"eXtEnSiOn-modules" i)])
[m (regexp-match-positions magic i)])
(if m
;; Read extension table:
;; Read table:
(begin
(file-position i (cdar m))
(let ([l (read i)])
(values (cadr l) (cdar m) (file-position i))))
;; No extension table:
;; No table:
(values null #f #f)))))])
(if (null? exts)
(loop (cdr orig-binaries) (cdr binaries) (cdr types) (cdr sub-dirs) counter)
@ -385,52 +393,152 @@
(let loop ([exts exts][counter counter])
(if (null? exts)
(values null counter)
(let* ([src (path->complete-path
(bytes->path (caar exts))
(let-values ([(base name dir?)
(split-path (path->complete-path (car orig-binaries)
(current-directory)))])
base))]
[name (let-values ([(base name dir?) (split-path src)])
name)]
(let* ([src (extract-src (car exts) (car orig-binaries))]
[dest (construct-dest src)]
[sub (format "e~a" counter)])
; Make dest dir and copy
(make-directory* (build-path exts-dir sub))
(let ([f (build-path exts-dir sub name)])
(when (file-exists? f)
(delete-file f))
(copy-file src f))
(when (and src copy?)
; Make dest and copy
(make-directory* (build-path exts-dir sub (or (path-only dest) 'same)))
(let ([f (build-path exts-dir sub dest)])
(when (or (file-exists? f)
(directory-exists? f)
(link-exists? f))
(delete-directory/files f))
(copy-directory/files src f)))
;; Generate the new extension entry for the table, and combine with
;; recur result for the rest:
(let-values ([(rest-exts counter)
(loop (cdr exts) (add1 counter))])
(values (cons (list (path->bytes
(relative->binary-relative (car types)
(car sub-dirs)
(build-path relative-exts-dir sub name)))
(cadr (car exts)))
rest-exts)
(loop (cdr exts) (inc-counter counter))])
(values (if src
(cons (transform-entry
(path->bytes
(relative->binary-relative (car sub-dirs)
(car types)
(build-path relative-exts-dir sub dest)))
(car exts))
rest-exts)
(cons (car exts)
rest-exts))
counter)))))])
;; Update the binary with the new paths
(let* ([str (string->bytes/utf-8 (format "~s" new-exts))]
[extra-space 7] ; = "(quote" plus ")"
[delta (- (- end-pos start-pos) (bytes-length str) extra-space)])
(when (negative? delta)
(error 'copy-extensions-and-patch-binaries
"not enough room in executable for revised extension table"))
(with-output-to-file (car binaries)
(lambda ()
(let ([o (current-output-port)])
(file-position o start-pos)
(write-bytes #"(quote" o)
(write-bytes str o)
;; Add space before final closing paren. This preserves space in case the
;; genereated binary is input for a future distribution build.
(write-bytes (make-bytes delta (char->integer #\space)) o)
(write-bytes #")" o)))
'update))
(when copy?
;; Update the binary with the new paths
(let* ([str (string->bytes/utf-8 (format "~s" new-exts))]
[extra-space 7] ; = "(quote" plus ")"
[delta (- (- end-pos start-pos) (bytes-length str) extra-space)])
(when (negative? delta)
(error 'copy-and-patch-binaries
"not enough room in executable for revised ~s table"
magic))
(with-output-to-file (car binaries)
(lambda ()
(let ([o (current-output-port)])
(file-position o start-pos)
(write-bytes #"(quote" o)
(write-bytes str o)
;; Add space before final closing paren. This preserves space in case the
;; genereated binary is input for a future distribution build.
(write-bytes (make-bytes delta (char->integer #\space)) o)
(write-bytes #")" o)))
'update)))
(loop (cdr orig-binaries) (cdr binaries) (cdr types) (cdr sub-dirs) counter)))))))
(define (copy-extensions-and-patch-binaries orig-binaries binaries types sub-dirs
exts-dir relative-exts-dir
relative->binary-relative)
(copy-and-patch-binaries #t #rx#"eXtEnSiOn-modules"
;; extract-src:
(lambda (ext orig-binary)
(path->complete-path
(bytes->path (car ext))
(let-values ([(base name dir?)
(split-path (path->complete-path orig-binary
(current-directory)))])
base)))
;; construct-dest:
(lambda (src)
(let-values ([(base name dir?) (split-path src)])
name))
;; transform-entry
(lambda (new-path ext)
(list new-path (cadr ext)))
0 add1 ; <- counter
orig-binaries binaries types sub-dirs
exts-dir relative-exts-dir
relative->binary-relative))
(define (copy-runtime-files-and-patch-binaries orig-binaries binaries types sub-dirs
exts-dir relative-exts-dir
relative->binary-relative)
(let ([paths null])
;; Pass 1: collect all the paths
(copy-and-patch-binaries #f #rx#"rUnTiMe-paths"
;; extract-src:
(lambda (rt orig-binary)
(and (cadr rt)
(bytes->path (cadr rt))))
;; construct-dest:
(lambda (src)
(when src
(set! paths (cons src paths)))
"dummy")
;; transform-entry
(lambda (new-path ext) ext)
"rt" values ; <- counter
orig-binaries binaries types sub-dirs
exts-dir relative-exts-dir
relative->binary-relative)
(unless (null? paths)
;; Determine the shared path prefix:
(let* ([root-table (make-hash-table 'equal)]
[root->path-element (lambda (root)
(hash-table-get root-table
root
(lambda ()
(let ([v (format "r~a" (hash-table-count root-table))])
(hash-table-put! root-table root v)
v))))]
[explode (lambda (src)
(reverse
(let loop ([src src])
(let-values ([(base name dir?) (split-path src)])
(if base
(cons name (loop base))
(list (root->path-element name)))))))]
;; In reverse order, so we can pick off the paths
;; in the second pass:
[exploded (reverse (map explode paths))]
[max-len (apply max 0 (map length exploded))]
[common-len (let loop ([cnt 0])
(cond
[((add1 cnt) . = . max-len) cnt]
[(andmap (let ([i (list-ref (car exploded) cnt)])
(lambda (e)
(equal? (list-ref e cnt) i)))
exploded)
(loop (add1 cnt))]
[else cnt]))])
;; Pass 2: change all the paths
(copy-and-patch-binaries #t #rx#"rUnTiMe-paths"
;; extract-src:
(lambda (rt orig-binary)
(and (cadr rt)
(bytes->path (cadr rt))))
;; construct-dest:
(lambda (src)
(and src
(begin0
(apply build-path (list-tail (car exploded) common-len))
(set! exploded (cdr exploded)))))
;; transform-entry
(lambda (new-path ext)
(cons (car ext) (list new-path)))
"rt" values ; <- counter
orig-binaries binaries types sub-dirs
exts-dir relative-exts-dir
relative->binary-relative)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utilities

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

File diff suppressed because it is too large Load Diff

2
collects/mred/private/app.ss
View File

@ -107,7 +107,7 @@
af
(entry-point
(lambda () (when (send af accept-drag?)
(send af on-drop-file f))))))))))
(send af on-drop-file f))))))))))
(define (install-defh)
(wx:application-file-handler (make-app-handler

50
collects/mzlib/etc.ss
View File

@ -380,24 +380,44 @@
(not (eq? (namespace-variable-value n #t (lambda () ns-undefined))
ns-undefined)))
(define (extract-module-directory stx)
(let ([srcmod (let ([mpi (syntax-source-module stx)])
(if (module-path-index? mpi)
(module-path-index-resolve mpi)
mpi))])
(let ([str (symbol->string srcmod)])
(and ((string-length str) . > . 1)
(char=? #\, (string-ref str 0))
(let ([path (bytes->path (string->bytes/latin-1 (substring str 1)))])
(let-values ([(base name dir?) (split-path path)])
(and (path? base)
base)))))))
(define-syntax (this-expression-source-directory stx)
(syntax-case stx ()
[(_)
(let* ([source (syntax-source stx)]
[source (and (path? source) source)]
[local (or (current-load-relative-directory) (current-directory))]
[dir (path->main-collects-relative
(or (and source (file-exists? source)
(let-values ([(base file dir?)
(split-path source)])
(and (path? base)
(path->complete-path base local))))
local))])
(if (and (pair? dir) (eq? 'collects (car dir)))
(with-syntax ([d dir])
#'(main-collects-relative->path 'd))
(with-syntax ([d (if (bytes? dir) dir (path->bytes dir))])
#'(bytes->path d))))]))
(let ([source-path
(let* ([source (syntax-source stx)]
[source (and (path? source) source)]
[local (or (current-load-relative-directory) (current-directory))]
[dir (path->main-collects-relative
(or (and source (file-exists? source)
(let-values ([(base file dir?)
(split-path source)])
(and (path? base)
(path->complete-path base local))))
local))])
(if (and (pair? dir) (eq? 'collects (car dir)))
(with-syntax ([d dir])
(syntax/loc stx (main-collects-relative->path 'd)))
(with-syntax ([d (if (bytes? dir) dir (path->bytes dir))])
(syntax/loc stx (bytes->path d)))))])
(let ([mpi (syntax-source-module stx)])
(if mpi
(quasisyntax/loc stx
(or (extract-module-directory (quote-syntax #,stx))
#,source-path))
source-path)))]))
(define-syntax (this-expression-file-name stx)
(syntax-case stx ()

3
collects/mzlib/private/runtime-path-table.ss Normal file
View File

@ -0,0 +1,3 @@
(module runtime-path-table mzscheme
(provide table)
(define table #f))

137
collects/mzlib/runtime-path.ss Normal file
View File

@ -0,0 +1,137 @@
(module runtime-path mzscheme
(require (lib "etc.ss")
(lib "modcollapse.ss" "syntax")
(lib "dirs.ss" "setup")
(only "private/runtime-path-table.ss" table))
(provide define-runtime-path
define-runtime-paths
define-runtime-path-list
runtime-paths)
(define-for-syntax ext-file-table (make-hash-table))
(define (lookup-in-table tag-stx p)
;; This function is designed to cooperate with a table embedded
;; in an executable by create-embedding-executable.
(let ([mpi (syntax-source-module tag-stx)])
(let ([p (hash-table-get
table
(cons (cond
[(module-path-index? mpi)
(module-path-index-resolve mpi)]
[(symbol? mpi) mpi]
[else #f])
(if (path? p)
(path->bytes p)
p))
#f)])
(and p
(car p)
(let* ([p (car p)]
[p (if (bytes? p)
(bytes->path p)
p)])
(if (absolute-path? p)
p
(parameterize ([current-directory (find-system-path 'orig-dir)])
(or (find-executable-path (find-system-path 'exec-file) p #t)
(build-path (current-directory) p)))))))))
(define (resolve-paths tag-stx get-base paths)
(let ([base #f])
(map (lambda (p)
(or
;; Check table potentially substituted by
;; mzc --exe:
(and table
(lookup-in-table tag-stx p))
;; Normal resolution
(cond
[(and (or (string? p) (path? p))
(not (complete-path? p)))
(unless base
(set! base (get-base)))
(path->complete-path p base)]
[(string? p) (string->path p)]
[(path? p) p]
[(and (list? p)
(= 2 (length p))
(eq? 'so (car p))
(string? (cadr p)))
(let ([f (path-replace-suffix (cadr p) (system-type 'so-suffix))])
(or (ormap (lambda (p)
(let ([p (build-path p f)])
(and (file-exists? p)
p)))
(get-lib-search-dirs))
(cadr p)))]
[else (error 'runtime-path "unknown form: ~e" p)])))
paths)))
(define-for-syntax (register-ext-files tag-stx paths)
(let ([mpi (syntax-source-module tag-stx)])
(let ([modname (cond
[(module-path-index? mpi) (module-path-index-resolve mpi)]
[(symbol? mpi) mpi]
[else (error 'register-ext-files
"cannot determine source")])])
(let ([files (hash-table-get ext-file-table modname null)])
(hash-table-put! ext-file-table modname (append paths files))))))
(define-syntax (-define-runtime-path stx)
(syntax-case stx ()
[(_ orig-stx (id ...) expr to-list to-values)
(let ([ids (syntax->list #'(id ...))])
(unless (memq (syntax-local-context) '(module module-begin top-level))
(raise-syntax-error #f "allowed only at the top level" #'orig-stx))
(for-each (lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
#'orig-stx
id)))
ids)
(let ([tag (datum->syntax-object #'orig-stx 'tag #'orig-stx)])
#`(begin
(define-values (id ...)
(let-values ([(id ...) expr])
(let ([get-dir (lambda ()
#,(datum->syntax-object
tag
`(,#'this-expression-source-directory)
tag))])
(apply to-values (resolve-paths (quote-syntax #,tag)
get-dir
(to-list id ...))))))
(begin-for-syntax
(register-ext-files
(quote-syntax #,tag)
(let-values ([(id ...) expr])
(to-list id ...)))))))]))
(define-syntax (define-runtime-path stx)
(syntax-case stx ()
[(_ id expr) #`(-define-runtime-path #,stx (id) expr list values)]))
(define-syntax (define-runtime-paths stx)
(syntax-case stx ()
[(_ (id ...) expr) #`(-define-runtime-path #,stx (id ...) expr list values)]))
(define-syntax (define-runtime-path-list stx)
(syntax-case stx ()
[(_ id expr) #`(-define-runtime-path #,stx (id) expr values list)]))
(define-syntax (runtime-paths stx)
(syntax-case stx ()
[(_ mp)
#`(quote
#,(hash-table-get
ext-file-table
(module-path-index-resolve (module-path-index-join
(syntax-object->datum #'mp)
(syntax-source-module stx)))
null))]))
)

7
collects/mzlib/sandbox.ss
View File

@ -362,13 +362,6 @@
(define (get-uncovered-expressions eval . args)
(apply (eval get-uncovered-expressions) args))
(define-syntax parameterize*
(syntax-rules ()
[(parameterize* ([p1 v1] [p v] ...) body ...)
(parameterize ([p1 v1]) (parameterize* ([p v] ...) body ...))]
[(parameterize* () body ...)
(begin body ...)]))
(define (make-evaluator* init-hook require-perms program-or-maker)
(define cust (make-custodian))
(define coverage? (sandbox-coverage-enabled))

26
collects/openssl/mzssl.ss
View File

@ -16,7 +16,8 @@
(module mzssl mzscheme
(require (lib "foreign.ss")
(lib "port.ss")
(lib "kw.ss"))
(lib "kw.ss")
(lib "runtime-path.ss"))
(provide ssl-available?
ssl-load-fail-reason
@ -48,6 +49,17 @@
(unsafe!)
;; We need to declare because they might be distributed with PLT Scheme
;; in which case they should get bundled with stand-alone executables:
(define-runtime-path libcrypto-so
(case (system-type)
[(windows) '(so "libeay32")]
[else '(so "libcrypto")]))
(define-runtime-path libssl-so
(case (system-type)
[(windows) '(so "ssleay32")]
[else '(so "libssl")]))
(define ssl-load-fail-reason #f)
(define 3m? (regexp-match #rx#"3m" (path->bytes (system-library-subpath))))
@ -56,22 +68,14 @@
(with-handlers ([exn:fail? (lambda (x)
(set! ssl-load-fail-reason (exn-message x))
#f)])
(case (system-type)
[(windows)
(ffi-lib "libeay32")]
[else
(ffi-lib "libcrypto")])))
(ffi-lib libcrypto-so)))
(define libssl
(and libcrypto
(with-handlers ([exn:fail? (lambda (x)
(set! ssl-load-fail-reason (exn-message x))
#f)])
(case (system-type)
[(windows)
(ffi-lib "ssleay32")]
[else
(ffi-lib "libssl")]))))
(ffi-lib libssl-so))))
(define libmz (ffi-lib #f))

11
collects/plot/fit-low-level.ss
View File

@ -1,11 +1,12 @@
(module fit-low-level mzscheme
(require (lib "foreign.ss") (lib "etc.ss"))
(require (lib "foreign.ss") (lib "runtime-path.ss"))
(unsafe!)
(define libfit
(ffi-lib (build-path (this-expression-source-directory)
"compiled" "native" (system-library-subpath #f)
"libfit")))
(define-runtime-path libfit-path
(build-path "compiled" "native" (system-library-subpath #f)
(path-replace-suffix "libfit" (system-type 'so-suffix))))
(define libfit (ffi-lib libfit-path))
(define do-fit-int
(get-ffi-obj "do_fit" libfit

0
collects/plot/plstnd5.fnt → collects/plot/fonts/plstnd5.fnt
View File

0
collects/plot/plxtnd5.fnt → collects/plot/fonts/plxtnd5.fnt
View File

14
collects/plot/plplot.ss
View File

@ -1,17 +1,19 @@
(module plplot mzscheme
(require (lib "etc.ss") (lib "list.ss") (lib "foreign.ss"))
(require (lib "etc.ss") (lib "list.ss") (lib "foreign.ss") (lib "runtime-path.ss"))
(unsafe!)
(define libplplot
(ffi-lib
(build-path (this-expression-source-directory)
"compiled" "native" (system-library-subpath #f) "libplplot")))
(define-runtime-path plplot-path
(build-path "compiled" "native" (system-library-subpath #f)
(path-replace-suffix "libplplot" (system-type 'so-suffix))))
(define-runtime-path font-dir "fonts")
(define libplplot (ffi-lib plplot-path))
(define plplotlibdir (get-ffi-obj "plplotLibDir" libplplot _string))
;; set the lib dir to contain the fonts:
(let ([path (this-expression-source-directory)])
(let ([path font-dir])
;; free current pointer, if any:
(let ([p (get-ffi-obj "plplotLibDir" libplplot _pointer)])
(when p (free p)))

5
collects/setup/dirs.ss
View File

@ -8,10 +8,7 @@
;; path normalization is not really necessary by any existing code,
;; but there might be applications that rely on these paths, so it's
;; best to do some minor normalization. This is similar to what
;; "main-collects.ss" does. Again, this makes mzscheme expand paths
;; that begin with `~'.
;; Note: (expand-path (simplify-path P #f)) is bogus, if P is
;; "./~foo" or "~foo/.."
;; "main-collects.ss" does.
(define (system-path* what)
(simplify-path (expand-path (find-system-path what)) #f))

3
collects/syntax/doc.txt
View File

@ -244,9 +244,6 @@ _docprovide.ss_: attaching documentation to exports
> (provide-and-document doc-label-id doc-row ...) - a form that
exports names and records documentation information.
!! IMPORTANT: For now, the exporting module must be required with a
`lib' or `file' form. Relative paths do no work correctly !!
The `doc-label-id' identifier is used as a key for accessing the
documentation through `lookup-documentation'. The actual
documentation is organized into "rows", each with a section title.

17
collects/syntax/private/doctable.ss
View File

@ -1,15 +1,11 @@
(module doctable mzscheme
(require (lib "moddep.ss" "syntax"))
(define ht (make-hash-table 'equal))
(define ht (make-hash-table))
(define (register-documentation src-stx label v)
(let ([mod (let ([s (syntax-source-module src-stx)])
(if (module-path-index? s)
((current-module-name-resolver)
(collapse-module-path-index s `(lib "docprovide.ss" "syntax"))
#f #f)
(module-path-index-resolve s)
s))])
(let ([mht (hash-table-get ht mod
(lambda ()
@ -19,9 +15,12 @@
(hash-table-put! mht label v))))
(define (lookup-documentation mod label)
(let ([mht (hash-table-get ht mod (lambda () #f))])
(and mht
(hash-table-get mht label (lambda () #f)))))
(let ([mod (if (symbol? mod)
mod
(module-path-index-resolve (module-path-index-join mod #f)))])
(let ([mht (hash-table-get ht mod (lambda () #f))])
(and mht
(hash-table-get mht label (lambda () #f))))))
(provide register-documentation
lookup-documentation))

9
collects/tests/mzscheme/embed-me10.ss Normal file
View File

@ -0,0 +1,9 @@
(module embed-me10 mzscheme
(require (lib "mzssl.ss" "openssl"))
(with-output-to-file "stdout"
(lambda ()
(printf "~a\n" ssl-available?))
'append))

15
collects/tests/mzscheme/embed-me7.ss Normal file
View File

@ -0,0 +1,15 @@
(module embed-me7 mzscheme
(require (lib "plot.ss" "plot")
(lib "mred.ss" "mred")
(lib "class.ss"))
(define img (plot (line (lambda (x) x))))
(define e (new text%))
(send e insert img)
(with-output-to-file "stdout"
(lambda ()
(printf "plotted\n"))
'append))

31
collects/tests/mzscheme/embed-me8.c Normal file
View File

@ -0,0 +1,31 @@
#include "escheme.h"
Scheme_Object *ex(int argc, Scheme_Object **argv)
{
return scheme_make_utf8_string("Hello, world!");
}
Scheme_Object *scheme_reload(Scheme_Env *env)
{
Scheme_Env *menv;
menv = scheme_primitive_module(scheme_intern_symbol("embed-me8"),
env);
scheme_add_global("ex", scheme_make_prim_w_arity(ex, "ex", 0, 0), menv);
scheme_finish_primitive_module(menv);
return scheme_void;
}
Scheme_Object *scheme_initialize(Scheme_Env *env)
{
/* First load is same as every load: */
return scheme_reload(env);
}
Scheme_Object *scheme_module_name()
{
return scheme_intern_symbol("embed-me8");
}

6
collects/tests/mzscheme/embed-me9.ss Normal file
View File

@ -0,0 +1,6 @@
(module embed-me9 mzscheme
(require "embed-me8.ss")
(with-output-to-file "stdout"
(lambda ()
(printf "~a\n" (ex)))
'append))

156
collects/tests/mzscheme/embed.ss
View File

@ -4,33 +4,52 @@
(Section 'embed)
(require (lib "embed.ss" "compiler")
(lib "process.ss"))
(lib "file.ss")
(lib "process.ss")
(lib "distribute.ss" "compiler"))
(define (mk-dest-bin mred?)
(case (system-type)
[(windows) "e.exe"]
[(unix) "e"]
[(macosx) (if mred?
"e.app"
"e")]))
(define (mk-dest mred?)
(build-path (find-system-path 'temp-dir)
(case (system-type)
[(windows) "e.exe"]
[(unix) "e"]
[(macosx) (if mred?
"e.app"
"e")])))
(mk-dest-bin mred?)))
(define mz-dest (mk-dest #f))
(define mr-dest (mk-dest #t))
(define dist-dir (build-path (find-system-path 'temp-dir)
"e-dist"))
(define dist-mz-exe (build-path
(case (system-type)
[(windows) 'same]
[else "bin"])
(mk-dest-bin #f)))
(define dist-mred-exe (build-path
(case (system-type)
[(windows macosx) 'same]
[else "bin"])
(mk-dest-bin #t)))
(define (prepare exe src)
(printf "Making ~a with ~a...~n" exe src)
(when (file-exists? exe)
(delete-file exe)))
(define (try-exe exe expect mred?)
(define (try-one-exe exe expect mred?)
(printf "Running ~a\n" exe)
(let ([plthome (getenv "PLTHOME")]
[collects (getenv "PLTCOLLECTS")])
;; Try to hide usual collections:
(when plthome
(putenv "PLTHOME" (path->string (find-system-path 'temp-dir))))
(putenv "PLTHOME" (path->string (build-path (find-system-path 'temp-dir) "NOPE"))))
(when collects
(putenv "PLTCOLLECTS" (path->string (find-system-path 'temp-dir))))
(putenv "PLTCOLLECTS" (path->string (build-path (find-system-path 'temp-dir) "NOPE"))))
;; Execute:
(parameterize ([current-directory (find-system-path 'temp-dir)])
(when (file-exists? "stdout")
@ -47,6 +66,24 @@
(test expect with-input-from-file (build-path (find-system-path 'temp-dir) "stdout")
(lambda () (read-string 5000)))))
(define try-exe
(case-lambda
[(exe expect mred?)
(try-exe exe expect mred? void)]
[(exe expect mred? dist-hook . collects)
(try-one-exe exe expect mred?)
;; Build a distirbution directory, and try that, too:
(when (directory-exists? dist-dir)
(delete-directory/files dist-dir))
(assemble-distribution dist-dir (list exe) #:copy-collects collects)
(dist-hook)
(try-one-exe (build-path dist-dir
(if mred?
dist-mred-exe
dist-mz-exe))
expect mred?)
(delete-directory/files dist-dir)]))
(define (mz-tests mred?)
(define dest (if mred? mr-dest mz-dest))
(define (flags s)
@ -161,19 +198,22 @@
(mz-tests #f)
(mz-tests #t)
(prepare mr-dest "embed-me5.ss")
(make-embedding-executable
mr-dest #t #f
`((#t (lib "embed-me5.ss" "tests" "mzscheme")))
null
null
`("-ZmvqL" "embed-me5.ss" "tests/mzscheme"))
(try-exe mr-dest "This is 5: #<struct:class:button%>\n" #t)
(begin
(prepare mr-dest "embed-me5.ss")
(make-embedding-executable
mr-dest #t #f
`((#t (lib "embed-me5.ss" "tests" "mzscheme")))
null
null
`("-ZmvqL" "embed-me5.ss" "tests/mzscheme"))
(try-exe mr-dest "This is 5: #<struct:class:button%>\n" #t))
;; Try the mzc interface:
(require (lib "dirs.ss" "setup")
(lib "file.ss"))
(define mzc (build-path (find-console-bin-dir) "mzc"))
(define mzc (build-path (find-console-bin-dir) (if (eq? 'windows (system-type))
"mzc.exe"
"mzc")))
(define (mzc-tests mred?)
(parameterize ([current-directory (find-system-path 'temp-dir)])
@ -206,7 +246,8 @@
"--collects-path"
(path->string (find-collects-dir))
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss")))
(try-exe (mk-dest mred?) "This is 6\n#t\n" mred?)
;; Don't try a distribution for this one:
(try-one-exe (mk-dest mred?) "This is 6\n#t\n" mred?)
;; Try --collects-dest mode
(system* mzc
@ -216,7 +257,7 @@
"--collects-dest" "cts"
"--collects-path" "cts"
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss")))
(try-exe (mk-dest mred?) "This is 6\n#t\n" mred?)
(try-exe (mk-dest mred?) "This is 6\n#t\n" mred? void "cts") ; <- cts copied to distribution
(delete-directory/files "cts")
(try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?)
@ -225,7 +266,65 @@
(mzc-tests #t)
(mzc-tests #f)
;; One MrEd-specific test with mzc:
(require (lib "file.ss" "dynext"))
(define (extension-test mred?)
(parameterize ([current-directory (find-system-path 'temp-dir)])
(define obj-file
(build-path (find-system-path 'temp-dir) (append-object-suffix "embed-me8")))
(define ext-base-dir
(build-path (find-system-path 'temp-dir)
"compiled"))
(define ext-dir
(build-path ext-base-dir
"native"
(system-library-subpath)))
(define ext-file
(build-path ext-dir (append-extension-suffix "embed-me8")))
(define ss-file
(build-path (find-system-path 'temp-dir) "embed-me9.ss"))
(make-directory* ext-dir)
(system* mzc
"--cc"
"-d" (path->string (path-only obj-file))
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me8.c")))
(system* mzc
"--ld"
(path->string ext-file)
(path->string obj-file))
(when (file-exists? ss-file)
(delete-file ss-file))
(copy-file (build-path (collection-path "tests" "mzscheme") "embed-me9.ss")
ss-file)
(system* mzc
(if mred? "--gui-exe" "--exe")
(path->string (mk-dest mred?))
(path->string ss-file))
(delete-file ss-file)
(try-exe (mk-dest mred?) "Hello, world!\n" mred? (lambda ()
(delete-directory/files ext-base-dir)))
;; openssl, which needs extra binaries under Windows
(system* mzc
(if mred? "--gui-exe" "--exe")
(path->string (mk-dest mred?))
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me10.ss")))
(try-exe (mk-dest mred?) "#t\n" mred?)))
(extension-test #f)
(extension-test #t)
;; A MrEd-specific test with mzc:
(parameterize ([current-directory (find-system-path 'temp-dir)])
(system* mzc
"--gui-exe"
@ -233,6 +332,19 @@
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me5.ss")))
(try-exe (mk-dest #t) "This is 5: #<struct:class:button%>\n" #t))
;; Another MrEd-specific: try embedding plot, which has extra DLLs and font files:
(parameterize ([current-directory (find-system-path 'temp-dir)])
(define direct (build-path (find-system-path 'temp-dir) "direct.ps"))
(system* (build-path (find-console-bin-dir) "mred")
"-qu"
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me7.ss"))
(path->string direct))
(system* mzc
"--gui-exe"
(path->string (mk-dest #t))
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me7.ss")))
(try-exe (mk-dest #t) "plotted\n" #t))
(report-errs)

4
collects/tests/mzscheme/module.ss
View File

@ -284,8 +284,8 @@
(lambda ()
(write `(module tmp2 mzscheme (require ,f1))))
'truncate/replace)
(err/rt-test (dynamic-require f1 #f) exn:fail-cycle?)
(err/rt-test (dynamic-require f2 #f) exn:fail-cycle?)
(err/rt-test (dynamic-require (build-path (current-directory) f1) #f) exn:fail-cycle?)
(err/rt-test (dynamic-require (build-path (current-directory) f2) #f) exn:fail-cycle?)
(delete-file f1)
(delete-file f2))

10
doc/release-notes/mred/HISTORY
View File

@ -1,8 +1,14 @@
Version 369.10
Improved the disabled appearance of some controls under Mac OS X
Version 369.9
Added use-background-style and background-style-used? methods
Added use-style-background and style-background-used? methods
to editor-snip%; changes the editor-snip WXME format
Version 369.6
WXME file format changed to include a #reader() prefix
@ -1229,7 +1235,7 @@ wx:the-snip-class-list was replaced by (wx:get-the-snip-class-list)
wx:the-buffer-data-class-list was replaced by (wx:get-the-buffer-data-class-list)
Added transparent text backing for editor text
Added wx:dc% try-colour method
wx:window% capture-mode, release-mouse, and make-modal no longer supported
wx:window% capture-mouse, release-mouse, and make-modal no longer supported
Modal dialogs can be used instead of make-modal (modal is
specified through the constructor). There is currently no
replacement for capture-mouse and release-mouse, but a replacement is

6
doc/release-notes/mzscheme/HISTORY
View File

@ -1,3 +1,9 @@
Version 369.10
Added parameterize*
Added module-path-index-resolve
Fixed mzc --exe to work with C-implemented extension modules
Added runtime-paths.ss MzLib library to cooperate with mzc --exe
Version 369.9
Module top-level enforces initial categorization of expressions
versus other forms

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

File diff suppressed because it is too large Load Diff

14
src/mzscheme/src/module.c
View File

@ -50,6 +50,7 @@ static Scheme_Object *module_compiled_exports(int argc, Scheme_Object *argv[]);
static Scheme_Object *module_to_namespace(int argc, Scheme_Object *argv[]);
static Scheme_Object *module_path_index_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *module_path_index_resolve(int argc, Scheme_Object *argv[]);
static Scheme_Object *module_path_index_split(int argc, Scheme_Object *argv[]);
static Scheme_Object *module_path_index_join(int argc, Scheme_Object *argv[]);
@ -348,6 +349,11 @@ void scheme_init_module(Scheme_Env *env)
"module-path-index?",
1, 1, 1),
env);
scheme_add_global_constant("module-path-index-resolve",
scheme_make_prim_w_arity(module_path_index_resolve,
"module-path-index-resolve",
1, 1),
env);
scheme_add_global_constant("module-path-index-split",
scheme_make_prim_w_arity2(module_path_index_split,
"module-path-index-split",
@ -1681,6 +1687,14 @@ static Scheme_Object *module_path_index_p(int argc, Scheme_Object *argv[])
: scheme_false);
}
static Scheme_Object *module_path_index_resolve(int argc, Scheme_Object *argv[])
{
if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type))
scheme_wrong_type("module-path-index-resolve", "module-path-index", 0, argc, argv);
return scheme_module_resolve(argv[0], 0);
}
static Scheme_Object *module_path_index_split(int argc, Scheme_Object *argv[])
{
Scheme_Modidx *modidx;

2
src/mzscheme/src/schminc.h
View File

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 892
#define EXPECTED_PRIM_COUNT 893
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

4
src/mzscheme/src/schvers.h
View File

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 369
#define MZSCHEME_VERSION_MINOR 9
#define MZSCHEME_VERSION_MINOR 10
#define MZSCHEME_VERSION "369.9" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "369.10" _MZ_SPECIAL_TAG

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

@ -2668,6 +2668,14 @@
"(let()"
" expr1"
" expr ...))))))))"
"(define-syntax parameterize*"
"(syntax-rules()"
"((_() body1 body ...)"
"(let() body1 body ...))"
"((_((lhs1 rhs1)(lhs rhs) ...) body1 body ...)"
"(parameterize((lhs1 rhs1))"
"(parameterize*((lhs rhs) ...)"
" body1 body ...)))))"
"(define(current-parameterization)"
"(extend-parameterization(continuation-mark-set-first #f parameterization-key)))"
"(define(call-with-parameterization paramz thunk)"
@ -2855,7 +2863,7 @@
" (printf \"cpu time: ~s real time: ~s gc time: ~s~n\" cpu user gc)"
"(apply values v)))))))"
"(provide case do delay force promise?"
" parameterize current-parameterization call-with-parameterization"
" parameterize parameterize* current-parameterization call-with-parameterization"
" parameterize-break current-break-parameterization call-with-break-parameterization"
" with-handlers with-handlers* call-with-exception-handler"
" set!-values"
@ -3294,7 +3302,7 @@
"((path? s) "
"(if(absolute-path? s)"
" s"
" (list \"(a path must be absolute)\")))"
" (list \" (a path must be absolute)\")))"
"((or(not(pair? s))"
"(not(list? s)))"
" #f)"

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

@ -3069,6 +3069,15 @@
expr1
expr ...))))])))
(define-syntax parameterize*
(syntax-rules ()
[(_ () body1 body ...)
(let () body1 body ...)]
[(_ ([lhs1 rhs1] [lhs rhs] ...) body1 body ...)
(parameterize ([lhs1 rhs1])
(parameterize* ([lhs rhs] ...)
body1 body ...))]))
(define (current-parameterization)
(extend-parameterization (continuation-mark-set-first #f parameterization-key)))
@ -3288,7 +3297,7 @@
(apply values v)))])))
(provide case do delay force promise?
parameterize current-parameterization call-with-parameterization
parameterize parameterize* current-parameterization call-with-parameterization
parameterize-break current-break-parameterization call-with-break-parameterization
with-handlers with-handlers* call-with-exception-handler
set!-values
@ -3770,7 +3779,7 @@
[(path? s)
(if (absolute-path? s)
s
(list "(a path must be absolute)"))]
(list " (a path must be absolute)"))]
[(or (not (pair? s))
(not (list? s)))
#f]

59
src/mzscheme/src/stxobj.c
View File

@ -3371,15 +3371,19 @@ Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve)
src = SCHEME_VEC_ELS(vec)[1];
dest = SCHEME_VEC_ELS(vec)[2];
if (!chain_from) {
srcmod = dest;
} else if (!SAME_OBJ(chain_from, dest)) {
srcmod = scheme_modidx_shift(dest,
chain_from,
srcmod);
}
/* If src is #f, shift is just for phase; no redirection */
if (!SCHEME_FALSEP(src)) {
chain_from = src;
if (!chain_from) {
srcmod = dest;
} else if (!SAME_OBJ(chain_from, dest)) {
srcmod = scheme_modidx_shift(dest,
chain_from,
srcmod);
}
chain_from = src;
}
}
WRAP_POS_INC(w);
@ -4185,31 +4189,24 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
/* chain-specific cache; drop it */
} else {
/* box, a phase shift */
/* Any more rename tables? */
WRAP_POS l;
WRAP_POS_COPY(l, w);
while (!WRAP_POS_END_P(l)) {
if (SCHEME_RENAMESP(WRAP_POS_FIRST(l)))
break;
WRAP_POS_INC(l);
/* We used to drop a phase shift if there are no following
rename tables. However, the phase shift also identifies
the source module, which can be relevant. So, keep the
phase shift. */
/* Need the phase shift, but drop the export table, if any: */
Scheme_Object *aa;
aa = SCHEME_BOX_VAL(a);
if (SCHEME_TRUEP(SCHEME_VEC_ELS(aa)[3])) {
a = scheme_make_vector(4, NULL);
SCHEME_VEC_ELS(a)[0] = SCHEME_VEC_ELS(aa)[0];
SCHEME_VEC_ELS(a)[1] = SCHEME_VEC_ELS(aa)[1];
SCHEME_VEC_ELS(a)[2] = SCHEME_VEC_ELS(aa)[2];
SCHEME_VEC_ELS(a)[3] = scheme_false;
a = scheme_box(a);
}
/* If l is the end, don't need the phase shift */
if (!WRAP_POS_END_P(l)) {
/* Need the phase shift, but drop the export table, if any: */
Scheme_Object *aa;
aa = SCHEME_BOX_VAL(a);
if (SCHEME_TRUEP(SCHEME_VEC_ELS(aa)[3])) {
a = scheme_make_vector(4, NULL);
SCHEME_VEC_ELS(a)[0] = SCHEME_VEC_ELS(aa)[0];
SCHEME_VEC_ELS(a)[1] = SCHEME_VEC_ELS(aa)[1];
SCHEME_VEC_ELS(a)[2] = SCHEME_VEC_ELS(aa)[2];
SCHEME_VEC_ELS(a)[3] = scheme_false;
a = scheme_box(a);
}
stack = CONS(a, stack);
stack_size++;
}
stack = CONS(a, stack);
stack_size++;
}
}