1#lang racket/base 2(require racket/path 3 racket/file 4 racket/port 5 racket/promise 6 racket/list 7 racket/contract 8 syntax/moddep 9 syntax/modcollapse 10 xml/plist 11 setup/dirs 12 setup/variant 13 setup/collects 14 file/ico 15 racket/private/so-search 16 racket/private/share-search 17 racket/private/link-path 18 setup/cross-system 19 "private/cm-minimal.rkt" 20 "private/winsubsys.rkt" 21 "private/macfw.rkt" 22 "private/mach-o.rkt" 23 "private/elf.rkt" 24 "private/windlldir.rkt" 25 "private/pe-rsrc.rkt" 26 "private/collects-path.rkt" 27 "private/configdir.rkt" 28 "private/write-perm.rkt" 29 "private/win-dll-list.rkt" 30 "find-exe.rkt") 31 32(provide/contract [make-embedding-executable 33 (->* (path-string? 34 any/c 35 any/c 36 (listof (or/c (list/c (or/c symbol? #f #t) 37 (or/c path? module-path?)) 38 (list/c (or/c symbol? #f #t) 39 (or/c path? module-path?) 40 (listof symbol?)))) 41 (listof path-string?) 42 any/c 43 (listof string?)) 44 ((listof (cons/c symbol? any/c)) 45 any/c 46 symbol? 47 (or/c #f 48 path-string? 49 (listof path-string?))) 50 void?)] 51 [create-embedding-executable 52 (->* (path-string?) 53 (#:modules 54 (listof (or/c (list/c (or/c symbol? #f #t) 55 (or/c path? module-path?)) 56 (list/c (or/c symbol? #f #t) 57 (or/c path? module-path?) 58 (listof symbol?)))) 59 #:configure-via-first-module? any/c 60 #:early-literal-expressions (listof any/c) 61 #:literal-files (listof path-string?) 62 #:literal-expression any/c 63 #:literal-expressions (listof any/c) 64 #:cmdline (listof string?) 65 #:gracket? any/c 66 #:mred? any/c 67 #:variant (or/c '3m 'cgc 'cs) 68 #:aux (listof (cons/c symbol? any/c)) 69 #:collects-path (or/c #f 70 path-string? 71 (listof path-string?)) 72 #:collects-dest (or/c #f path-string?) 73 #:launcher? any/c 74 #:verbose? any/c 75 #:compiler (-> any/c compiled-expression?) 76 #:expand-namespace namespace? 77 #:src-filter (-> path? any) 78 #:on-extension (or/c #f (-> path-string? boolean? any)) 79 #:get-extra-imports (-> path? compiled-module-expression? (listof module-path?))) 80 void?)]) 81 82(provide write-module-bundle 83 embedding-executable-is-directory? 84 embedding-executable-is-actually-directory? 85 embedding-executable-put-file-extension+style+filters 86 embedding-executable-add-suffix) 87 88 89(define (embedding-executable-is-directory? mred?) 90 #f) 91 92(define (embedding-executable-is-actually-directory? mred?) 93 (and mred? (eq? 'macosx (cross-system-type)))) 94 95(define (embedding-executable-put-file-extension+style+filters mred?) 96 (case (cross-system-type) 97 [(windows) (values "exe" null '(("Executable" "*.exe")))] 98 [(macosx) (if mred? 99 (values "app" '(enter-packages) '(("App" "*.app"))) 100 (values #f null null))] 101 [else (values #f null null)])) 102 103(define (embedding-executable-add-suffix path mred?) 104 (let* ([path (if (string? path) 105 (string->path path) 106 path)] 107 [fixup (lambda (re sfx) 108 (if (regexp-match re (path->bytes path)) 109 path 110 (path-add-extension path sfx #".")))]) 111 (case (cross-system-type) 112 [(windows) (fixup #rx#".[.][eE][xX][eE]$" #".exe")] 113 [(macosx) (if mred? 114 (fixup #rx#".[.][aA][pP][pP]$" #".app") 115 path)] 116 [else path]))) 117 118(define (mac-dest->executable dest mred?) 119 (if mred? 120 (let-values ([(base name dir?) (split-path dest)]) 121 (build-path dest 122 "Contents" "MacOS" 123 (path-replace-extension name #""))) 124 dest)) 125 126(define exe-suffix? 127 (delay (equal? #"i386-cygwin" (path->bytes (cross-system-library-subpath))))) 128 129;; Find the magic point in the binary: 130(define (find-cmdline what rx) 131 (let ([m (regexp-match-positions rx (current-input-port))]) 132 (if m 133 (caar m) 134 (error 135 'create-embedding-executable 136 (format 137 "can't find ~a position in executable" 138 what))))) 139 140 141(define (relativize exec-name dest adjust) 142 (let ([p (find-relative-path 143 (let-values ([(dir name dir?) (split-path 144 (normal-case-path 145 (normalize-path dest)))]) 146 dir) 147 (normal-case-path (normalize-path exec-name)))]) 148 (if (relative-path? p) 149 (adjust p) 150 p))) 151 152;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 153 154(define (find-relevant-lib-dir f #:default [default #f]) 155 (or 156 (for/or ([lib-dir (in-list (get-cross-lib-search-dirs))]) 157 (define p (build-path lib-dir f)) 158 (and (or (file-exists? p) 159 (directory-exists? p)) 160 lib-dir)) 161 default 162 (error 'find-relevant-lib-dir 163 "could not find ~s" 164 f))) 165 166(define (find-in-lib f) 167 (build-path (find-relevant-lib-dir f #:default (find-lib-dir)) 168 f)) 169 170;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 171 172(define (prepare-macosx-mred exec-name dest aux variant) 173 (let* ([name (let-values ([(base name dir?) (split-path dest)]) 174 (path-replace-extension name #""))] 175 [src (find-in-lib "Starter.app")] 176 [creator (let ([c (assq 'creator aux)]) 177 (or (and c 178 (cdr c)) 179 "MrSt"))] 180 [file-types (let ([m (assq 'file-types aux)]) 181 (and m 182 (pair? (cdr m)) 183 (cdr m)))] 184 [uti-exports (let ([m (assq 'uti-exports aux)]) 185 (and m 186 (pair? (cdr m)) 187 (cdr m)))] 188 [resource-files (let ([m (assq 'resource-files aux)]) 189 (and m 190 (cdr m)))]) 191 (when creator 192 (unless (and (string? creator) (= 4 (string-length creator))) 193 (error 'make-executable "creator is not a 4-character string: ~e" creator))) 194 (when file-types 195 (unless (and (list? file-types) 196 (andmap list? file-types) 197 (andmap (lambda (spec) 198 (andmap (lambda (p) 199 (and (list? p) 200 (= 2 (length p)) 201 (string? (car p)))) 202 spec)) 203 file-types)) 204 (error 'make-executable "bad file-types spec: ~e" file-types))) 205 (when resource-files 206 (unless (and (list? resource-files) 207 (andmap path-string? 208 resource-files)) 209 (error 'make-executable "resource-files is not a list of paths: ~e" resource-files))) 210 211 (when (or (directory-exists? dest) 212 (file-exists? dest) 213 (link-exists? dest)) 214 (delete-directory/files dest)) 215 (make-directory* (build-path dest "Contents" "Resources")) 216 (make-directory* (build-path dest "Contents" "MacOS")) 217 (copy-file exec-name (build-path dest "Contents" "MacOS" name)) 218 (copy-file (build-path src "Contents" "PkgInfo") 219 (build-path dest "Contents" "PkgInfo")) 220 (let ([icon (or (let ([icon (assq 'icns aux)]) 221 (and icon 222 (cdr icon))) 223 (build-path src "Contents" "Resources" "Starter.icns"))]) 224 (copy-file icon 225 (build-path dest "Contents" "Resources" "Starter.icns"))) 226 (let ([orig-plist (call-with-input-file (build-path src 227 "Contents" 228 "Info.plist") 229 read-plist)] 230 [plist-replace (lambda (plist . l) 231 (let loop ([plist plist][l l]) 232 (if (null? l) 233 plist 234 (let ([key (car l)] 235 [val (cadr l)]) 236 (loop `(dict 237 ,@(let loop ([c (cdr plist)]) 238 (cond 239 [(null? c) (list (list 'assoc-pair key val))] 240 [(string=? (cadar c) key) 241 (cons (list 'assoc-pair key val) 242 (cdr c))] 243 [else 244 (cons (car c) 245 (loop (cdr c)))]))) 246 (cddr l))))))]) 247 (let* ([new-plist (plist-replace 248 orig-plist 249 250 "CFBundleExecutable" 251 (path->string name) 252 253 "CFBundleSignature" 254 creator 255 256 "CFBundleIdentifier" 257 (format "org.racket-lang.~a" (path->string name)))] 258 [new-plist (if uti-exports 259 (plist-replace 260 new-plist 261 "UTExportedTypeDeclarations" 262 (cons 'array 263 (map (lambda (spec) 264 (cons 265 'dict 266 (map (lambda (p) 267 (list 268 'assoc-pair 269 (car p) 270 (cadr p))) 271 spec))) 272 uti-exports))) 273 new-plist)] 274 [new-plist (if file-types 275 (plist-replace 276 new-plist 277 "CFBundleDocumentTypes" 278 (cons 'array 279 (map (lambda (spec) 280 (cons 281 'dict 282 (map (lambda (p) 283 (list 284 'assoc-pair 285 (car p) 286 (cadr p))) 287 spec))) 288 file-types))) 289 new-plist)]) 290 (call-with-output-file (build-path dest 291 "Contents" 292 "Info.plist") 293 #:exists 'truncate 294 (lambda (port) 295 (write-plist new-plist port))))) 296 (let* ([pkginfo-path (build-path dest "Contents" "PkgInfo")] 297 [old-perms (ensure-writable pkginfo-path)]) 298 (call-with-output-file pkginfo-path 299 #:exists 'truncate 300 (lambda (port) 301 (fprintf port "APPL~a" creator))) 302 (done-writable pkginfo-path old-perms)) 303 (when resource-files 304 (for-each (lambda (p) 305 (let-values ([(base name dir?) (split-path p)]) 306 (copy-file p (build-path dest 307 "Contents" 308 "Resources" 309 name)))) 310 resource-files)) 311 (build-path dest "Contents" "MacOS" name))) 312 313;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 314 315;; Represent modules with lists starting with the filename, so we 316;; can use assoc: 317(define (make-mod normal-file-path normal-module-path 318 code name full-name relative-mappings-box 319 runtime-paths runtime-module-syms 320 actual-file-path 321 use-source?) 322 (list normal-file-path normal-module-path code 323 name full-name relative-mappings-box 324 runtime-paths runtime-module-syms 325 actual-file-path 326 use-source?)) 327 328(define (mod-file m) (strip-submod (car m))) 329(define (mod-mod-path m) (cadr m)) 330(define (mod-code m) (caddr m)) 331(define (mod-name m) (list-ref m 3)) 332(define (mod-full-name m) (list-ref m 4)) 333(define (mod-mappings m) (unbox (list-ref m 5))) 334(define (mod-runtime-paths m) (list-ref m 6)) 335(define (mod-runtime-module-syms m) (list-ref m 7)) 336(define (mod-actual-file m) (list-ref m 8)) 337(define (mod-use-source? m) (list-ref m 9)) 338 339(define (file-mod-name-base path) 340 (define-values (base name dir?) (split-path path)) 341 (path->string (path-replace-extension name #""))) 342 343(struct file-mod-name-state (path->relative-cache used wrt-path)) 344(define (make-generate-file-mod-name-state wrt-path) 345 (file-mod-name-state (make-hash) (make-hasheq) wrt-path)) 346 347(define (generate-file-mod-name gen-state path) 348 (define mp (path->module-path path 349 #:cache (file-mod-name-state-path->relative-cache gen-state))) 350 (define str 351 (cond 352 [(and mp (pair? mp) (eq? (car mp) 'lib) (null? (cddr mp))) 353 (cadr mp)] 354 [else 355 (define rel (find-relative-path (file-mod-name-state-wrt-path gen-state) path)) 356 (path->string rel)])) 357 (define sym (string->symbol (regexp-replace #rx"[.](?:ss|rkt)$" str ""))) 358 (define used (file-mod-name-state-used gen-state)) 359 (let loop ([sym sym]) 360 (cond 361 [(hash-ref used sym #f) 362 (loop (string->symbol (format "~a>" sym)))] 363 [else 364 (hash-set! used sym #t) 365 (format "#%embedded:~a:" sym)]))) 366 367(define (normalize filename) 368 (if (pair? filename) 369 `(submod ,(normalize (cadr filename)) ,@(cddr filename)) 370 (let ([f (simplify-path (cleanse-path filename))]) 371 ;; Use normal-case-path on just the base part, to avoid 372 ;; changing the filename case (which should match the 373 ;; module-name case within the file): 374 (let-values ([(base name dir?) (split-path f)]) 375 (if (path? base) 376 (build-path (normal-case-path base) name) 377 f))))) 378 379(define (strip-submod a) 380 (if (and (pair? a) 381 (eq? 'submod (car a))) 382 (cadr a) 383 a)) 384 385(define (is-lib-path? a) 386 (let ([a (strip-submod a)]) 387 (or (and (pair? a) 388 (eq? 'lib (car a))) 389 (symbol? a)))) 390 391(define (symbol-to-lib-form l) 392 (if (symbol? l) 393 `(lib ,(symbol->string l)) 394 l)) 395 396(define (unix-style-split p) 397 (let ([m (regexp-match #rx"^([^/]*)/(.*)$" p)]) 398 (if m 399 (cons (cadr m) (unix-style-split (caddr m))) 400 (list p)))) 401 402(define (extract-last l) 403 (let loop ([l l][dirs null]) 404 (if (null? (cdr l)) 405 (values (reverse dirs) (car l)) 406 (loop (cdr l) (cons (car l) dirs))))) 407 408(define (adjust-ss/rkt-extension path) 409 (cond 410 [(file-exists? path) path] 411 [(path-has-extension? path #".ss") 412 (define rkt-path (path-replace-extension path #".rkt")) 413 (if (file-exists? rkt-path) 414 rkt-path 415 path)] 416 [(path-has-extension? path #".rkt") 417 (define ss-path (path-replace-extension path #".ss")) 418 (if (file-exists? ss-path) 419 ss-path 420 path)] 421 [else path])) 422 423(define (lib-module-filename collects-dest module-path) 424 (let-values ([(dir file) 425 (let ([s (lib-path->string (strip-submod module-path))]) 426 (extract-last (unix-style-split s)))]) 427 (let ([p (build-path collects-dest 428 (apply build-path dir) 429 (let ([l (use-compiled-file-paths)]) 430 (if (pair? l) 431 (car l) 432 "compiled")) 433 (path-add-extension file #".zo"))]) 434 (let-values ([(base name dir?) (split-path p)]) 435 (make-directory* base) 436 p)))) 437 438(define (file-date f) 439 (with-handlers ([exn:fail:filesystem? (lambda (x) -inf.0)]) 440 (file-or-directory-modify-seconds f))) 441 442(define-struct extension (path)) 443 444;; Loads module code, using .zo if there, compiling from .scm if not 445(define (get-code filename module-path ready-code use-submods codes file-mod-names verbose? collects-dest on-extension 446 compiler expand-namespace src-filter get-extra-imports working gen-state) 447 ;; filename can have the form `(submod ,filename ,sym ...) 448 (let* ([a (assoc filename (unbox codes))] 449 ;; If we didn't fine `filename` as-is, check now for 450 ;; using source, because in that case we'll only register the 451 ;; main module even if a submodule is include in `filename`. 452 [use-source? 453 (and (not a) 454 (src-filter (adjust-ss/rkt-extension (strip-submod filename))))] 455 ;; When using source or writing to collects, keep full modules: 456 [keep-full? (or use-source? collects-dest)] 457 ;; When keeping a full module, strip away submodule paths: 458 [filename (or (and (not a) 459 keep-full? 460 (pair? filename) 461 (cadr filename)) 462 filename)] 463 ;; Maybe search again after deciding whether to strip submodules: 464 [a (or a 465 (and keep-full? 466 ;; Try again: 467 (assoc filename (unbox codes))))]) 468 (cond 469 [a 470 ;; Already have this module. Make sure that library-referenced 471 ;; modules are consistently referenced through library paths: 472 (let ([found-lib? (is-lib-path? (mod-mod-path a))] 473 [look-lib? (is-lib-path? module-path)]) 474 (cond 475 [(and found-lib? look-lib?) 476 'ok] 477 [(or found-lib? look-lib?) 478 (error 'find-module 479 "module referenced both as a library and through a path: ~a" 480 filename)] 481 [else 'ok]))] 482 [(hash-ref working filename #f) 483 ;; in the process of loading the module; a cycle 484 ;; is possible through `define-runtime-path' 485 'ok] 486 [else 487 ;; First use of the module. Get code and then get code for imports. 488 (when verbose? 489 (eprintf "Getting ~s as ~s\n" module-path filename)) 490 (let* ([submod-path (if (pair? filename) 491 (cddr filename) 492 null)] 493 [just-filename (strip-submod filename)] 494 [root-module-path (strip-submod module-path)] 495 [actual-filename just-filename] ; `set!'ed below to adjust file extension 496 [name (file-mod-name-base just-filename)] 497 [file-mod-name (let ([a 498 ;; Try path with a submodule, first, then fall back to 499 ;; just the path part if there was a `submod` wrapper: 500 (or (assoc filename file-mod-names) 501 (and (pair? filename) 502 (assoc just-filename file-mod-names)))]) 503 (if a 504 (cdr a) 505 (generate-file-mod-name gen-state just-filename)))] 506 [full-name (string->symbol 507 (format "~a~a" 508 file-mod-name 509 (if (null? submod-path) 510 "" 511 submod-path)))]) 512 (hash-set! working filename full-name) 513 (let* ([get-module-code* 514 ;; Re-used when swapping code during cross-compilation. 515 (lambda (#:roots [roots (current-compiled-file-roots)] 516 #:host? [host? #f]) 517 (get-module-code just-filename 518 #:roots roots 519 #:submodule-path submod-path 520 (let ([l (use-compiled-file-paths)]) 521 (if (pair? l) 522 (car l) 523 "compiled")) 524 (if (and host? (cross-compiling?)) 525 (lambda (e) 526 (parameterize ([current-compile-target-machine (system-type 'target-machine)]) 527 (compiler e))) 528 compiler) 529 (if on-extension 530 (lambda (f l?) 531 (on-extension f l?) 532 #f) 533 (lambda (file _loader?) 534 (if _loader? 535 (error 'create-embedding-executable 536 "cannot use a _loader extension: ~e" 537 file) 538 (make-extension file)))) 539 #:choose 540 ;; Prefer extensions, if we're handling them: 541 (lambda (src zo so) 542 (set! actual-filename src) ; remember convert source name 543 (if on-extension 544 #f 545 (if (and (file-exists? so) 546 ((file-date so) . >= . (file-date zo))) 547 'so 548 #f)))))] 549 [code (or ready-code (get-module-code* #:host? #t))]) 550 (cond 551 [(extension? code) 552 (when verbose? 553 (eprintf " using extension: ~s\n" (extension-path code))) 554 (set-box! codes 555 (cons (make-mod filename module-path code 556 name full-name 557 (box null) null null 558 actual-filename 559 #f) 560 (unbox codes)))] 561 [code 562 (let ([importss (module-compiled-imports code)]) 563 (let* ([all-file-imports (filter (keep-import-dependency? keep-full? actual-filename) 564 (apply append (map cdr importss)))] 565 [extra-paths 566 (map symbol-to-lib-form (append (if keep-full? 567 (extract-full-imports module-path actual-filename code) 568 null) 569 (if use-source? 570 (list 'compiler/private/read-bstr) 571 null) 572 (get-extra-imports actual-filename code)))] 573 [extract-submods 574 (lambda (submods) 575 (if use-source? 576 null 577 (for/list ([m (in-list submods)] 578 #:when (or (member (last (module-compiled-name m)) use-submods) 579 (declares-always-preserved? m))) 580 m)))] 581 [prepare-code&submods 582 (lambda (code) 583 (define name (module-compiled-name code)) 584 (define renamed-code 585 (cond 586 [(symbol? name) code] 587 [else (module-compiled-name code (last name))])) 588 (define pre-submods (extract-submods (module-compiled-submodules renamed-code #t))) 589 (define post-submods (extract-submods (module-compiled-submodules renamed-code #f))) 590 (define new-code 591 (cond 592 [keep-full? code] 593 [else (module-compiled-submodules 594 (module-compiled-submodules renamed-code #f null) #t null)])) 595 (values new-code pre-submods post-submods))]) 596 (let*-values ([(runtime-paths) 597 (if (module-compiled-cross-phase-persistent? code) 598 ;; avoid potentially trying to redeclare cross-phase persistent modules, 599 ;; since redeclaration isn't allowed: 600 null 601 ;; check for run-time paths by visiting the module in an 602 ;; expand-time namespace: 603 (parameterize ([current-namespace expand-namespace]) 604 (let ([module-path 605 (if (path? module-path) 606 (path->complete-path module-path) 607 module-path)]) 608 (unless (module-declared? module-path) 609 (parameterize ([current-module-declare-name 610 (module-path-index-resolve (module-path-index-join 611 module-path 612 #f))]) 613 (eval code))) 614 (define e (expand `(,#'module m racket/kernel 615 (#%require (only ,module-path) 616 racket/runtime-path) 617 (runtime-paths ,module-path)))) 618 (syntax-case e (quote) 619 [(_ m mz (#%mb req (quote (spec ...)))) 620 (for/list ([p (in-list (syntax->datum #'(spec ...)))]) 621 ;; Strip variable reference from 'module specs, because 622 ;; we don't need them and they retain the namespace: 623 (if (and (pair? p) (eq? 'module (car p))) 624 (list 'module (cadr p)) 625 p))] 626 [_else (error 'create-empbedding-executable 627 "expansion mismatch when getting external paths: ~e" 628 (syntax->datum e))]))))] 629 [(extra-runtime-paths) (filter-map (lambda (p) 630 (and (pair? p) 631 (eq? (car p) 'module) 632 (cadr p))) 633 runtime-paths)] 634 [(code pre-submods post-submods) (prepare-code&submods code)]) 635 (let ([sub-files (map (lambda (i) 636 ;; use `just-filename', because i has submod name embedded 637 (normalize (resolve-module-path-index i just-filename))) 638 all-file-imports)] 639 [sub-paths (map (lambda (i) 640 ;; use `root-module-path', because i has submod name embedded 641 (collapse-module-path-index i root-module-path)) 642 all-file-imports)] 643 [normalized-extra-paths (map (lambda (i) (collapse-module-path i module-path)) 644 (append extra-runtime-paths extra-paths))] 645 [extra-files (map (lambda (i) (normalize (resolve-module-path-index (module-path-index-join i #f) 646 filename))) 647 ;; getting runtime-module-path symbols below 648 ;; relies on extra-runtime-paths being first: 649 (append extra-runtime-paths extra-paths))]) 650 (define (get-one-code sub-filename sub-path ready-code) 651 (get-code sub-filename sub-path ready-code null 652 codes 653 file-mod-names 654 verbose? 655 collects-dest 656 on-extension 657 compiler 658 expand-namespace 659 src-filter get-extra-imports 660 working 661 gen-state)) 662 (define (get-one-submodule-code m) 663 (define name (cadr (module-compiled-name m))) 664 (define mp `(submod "." ,name)) 665 (define mpi (module-path-index-join mp #f)) 666 (get-one-code (resolve-module-path-index mpi filename) 667 (if (is-lib-path? module-path) 668 ;; Preserve `lib`-ness of module reference: 669 (collapse-module-path-index 670 (module-path-index-join 671 mp 672 (module-path-index-join module-path #f))) 673 ;; Ok to collapse based on filename: 674 (collapse-module-path-index mpi filename)) 675 m)) 676 ;; Add code for pre submodules: 677 (for-each get-one-submodule-code pre-submods) 678 ;; Get code for imports: 679 (for-each (lambda (sf sp) (get-one-code sf sp #f)) 680 (append sub-files extra-files) 681 (append sub-paths normalized-extra-paths)) 682 (when verbose? 683 (unless (null? runtime-paths) 684 (eprintf "Runtime paths for ~s: ~s\n" 685 filename 686 runtime-paths))) 687 (if (and collects-dest 688 (is-lib-path? module-path)) 689 ;; Install code as .zo: 690 (begin 691 (with-output-to-file (lib-module-filename collects-dest module-path) 692 #:exists 'truncate/replace 693 (lambda () 694 (write code))) 695 ;; Record module as copied 696 (set-box! codes 697 (cons (make-mod filename module-path #f 698 #f #f 699 (box null) null null 700 actual-filename 701 use-source?) 702 (unbox codes)))) 703 ;; Build up relative module resolutions, relative to this one, 704 ;; that will be requested at run-time. 705 (let* ([lookup-full-name (lambda (sub-filename) 706 (let ([m (assoc sub-filename (unbox codes))]) 707 (if m 708 (mod-full-name m) 709 ;; must have been a cycle... 710 (hash-ref working sub-filename 711 (lambda () 712 ;; If `sub-filename` was included from source, 713 ;; then we'll need to use a submodule path: 714 `(,(hash-ref working (strip-submod sub-filename)) 715 ,@(cddr sub-filename)))))))] 716 [get-submod-mapping 717 (lambda (m) 718 (define name (cadr (module-compiled-name m))) 719 (cons `(submod "." ,name) 720 (lookup-full-name 721 (collapse-module-path-index 722 (module-path-index-join `(submod "." ,name) #f) 723 filename))))] 724 [mappings-box 725 (box (append 726 (filter (lambda (p) (and p (cdr p))) 727 (map (lambda (sub-i sub-filename sub-path) 728 (and (not (and collects-dest 729 (is-lib-path? sub-path))) 730 (if sub-i 731 (let-values ([(path base) (module-path-index-split sub-i)]) 732 (and base ; can be #f if path isn't relative 733 (begin 734 ;; Assert: base should refer to this module: 735 (let-values ([(path2 base2) (module-path-index-split base)]) 736 (when (or path2 base2) 737 (error 'embed "unexpected nested module path index ~s" base))) 738 (cons path (lookup-full-name sub-filename))))) 739 ;; a run-time path: 740 (cons (if (path? sub-path) 741 `(path ,(encode-link-path sub-path)) 742 sub-path) 743 (lookup-full-name sub-filename))))) 744 (append all-file-imports (map (lambda (p) #f) extra-runtime-paths)) 745 (append sub-files (take extra-files (length extra-runtime-paths))) 746 (append sub-paths extra-runtime-paths))) 747 (map get-submod-mapping pre-submods)))]) 748 ;; Record the module 749 ;; For cross-compilation, we need to be able to execute code using the host Racket (to find 750 ;; dependencies and runtime paths), but then we have to swap in code for the target Racket 751 ;; here, before writing it to the output. 752 (let ([code (cond 753 [(cross-compiling?) 754 (when verbose? 755 (eprintf "Swapping host code of ~s for target platform~n" module-path)) 756 (define target-code 757 (get-module-code* #:roots (cdr (current-compiled-file-roots)))) 758 ;; Apply the same trasformations to the target code that were made to the host code. 759 (define-values (prepared-code _pre-submods _post-submods) 760 (prepare-code&submods target-code)) 761 prepared-code] 762 [else 763 code])]) 764 (set-box! codes 765 (cons (make-mod filename module-path code 766 name full-name 767 mappings-box 768 runtime-paths 769 ;; extract runtime-path module symbols: 770 (let loop ([runtime-paths runtime-paths] 771 [extra-files extra-files]) 772 (cond 773 [(null? runtime-paths) null] 774 [(let ([p (car runtime-paths)]) 775 (and (pair? p) (eq? (car p) 'module))) 776 (cons (lookup-full-name (car extra-files)) 777 (loop (cdr runtime-paths) (cdr extra-files)))] 778 [else 779 (cons #f (loop (cdr runtime-paths) extra-files))])) 780 actual-filename 781 use-source?) 782 (unbox codes)))) 783 ;; Add code for post submodules: 784 (for-each get-one-submodule-code post-submods) 785 ;; Add post-submodule mappings: 786 (set-box! mappings-box 787 (append (unbox mappings-box) 788 (map get-submod-mapping post-submods)))))))))] 789 [else 790 (set-box! codes 791 (cons (make-mod filename module-path code 792 name #f 793 null null null 794 actual-filename 795 use-source?) 796 (unbox codes)))])))]))) 797 798(define ((keep-import-dependency? keep-full? path) orig-x) 799 (define-values (x base) (module-path-index-split orig-x)) 800 (not (or (and (pair? x) 801 (eq? 'quote (car x))) 802 (and keep-full? 803 ;; Don't try to include submodules specifically if the enclosing 804 ;; module is kept fully. Any needed dependencies will be 805 ;; extracted via `extract-full-imports`. 806 (pair? x) 807 (eq? (car x) 'submod) 808 (or (equal? (cadr x) ".") 809 (equal? path 810 (normalize (resolve-module-path-index (module-path-index-join (cadr x) #f) 811 path)))))))) 812 813(define (extract-full-imports module-path path code) 814 ;; When embedding a module from source or otherwise keeping a full 815 ;; module, we need to collect all dependencies from submodules 816 ;; (recursively), because they'll be needed to start again from 817 ;; source. 818 (let accum-from-mod ([mod code]) 819 (append 820 (map (lambda (i) (collapse-module-path-index i module-path)) 821 (filter (keep-import-dependency? #t path) 822 (apply append (map cdr (module-compiled-imports mod))))) 823 (apply append 824 (map accum-from-mod (module-compiled-submodules mod #t))) 825 (apply append 826 (map accum-from-mod (module-compiled-submodules mod #f)))))) 827 828(define (declares-always-preserved? m) 829 (for/or ([s (in-list 830 (append (module-compiled-submodules m #t) 831 (module-compiled-submodules m #f)))]) 832 (eq? (last (module-compiled-name s)) 'declare-preserve-for-embedding))) 833 834;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 835 836(define (compile-using-kernel e) 837 (let ([ns (make-empty-namespace)]) 838 (namespace-attach-module (current-namespace) ''#%kernel ns) 839 (parameterize ([current-namespace ns] 840 [current-compile-target-machine (get-compile-target-machine)]) 841 (namespace-require ''#%kernel) 842 (compile e)))) 843 844;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 845 846(define (lib-path->string path) 847 (cond 848 [(null? (cddr path)) 849 (if (regexp-match #rx"^[^/]*[.]" (cadr path)) 850 ;; mzlib 851 (string-append "mzlib/" (cadr path)) 852 ;; new-style 853 (if (regexp-match #rx"^[^/.]*$" (cadr path)) 854 (string-append (cadr path) "/main.ss") 855 (if (regexp-match #rx"^[^.]*$" (cadr path)) 856 ;; need an extension: 857 (string-append (cadr path) ".ss") 858 (cadr path))))] 859 [else 860 ;; old-style multi-string: 861 (string-append (apply string-append 862 (map (lambda (s) 863 (string-append s "/")) 864 (cddr path))) 865 (cadr path))])) 866 867(define (make-module-name-resolver code-l) 868 (let ([extensions (filter (lambda (m) (extension? (mod-code m))) code-l)]) 869 `(module #%resolver '#%kernel 870 (let-values ([(orig) (current-module-name-resolver)] 871 [(regs) (make-hasheq)] 872 [(mapping-table) (quote 873 ,(map 874 (lambda (m) 875 `(,(mod-full-name m) 876 ,(mod-mappings m))) 877 code-l))] 878 [(library-table) (quote 879 ,(filter values 880 (map (lambda (m) 881 (let loop ([path (mod-mod-path m)]) 882 (cond 883 [(and (pair? path) 884 (eq? 'lib (car path))) 885 (cons (lib-path->string path) 886 (mod-full-name m))] 887 [(and (pair? path) 888 (eq? 'planet (car path))) 889 ;; Normalize planet path 890 (cons (collapse-module-path path current-directory) 891 (mod-full-name m))] 892 [(and (pair? path) 893 (eq? 'submod (car path))) 894 (define m (loop (cadr path))) 895 (and m 896 (cons `(submod ,(car m) ,@(cddr path)) 897 (cdr m)))] 898 [else #f]))) 899 code-l)))]) 900 (hash-set! regs 901 (namespace-module-registry (current-namespace)) 902 (vector mapping-table library-table)) 903 (letrec-values ([(lookup) 904 (lambda (name rel-to stx load? for-submod? orig) 905 (if (not (module-path? name)) 906 ;; Bad input 907 (orig name rel-to stx load?) 908 (let-values ([(table-vec) (hash-ref regs (namespace-module-registry (current-namespace)) #f)] 909 [(name) (if (pair? name) 910 (if (eq? 'submod (car name)) 911 (if (null? (cddr name)) 912 (if (equal? ".." (cadr name)) 913 name 914 (if (equal? "." (cadr name)) 915 name 916 (cadr name))) ; strip away `submod' without a submodule path 917 name) 918 name) 919 name)]) 920 (if (not table-vec) 921 ;; No mappings in this registry 922 (orig name rel-to stx load?) 923 (let-values ([(mapping-table) (vector-ref table-vec 0)] 924 [(library-table) (vector-ref table-vec 1)]) 925 ;; Have a relative mapping? 926 (let-values ([(a) (if rel-to 927 (let-values ([(v) (assq (resolved-module-path-name rel-to) mapping-table)]) 928 (if v 929 v 930 ;; It we're loading a module from source, then `rel-to` might not be 931 ;; our eventual name, but `(current-module-declare-name)` provides 932 ;; one, so try using that to resolve the module: 933 (if (current-module-declare-name) 934 (assq (resolved-module-path-name (current-module-declare-name)) mapping-table) 935 #f))) 936 #f)] 937 [(ss->rkt) 938 (lambda (s) 939 (regexp-replace #rx"[.]ss$" s ".rkt"))]) 940 (if a 941 (let-values ([(a2) (assoc name (cadr a))]) 942 (if a2 943 (make-resolved-module-path (cdr a2)) 944 ;; No relative mapping found (presumably a lib) 945 (orig name rel-to stx load?))) 946 (let-values ([(lname) 947 ;; normalize `lib' to single string (same as lib-path->string): 948 (let-values ([(name) 949 (let-values ([(name) 950 ;; remove submod path; added back at end 951 (if (pair? name) 952 (if (eq? 'submod (car name)) 953 (cadr name) 954 name) 955 name)]) 956 (if (symbol? name) 957 (list 'lib (symbol->string name)) 958 name))]) 959 (if (pair? name) 960 (if (eq? 'lib (car name)) 961 (if (null? (cddr name)) 962 (if (regexp-match #rx"^[^/]*[.]" (cadr name)) 963 ;; mzlib 964 (string-append "mzlib/" (ss->rkt (cadr name))) 965 ;; new-style 966 (if (regexp-match #rx"^[^/.]*$" (cadr name)) 967 (string-append (cadr name) "/main.rkt") 968 (if (regexp-match #rx"^[^.]*$" (cadr name)) 969 ;; need an extension: 970 (string-append (cadr name) ".rkt") 971 (ss->rkt (cadr name))))) 972 ;; old-style multi-string 973 (string-append (apply string-append 974 (map (lambda (s) 975 (string-append s "/")) 976 (cddr name))) 977 (ss->rkt (cadr name)))) 978 (if (eq? 'planet (car name)) 979 (letrec-values ([(split) 980 (lambda (s rx extension-after) 981 (let-values ([(m) (regexp-match-positions 982 rx 983 s)]) 984 (if m 985 (cons (substring s 0 (caar m)) 986 (split (substring s (cdar m)) 987 rx 988 (- extension-after 1))) 989 (list 990 (if (extension-after . <= . 0) 991 (if (regexp-match? #rx"[.]" s) 992 s 993 (string-append s ".rkt")) 994 s)))))] 995 [(last-of) 996 (lambda (l) 997 (if (null? (cdr l)) 998 (car l) 999 (last-of (cdr l))))] 1000 [(not-last) 1001 (lambda (l) 1002 (if (null? (cdr l)) 1003 null 1004 (cons (car l) (not-last (cdr l)))))]) 1005 (if (null? (cddr name)) 1006 ;; need to normalize: 1007 (let-values ([(s) (if (symbol? (cadr name)) 1008 (symbol->string (cadr name)) 1009 (cadr name))]) 1010 (let-values ([(parts) (split s #rx"/" 2)]) 1011 (let-values ([(vparts) (split (cadr parts) #rx":" +inf.0)]) 1012 (cons 'planet 1013 (cons (if (null? (cddr parts)) 1014 "main.rkt" 1015 (ss->rkt (last-of parts))) 1016 (cons 1017 (cons 1018 (car parts) 1019 (cons (string-append (car vparts) 1020 ".plt") 1021 (if (null? (cddr parts)) 1022 null 1023 ;; FIXME: finish version parse: 1024 (cdddr parts)))) 1025 (if (null? (cddr parts)) 1026 null 1027 (not-last (cddr parts))))))))) 1028 ;; already in long form; move subcollects to end: 1029 (let-values ([(s) (cadr name)]) 1030 (let-values ([(parts) (split s #rx"/" +inf.0)]) 1031 (if (= 1 (length parts)) 1032 (list* 'planet 1033 (ss->rkt (cadr name)) 1034 (cddr name)) 1035 (list* 'planet 1036 (ss->rkt (last-of parts)) 1037 (caddr name) 1038 (append 1039 (cdddr name) 1040 (not-last parts)))))))) 1041 #f)) 1042 #f))] 1043 [(planet-match?) 1044 (lambda (a b) 1045 (if (equal? (cons (car a) (cddr a)) 1046 (cons (car b) (cddr b))) 1047 (let-values ([(a) (cadr a)] 1048 [(b) (cadr b)]) 1049 (if (equal? (car a) (car b)) 1050 (if (equal? (cadr a) (cadr b)) 1051 ;; Everything matches up to the version... 1052 ;; FIXME: check version. (Since the version isn't checked, 1053 ;; this currently works only when a single version of the 1054 ;; package is used in the executable.) 1055 #t 1056 #f) 1057 #f)) 1058 #f))] 1059 [(restore-submod) (lambda (lname) 1060 (if (pair? name) 1061 (if (eq? (car name) 'submod) 1062 (list* 'submod lname (cddr name)) 1063 lname) 1064 lname))]) 1065 ;; A library mapping that we have? 1066 (let-values ([(a3) (if lname 1067 (if (string? lname) 1068 ;; lib 1069 (assoc (restore-submod lname) library-table) 1070 ;; planet 1071 (ormap (lambda (e) 1072 (let-values ([(e) 1073 ;; handle submodule matching first: 1074 (if (pair? name) 1075 (if (eq? (car name) 'submod) 1076 (if (pair? (car e)) 1077 (if (eq? (caar e) 'submod) 1078 (if (equal? (cddar e) (cddr name)) 1079 (cons (cadar e) (cdr e)) 1080 #f) 1081 #f) 1082 #f) 1083 e) 1084 e)]) 1085 (if e 1086 (if (string? (car e)) 1087 #f 1088 (if (planet-match? (cdar e) (cdr lname)) 1089 e 1090 #f)) 1091 #f))) 1092 library-table)) 1093 #f)]) 1094 (if a3 1095 ;; Have it: 1096 (make-resolved-module-path (cdr a3)) 1097 (if (if for-submod? 1098 (if (pair? name) 1099 (if (eq? (car name) 'quote) 1100 (assq (cadr name) mapping-table) 1101 #f) 1102 #f) 1103 #f) 1104 ;; Report that we have mappings relative to `name`: 1105 (make-resolved-module-path (cadr name)) 1106 ;; Let default handler try: 1107 (orig name rel-to stx load?))))))))))))] 1108 [(embedded-resolver) 1109 (case-lambda 1110 [(name from-namespace) 1111 ;; A notification 1112 (if from-namespace 1113 ;; If the source namespace has a mapping for `name', 1114 ;; then copy it to the current namespace. 1115 (let-values ([(name) (if name (resolved-module-path-name name) #f)]) 1116 (let-values ([(src-vec) (hash-ref regs (namespace-module-registry from-namespace) #f)]) 1117 (let-values ([(a) (if src-vec 1118 (assq name (vector-ref src-vec 0)) 1119 #f)]) 1120 (if a 1121 (let-values ([(vec) (hash-ref regs (namespace-module-registry (current-namespace)) 1122 (lambda () 1123 (let-values ([(vec) (vector null null)]) 1124 (hash-set! regs (namespace-module-registry (current-namespace)) vec) 1125 vec)))]) 1126 ;; add mapping: 1127 (vector-set! vec 0 (cons a (vector-ref vec 0))) 1128 ;; add library mappings: 1129 (vector-set! vec 1 (append 1130 (letrec-values ([(loop) 1131 (lambda (l) 1132 (if (null? l) 1133 null 1134 (if (eq? (cdar l) name) 1135 (cons (car l) (loop (cdr l))) 1136 (loop (cdr l)))))]) 1137 (loop library-table)) 1138 (vector-ref vec 1)))) 1139 (void))))) 1140 (void)) 1141 (orig name from-namespace)] 1142 [(name rel-to stx load?) 1143 (lookup name rel-to stx load? #f 1144 (lambda (name rel-to stx load?) 1145 ;; For a submodule, if we have a mapping for the base name, 1146 ;; then don't try the original handler. 1147 (let-values ([(base) 1148 (if (pair? name) 1149 (if (eq? (car name) 'submod) 1150 ;; Pass #t for `for-submod?`, which causes a 1151 ;; resolved module name to be returned for a quoted 1152 ;; module name if we have any relative mappings for it: 1153 (lookup (cadr name) rel-to stx load? #t (lambda (n r s l?) #f)) 1154 #f) 1155 #f)]) 1156 (if base 1157 ;; don't chain to `orig'; try `lookup` again with `(submod "." ...)`, 1158 ;; and if that still fails, just construct a submodule path: 1159 (lookup (cons 'submod (cons "." (cddr name))) base stx load? #f 1160 (lambda (name rel-to stx load?) 1161 (make-resolved-module-path 1162 (cons (resolved-module-path-name base) (cddr name))))) 1163 ;; chain to `orig': 1164 (orig name rel-to stx load?)))))])]) 1165 (current-module-name-resolver embedded-resolver)))))) 1166 1167(define (ss<->rkt path mk-full) 1168 (cond 1169 [(path-has-extension? path #".ss") 1170 (ss<->rkt (path-replace-extension path #".rkt") mk-full)] 1171 [(path-has-extension? path #".rkt") 1172 (define full-path (mk-full path)) 1173 (if (file-exists? full-path) 1174 full-path 1175 (let ([p2 (mk-full (path-replace-extension path #".ss"))]) 1176 (if (file-exists? p2) 1177 p2 1178 full-path)))] 1179 [else (mk-full path)])) 1180 1181;; Write a module bundle that can be loaded with 'load' (do not embed it 1182;; into an executable). The bundle is written to the current output port. 1183(define (do-write-module-bundle outp verbose? modules 1184 early-literal-expressions config? literal-files literal-expressions 1185 collects-dest 1186 on-extension program-name compiler expand-namespace 1187 src-filter get-extra-imports on-decls-done 1188 embedded-dlls-box) 1189 (let* ([program-name-bytes (if program-name 1190 (path->bytes program-name) 1191 #"?")] 1192 [module-paths (map cadr modules)] 1193 [use-submoduless (map (lambda (m) (if (pair? (cddr m)) (caddr m) '())) modules)] 1194 [resolve-one-path (lambda (mp) 1195 (let ([f (resolve-module-path mp #f)]) 1196 (unless f 1197 (error 'write-module-bundle "bad module path: ~e" mp)) 1198 (normalize f)))] 1199 [files (map resolve-one-path module-paths)] 1200 [collapse-one (lambda (mp) 1201 (collapse-module-path mp (build-path (current-directory) "dummy.rkt")))] 1202 [collapsed-mps (map collapse-one module-paths)] 1203 [gen-state (make-generate-file-mod-name-state (or (and (pair? files) 1204 (let-values ([(base name dir) (split-path (car files))]) 1205 base)) 1206 (current-directory)))] 1207 [file-mod-names (map (lambda (f m) 1208 (cons f (let ([p (car m)] 1209 [f (strip-submod f)]) 1210 (cond 1211 [(symbol? p) (format "~a~a" p (file-mod-name-base f))] 1212 [(eq? p #t) (generate-file-mod-name gen-state f)] 1213 [(not p) (file-mod-name-base f)] 1214 [else (error 1215 'write-module-bundle 1216 "bad prefix: ~e" 1217 p)])))) 1218 files modules)] 1219 ;; Each element is created with `make-mod'. 1220 ;; As we descend the module tree, we append to the front after 1221 ;; loading imports, so the list in the right order. 1222 [codes (box null)] 1223 [get-code-at (lambda (f mp submods) 1224 (get-code f mp #f submods codes file-mod-names verbose? collects-dest 1225 on-extension compiler expand-namespace 1226 src-filter get-extra-imports 1227 (make-hash) gen-state))] 1228 [__ 1229 ;; Load all code: 1230 (for-each get-code-at files collapsed-mps use-submoduless)] 1231 [config-infos (if config? 1232 (let ([a (assoc (car files) (unbox codes))]) 1233 (let ([info (module-compiled-language-info (mod-code a))]) 1234 (and info 1235 (let ([get-info ((dynamic-require (vector-ref info 0) (vector-ref info 1)) 1236 (vector-ref info 2))]) 1237 (get-info 'configure-runtime null))))) 1238 null)]) 1239 ;; Add module for runtime configuration: 1240 (when config-infos 1241 (for ([config-info (in-list config-infos)]) 1242 (let ([mp (vector-ref config-info 0)]) 1243 (get-code-at (resolve-one-path mp) 1244 (collapse-one mp) 1245 null)))) 1246 ;; Drop elements of `codes' that just record copied libs: 1247 (set-box! codes (filter mod-code (unbox codes))) 1248 ;; Bind `module' to get started: 1249 (write (compile-using-kernel '(namespace-require '(only '#%kernel module))) outp) 1250 ;; Install a module name resolver that redirects 1251 ;; to the embedded modules 1252 (write (make-module-name-resolver (filter mod-code (unbox codes))) outp) 1253 (write (compile-using-kernel '(namespace-require ''#%resolver)) outp) 1254 ;; Write the extension table and copy module code: 1255 (let* ([l (reverse (unbox codes))] 1256 [extensions (filter (lambda (m) (extension? (mod-code m))) l)] 1257 [runtimes (filter (lambda (m) (pair? (mod-runtime-paths m))) l)] 1258 [table-mod 1259 (if (null? runtimes) 1260 #f 1261 (let* ([table-sym (module-path-index-resolve 1262 (module-path-index-join '(lib "runtime-path-table.rkt" "racket" "private") 1263 #f))] 1264 [table-path (resolved-module-path-name table-sym)]) 1265 (assoc (normalize table-path) l)))]) 1266 (unless (null? extensions) 1267 ;; The extension table:` 1268 (write 1269 `(module #%extension-table '#%kernel 1270 (#%require '#%utils) 1271 (let-values ([(eXtEnSiOn-modules) ;; this name is magic for the exe->distribution process 1272 (quote ,(map (lambda (m) 1273 (let ([p (extension-path (mod-code m))]) 1274 (when verbose? 1275 (eprintf "Recording extension at ~s\n" p)) 1276 (list (path->bytes p) 1277 (mod-full-name m) 1278 ;; The program name isn't used. It just helps ensures that 1279 ;; there's plenty of room in the executable for patching 1280 ;; the path later when making a distribution. 1281 program-name-bytes))) 1282 extensions))]) 1283 (for-each (lambda (pr) 1284 (current-module-declare-name (make-resolved-module-path (cadr pr))) 1285 (let-values ([(p) (bytes->path (car pr))]) 1286 (load-extension (if (relative-path? p) 1287 (let-values ([(d) (current-directory)]) 1288 (current-directory (find-system-path 'orig-dir)) 1289 (begin0 1290 (let-values ([(p2) (find-executable-path (find-system-path 'exec-file) p #t)]) 1291 (if p2 1292 p2 1293 (path->complete-path p (current-directory)))) 1294 (current-directory d))) 1295 p)))) 1296 eXtEnSiOn-modules))) 1297 outp) 1298 (write (compile-using-kernel '(namespace-require ''#%extension-table)) outp)) 1299 ;; Runtime-path table: 1300 (unless (null? runtimes) 1301 (unless table-mod 1302 (error 'create-embedding-executable "cannot find module for runtime-path table")) 1303 (write (compile-using-kernel 1304 `(current-module-declare-name (make-resolved-module-path 1305 ',(mod-full-name table-mod)))) 1306 outp) 1307 (write `(module runtime-path-table '#%kernel 1308 (#%provide table) 1309 (define-values (table) 1310 (make-immutable-hash 1311 (let-values ([(rUnTiMe-paths) ; this is a magic name for exe->distribution process 1312 ',(apply append 1313 (map (lambda (nc) 1314 (map (lambda (p sym) 1315 (list 1316 (cons (mod-full-name nc) 1317 (if (path? p) 1318 (path->bytes p) 1319 (if (and (pair? p) 1320 (eq? 'module (car p))) 1321 (list 'module (let ([p (cadr p)]) 1322 (if (path? p) 1323 `(path ,(encode-link-path p)) 1324 p))) 1325 p))) 1326 (let ([p (cond 1327 [(bytes? p) (bytes->path p)] 1328 [(so-spec? p) 1329 (define path (so-find p 1330 (cross-system-type 'so-suffix) 1331 (get-cross-lib-search-dirs))) 1332 (cond 1333 [(and path embedded-dlls-box) 1334 (set-box! embedded-dlls-box (cons path (unbox embedded-dlls-box))) 1335 ;; Don't record the path in the executable since we'll 1336 ;; record the whole DLL in the executable 1337 #f] 1338 [else path])] 1339 [(share-spec? p) (share-find p)] 1340 [(and (list? p) 1341 (eq? 'lib (car p))) 1342 (let ([p (if (null? (cddr p)) 1343 (if (regexp-match #rx"^[^/]*[.]" (cadr p)) 1344 p 1345 (let ([s (regexp-split #rx"/" (cadr p))]) 1346 (if (null? (cdr s)) 1347 `(lib "main.rkt" ,(cadr p)) 1348 (let ([s (reverse s)]) 1349 `(lib ,(car s) ,@(reverse (cdr s))))))) 1350 p)]) 1351 (ss<->rkt 1352 (cadr p) 1353 (lambda (file) 1354 (apply collection-file-path 1355 file 1356 (if (null? (cddr p)) 1357 (list "mzlib") 1358 (cddr p)) 1359 #:check-compiled? #f))))] 1360 [(and (list? p) 1361 (eq? 'module (car p))) 1362 sym] 1363 [else p])]) 1364 (and p 1365 (if (symbol? p) 1366 p 1367 (path->bytes 1368 (simplify-path 1369 (if (absolute-path? p) 1370 p 1371 (build-path (path-only (mod-file nc)) p))))))) 1372 ;; As for the extension table, a placeholder to save 1373 ;; room likely needed by the distribution-mangler. 1374 ;; The extra "."s are meant to cover the relative 1375 ;; path (even in Windows format) to runtime files, 1376 ;; and the program name is also part of that path. 1377 (bytes-append (make-bytes 32 (char->integer #\.)) program-name-bytes))) 1378 (mod-runtime-paths nc) 1379 (mod-runtime-module-syms nc))) 1380 runtimes))]) 1381 rUnTiMe-paths)))) 1382 outp)) 1383 ;; Copy module code: 1384 (for-each 1385 (lambda (nc) 1386 (unless (or (extension? (mod-code nc)) 1387 (eq? nc table-mod)) 1388 (when verbose? 1389 (eprintf "Writing module from ~s\n" (mod-file nc))) 1390 (write (compile-using-kernel 1391 `(current-module-declare-name 1392 (make-resolved-module-path 1393 ',(mod-full-name nc)))) 1394 outp) 1395 (if (mod-use-source? nc) 1396 (call-with-input-file* (mod-actual-file nc) 1397 (lambda (inp) 1398 (define bstr (port->bytes inp)) 1399 ;; The indirection through `compiler/private/read-bstr` ensures 1400 ;; that the source module is delimited by an EOF: 1401 (fprintf outp "#reader compiler/private/read-bstr ~s" bstr))) 1402 (write (mod-code nc) outp)))) 1403 l)) 1404 (write (compile-using-kernel '(current-module-declare-name #f)) outp) 1405 ;; Remove `module' binding before we start running user code: 1406 (write (compile-using-kernel '(namespace-set-variable-value! 'module #f #t)) outp) 1407 (write (compile-using-kernel '(namespace-undefine-variable! 'module)) outp) 1408 (on-decls-done outp) 1409 (newline outp) 1410 (for-each (lambda (v) (write v outp)) early-literal-expressions) 1411 (when config-infos 1412 (for ([config-info (in-list config-infos)]) 1413 (let ([a (assoc (resolve-one-path (vector-ref config-info 0)) (unbox codes))]) 1414 (write (compile-using-kernel `((dynamic-require '',(mod-full-name a) 1415 ',(vector-ref config-info 1)) 1416 ',(vector-ref config-info 2))) 1417 outp)))) 1418 (for-each (lambda (f) 1419 (when verbose? 1420 (eprintf "Copying from ~s\n" f)) 1421 (call-with-input-file* f 1422 (lambda (i) 1423 (copy-port i outp)))) 1424 literal-files) 1425 (for-each (lambda (v) (write v outp)) literal-expressions))) 1426 1427(define (make-default-compiler expand-namespace) 1428 (lambda (expr) 1429 (parameterize ([current-namespace expand-namespace] 1430 [current-compile-target-machine (get-compile-target-machine)]) 1431 (compile expr)))) 1432 1433(define (write-module-bundle #:verbose? [verbose? #f] 1434 #:modules [modules null] 1435 #:configure-via-first-module? [config? #f] 1436 #:literal-files [literal-files null] 1437 #:early-literal-expressions [early-literal-expressions null] 1438 #:literal-expressions [literal-expressions null] 1439 #:on-extension [on-extension #f] 1440 #:expand-namespace [expand-namespace (current-namespace)] 1441 #:compiler [compiler (make-default-compiler expand-namespace)] 1442 #:src-filter [src-filter (lambda (filename) #f)] 1443 #:get-extra-imports [get-extra-imports (lambda (filename code) null)]) 1444 (do-write-module-bundle (current-output-port) verbose? modules 1445 early-literal-expressions config? literal-files literal-expressions 1446 #f ; collects-dest 1447 on-extension 1448 #f ; program-name 1449 compiler expand-namespace 1450 src-filter get-extra-imports 1451 void 1452 #f)) ; don't accumulate embedded DLLs 1453 1454(define (cross-compiling?) 1455 (cross-multi-compile? (current-compiled-file-roots))) 1456 1457(define (get-compile-target-machine) 1458 (if (cross-compiling?) 1459 (cross-system-type 'target-machine) 1460 (system-type 'target-machine))) 1461 1462 1463;; The old interface: 1464(define make-embedding-executable 1465 (lambda (dest mred? verbose? 1466 modules 1467 literal-files literal-expression 1468 cmdline 1469 [aux null] 1470 [launcher? #f] 1471 [variant (cross-system-type 'gc)] 1472 [collects-path #f]) 1473 (create-embedding-executable dest 1474 #:mred? mred? 1475 #:verbose? verbose? 1476 #:modules modules 1477 #:literal-files literal-files 1478 #:literal-expression literal-expression 1479 #:cmdline cmdline 1480 #:aux aux 1481 #:launcher? launcher? 1482 #:variant variant 1483 #:collects-path collects-path))) 1484 1485;; Use `write-module-bundle', but figure out how to put it into an executable 1486(define (create-embedding-executable dest 1487 #:mred? [really-mred? #f] 1488 #:gracket? [gracket? #f] 1489 #:verbose? [verbose? #f] 1490 #:modules [modules null] 1491 #:configure-via-first-module? [config? #f] 1492 #:literal-files [literal-files null] 1493 #:early-literal-expressions [early-literal-expressions null] 1494 #:literal-expression [literal-expression #f] 1495 #:literal-expressions [literal-expressions 1496 (if literal-expression 1497 (list literal-expression) 1498 null)] 1499 #:cmdline [cmdline null] 1500 #:aux [aux null] 1501 #:launcher? [launcher? #f] 1502 #:variant [variant (cross-system-type 'gc)] 1503 #:collects-path [collects-path #f] 1504 #:collects-dest [collects-dest #f] 1505 #:on-extension [on-extension #f] 1506 #:expand-namespace [expand-namespace (current-namespace)] 1507 #:compiler [compiler (make-default-compiler expand-namespace)] 1508 #:src-filter [src-filter (lambda (filename) #f)] 1509 #:get-extra-imports [get-extra-imports (lambda (filename code) null)]) 1510 (define mred? (or really-mred? gracket?)) 1511 (define keep-exe? (and launcher? 1512 (let ([m (assq 'forget-exe? aux)]) 1513 (or (not m) 1514 (not (cdr m)))))) 1515 (define unix-starter? (and (eq? (cross-system-type) 'unix) 1516 (let ([m (assq 'original-exe? aux)]) 1517 (or (not m) 1518 (not (cdr m)))))) 1519 (define long-cmdline? #t) 1520 (define relative? (let ([m (assq 'relative? aux)]) 1521 (and m (cdr m)))) 1522 (define collects-path-bytes (collects-path->bytes 1523 ((if (and mred? 1524 (eq? 'macosx (cross-system-type))) 1525 mac-mred-collects-path-adjust 1526 values) 1527 collects-path))) 1528 (define word-size (if (fixnum? (expt 2 32)) 8 4)) 1529 (unless (or long-cmdline? 1530 ((apply + 1531 (map (lambda (s) 1532 (+ word-size (bytes-length (string->bytes/utf-8 s)))) 1533 cmdline)) . < . 80)) 1534 (error 'create-embedding-executable "command line too long: ~e" cmdline)) 1535 (check-collects-path 'create-embedding-executable collects-path collects-path-bytes) 1536 (let ([exe (find-exe #:cross? #t #:untethered? #t mred? variant)]) 1537 (when verbose? 1538 (eprintf "Copying to ~s\n" dest)) 1539 (let-values ([(dest-exe orig-exe osx?) 1540 (cond 1541 [(and mred? (eq? 'macosx (cross-system-type))) 1542 (values (prepare-macosx-mred exe dest aux variant) 1543 (mac-dest->executable (find-in-lib "Starter.app") 1544 #t) 1545 #t)] 1546 [unix-starter? 1547 (let ([starter (find-in-lib (if (force exe-suffix?) 1548 "starter.exe" 1549 "starter"))]) 1550 (when (or (file-exists? dest) 1551 (directory-exists? dest) 1552 (link-exists? dest)) 1553 (delete-file dest)) 1554 (copy-file starter dest) 1555 (values dest starter #f))] 1556 [else 1557 (when (or (file-exists? dest) 1558 (directory-exists? dest) 1559 (link-exists? dest)) 1560 ;; Delete-file isn't enough if the target 1561 ;; is supposed to be a directory. But 1562 ;; currently, that happens only for GRacket 1563 ;; on Mac OS, which is handled above. 1564 (delete-file dest)) 1565 (copy-file exe dest) 1566 (values dest exe #f)])]) 1567 (with-handlers ([void (lambda (x) 1568 (if osx? 1569 (when (directory-exists? dest) 1570 (delete-directory/files dest)) 1571 (when (file-exists? dest) 1572 (delete-file dest))) 1573 (raise x))]) 1574 (define old-perms (ensure-writable dest-exe)) 1575 (when (and (eq? 'macosx (cross-system-type)) 1576 (not unix-starter?) 1577 (get-current-framework-path (mac-dest->executable dest mred?) "Racket")) 1578 (remove-signature dest-exe) ;; best to do this before modifying the file in any other way 1579 (let ([m (or (assq 'framework-root aux) 1580 (and relative? '(framework-root . #f)))]) 1581 (if m 1582 (if (cdr m) 1583 (update-framework-path (cdr m) 1584 (mac-dest->executable dest mred?) 1585 mred?) 1586 (when mred? 1587 ;; adjust relative path, since exe may change directory : 1588 (define rel (find-relative-path* dest (find-relevant-lib-dir "Racket.framework"))) 1589 (update-framework-path (format "@executable_path/../../../~a" 1590 (path->directory-path rel)) 1591 (mac-dest->executable dest mred?) 1592 #t))) 1593 ;; Check whether we need an absolute path to frameworks: 1594 (let ([dest (mac-dest->executable dest mred?)]) 1595 (when (regexp-match #rx"^@executable_path" 1596 (get-current-framework-path dest "Racket")) 1597 (update-framework-path (string-append 1598 (path->string (find-relevant-lib-dir "Racket.framework")) 1599 "/") 1600 dest 1601 mred?)))))) 1602 (define embed-dlls? (and (eq? 'windows (cross-system-type)) 1603 (let ([m (assq 'embed-dlls? aux)]) 1604 (and m (cdr m))))) 1605 (define embedded-dlls-box (and embed-dlls? (box null))) 1606 (when (eq? 'windows (cross-system-type)) 1607 (cond 1608 [embed-dlls? 1609 (update-dll-dir dest #t)] 1610 [else 1611 (let ([m (or (assq 'dll-dir aux) 1612 (and relative? '(dll-dir . #f)))]) 1613 (if m 1614 (if (cdr m) 1615 (update-dll-dir dest (cdr m)) 1616 ;; adjust relative path, since exe directory can change: 1617 (update-dll-dir dest (find-relative-path* dest (find-cross-dll-dir)))) 1618 ;; Check whether we need an absolute path to DLLs: 1619 (let ([dir (get-current-dll-dir dest)]) 1620 (when (relative-path? dir) 1621 (let-values ([(orig-dir name dir?) (split-path 1622 (path->complete-path orig-exe))]) 1623 (update-dll-dir dest (build-path orig-dir dir)))))))])) 1624 (define (adjust-config-dir) 1625 (let ([m (or (assq 'config-dir aux) 1626 (and relative? '(config-dir . #f)))] 1627 [dest->executable (lambda (dest) 1628 (if osx? 1629 (mac-dest->executable dest mred?) 1630 dest))]) 1631 (define (gui-bin->config rel) 1632 ;; Find the path to config-dir relative to the executable 1633 (define p (find-relative-path* (if keep-exe? orig-exe dest) (find-config-dir))) 1634 (simplify-path 1635 (if (eq? rel 'same) 1636 p 1637 (build-path rel p)) 1638 #f)) 1639 (if m 1640 (if (cdr m) 1641 (update-config-dir (dest->executable dest) (cdr m)) 1642 (when (and mred? (not keep-exe?)) 1643 (cond 1644 [osx? 1645 ;; adjust relative path (since GRacket is likely off by one): 1646 (update-config-dir (mac-dest->executable dest mred?) 1647 (gui-bin->config "../../.."))] 1648 [(eq? 'windows (cross-system-type)) 1649 ;; adjust relative path (since GRacket is likely off by one): 1650 (update-config-dir dest (gui-bin->config 'same))] 1651 [else 1652 (update-config-dir dest (gui-bin->config 'same))]))) 1653 ;; Check whether we need an absolute path to config: 1654 (let ([dir (get-current-config-dir (dest->executable dest))]) 1655 (when (relative-path? dir) 1656 (let-values ([(orig-dir name dir?) (split-path 1657 (path->complete-path orig-exe))]) 1658 (update-config-dir (dest->executable dest) 1659 (build-path orig-dir dir)))))))) 1660 (unless unix-starter? ; need to delay adjustment for Unix starter; see below 1661 (adjust-config-dir)) 1662 (let ([write-module 1663 (lambda (s) 1664 (define pos #f) 1665 (do-write-module-bundle s 1666 verbose? modules 1667 early-literal-expressions config? 1668 literal-files literal-expressions collects-dest 1669 on-extension 1670 (file-name-from-path dest) 1671 compiler 1672 expand-namespace 1673 src-filter 1674 get-extra-imports 1675 (lambda (outp) (set! pos (file-position outp))) 1676 embedded-dlls-box) 1677 pos)] 1678 [make-full-cmdline 1679 (lambda (start decl-end end) 1680 (let ([start-s (number->string start)] 1681 [decl-end-s (number->string decl-end)] 1682 [end-s (number->string end)]) 1683 (append (if launcher? 1684 (if (and keep-exe? 1685 ;; a unix starter uses the same path as it execs 1686 (not unix-starter?)) 1687 ;; argv[0] replacement: 1688 (list (path->string 1689 (if relative? 1690 (relativize exe dest-exe values) 1691 exe))) 1692 ;; No argv[0]: 1693 null) 1694 (list "-k" start-s decl-end-s end-s)) 1695 cmdline)))] 1696 [make-starter-cmdline 1697 (lambda (full-cmdline) 1698 (apply bytes-append 1699 (map (lambda (s) 1700 (bytes-append 1701 (cond 1702 [(path? s) (path->bytes s)] 1703 [else (string->bytes/locale s)]) 1704 #"\0")) 1705 (append 1706 (list (if relative? 1707 (relativize exe dest-exe values) 1708 exe) 1709 (let ([dir (find-cross-dll-dir)]) 1710 (if dir 1711 (if relative? 1712 (relativize dir dest-exe values) 1713 dir) 1714 ""))) 1715 full-cmdline))))] 1716 [write-cmdline 1717 (lambda (full-cmdline out) 1718 (for-each 1719 (lambda (s) 1720 (fprintf out "~a~a~c" 1721 (integer->integer-bytes 1722 (add1 (bytes-length (string->bytes/utf-8 s)) ) 1723 4 #t #f) 1724 s 1725 #\000)) 1726 full-cmdline) 1727 (display "\0\0\0\0" out))]) 1728 (let-values ([(start decl-end end cmdline-end) 1729 (cond 1730 [(eq? (cross-system-type) 'windows) 1731 ;; Add as a resource 1732 (define o (open-output-bytes)) 1733 (define decl-len (write-module o)) 1734 (define init-len (bytes-length (get-output-bytes o))) 1735 (write-cmdline (make-full-cmdline 0 decl-len init-len) o) 1736 (define bstr (get-output-bytes o)) 1737 (define cmdline-len (- (bytes-length bstr) init-len)) 1738 (define-values (pe rsrcs) (call-with-input-file* 1739 dest-exe 1740 read-pe+resources)) 1741 (define new-rsrcs (resource-set rsrcs 1742 ;; Racket's "user-defined" type for excutable 1743 ;; plus command line: 1744 257 1745 1 1746 1033 ; U.S. English 1747 bstr)) 1748 (define new+dll-rsrcs 1749 (if embed-dlls? 1750 (resource-set new-rsrcs 1751 ;; Racket's "user-defined" type for embedded DLLs: 1752 258 1753 1 1754 1033 ; U.S. English 1755 (pack-embedded-dlls 1756 (append 1757 (get-racket-dlls 1758 (list 1759 (case (cross-system-type 'gc) 1760 [(3m) (if mred? 'gracket3m 'racket3m)] 1761 [(cgc) (if mred? 'gracketcgc 'racketcgc)] 1762 [(cs) (if mred? 'gracketcs 'racketcs)]))) 1763 (unbox embedded-dlls-box)))) 1764 new-rsrcs)) 1765 (update-resources dest-exe pe new+dll-rsrcs) 1766 (values 0 decl-len init-len (+ init-len cmdline-len))] 1767 [(memq (cross-system-type 'os*) '(macosx darwin)) 1768 ;; For Mach-O, we know how to add a proper segment 1769 (remove-signature dest-exe) ; may be needed in 'darwin mode 1770 (define s (open-output-bytes)) 1771 (define decl-len (write-module s)) 1772 (let* ([s (get-output-bytes s)] 1773 [cl (let ([o (open-output-bytes)]) 1774 ;; position is relative to __PLTSCHEME: 1775 (let ([cmdline (make-full-cmdline 0 decl-len (bytes-length s))]) 1776 (cond 1777 [unix-starter? (display (make-starter-cmdline cmdline) o)] 1778 [else (write-cmdline cmdline o)])) 1779 (get-output-bytes o))]) 1780 (let ([start (add-plt-segment 1781 dest-exe 1782 (bytes-append 1783 s 1784 cl))]) 1785 (let ([start 0]) ; i.e., relative to __PLTSCHEME 1786 (values start 1787 (+ start decl-len) 1788 (+ start (bytes-length s)) 1789 (+ start (bytes-length s) (bytes-length cl))))))] 1790 [else 1791 ;; Unix starter or direct embedding: Maybe ELF, in which case we 1792 ;; can add a proper section 1793 (define-values (s e dl p) 1794 (add-racket-section 1795 orig-exe 1796 dest-exe 1797 #".rackprog" 1798 (lambda (start) 1799 (let ([s (open-output-bytes)]) 1800 (define decl-len (write-module s)) 1801 (let ([p (file-position s)]) 1802 (let ([cmdline (make-full-cmdline 0 decl-len p)]) 1803 (cond 1804 [unix-starter? (display (make-starter-cmdline cmdline) s)] 1805 [else (write-cmdline cmdline s)])) 1806 (values (get-output-bytes s) decl-len p)))))) 1807 (if (and s e) 1808 ;; ELF succeeded, so make values relative to start: 1809 (values 0 dl p (- e s)) 1810 ;; Otherwise, just add to the end of the file: 1811 (let ([start (file-size dest-exe)]) 1812 (define decl-end 1813 (call-with-output-file* dest-exe write-module 1814 #:exists 'append)) 1815 (values start decl-end (file-size dest-exe) #f)))])]) 1816 (when unix-starter? 1817 (adjust-config-dir)) 1818 (when verbose? 1819 (eprintf "Setting command line\n")) 1820 (let () 1821 (let ([full-cmdline (make-full-cmdline start decl-end end)]) 1822 (cond 1823 [collects-path-bytes 1824 (when verbose? 1825 (eprintf "Setting collection path\n")) 1826 (set-collects-path dest-exe collects-path-bytes)] 1827 [(and mred? (not keep-exe?)) 1828 (cond 1829 [osx? 1830 ;; default path in `gracket' is off by one: 1831 (set-collects-path dest-exe (path->bytes 1832 (build-path 'up 'up 'up 1833 (find-relative-path* dest (find-collects-dir)))))] 1834 [(eq? 'windows (cross-system-type)) 1835 ;; off by one in this case, too: 1836 (set-collects-path dest-exe (path->bytes 1837 (find-relative-path* dest (find-collects-dir))))])]) 1838 (cond 1839 [unix-starter? 1840 (let ([numpos (with-input-from-file dest-exe 1841 (lambda () (find-cmdline 1842 "configuration" 1843 #"cOnFiG:")))] 1844 [typepos (and (or mred? (or (eq? variant '3m) 1845 (eq? variant 'cs))) 1846 (with-input-from-file dest-exe 1847 (lambda () (find-cmdline 1848 "exeuctable type" 1849 #"bINARy tYPe:"))))] 1850 [cmdline (if cmdline-end 1851 #f 1852 (make-starter-cmdline full-cmdline))] 1853 [out (open-output-file dest-exe #:exists 'update)]) 1854 (let ([old-cmdline-end cmdline-end] 1855 [cmdline-end (or cmdline-end (+ end (bytes-length cmdline)))] 1856 [write-num (lambda (n) 1857 (write-bytes (integer->integer-bytes n 4 #t #f) out))]) 1858 (dynamic-wind 1859 void 1860 (lambda () 1861 (when typepos 1862 (when mred? 1863 (file-position out (+ typepos 13)) 1864 (write-bytes #"r" out)) 1865 (when (eq? variant '3m) 1866 (file-position out (+ typepos 15)) 1867 (write-bytes #"3" out)) 1868 (when (eq? variant 'cs) 1869 (file-position out (+ typepos 15)) 1870 (write-bytes #"s" out)) 1871 (flush-output out)) 1872 (file-position out (+ numpos 7)) 1873 (write-bytes (if keep-exe? #"*" #"!") out) 1874 (write-num start) 1875 (write-num decl-end) 1876 (write-num end) 1877 (write-num cmdline-end) 1878 (write-num (length full-cmdline)) 1879 (write-num (if mred? 1 0)) 1880 (flush-output out) 1881 (unless old-cmdline-end 1882 (file-position out end) 1883 (write-bytes cmdline out) 1884 (flush-output out))) 1885 (lambda () 1886 (close-output-port out)))))] 1887 [else 1888 (let ([cmdpos (with-input-from-file dest-exe 1889 (lambda () (find-cmdline 1890 "cmdline" 1891 #"\\[Replace me for EXE hack")))] 1892 [anotherpos (and mred? 1893 (eq? 'windows (cross-system-type)) 1894 (let ([m (assq 'single-instance? aux)]) 1895 (and m (not (cdr m)))) 1896 (with-input-from-file dest-exe 1897 (lambda () (find-cmdline 1898 "instance-check" 1899 #"yes, please check for another"))))] 1900 [out (open-output-file dest-exe #:exists 'update)] 1901 [cmdline-done? cmdline-end]) 1902 (dynamic-wind 1903 void 1904 (lambda () 1905 (when anotherpos 1906 (file-position out anotherpos) 1907 (write-bytes #"no," out)) 1908 (if long-cmdline? 1909 ;; write cmdline at end: 1910 (unless cmdline-done? 1911 (file-position out end)) 1912 (begin 1913 ;; write (short) cmdline in the normal position: 1914 (file-position out cmdpos) 1915 (display "!" out))) 1916 (unless cmdline-done? 1917 (write-cmdline full-cmdline out)) 1918 (when long-cmdline? 1919 ;; cmdline written at the end, in a resource, etc.; 1920 ;; now put forwarding information at the normal cmdline pos 1921 (let ([new-end (or cmdline-end 1922 (file-position out))]) 1923 (file-position out cmdpos) 1924 (fprintf out "~a...~a~a" 1925 (if keep-exe? "*" "?") 1926 (integer->integer-bytes end 4 #t #f) 1927 (integer->integer-bytes (- new-end end) 4 #t #f))))) 1928 (lambda () 1929 (close-output-port out))) 1930 (let ([m (and (eq? 'windows (cross-system-type)) 1931 (assq 'ico aux))]) 1932 (when m 1933 (replace-all-icos (read-icos (cdr m)) dest-exe))) 1934 (let ([m (and (eq? 'windows (cross-system-type)) 1935 (assq 'subsystem aux))]) 1936 (when m 1937 (set-subsystem dest-exe (cdr m)))))])))) 1938 (when (memq (cross-system-type 'os*) '(macosx darwin)) 1939 (add-ad-hoc-signature dest-exe)) 1940 (done-writable dest-exe old-perms)))))) 1941 1942;; For Mac OS GRacket, the actual executable is deep inside the 1943;; nominal executable bundle 1944(define (mac-mred-collects-path-adjust p) 1945 (cond 1946 [(not p) #f] 1947 [(list? p) (map mac-mred-collects-path-adjust p)] 1948 [(relative-path? p) (build-path 'up 'up 'up p)] 1949 [else p])) 1950 1951(define (find-relative-path* wrt-exe p) 1952 (define-values (wrt base name) (split-path (path->complete-path wrt-exe))) 1953 (find-relative-path (simplify-path wrt) (simplify-path p))) 1954 1955;; To embed DLLs in the executable as resource ID 258: 1956(define (pack-embedded-dlls name-or-paths) 1957 (define bstrs (for/list ([p (in-list name-or-paths)]) 1958 (file->bytes (if (string? p) 1959 (search-dll p) 1960 p)))) 1961 (define names (for/list ([p (in-list name-or-paths)]) 1962 (if (string? p) 1963 p 1964 (let-values ([(base name dir) (split-path p)]) 1965 (path-element->string name))))) 1966 (define start-pos (+ 4 ; count 1967 ;; name array: 1968 (for/sum ([p (in-list names)]) 1969 (+ 2 (bytes-length (string->bytes/utf-8 p)))) 1970 ;; starting-position array: 1971 (* 4 (add1 (length names))))) 1972 (define-values (rev-offsets total) 1973 (for/fold ([rev-offsets null] [total start-pos]) ([bstr (in-list bstrs)]) 1974 (values (cons total rev-offsets) 1975 (+ total (bytes-length bstr))))) 1976 (apply 1977 bytes-append 1978 (integer->integer-bytes (length names) 4 #t #f) 1979 (append 1980 (for/list ([p (in-list names)]) 1981 (define bstr (string->bytes/utf-8 p)) 1982 (bytes-append (integer->integer-bytes (bytes-length bstr) 2 #t #f) bstr)) 1983 (for/list ([offset (in-list (reverse rev-offsets))]) 1984 (integer->integer-bytes offset 4 #t #f)) 1985 (list (integer->integer-bytes total 4 #t #f)) 1986 bstrs))) 1987