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

misc minor improvements

Browse Source 
svn: r16553
This commit is contained in:
Eli Barzilay 2009-11-05 07:15:30 +00:00
parent 37adbb42a8
commit c696c7e88c
1 changed files with 246 additions and 319 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

531
collects/launcher/launcher-unit.ss
View File

@ -1,9 +1,9 @@
#lang scheme/unit #lang scheme/unit
(require scheme/path (require scheme/path
scheme/file scheme/file
scheme/list scheme/list
scheme/string
compiler/embed compiler/embed
setup/dirs setup/dirs
@ -33,9 +33,9 @@
(eq? kind 'mzscheme))) (eq? kind 'mzscheme)))
(let ([bin-dir (find-console-bin-dir)]) (let ([bin-dir (find-console-bin-dir)])
(and bin-dir (and bin-dir
(file-exists? (build-path (file-exists?
bin-dir (build-path bin-dir
(format "~a~a" kind (variant-suffix variant #f))))))] (format "~a~a" kind (variant-suffix variant #f))))))]
[(eq? 'macosx (system-type)) [(eq? 'macosx (system-type))
;; kind must be mred, because mzscheme case is caught above ;; kind must be mred, because mzscheme case is caught above
(directory-exists? (build-path (find-gui-bin-dir) (directory-exists? (build-path (find-gui-bin-dir)
@ -43,12 +43,10 @@
cased-kind-name cased-kind-name
(variant-suffix variant #f))))] (variant-suffix variant #f))))]
[(eq? 'windows (system-type)) [(eq? 'windows (system-type))
(file-exists? (build-path (if (eq? kind 'mzscheme) (file-exists?
(find-console-bin-dir) (build-path
(find-gui-bin-dir)) (if (eq? kind 'mzscheme) (find-console-bin-dir) (find-gui-bin-dir))
(format "~a~a.exe" (format "~a~a.exe" cased-kind-name (variant-suffix variant #t))))]
cased-kind-name
(variant-suffix variant #t))))]
[else (error "unknown system type")])) [else (error "unknown system type")]))
(define (available-variants kind) (define (available-variants kind)
@ -99,64 +97,46 @@
(memq v '(script-3m script-cgc))) (memq v '(script-3m script-cgc)))
(define (add-file-suffix path variant mred?) (define (add-file-suffix path variant mred?)
(let ([s (variant-suffix variant (case (system-type) (let ([s (variant-suffix
[(unix) #f] variant
[(windows) #t] (case (system-type)
[(macosx) (and mred? [(unix) #f]
(not (script-variant? variant)))]))]) [(windows) #t]
[(macosx) (and mred? (not (script-variant? variant)))]))])
(if (string=? "" s) (if (string=? "" s)
path path
(path-replace-suffix
path
(string->bytes/utf-8
(if (and (eq? 'windows (system-type)) (if (and (eq? 'windows (system-type))
(regexp-match #rx#"[.]exe$" (path->bytes path))) (regexp-match #rx#"[.]exe$" (path->bytes path)))
(path-replace-suffix path (string->bytes/utf-8 (format "~a.exe" s)
(format "~a.exe" s))) s))))))
(path-replace-suffix path (string->bytes/utf-8 s))))))
(define (string-append/spaces f flags) (define (string-append/spaces f flags)
(if (null? flags) (string-append* (append-map (lambda (x) (list (f x) " ")) flags)))
""
(string-append
(f (car flags))
" "
(string-append/spaces f (cdr flags)))))
(define (str-list->sh-str flags) (define (str-list->sh-str flags)
(letrec ([trans (string-append/spaces
(lambda (s) (lambda (s)
(cond (string-append "'" (regexp-replace* #rx"'" s "'\"'\"'") "'"))
[(regexp-match "(.*)'(.*)" s) flags))
=> (lambda (m)
(string-append (trans (cadr m))
"\"'\""
(trans (caddr m))))]
[else (format "'~a'" s)]))])
(string-append/spaces trans flags)))
(define (str-list->dos-str flags) (define (str-list->dos-str flags)
(letrec ([trans (define (trans s)
(lambda (s) (if (not (regexp-match? #rx"[ \n\t\r\v\"\\]" s))
(if (or (regexp-match (string #\[ #\space #\newline #\tab #\return #\vtab #\]) s) s
(regexp-match "\"" s) (list->string
(regexp-match "\\\\" s)) (let loop ([l (string->list s)] [slashes '()])
(list->string (cond [(null? l) '()]
(let loop ([l (string->list s)][wrote-slash 0]) [(char-whitespace? (car l))
(cond `(,@slashes #\" ,(car l) #\" ,@(loop (cdr l) '()))]
[(null? l) null] [(eq? #\\ (car l))
[(char-whitespace? (car l)) `(#\\ ,@(loop (cdr l) (cons #\\ slashes)))]
(append [(eq? #\" (car l))
(string->list (make-string wrote-slash #\\)) `(,@slashes #\" #\\ #\" #\" ,@(loop (cdr l) '()))]
(list #\" (car l) #\") [else `(,(car l) ,@(loop (cdr l) '()))])))))
(loop (cdr l) 0))] (string-append/spaces trans flags))
[else
(case (car l)
[(#\\) (cons #\\ (loop (cdr l) (add1 wrote-slash)))]
[(#\") (append
(string->list (make-string wrote-slash #\\))
`(#\" #\\ #\" #\")
(loop (cdr l) 0))]
[else (cons (car l) (loop (cdr l) 0))])])))
s))])
(string-append/spaces trans flags)))
(define one-arg-x-flags '((xa "-display") (define one-arg-x-flags '((xa "-display")
(xb "-geometry") (xb "-geometry")
@ -177,28 +157,15 @@
(define (skip-x-flags flags) (define (skip-x-flags flags)
(let ([xfmem (lambda (flag) (lambda (xf) (member flag (cdr xf))))]) (let ([xfmem (lambda (flag) (lambda (xf) (member flag (cdr xf))))])
(let loop ([f flags]) (let loop ([f flags])
(if (null? f) (cond [(null? f) null]
null [(ormap (xfmem (car f)) one-arg-x-flags)
(if (ormap (xfmem (car f)) one-arg-x-flags) (if (null? (cdr f)) null (loop (cddr f)))]
(if (null? (cdr f)) [(ormap (xfmem (car f)) no-arg-x-flags) (loop (cdr f))]
null [else f]))))
(loop (cddr f)))
(if (ormap (xfmem (car f)) no-arg-x-flags)
(loop (cdr f))
f))))))
(define (output-x-arg-getter exec args) (define (output-x-arg-getter exec args)
(let ([or-flags (let ([or-flags (lambda (l) (string-append* (add-between l " | ")))])
(lambda (l) (string-append*
(if (null? (cdr l))
(car l)
(string-append
(car l)
(apply
string-append
(map (lambda (s) (string-append " | " s)) (cdr l))))))])
(apply
string-append
(append (append
(list "# Find X flags and shift them to the front\n" (list "# Find X flags and shift them to the front\n"
"findxend() {\n" "findxend() {\n"
@ -230,15 +197,15 @@
" findxend ${1+\"$@\"}\n" " findxend ${1+\"$@\"}\n"
"}\nfindxend ${1+\"$@\"}\n") "}\nfindxend ${1+\"$@\"}\n")
exec exec
(apply (string-append*
string-append
(append (append
(map (map (lambda (f)
(lambda (f) (format " ${~a+\"~a\"} ${~a+\"$~a\"}" (car f) (cadr f) (car f) (car f))) (format " ${~a+\"~a\"} ${~a+\"$~a\"}"
one-arg-x-flags) (car f) (cadr f) (car f) (car f)))
(map one-arg-x-flags)
(lambda (f) (format " ${~a+\"~a\"}" (car f) (cadr f))) (map (lambda (f)
no-arg-x-flags))) (format " ${~a+\"~a\"}" (car f) (cadr f)))
no-arg-x-flags)))
args)))))) args))))))
(define (protect-shell-string s) (define (protect-shell-string s)
@ -251,11 +218,9 @@
(define (relativize bindir-explode dest-explode) (define (relativize bindir-explode dest-explode)
(let loop ([b bindir-explode] [d dest-explode]) (let loop ([b bindir-explode] [d dest-explode])
(if (and (pair? b) (equal? (car b) (car d))) (if (and (pair? b) (equal? (car b) (car d)))
(loop (cdr b) (cdr d)) (loop (cdr b) (cdr d))
(let ([p (append (map (lambda (x) 'up) (cdr d)) b)]) (let ([p (append (map (lambda (x) 'up) (cdr d)) b)])
(if (null? p) (if (null? p) #f (apply build-path p))))))
#f
(apply build-path p))))))
(define (make-relative-path-header dest bindir) (define (make-relative-path-header dest bindir)
;; rely only on binaries in /usr/bin:/bin ;; rely only on binaries in /usr/bin:/bin
@ -310,10 +275,7 @@
"\n" "\n"
"bindir=\"$D" "bindir=\"$D"
(let ([s (relativize bindir-explode dest-explode)]) (let ([s (relativize bindir-explode dest-explode)])
(if s (if s (string-append "/" (protect-shell-string s)) ""))
(string-append "/"
(protect-shell-string s))
""))
"\"\n" "\"\n"
"PATH=\"$saveP\"\n") "PATH=\"$saveP\"\n")
;; fallback to absolute path header ;; fallback to absolute path header
@ -396,94 +358,85 @@
(define (make-windows-launcher kind variant flags dest aux) (define (make-windows-launcher kind variant flags dest aux)
(if (not (and (let ([m (assq 'independent? aux)]) (if (not (and (let ([m (assq 'independent? aux)])
(and m (cdr m))))) (and m (cdr m)))))
;; Normal launcher: ;; Normal launcher:
(make-embedding-executable dest (eq? kind 'mred) #f (make-embedding-executable
null null null dest (eq? kind 'mred) #f null null null flags aux #t variant)
flags ;; Independent launcher (needed for Setup PLT):
aux (begin
#t (install-template dest kind "mzstart.exe" "mrstart.exe")
variant) (let ([bstr (bytes->utf-16-bytes
;; Independent launcher (needed for Setup PLT): (string->bytes/utf-8 (str-list->dos-str flags)))]
(begin [p (open-input-file dest)]
(install-template dest kind "mzstart.exe" "mrstart.exe") [m (utf-16-regexp #"<Command Line: Replace This")]
(let ([bstr (bytes->utf-16-bytes [x (utf-16-regexp #"<Executable Directory: Replace This")]
(string->bytes/utf-8 (str-list->dos-str flags)))] [v (utf-16-regexp #"<Executable Variant: Replace This")])
[p (open-input-file dest)] (let* ([exedir (bytes->utf-16-bytes
[m (utf-16-regexp #"<Command Line: Replace This")] (bytes-append
[x (utf-16-regexp #"<Executable Directory: Replace This")] (path->bytes (let ([bin-dir (if (eq? kind 'mred)
[v (utf-16-regexp #"<Executable Variant: Replace This")]) (find-gui-bin-dir)
(let* ([exedir (bytes->utf-16-bytes (find-console-bin-dir))])
(bytes-append (if (let ([m (assq 'relative? aux)])
(path->bytes (let ([bin-dir (if (eq? kind 'mred) (and m (cdr m)))
(find-gui-bin-dir) (or (relativize (normalize+explode-path bin-dir)
(find-console-bin-dir))]) (normalize+explode-path dest))
(if (let ([m (assq 'relative? aux)]) (build-path 'same))
(and m (cdr m))) bin-dir)))
(or (relativize (normalize+explode-path bin-dir) ;; null wchar marks end of executable directory
(normalize+explode-path dest)) #"\0\0"))]
(build-path 'same)) [find-it ; Find the magic start
bin-dir))) (lambda (magic s)
;; null wchar marks end of executable directory (file-position p 0)
#"\0\0"))] (let ([m (regexp-match-positions magic p)])
[find-it ; Find the magic start (if m
(lambda (magic s) (car m)
(file-position p 0) (begin
(let ([m (regexp-match-positions magic p)]) (close-input-port p)
(if m (when (file-exists? dest) (delete-file dest))
(car m) (error 'make-windows-launcher
(begin "Couldn't find ~a position in template" s)))))]
(close-input-port p) [exedir-poslen (find-it x "executable path")]
(when (file-exists? dest) [command-poslen (find-it m "command-line")]
(delete-file dest)) [variant-poslen (find-it v "variant")]
(error [pos-exedir (car exedir-poslen)]
'make-windows-launcher [len-exedir (- (cdr exedir-poslen) (car exedir-poslen))]
(format [pos-command (car command-poslen)]
"Couldn't find ~a position in template" s))))))] [len-command (- (cdr command-poslen) (car command-poslen))]
[exedir-poslen (find-it x "executable path")] [pos-variant (car variant-poslen)]
[command-poslen (find-it m "command-line")] [space (char->integer #\space)]
[variant-poslen (find-it v "variant")] [write-magic
[pos-exedir (car exedir-poslen)] (lambda (p s pos len)
[len-exedir (- (cdr exedir-poslen) (car exedir-poslen))] (file-position p pos)
[pos-command (car command-poslen)] (display s p)
[len-command (- (cdr command-poslen) (car command-poslen))] (display (make-bytes (- len (bytes-length s)) space) p))]
[pos-variant (car variant-poslen)] [check-len
[space (char->integer #\space)] (lambda (len s es)
[write-magic (when (> (bytes-length s) len)
(lambda (p s pos len) (when (file-exists? dest) (delete-file dest))
(file-position p pos) (error
(display s p) (format
(display (make-bytes (- len (bytes-length s)) space) p))] "~a exceeds limit of ~a characters with ~a characters: ~a"
[check-len es len (string-length s) s))))])
(lambda (len s es) (close-input-port p)
(when (> (bytes-length s) len) (check-len len-exedir exedir "executable home directory")
(when (file-exists? dest) (check-len len-command bstr "collection/file name")
(delete-file dest)) (let ([p (open-output-file dest #:exists 'update)])
(error (write-magic p exedir pos-exedir len-exedir)
(format (write-magic p (bytes-append bstr #"\0\0") pos-command len-command)
"~a exceeds limit of ~a characters with ~a characters: ~a" (let* ([suffix (variant-suffix (current-launcher-variant) #t)]
es len (string-length s) s))))]) [suffix-bytes
(close-input-port p) (bytes-append
(check-len len-exedir exedir "executable home directory") (list->bytes
(check-len len-command bstr "collection/file name") (append-map (lambda (c) (list c 0))
(let ([p (open-output-file dest #:exists 'update)]) (bytes->list (string->bytes/latin-1 suffix))))
(write-magic p exedir pos-exedir len-exedir) #"\0\0")])
(write-magic p (bytes-append bstr #"\0\0") pos-command len-command) (write-magic p suffix-bytes pos-variant (bytes-length suffix-bytes)))
(let* ([suffix (variant-suffix (current-launcher-variant) #t)] (close-output-port p)))))))
[suffix-bytes (bytes-append
(list->bytes
(apply append
(map (lambda (c) (list c 0))
(bytes->list (string->bytes/latin-1 suffix)))))
#"\0\0")])
(write-magic p suffix-bytes pos-variant (bytes-length suffix-bytes)))
(close-output-port p)))))))
;; OS X launcher code: ;; OS X launcher code:
; make-macosx-launcher : symbol (listof str) pathname -> ; make-macosx-launcher : symbol (listof str) pathname ->
(define (make-macosx-launcher kind variant flags dest aux) (define (make-macosx-launcher kind variant flags dest aux)
(if (or (eq? kind 'mzscheme) (if (or (eq? kind 'mzscheme) (script-variant? variant))
(script-variant? variant))
;; MzScheme or script launcher is the same as for Unix ;; MzScheme or script launcher is the same as for Unix
(make-unix-launcher kind variant flags dest aux) (make-unix-launcher kind variant flags dest aux)
;; MrEd "launcher" is a stand-alone executable ;; MrEd "launcher" is a stand-alone executable
@ -496,28 +449,23 @@
(define (make-macos-launcher kind variant flags dest aux) (define (make-macos-launcher kind variant flags dest aux)
(install-template dest kind "GoMr" "GoMr") (install-template dest kind "GoMr" "GoMr")
(let ([p (open-input-file dest)]) (let* ([p (open-input-file dest)]
(let ([m (regexp-match-positions #rx#"<Insert offset here>" p)]) [m (regexp-match-positions #rx#"<Insert offset here>" p)])
;; fast-forward to the end: ;; fast-forward to the end:
(let ([s (make-bytes 4096)]) (let ([s (make-bytes 4096)])
(let loop () (let loop ()
(if (eof-object? (read-bytes! s p)) (if (eof-object? (read-bytes! s p)) (file-position p) (loop))))
(file-position p) (let ([data-fork-size (file-position p)])
(loop)))) (close-input-port p)
(let ([data-fork-size (file-position p)]) (let ([p (open-output-file dest #:exists 'update)]
(close-input-port p) [str (str-list->sh-str
(let ([p (open-output-file dest #:exists 'update)] (append (if (eq? kind 'mred) null '("-Z")) flags))])
[str (str-list->sh-str (append (file-position p (caar m))
(if (eq? kind 'mred) (display (integer->integer-bytes (string-length str) 4 #t #t) p)
null (display (integer->integer-bytes data-fork-size 4 #t #t) p)
'("-Z")) (file-position p data-fork-size)
flags))]) (display str p)
(file-position p (caar m)) (close-output-port p)))))
(display (integer->integer-bytes (string-length str) 4 #t #t) p)
(display (integer->integer-bytes data-fork-size 4 #t #t) p)
(file-position p data-fork-size)
(display str p)
(close-output-port p))))))
(define (get-maker) (define (get-maker)
(case (system-type) (case (system-type)
@ -526,73 +474,61 @@
[(macos) make-macos-launcher] [(macos) make-macos-launcher]
[(macosx) make-macosx-launcher])) [(macosx) make-macosx-launcher]))
(define make-mred-launcher (define (make-mred-launcher flags dest [aux null])
(lambda (flags dest [aux null]) ((get-maker) 'mred (current-launcher-variant) flags dest aux))
(let ([variant (current-launcher-variant)])
((get-maker) 'mred variant flags dest aux))))
(define make-mzscheme-launcher (define (make-mzscheme-launcher flags dest [aux null])
(lambda (flags dest [aux null]) ((get-maker) 'mzscheme (current-launcher-variant) flags dest aux))
(let ([variant (current-launcher-variant)])
((get-maker) 'mzscheme variant flags dest aux))))
(define (strip-suffix s) (define (strip-suffix s)
(path-replace-suffix s #"")) (path-replace-suffix s #""))
(define (build-aux-from-path aux-root) (define (build-aux-from-path aux-root)
(let ([aux-root (if (string? aux-root) (let ([aux-root (if (string? aux-root) (string->path aux-root) aux-root)])
(string->path aux-root) (define (try key suffix)
aux-root)]) (let ([p (path-replace-suffix aux-root suffix)])
(let ([try (lambda (key suffix) (if (file-exists? p) (list (cons key p)) null)))
(let ([p (path-replace-suffix aux-root suffix)]) (append
(if (file-exists? p) (try 'icns #".icns")
(list (cons key p)) (try 'ico #".ico")
null)))]) (try 'independent? #".lch")
(append (let ([l (try 'creator #".creator")])
(try 'icns #".icns") (if (null? l)
(try 'ico #".ico") l
(try 'independent? #".lch") (with-handlers ([exn:fail:filesystem? (lambda (x) null)])
(let ([l (try 'creator #".creator")]) (with-input-from-file (cdar l)
(if (null? l) (lambda ()
l (let ([s (read-string 4)])
(with-handlers ([exn:fail:filesystem? (lambda (x) null)]) (if s (list (cons (caar l) s)) null)))))))
(with-input-from-file (cdar l) (let ([l (try 'file-types #".filetypes")])
(lambda () (if (null? l)
(let ([s (read-string 4)]) l
(if s (with-handlers ([exn:fail:filesystem? (lambda (x) null)])
(list (cons (caar l) s)) (with-input-from-file (cdar l)
null))))))) (lambda ()
(let ([l (try 'file-types #".filetypes")]) (let*-values ([(d) (read)]
(if (null? l) [(local-dir base dir?) (split-path aux-root)]
l [(icon-files)
(with-handlers ([exn:fail:filesystem? (lambda (x) null)]) (append-map
(with-input-from-file (cdar l) (lambda (spec)
(lambda () (let ([m (assoc "CFBundleTypeIconFile" spec)])
(let ([d (read)]) (if m
(let-values ([(local-dir base dir?) (split-path aux-root)]) (list (build-path
(let ([icon-files (path->complete-path local-dir)
(apply (format "~a.icns" (cadr m))))
append null)))
(map (lambda (spec) d)])
(let ([m (assoc "CFBundleTypeIconFile" spec)]) (list (cons 'file-types d)
(if m (cons 'resource-files
(list (build-path (remove-duplicates icon-files)))))))))
(path->complete-path local-dir) (let ([l (try 'file-types #".utiexports")])
(format "~a.icns" (cadr m)))) (if (null? l)
null))) l
d))]) (with-handlers ([exn:fail:filesystem? (lambda (x) null)])
(list (with-input-from-file (cdar l)
(cons 'file-types d) (lambda ()
(cons 'resource-files (remove-duplicates icon-files))))))))))) (let ([d (read)])
(let ([l (try 'file-types #".utiexports")]) (list (cons 'uti-exports d)))))))))))
(if (null? l)
l
(with-handlers ([exn:fail:filesystem? (lambda (x) null)])
(with-input-from-file (cdar l)
(lambda ()
(let ([d (read)])
(list
(cons 'uti-exports d))))))))))))
(define (make-mred-program-launcher file collection dest) (define (make-mred-program-launcher file collection dest)
(make-mred-launcher (list "-l-" (string-append collection "/" file)) (make-mred-launcher (list "-l-" (string-append collection "/" file))
@ -609,19 +545,13 @@
(strip-suffix file))))) (strip-suffix file)))))
(define (unix-sfx file mred?) (define (unix-sfx file mred?)
(list->string (string-downcase (regexp-replace* #px"\\s" file "-")))
(map
(lambda (c)
(if (char-whitespace? c)
#\-
(char-downcase c)))
(string->list file))))
(define (sfx file mred?) (define (sfx file mred?)
(case (system-type) (case (system-type)
[(unix) (unix-sfx file mred?)] [(unix) (unix-sfx file mred?)]
[(windows) (string-append (if mred? file (unix-sfx file mred?)) [(windows)
".exe")] (string-append (if mred? file (unix-sfx file mred?)) ".exe")]
[else file])) [else file]))
(define (program-launcher-path name mred?) (define (program-launcher-path name mred?)
@ -646,10 +576,10 @@
(define (mzscheme-program-launcher-path name) (define (mzscheme-program-launcher-path name)
(case (system-type) (case (system-type)
[(macosx) (add-file-suffix [(macosx)
(build-path (find-console-bin-dir) (unix-sfx name #f)) (add-file-suffix (build-path (find-console-bin-dir) (unix-sfx name #f))
(current-launcher-variant) (current-launcher-variant)
#f)] #f)]
[else (program-launcher-path name #f)])) [else (program-launcher-path name #f)]))
(define (mred-launcher-is-directory?) (define (mred-launcher-is-directory?)
@ -680,39 +610,36 @@
(put-file-extension+style+filters (put-file-extension+style+filters
(if (and (eq? 'macosx (system-type)) (if (and (eq? 'macosx (system-type))
(script-variant? (current-launcher-variant))) (script-variant? (current-launcher-variant)))
'unix 'unix
(system-type)))) (system-type))))
(define (mzscheme-launcher-put-file-extension+style+filters) (define (mzscheme-launcher-put-file-extension+style+filters)
(put-file-extension+style+filters (put-file-extension+style+filters
(if (eq? 'macosx (system-type)) (if (eq? 'macosx (system-type)) 'unix (system-type))))
'unix
(system-type))))
(define mred-launcher-up-to-date? (define (mred-launcher-up-to-date? dest [aux null])
(lambda (dest [aux null]) (mzscheme-launcher-up-to-date? dest aux))
(mzscheme-launcher-up-to-date? dest aux)))
(define mzscheme-launcher-up-to-date? (define (mzscheme-launcher-up-to-date? dest [aux null])
(lambda (dest [aux null]) (cond
(cond ;; When running Setup PLT under Windows, the
;; When running Setup PLT under Windows, the ;; launcher process stays running until MzScheme
;; launcher process stays running until MzScheme ;; completes, which means that it cannot be
;; completes, which means that it cannot be ;; overwritten at that time. So we assume
;; overwritten at that time. So we assume ;; that a Setup-PLT-style independent launcher
;; that a Setup-PLT-style independent launcher ;; is always up-to-date.
;; is always up-to-date. [(eq? 'windows (system-type))
[(eq? 'windows (system-type)) (and (let ([m (assq 'independent? aux)]) (and m (cdr m)))
(and (let ([m (assq 'independent? aux)]) (file-exists? dest))]
(and m (cdr m))) ;; For any other setting, we could implement
(file-exists? dest))] ;; a fancy check, but for now always re-create
;; For any other setting, we could implement ;; launchers.
;; a fancy check, but for now always re-create [else #f]))
;; launchers.
[else #f])))
(define (install-mred-program-launcher file collection name) (define (install-mred-program-launcher file collection name)
(make-mred-program-launcher file collection (mred-program-launcher-path name))) (make-mred-program-launcher file collection
(mred-program-launcher-path name)))
(define (install-mzscheme-program-launcher file collection name) (define (install-mzscheme-program-launcher file collection name)
(make-mzscheme-program-launcher file collection (mzscheme-program-launcher-path name))) (make-mzscheme-program-launcher file collection
(mzscheme-program-launcher-path name)))