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

improve runtime-path support for building stand-alone gui exes

Browse Source 
original commit: 75a6bfe119d97ef81a28626bebe2b33799d41c06
This commit is contained in:
Matthew Flatt 2010-10-22 19:01:27 -06:00
parent 27f087f38f
commit cb9880c410
1 changed files with 49 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
collects/mzlib/runtime-path.rkt
View File

@ -11,24 +11,23 @@
(provide define-runtime-path (provide define-runtime-path
define-runtime-paths define-runtime-paths
define-runtime-path-list define-runtime-path-list
define-runtime-module-path
runtime-paths) runtime-paths)
(define-for-syntax ext-file-table (make-hasheq)) (define-for-syntax ext-file-table (make-hasheq))
(define (lookup-in-table tag-stx p) (define (lookup-in-table var-ref p)
;; This function is designed to cooperate with a table embedded ;; This function is designed to cooperate with a table embedded
;; in an executable by create-embedding-executable. ;; in an executable by create-embedding-executable.
(let ([mpi (syntax-source-module tag-stx)]) (let ([modname (variable-reference->resolved-module-path var-ref)])
(let ([p (hash-ref (let ([p (hash-ref
table table
(cons (cond (cons (resolved-module-path-name modname)
[(module-path-index? mpi)
(resolved-module-path-name (module-path-index-resolve mpi))]
[(symbol? mpi) mpi]
[else #f])
(if (path? p) (if (path? p)
(path->bytes p) (path->bytes p)
p)) (if (and (pair? p) (eq? 'module (car p)))
(list 'module (cadr p))
p)))
#f)]) #f)])
(and p (and p
(car p) (car p)
@ -36,11 +35,13 @@
[p (if (bytes? p) [p (if (bytes? p)
(bytes->path p) (bytes->path p)
p)]) p)])
(if (symbol? p)
(module-path-index-join (list 'quote p) #f) ; make it a module path index
(if (absolute-path? p) (if (absolute-path? p)
p p
(parameterize ([current-directory (find-system-path 'orig-dir)]) (parameterize ([current-directory (find-system-path 'orig-dir)])
(or (find-executable-path (find-system-path 'exec-file) p #t) (or (find-executable-path (find-system-path 'exec-file) p #t)
(build-path (current-directory) p))))))))) (build-path (current-directory) p))))))))))
(define (resolve-paths tag-stx get-base paths) (define (resolve-paths tag-stx get-base paths)
(let ([base #f]) (let ([base #f])
@ -85,18 +86,24 @@
(null? (cdr strs))) (null? (cdr strs)))
(list "mzlib") (list "mzlib")
(append (cddr p) (drop-right strs 1)))))] (append (cddr p) (drop-right strs 1)))))]
[(and (list? p)
((length p) . = . 3)
(eq? 'module (car p))
(or (not (caddr p))
(variable-reference? (caddr p))))
(let ([p (cadr p)]
[vr (caddr p)])
(unless (module-path? p)
(error 'runtime-path "not a module path: ~.s" p))
(module-path-index-join p (and vr
(variable-reference->resolved-module-path vr))))]
[else (error 'runtime-path "unknown form: ~.s" p)]))) [else (error 'runtime-path "unknown form: ~.s" p)])))
paths))) paths)))
(define-for-syntax (register-ext-files tag-stx paths) (define-for-syntax (register-ext-files var-ref paths)
(let ([mpi (syntax-source-module tag-stx)]) (let ([modname (variable-reference->resolved-module-path var-ref)])
(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-ref ext-file-table modname null)]) (let ([files (hash-ref ext-file-table modname null)])
(hash-set! ext-file-table modname (append paths files)))))) (hash-set! ext-file-table modname (append paths files)))))
(define-syntax (-define-runtime-path stx) (define-syntax (-define-runtime-path stx)
(syntax-case stx () (syntax-case stx ()
@ -111,23 +118,22 @@
#'orig-stx #'orig-stx
id))) id)))
ids) ids)
(let ([tag (datum->syntax #'orig-stx 'tag #'orig-stx)])
#`(begin #`(begin
(define-values (id ...) (define-values (id ...)
(let-values ([(id ...) expr]) (let-values ([(id ...) expr])
(let ([get-dir (lambda () (let ([get-dir (lambda ()
#,(datum->syntax #,(datum->syntax
tag #'orig-stx
`(,#'this-expression-source-directory) `(,#'this-expression-source-directory)
tag))]) #'orig-stx))])
(apply to-values (resolve-paths (quote-syntax #,tag) (apply to-values (resolve-paths (#%variable-reference)
get-dir get-dir
(to-list id ...)))))) (to-list id ...))))))
(begin-for-syntax (begin-for-syntax
(register-ext-files (register-ext-files
(quote-syntax #,tag) (#%variable-reference)
(let-values ([(id ...) expr]) (let-values ([(id ...) expr])
(to-list id ...)))))))])) (to-list id ...))))))]))
(define-syntax (define-runtime-path stx) (define-syntax (define-runtime-path stx)
(syntax-case stx () (syntax-case stx ()
@ -141,6 +147,10 @@
(syntax-case stx () (syntax-case stx ()
[(_ id expr) #`(-define-runtime-path #,stx (id) expr values list)])) [(_ id expr) #`(-define-runtime-path #,stx (id) expr values list)]))
(define-syntax (define-runtime-module-path stx)
(syntax-case stx ()
[(_ id expr) #`(-define-runtime-path #,stx (id) `(module ,expr ,(#%variable-reference)) list values)]))
(define-syntax (runtime-paths stx) (define-syntax (runtime-paths stx)
(syntax-case stx () (syntax-case stx ()
[(_ mp) [(_ mp)