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

166
collects/compiler/distribute.ss
View File

@ -109,7 +109,7 @@
[sub-dir [sub-dir
(build-path 'up relative-dir)] (build-path 'up relative-dir)]
[(and (eq? 'macosx (system-type)) [(and (eq? 'macosx (system-type))
(memq type '(mred mredx)) (memq type '(mredcgc mred3m))
(not single-mac-app?)) (not single-mac-app?))
(build-path 'up 'up 'up relative-dir)] (build-path 'up 'up 'up relative-dir)]
[else [else
@ -126,6 +126,11 @@
exts-dir exts-dir
relative-exts-dir relative-exts-dir
relative->binary-relative) 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! ;; Done!
(void))))) (void)))))
@ -355,27 +360,30 @@
(flush-output o))) (flush-output o)))
'update))))) 'update)))))
(define (copy-extensions-and-patch-binaries orig-binaries binaries types sub-dirs (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 exts-dir relative-exts-dir
relative->binary-relative) relative->binary-relative)
(let loop ([orig-binaries orig-binaries] (let loop ([orig-binaries orig-binaries]
[binaries binaries] [binaries binaries]
[types types] [types types]
[sub-dirs sub-dirs] [sub-dirs sub-dirs]
[counter 0]) [counter init-counter])
(unless (null? binaries) (unless (null? binaries)
(let-values ([(exts start-pos end-pos) (let-values ([(exts start-pos end-pos)
(with-input-from-file (car binaries) (with-input-from-file (car binaries)
(lambda () (lambda ()
(let* ([i (current-input-port)] (let* ([i (current-input-port)]
[m (regexp-match-positions #rx#"eXtEnSiOn-modules" i)]) [m (regexp-match-positions magic i)])
(if m (if m
;; Read extension table: ;; Read table:
(begin (begin
(file-position i (cdar m)) (file-position i (cdar m))
(let ([l (read i)]) (let ([l (read i)])
(values (cadr l) (cdar m) (file-position i)))) (values (cadr l) (cdar m) (file-position i))))
;; No extension table: ;; No table:
(values null #f #f)))))]) (values null #f #f)))))])
(if (null? exts) (if (null? exts)
(loop (cdr orig-binaries) (cdr binaries) (cdr types) (cdr sub-dirs) counter) (loop (cdr orig-binaries) (cdr binaries) (cdr types) (cdr sub-dirs) counter)
@ -385,39 +393,42 @@
(let loop ([exts exts][counter counter]) (let loop ([exts exts][counter counter])
(if (null? exts) (if (null? exts)
(values null counter) (values null counter)
(let* ([src (path->complete-path (let* ([src (extract-src (car exts) (car orig-binaries))]
(bytes->path (caar exts)) [dest (construct-dest src)]
(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)]
[sub (format "e~a" counter)]) [sub (format "e~a" counter)])
; Make dest dir and copy (when (and src copy?)
(make-directory* (build-path exts-dir sub)) ; Make dest and copy
(let ([f (build-path exts-dir sub name)]) (make-directory* (build-path exts-dir sub (or (path-only dest) 'same)))
(when (file-exists? f) (let ([f (build-path exts-dir sub dest)])
(delete-file f)) (when (or (file-exists? f)
(copy-file src 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 ;; Generate the new extension entry for the table, and combine with
;; recur result for the rest: ;; recur result for the rest:
(let-values ([(rest-exts counter) (let-values ([(rest-exts counter)
(loop (cdr exts) (add1 counter))]) (loop (cdr exts) (inc-counter counter))])
(values (cons (list (path->bytes (values (if src
(relative->binary-relative (car types) (cons (transform-entry
(car sub-dirs) (path->bytes
(build-path relative-exts-dir sub name))) (relative->binary-relative (car sub-dirs)
(cadr (car exts))) (car types)
(build-path relative-exts-dir sub dest)))
(car exts))
rest-exts) rest-exts)
(cons (car exts)
rest-exts))
counter)))))]) counter)))))])
(when copy?
;; Update the binary with the new paths ;; Update the binary with the new paths
(let* ([str (string->bytes/utf-8 (format "~s" new-exts))] (let* ([str (string->bytes/utf-8 (format "~s" new-exts))]
[extra-space 7] ; = "(quote" plus ")" [extra-space 7] ; = "(quote" plus ")"
[delta (- (- end-pos start-pos) (bytes-length str) extra-space)]) [delta (- (- end-pos start-pos) (bytes-length str) extra-space)])
(when (negative? delta) (when (negative? delta)
(error 'copy-extensions-and-patch-binaries (error 'copy-and-patch-binaries
"not enough room in executable for revised extension table")) "not enough room in executable for revised ~s table"
magic))
(with-output-to-file (car binaries) (with-output-to-file (car binaries)
(lambda () (lambda ()
(let ([o (current-output-port)]) (let ([o (current-output-port)])
@ -428,9 +439,106 @@
;; genereated binary is input for a future distribution build. ;; genereated binary is input for a future distribution build.
(write-bytes (make-bytes delta (char->integer #\space)) o) (write-bytes (make-bytes delta (char->integer #\space)) o)
(write-bytes #")" o))) (write-bytes #")" o)))
'update)) 'update)))
(loop (cdr orig-binaries) (cdr binaries) (cdr types) (cdr sub-dirs) counter))))))) (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 ;; Utilities

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

@ -278,9 +278,9 @@
;; Represent modules with lists starting with the filename, so we ;; Represent modules with lists starting with the filename, so we
;; can use assoc: ;; can use assoc:
(define (make-mod normal-file-path normal-module-path code name prefix full-name relative-mappings) (define (make-mod normal-file-path normal-module-path code name prefix full-name relative-mappings runtime-paths)
(list normal-file-path normal-module-path code (list normal-file-path normal-module-path code
name prefix full-name relative-mappings)) name prefix full-name relative-mappings runtime-paths))
(define (mod-file m) (car m)) (define (mod-file m) (car m))
(define (mod-mod-path m) (cadr m)) (define (mod-mod-path m) (cadr m))
@ -289,12 +289,13 @@
(define (mod-prefix m) (list-ref m 4)) (define (mod-prefix m) (list-ref m 4))
(define (mod-full-name m) (list-ref m 5)) (define (mod-full-name m) (list-ref m 5))
(define (mod-mappings m) (list-ref m 6)) (define (mod-mappings m) (list-ref m 6))
(define (mod-runtime-paths m) (list-ref m 7))
(define (generate-prefix) (define (generate-prefix)
(format "#%embedded:~a:" (gensym))) (format "#%embedded:~a:" (gensym)))
(define (normalize filename) (define (normalize filename)
(simplify-path (expand-path filename))) (normal-case-path (simplify-path (expand-path filename))))
(define (is-lib-path? a) (define (is-lib-path? a)
(and (pair? a) (and (pair? a)
@ -331,9 +332,8 @@
(define-struct extension (path)) (define-struct extension (path))
;; Loads module code, using .zo if there, compiling from .scm if not ;; Loads module code, using .zo if there, compiling from .scm if not
(define (get-code filename module-path codes prefixes verbose? collects-dest on-extension) (define (get-code filename module-path codes prefixes verbose? collects-dest on-extension
(when verbose? compiler expand-namespace)
(fprintf (current-error-port) "Getting ~s~n" filename))
(let ([a (assoc filename (unbox codes))]) (let ([a (assoc filename (unbox codes))])
(if a (if a
;; Already have this module. Make sure that library-referenced ;; Already have this module. Make sure that library-referenced
@ -349,9 +349,12 @@
filename)] filename)]
[else 'ok])) [else 'ok]))
;; First use of the module. Get code and then get code for imports. ;; First use of the module. Get code and then get code for imports.
(begin
(when verbose?
(fprintf (current-error-port) "Getting ~s~n" filename))
(let ([code (get-module-code filename (let ([code (get-module-code filename
"compiled" "compiled"
compile compiler
(if on-extension (if on-extension
(lambda (f l?) (lambda (f l?)
(on-extension f l?) (on-extension f l?)
@ -374,7 +377,7 @@
(cons (make-mod filename module-path code (cons (make-mod filename module-path code
name prefix (string->symbol name prefix (string->symbol
(format "~a~a" prefix name)) (format "~a~a" prefix name))
null) null null)
(unbox codes)))] (unbox codes)))]
[code [code
(let-values ([(imports fs-imports ft-imports) (module-compiled-imports code)]) (let-values ([(imports fs-imports ft-imports) (module-compiled-imports code)])
@ -392,8 +395,30 @@
prefixes prefixes
verbose? verbose?
collects-dest collects-dest
on-extension)) on-extension
compiler
expand-namespace))
sub-files sub-paths) sub-files sub-paths)
(let ([runtime-paths
(parameterize ([current-namespace expand-namespace])
(eval code)
(let ([module-path
(if (path? module-path)
(path->complete-path module-path)
module-path)])
(syntax-case (expand `(module m mzscheme
(require (only ,module-path)
(lib "runtime-path.ss"))
(runtime-paths ,module-path))) (quote)
[(_ m mz (#%mb rfs req (quote (spec ...))))
(syntax-object->datum #'(spec ...))]
[_else (error 'create-empbedding-executable
"expansion mismatch when getting external paths")])))])
(when verbose?
(unless (null? runtime-paths)
(fprintf (current-error-port) "Runtime paths for ~s: ~s\n"
filename
runtime-paths)))
(if (and collects-dest (if (and collects-dest
(is-lib-path? module-path)) (is-lib-path? module-path))
;; Install code as .zo: ;; Install code as .zo:
@ -405,7 +430,7 @@
;; Record module as copied ;; Record module as copied
(set-box! codes (set-box! codes
(cons (make-mod filename module-path #f (cons (make-mod filename module-path #f
#f #f #f #f) #f #f #f #f null)
(unbox codes)))) (unbox codes))))
;; Build up relative module resolutions, relative to this one, ;; Build up relative module resolutions, relative to this one,
;; that will be requested at run-time. ;; that will be requested at run-time.
@ -427,14 +452,15 @@
(format "~a~a" prefix name)) (format "~a~a" prefix name))
(filter (lambda (p) (filter (lambda (p)
(and p (cdr p))) (and p (cdr p)))
mappings)) mappings)
(unbox codes))))))))] runtime-paths)
(unbox codes)))))))))]
[else [else
(set-box! codes (set-box! codes
(cons (make-mod filename module-path code (cons (make-mod filename module-path code
name #f #f name #f #f
null) null null)
(unbox codes)))]))))) (unbox codes)))]))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -475,7 +501,7 @@
(if a2 (if a2
(cdr a2) (cdr a2)
;; No relative mapping found (presumably a lib) ;; No relative mapping found (presumably a lib)
(orig name rel-to stx))) (orig name rel-to stx load?)))
;; A library mapping that we have? ;; A library mapping that we have?
(let ([a3 (and (pair? name) (let ([a3 (and (pair? name)
(eq? (car name) 'lib) (eq? (car name) 'lib)
@ -519,7 +545,7 @@
;; Write a module bundle that can be loaded with 'load' (do not embed it ;; Write a module bundle that can be loaded with 'load' (do not embed it
;; into an executable). The bundle is written to the current output port. ;; into an executable). The bundle is written to the current output port.
(define (write-module-bundle verbose? modules literal-files literal-expression collects-dest (define (write-module-bundle verbose? modules literal-files literal-expression collects-dest
on-extension program-name) on-extension program-name compiler expand-namespace)
(let* ([module-paths (map cadr modules)] (let* ([module-paths (map cadr modules)]
[files (map [files (map
(lambda (mp) (lambda (mp)
@ -548,7 +574,7 @@
;; loasing imports, so the list in the right order. ;; loasing imports, so the list in the right order.
[codes (box null)]) [codes (box null)])
(for-each (lambda (f mp) (get-code f mp codes prefix-mapping verbose? collects-dest (for-each (lambda (f mp) (get-code f mp codes prefix-mapping verbose? collects-dest
on-extension)) on-extension compiler expand-namespace))
files files
collapsed-mps) collapsed-mps)
;; Drop elements of `codes' that just record copied libs: ;; Drop elements of `codes' that just record copied libs:
@ -558,10 +584,24 @@
(write (make-module-name-resolver (filter mod-code (unbox codes)))) (write (make-module-name-resolver (filter mod-code (unbox codes))))
;; Write the extension table and copy module code: ;; Write the extension table and copy module code:
(let* ([l (unbox codes)] (let* ([l (unbox codes)]
[extensions (filter (lambda (m) (extension? (mod-code m))) l)]) [extensions (filter (lambda (m) (extension? (mod-code m))) l)]
[runtimes (filter (lambda (m) (pair? (mod-runtime-paths m))) l)]
[table-mod
(if (null? runtimes)
#f
(let* ([table-sym (module-path-index-resolve
(module-path-index-join '(lib "runtime-path-table.ss" "mzlib" "private")
'mzscheme))]
[table-path (bytes->path
(bytes-append
(subbytes (string->bytes/latin-1 (symbol->string table-sym))
1)
#".ss"))])
(assoc (normalize table-path) l)))])
(unless (null? extensions) (unless (null? extensions)
;; The extension table:
(write (write
`(let ([eXtEnSiOn-modules ;; this name is magic for the exe -> distribution process `(let ([eXtEnSiOn-modules ;; this name is magic for the exe->distribution process
(quote ,(map (lambda (m) (quote ,(map (lambda (m)
(let ([p (extension-path (mod-code m))]) (let ([p (extension-path (mod-code m))])
(when verbose? (when verbose?
@ -582,9 +622,53 @@
(path->complete-path p (current-directory)))) (path->complete-path p (current-directory))))
p)))) p))))
eXtEnSiOn-modules)))) eXtEnSiOn-modules))))
;; Runtime-path table:
(unless (null? runtimes)
(unless table-mod
(error 'create-embedding-executable "cannot find module for runtime-path table"))
(write `(current-module-name-prefix ',(string->symbol (mod-prefix table-mod))))
(write `(module runtime-path-table mzscheme
(provide table)
(define table
(make-immutable-hash-table
(let ([rUnTiMe-paths ; this is a magic name for exe->distribution process
',(apply append
(map (lambda (nc)
(map (lambda (p)
(list
(cons (mod-full-name nc)
(if (path? p)
(path->bytes p)
p))
(let ([p (cond
[(bytes? p) (bytes->path p)]
[(and (list? p) (= 2 (length p))
(eq? 'so (car p)))
(let ([f (path-replace-suffix (cadr p)
(system-type 'so-suffix))])
(ormap (lambda (p)
(let ([p (build-path p f)])
(and (file-exists? p)
p)))
(get-lib-search-dirs)))]
[else p])])
(and p
(path->bytes
(if (absolute-path? p)
p
(build-path (path-only (mod-file nc)) p)))))
;; As for the extension table, a placeholder to save
;; room likely needed by the distribution-mangler
(bytes-append #"................." (path->bytes program-name))))
(mod-runtime-paths nc)))
runtimes))])
rUnTiMe-paths)
'equal)))))
;; Copy module code:
(for-each (for-each
(lambda (nc) (lambda (nc)
(unless (extension? (mod-code nc)) (unless (or (extension? (mod-code nc))
(eq? nc table-mod))
(when verbose? (when verbose?
(fprintf (current-error-port) "Writing module from ~s~n" (mod-file nc))) (fprintf (current-error-port) "Writing module from ~s~n" (mod-file nc)))
(write `(current-module-name-prefix ',(string->symbol (mod-prefix nc)))) (write `(current-module-name-prefix ',(string->symbol (mod-prefix nc))))
@ -637,7 +721,11 @@
[variant (system-type 'gc)] [variant (system-type 'gc)]
[collects-path #f] [collects-path #f]
[collects-dest #f] [collects-dest #f]
[on-extension #f]) [on-extension #f]
[expand-namespace (current-namespace)]
[compiler (lambda (expr)
(parameterize ([current-namespace expand-namespace])
(compile expr)))])
(define keep-exe? (and launcher? (define keep-exe? (and launcher?
(let ([m (assq 'forget-exe? aux)]) (let ([m (assq 'forget-exe? aux)])
(or (not m) (or (not m)
@ -734,7 +822,9 @@
(lambda () (lambda ()
(write-module-bundle verbose? modules literal-files literal-expression collects-dest (write-module-bundle verbose? modules literal-files literal-expression collects-dest
on-extension on-extension
(file-name-from-path dest)))]) (file-name-from-path dest)
compiler
expand-namespace))])
(let-values ([(start end) (let-values ([(start end)
(if (and (eq? (system-type) 'macosx) (if (and (eq? (system-type) 'macosx)
(not unix-starter?)) (not unix-starter?))

24
collects/mzlib/etc.ss
View File

@ -380,9 +380,23 @@
(not (eq? (namespace-variable-value n #t (lambda () ns-undefined)) (not (eq? (namespace-variable-value n #t (lambda () ns-undefined))
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) (define-syntax (this-expression-source-directory stx)
(syntax-case stx () (syntax-case stx ()
[(_) [(_)
(let ([source-path
(let* ([source (syntax-source stx)] (let* ([source (syntax-source stx)]
[source (and (path? source) source)] [source (and (path? source) source)]
[local (or (current-load-relative-directory) (current-directory))] [local (or (current-load-relative-directory) (current-directory))]
@ -395,9 +409,15 @@
local))]) local))])
(if (and (pair? dir) (eq? 'collects (car dir))) (if (and (pair? dir) (eq? 'collects (car dir)))
(with-syntax ([d dir]) (with-syntax ([d dir])
#'(main-collects-relative->path 'd)) (syntax/loc stx (main-collects-relative->path 'd)))
(with-syntax ([d (if (bytes? dir) dir (path->bytes dir))]) (with-syntax ([d (if (bytes? dir) dir (path->bytes dir))])
#'(bytes->path d))))])) (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) (define-syntax (this-expression-file-name stx)
(syntax-case 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) (define (get-uncovered-expressions eval . args)
(apply (eval get-uncovered-expressions) 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 (make-evaluator* init-hook require-perms program-or-maker)
(define cust (make-custodian)) (define cust (make-custodian))
(define coverage? (sandbox-coverage-enabled)) (define coverage? (sandbox-coverage-enabled))

26
collects/openssl/mzssl.ss
View File

@ -16,7 +16,8 @@
(module mzssl mzscheme (module mzssl mzscheme
(require (lib "foreign.ss") (require (lib "foreign.ss")
(lib "port.ss") (lib "port.ss")
(lib "kw.ss")) (lib "kw.ss")
(lib "runtime-path.ss"))
(provide ssl-available? (provide ssl-available?
ssl-load-fail-reason ssl-load-fail-reason
@ -48,6 +49,17 @@
(unsafe!) (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 ssl-load-fail-reason #f)
(define 3m? (regexp-match #rx#"3m" (path->bytes (system-library-subpath)))) (define 3m? (regexp-match #rx#"3m" (path->bytes (system-library-subpath))))
@ -56,22 +68,14 @@
(with-handlers ([exn:fail? (lambda (x) (with-handlers ([exn:fail? (lambda (x)
(set! ssl-load-fail-reason (exn-message x)) (set! ssl-load-fail-reason (exn-message x))
#f)]) #f)])
(case (system-type) (ffi-lib libcrypto-so)))
[(windows)
(ffi-lib "libeay32")]
[else
(ffi-lib "libcrypto")])))
(define libssl (define libssl
(and libcrypto (and libcrypto
(with-handlers ([exn:fail? (lambda (x) (with-handlers ([exn:fail? (lambda (x)
(set! ssl-load-fail-reason (exn-message x)) (set! ssl-load-fail-reason (exn-message x))
#f)]) #f)])
(case (system-type) (ffi-lib libssl-so))))
[(windows)
(ffi-lib "ssleay32")]
[else
(ffi-lib "libssl")]))))
(define libmz (ffi-lib #f)) (define libmz (ffi-lib #f))

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

@ -1,11 +1,12 @@
(module fit-low-level mzscheme (module fit-low-level mzscheme
(require (lib "foreign.ss") (lib "etc.ss")) (require (lib "foreign.ss") (lib "runtime-path.ss"))
(unsafe!) (unsafe!)
(define libfit (define-runtime-path libfit-path
(ffi-lib (build-path (this-expression-source-directory) (build-path "compiled" "native" (system-library-subpath #f)
"compiled" "native" (system-library-subpath #f) (path-replace-suffix "libfit" (system-type 'so-suffix))))
"libfit")))
(define libfit (ffi-lib libfit-path))
(define do-fit-int (define do-fit-int
(get-ffi-obj "do_fit" libfit (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 (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!) (unsafe!)
(define libplplot (define-runtime-path plplot-path
(ffi-lib (build-path "compiled" "native" (system-library-subpath #f)
(build-path (this-expression-source-directory) (path-replace-suffix "libplplot" (system-type 'so-suffix))))
"compiled" "native" (system-library-subpath #f) "libplplot"))) (define-runtime-path font-dir "fonts")
(define libplplot (ffi-lib plplot-path))
(define plplotlibdir (get-ffi-obj "plplotLibDir" libplplot _string)) (define plplotlibdir (get-ffi-obj "plplotLibDir" libplplot _string))
;; set the lib dir to contain the fonts: ;; set the lib dir to contain the fonts:
(let ([path (this-expression-source-directory)]) (let ([path font-dir])
;; free current pointer, if any: ;; free current pointer, if any:
(let ([p (get-ffi-obj "plplotLibDir" libplplot _pointer)]) (let ([p (get-ffi-obj "plplotLibDir" libplplot _pointer)])
(when p (free p))) (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, ;; path normalization is not really necessary by any existing code,
;; but there might be applications that rely on these paths, so it's ;; but there might be applications that rely on these paths, so it's
;; best to do some minor normalization. This is similar to what ;; best to do some minor normalization. This is similar to what
;; "main-collects.ss" does. Again, this makes mzscheme expand paths ;; "main-collects.ss" does.
;; that begin with `~'.
;; Note: (expand-path (simplify-path P #f)) is bogus, if P is
;; "./~foo" or "~foo/.."
(define (system-path* what) (define (system-path* what)
(simplify-path (expand-path (find-system-path what)) #f)) (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 > (provide-and-document doc-label-id doc-row ...) - a form that
exports names and records documentation information. 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 The `doc-label-id' identifier is used as a key for accessing the
documentation through `lookup-documentation'. The actual documentation through `lookup-documentation'. The actual
documentation is organized into "rows", each with a section title. documentation is organized into "rows", each with a section title.

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

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

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

@ -4,33 +4,52 @@
(Section 'embed) (Section 'embed)
(require (lib "embed.ss" "compiler") (require (lib "embed.ss" "compiler")
(lib "process.ss")) (lib "file.ss")
(lib "process.ss")
(lib "distribute.ss" "compiler"))
(define (mk-dest mred?) (define (mk-dest-bin mred?)
(build-path (find-system-path 'temp-dir)
(case (system-type) (case (system-type)
[(windows) "e.exe"] [(windows) "e.exe"]
[(unix) "e"] [(unix) "e"]
[(macosx) (if mred? [(macosx) (if mred?
"e.app" "e.app"
"e")]))) "e")]))
(define (mk-dest mred?)
(build-path (find-system-path 'temp-dir)
(mk-dest-bin mred?)))
(define mz-dest (mk-dest #f)) (define mz-dest (mk-dest #f))
(define mr-dest (mk-dest #t)) (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) (define (prepare exe src)
(printf "Making ~a with ~a...~n" exe src) (printf "Making ~a with ~a...~n" exe src)
(when (file-exists? exe) (when (file-exists? exe)
(delete-file 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")] (let ([plthome (getenv "PLTHOME")]
[collects (getenv "PLTCOLLECTS")]) [collects (getenv "PLTCOLLECTS")])
;; Try to hide usual collections: ;; Try to hide usual collections:
(when plthome (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 (when collects
(putenv "PLTCOLLECTS" (path->string (find-system-path 'temp-dir)))) (putenv "PLTCOLLECTS" (path->string (build-path (find-system-path 'temp-dir) "NOPE"))))
;; Execute: ;; Execute:
(parameterize ([current-directory (find-system-path 'temp-dir)]) (parameterize ([current-directory (find-system-path 'temp-dir)])
(when (file-exists? "stdout") (when (file-exists? "stdout")
@ -47,6 +66,24 @@
(test expect with-input-from-file (build-path (find-system-path 'temp-dir) "stdout") (test expect with-input-from-file (build-path (find-system-path 'temp-dir) "stdout")
(lambda () (read-string 5000))))) (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 (mz-tests mred?)
(define dest (if mred? mr-dest mz-dest)) (define dest (if mred? mr-dest mz-dest))
(define (flags s) (define (flags s)
@ -161,19 +198,22 @@
(mz-tests #f) (mz-tests #f)
(mz-tests #t) (mz-tests #t)
(prepare mr-dest "embed-me5.ss") (begin
(make-embedding-executable (prepare mr-dest "embed-me5.ss")
(make-embedding-executable
mr-dest #t #f mr-dest #t #f
`((#t (lib "embed-me5.ss" "tests" "mzscheme"))) `((#t (lib "embed-me5.ss" "tests" "mzscheme")))
null null
null null
`("-ZmvqL" "embed-me5.ss" "tests/mzscheme")) `("-ZmvqL" "embed-me5.ss" "tests/mzscheme"))
(try-exe mr-dest "This is 5: #<struct:class:button%>\n" #t) (try-exe mr-dest "This is 5: #<struct:class:button%>\n" #t))
;; Try the mzc interface: ;; Try the mzc interface:
(require (lib "dirs.ss" "setup") (require (lib "dirs.ss" "setup")
(lib "file.ss")) (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?) (define (mzc-tests mred?)
(parameterize ([current-directory (find-system-path 'temp-dir)]) (parameterize ([current-directory (find-system-path 'temp-dir)])
@ -206,7 +246,8 @@
"--collects-path" "--collects-path"
(path->string (find-collects-dir)) (path->string (find-collects-dir))
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) (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 ;; Try --collects-dest mode
(system* mzc (system* mzc
@ -216,7 +257,7 @@
"--collects-dest" "cts" "--collects-dest" "cts"
"--collects-path" "cts" "--collects-path" "cts"
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me6.ss"))) (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") (delete-directory/files "cts")
(try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?) (try-exe (mk-dest mred?) "This is 6\nno etc.ss\n" mred?)
@ -225,7 +266,65 @@
(mzc-tests #t) (mzc-tests #t)
(mzc-tests #f) (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)]) (parameterize ([current-directory (find-system-path 'temp-dir)])
(system* mzc (system* mzc
"--gui-exe" "--gui-exe"
@ -233,6 +332,19 @@
(path->string (build-path (collection-path "tests" "mzscheme") "embed-me5.ss"))) (path->string (build-path (collection-path "tests" "mzscheme") "embed-me5.ss")))
(try-exe (mk-dest #t) "This is 5: #<struct:class:button%>\n" #t)) (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) (report-errs)

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

@ -284,8 +284,8 @@
(lambda () (lambda ()
(write `(module tmp2 mzscheme (require ,f1)))) (write `(module tmp2 mzscheme (require ,f1))))
'truncate/replace) 'truncate/replace)
(err/rt-test (dynamic-require f1 #f) exn:fail-cycle?) (err/rt-test (dynamic-require (build-path (current-directory) f1) #f) exn:fail-cycle?)
(err/rt-test (dynamic-require f2 #f) exn:fail-cycle?) (err/rt-test (dynamic-require (build-path (current-directory) f2) #f) exn:fail-cycle?)
(delete-file f1) (delete-file f1)
(delete-file f2)) (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 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 to editor-snip%; changes the editor-snip WXME format
Version 369.6 Version 369.6
WXME file format changed to include a #reader() prefix 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) wx:the-buffer-data-class-list was replaced by (wx:get-the-buffer-data-class-list)
Added transparent text backing for editor text Added transparent text backing for editor text
Added wx:dc% try-colour method 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 Modal dialogs can be used instead of make-modal (modal is
specified through the constructor). There is currently no specified through the constructor). There is currently no
replacement for capture-mouse and release-mouse, but a replacement is 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 Version 369.9
Module top-level enforces initial categorization of expressions Module top-level enforces initial categorization of expressions
versus other forms 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_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_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_split(int argc, Scheme_Object *argv[]);
static Scheme_Object *module_path_index_join(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?", "module-path-index?",
1, 1, 1), 1, 1, 1),
env); 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_add_global_constant("module-path-index-split",
scheme_make_prim_w_arity2(module_path_index_split, scheme_make_prim_w_arity2(module_path_index_split,
"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); : 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[]) static Scheme_Object *module_path_index_split(int argc, Scheme_Object *argv[])
{ {
Scheme_Modidx *modidx; Scheme_Modidx *modidx;

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

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

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

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 369 #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()" "(let()"
" expr1" " expr1"
" expr ...))))))))" " 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)" "(define(current-parameterization)"
"(extend-parameterization(continuation-mark-set-first #f parameterization-key)))" "(extend-parameterization(continuation-mark-set-first #f parameterization-key)))"
"(define(call-with-parameterization paramz thunk)" "(define(call-with-parameterization paramz thunk)"
@ -2855,7 +2863,7 @@
" (printf \"cpu time: ~s real time: ~s gc time: ~s~n\" cpu user gc)" " (printf \"cpu time: ~s real time: ~s gc time: ~s~n\" cpu user gc)"
"(apply values v)))))))" "(apply values v)))))))"
"(provide case do delay force promise?" "(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" " parameterize-break current-break-parameterization call-with-break-parameterization"
" with-handlers with-handlers* call-with-exception-handler" " with-handlers with-handlers* call-with-exception-handler"
" set!-values" " set!-values"
@ -3294,7 +3302,7 @@
"((path? s) " "((path? s) "
"(if(absolute-path? s)" "(if(absolute-path? s)"
" s" " s"
" (list \"(a path must be absolute)\")))" " (list \" (a path must be absolute)\")))"
"((or(not(pair? s))" "((or(not(pair? s))"
"(not(list? s)))" "(not(list? s)))"
" #f)" " #f)"

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

@ -3069,6 +3069,15 @@
expr1 expr1
expr ...))))]))) 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) (define (current-parameterization)
(extend-parameterization (continuation-mark-set-first #f parameterization-key))) (extend-parameterization (continuation-mark-set-first #f parameterization-key)))
@ -3288,7 +3297,7 @@
(apply values v)))]))) (apply values v)))])))
(provide case do delay force promise? (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 parameterize-break current-break-parameterization call-with-break-parameterization
with-handlers with-handlers* call-with-exception-handler with-handlers with-handlers* call-with-exception-handler
set!-values set!-values
@ -3770,7 +3779,7 @@
[(path? s) [(path? s)
(if (absolute-path? s) (if (absolute-path? s)
s s
(list "(a path must be absolute)"))] (list " (a path must be absolute)"))]
[(or (not (pair? s)) [(or (not (pair? s))
(not (list? s))) (not (list? s)))
#f] #f]

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

@ -3371,6 +3371,9 @@ Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve)
src = SCHEME_VEC_ELS(vec)[1]; src = SCHEME_VEC_ELS(vec)[1];
dest = SCHEME_VEC_ELS(vec)[2]; dest = SCHEME_VEC_ELS(vec)[2];
/* If src is #f, shift is just for phase; no redirection */
if (!SCHEME_FALSEP(src)) {
if (!chain_from) { if (!chain_from) {
srcmod = dest; srcmod = dest;
} else if (!SAME_OBJ(chain_from, dest)) { } else if (!SAME_OBJ(chain_from, dest)) {
@ -3381,6 +3384,7 @@ Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve)
chain_from = src; chain_from = src;
} }
}
WRAP_POS_INC(w); WRAP_POS_INC(w);
} }
@ -4185,16 +4189,10 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
/* chain-specific cache; drop it */ /* chain-specific cache; drop it */
} else { } else {
/* box, a phase shift */ /* box, a phase shift */
/* Any more rename tables? */ /* We used to drop a phase shift if there are no following
WRAP_POS l; rename tables. However, the phase shift also identifies
WRAP_POS_COPY(l, w); the source module, which can be relevant. So, keep the
while (!WRAP_POS_END_P(l)) { phase shift. */
if (SCHEME_RENAMESP(WRAP_POS_FIRST(l)))
break;
WRAP_POS_INC(l);
}
/* 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: */ /* Need the phase shift, but drop the export table, if any: */
Scheme_Object *aa; Scheme_Object *aa;
aa = SCHEME_BOX_VAL(a); aa = SCHEME_BOX_VAL(a);
@ -4211,7 +4209,6 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
stack_size++; stack_size++;
} }
} }
}
if (just_simplify) { if (just_simplify) {
if (stack_size) { if (stack_size) {