diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 339b282d45..cc51c43723 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "6.2.900.10") +(define version "6.2.900.11") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/pkg/scribblings/lib.scrbl b/pkgs/racket-doc/pkg/scribblings/lib.scrbl index c5f74772e7..13cf6f6444 100644 --- a/pkgs/racket-doc/pkg/scribblings/lib.scrbl +++ b/pkgs/racket-doc/pkg/scribblings/lib.scrbl @@ -678,7 +678,7 @@ represented by @racket[dir] and named @racket[pkg-name].} [pkg-name string] [#:namespace namespace namespace? (make-base-namespace)] [#:system-type sys-type (or/c #f symbol?) (system-type)] - [#:system-library-subpath sys-lib-subpath (or/c #f path?) + [#:system-library-subpath sys-lib-subpath (or/c #f path-for-some-system?) (system-library-subpath #f)]) (listof (cons/c symbol? string?))]{ diff --git a/pkgs/racket-doc/scribblings/raco/common.rkt b/pkgs/racket-doc/scribblings/raco/common.rkt index 983db069ba..be564f6ce5 100644 --- a/pkgs/racket-doc/scribblings/raco/common.rkt +++ b/pkgs/racket-doc/scribblings/raco/common.rkt @@ -7,5 +7,8 @@ (define inside-doc '(lib "scribblings/inside/inside.scrbl")) +(define guide-doc + '(lib "scribblings/guide/guide.scrbl")) + (define reference-doc '(lib "scribblings/reference/reference.scrbl")) diff --git a/pkgs/racket-doc/scribblings/raco/setup.scrbl b/pkgs/racket-doc/scribblings/raco/setup.scrbl index e2a3f2b833..58d6b50d9f 100644 --- a/pkgs/racket-doc/scribblings/raco/setup.scrbl +++ b/pkgs/racket-doc/scribblings/raco/setup.scrbl @@ -14,6 +14,7 @@ setup/collection-name setup/collection-search setup/matching-platform + setup/cross-system setup/path-to-relative setup/xref scribble/xref ;; info -- no bindings from this are used @@ -1782,9 +1783,14 @@ Returns @racket[#t] if @racket[v] is a symbol, string, or regexp value (in the sense of @racket[regexp?]), @racket[#f] otherwise.} @defproc[(matching-platform? [spec platform-spec?] - [#:system-type sys-type (or/c #f symbol?) (system-type)] - [#:system-library-subpath sys-lib-subpath (or/c #f path?) - (system-library-subpath #f)]) + [#:cross? cross? any/c #f] + [#:system-type sys-type (or/c #f symbol?) (if cross? + (cross-system-type) + (system-type))] + [#:system-library-subpath sys-lib-subpath (or/c #f path-for-some-system?) + (if cross? + (cross-system-library-subpath #f) + (system-library-subpath #f))]) boolean?]{ Reports whether @racket[spec] matches @racket[sys-type] or @@ -1800,8 +1806,74 @@ If @racket[spec] is a string, then the result is @racket[#t] if If @racket[spec] is a regexp value, then the result is @racket[#t] if the regexp matches @racket[(path->string sys-lib-subpath)], +@racket[#f] otherwise. + +@history[#:changed "6.2.900.11" @elem{Added @racket[#:cross?] argument and + changed the contract on @racket[sys-lib-subpath] + to accept @racket[path-for-some-system?] + instead of just @racket[path?].}]} + +@; ------------------------------------------------------------------------ + +@section[#:tag "cross-system"]{API for Cross-Platform Configuration} + +@defmodule[setup/cross-system]{The @racketmodname[setup/cross-system] +library provides functions for querying the system properties of a +destination platform, which can be different than the current platform +in cross-installation modes.} + +A Racket installation includes a @filepath{system.rktd} file in the +directory reported by @racket[(find-lib-dir)]. When the information in that file +does not match the running Racket's information, then the +@racketmodname[setup/cross-system] module infers that Racket is being +run in cross-installation mode. + +For example, if an in-place Racket installation for a different +platform resides at @nonterm{cross-dir}, then + +@commandline{racket -G @nonterm{cross-dir}/etc -X @nonterm{cross-dir}/collects -l- raco pkg} + +runs @exec{raco pkg} using the current platform's @exec{racket} +executable, but using the collections and other configuration +information of @nonterm{cross-dir}, as well as modifying the packages +of @nonterm{cross-dir}. That can work as long as no platform-specific +libraries need to run to perform the requested @exec{raco pkg} action +(e.g., when installing built packages). + + +@history[#:added "6.2.900.11"] + +@defproc[(cross-system-type [mode (or/c 'os 'word 'gc 'link 'machine + 'so-suffix 'so-mode 'fs-change) + 'os]) + (or/c symbol? string? bytes? exact-positive-integer? vector?)]{ + +Like @racket[system-type], but for the target platform instead of the +current platform in cross-installation mode. When not in +cross-installation mode, the results are the same as for +@racket[system-type].} + + +@defproc[(cross-system-library-subpath [mode (or/c 'cgc '3m #f) + (system-type 'gc)]) + path-for-some-system?]{ + +Like @racket[system-library-subpath], but for the target platform +instead of the current platform in cross-installation mode. When not +in cross-installation mode, the results are the same as for +@racket[system-library-subpath]. + +In cross-installation mode, the target platform may have a different +path convention than the current platform, so the result is +@racket[path-for-some-system?] instead of @racket[path?].} + + +@defproc[(cross-installation?) boolean?]{ + +Returns @racket[#t] if cross-installation mode has been detected, @racket[#f] otherwise.} + @; ------------------------------------------------------------------------ @section[#:tag "xref"]{API for Cross-References for Installed Manuals} diff --git a/pkgs/racket-doc/scribblings/reference/runtime.scrbl b/pkgs/racket-doc/scribblings/reference/runtime.scrbl index 80f441f91d..cfce564784 100644 --- a/pkgs/racket-doc/scribblings/reference/runtime.scrbl +++ b/pkgs/racket-doc/scribblings/reference/runtime.scrbl @@ -1,5 +1,6 @@ #lang scribble/doc -@(require "mz.rkt") +@(require "mz.rkt" + (for-label setup/cross-system)) @title[#:tag "runtime"]{Environment and Runtime Information} @@ -9,7 +10,8 @@ (or/c symbol? string? bytes? exact-positive-integer? vector?)]{ Returns information about the operating system, build mode, or machine -for a running Racket. +for a running Racket. (Installation tools should use @racket[cross-system-type], +instead, to support cross-installation.) In @indexed-racket['os] mode, the possible symbol results are: @@ -117,7 +119,10 @@ The optional @racket[mode] argument specifies the relevant garbage-collection variant, which one of the possible results of @racket[(system-type 'gc)]: @racket['cgc] or @racket['3m]. It can also be @racket[#f], in which case the result is independent of the -garbage-collection variant.} +garbage-collection variant. + +Installation tools should use @racket[cross-system-library-subpath], +instead, to support cross-installation.} @defproc[(version) (and/c string? immutable?)]{ diff --git a/racket/collects/compiler/distribute.rkt b/racket/collects/compiler/distribute.rkt index bfad737437..ca6d6291af 100644 --- a/racket/collects/compiler/distribute.rkt +++ b/racket/collects/compiler/distribute.rkt @@ -4,6 +4,7 @@ setup/dirs racket/list setup/variant + setup/cross-system pkg/path setup/main-collects dynext/filename-version @@ -22,7 +23,7 @@ [_ (unless (directory-exists? dest-dir) (make-directory dest-dir))] [sub-dirs (map (lambda (b type) - (case (system-type) + (case (cross-system-type) [(windows) #f] [(unix) "bin"] [(macosx) (if (memq type '(gracketcgc gracket3m)) @@ -41,7 +42,7 @@ (let-values ([(base name dir?) (split-path b)]) (let ([dest (build-path dest-dir name)]) (if (and (memq type '(gracketcgc gracket3m)) - (eq? 'macosx (system-type))) + (eq? 'macosx (cross-system-type))) (begin (copy-app b dest) (app-to-file dest)) @@ -51,7 +52,7 @@ orig-binaries sub-dirs types)] - [single-mac-app? (and (eq? 'macosx (system-type)) + [single-mac-app? (and (eq? 'macosx (cross-system-type)) (= 1 (length types)) (memq (car types) '(gracketcgc gracket3m)))]) ;; Create directories for libs, collects, and extensions: @@ -111,7 +112,7 @@ (cond [sub-dir (build-path 'up relative-dir)] - [(and (eq? 'macosx (system-type)) + [(and (eq? 'macosx (cross-system-type)) (memq type '(gracketcgc gracket3m)) (not single-mac-app?)) (build-path 'up 'up 'up relative-dir)] @@ -139,7 +140,7 @@ (void)))))) (define (install-libs lib-dir types) - (case (system-type) + (case (cross-system-type) [(windows) (let ([copy-dll (lambda (name) (copy-file* (search-dll (find-dll-dir) name) @@ -275,7 +276,7 @@ (build-path lib-dir (car files))))) (define (patch-binaries binaries types) - (case (system-type) + (case (cross-system-type) [(windows) (for-each (lambda (b) (update-dll-dir b "lib")) @@ -565,7 +566,7 @@ ;; Utilities (define (shared-libraries?) - (eq? 'shared (system-type 'link))) + (eq? 'shared (cross-system-type 'link))) (define (to-path s) (if (string? s) @@ -580,7 +581,7 @@ (let ([m (regexp-match #rx#"bINARy tYPe:(e?)(.)(.)(.)" (current-input-port))]) (if m (begin - (when (eq? 'unix (system-type)) + (when (eq? 'unix (cross-system-type)) (unless (equal? (cadr m) #"e") (error 'assemble-distribution "file is an original PLT executable, not a stub binary: ~e" @@ -635,7 +636,7 @@ (copy-directory/files src dest)) (define (app-to-file b) - (if (and (eq? 'macosx (system-type)) + (if (and (eq? 'macosx (cross-system-type)) (regexp-match #rx#"[.][aA][pP][pP]$" (path->bytes (if (string? b) (string->path b) diff --git a/racket/collects/compiler/embed.rkt b/racket/collects/compiler/embed.rkt index 5bf8add8f4..105b4966eb 100644 --- a/racket/collects/compiler/embed.rkt +++ b/racket/collects/compiler/embed.rkt @@ -12,6 +12,7 @@ setup/variant file/ico racket/private/so-search + setup/cross-system "private/winsubsys.rkt" "private/macfw.rkt" "private/mach-o.rkt" @@ -84,10 +85,10 @@ #f) (define (embedding-executable-is-actually-directory? mred?) - (and mred? (eq? 'macosx (system-type)))) + (and mred? (eq? 'macosx (cross-system-type)))) (define (embedding-executable-put-file-extension+style+filters mred?) - (case (system-type) + (case (cross-system-type) [(windows) (values "exe" null '(("Executable" "*.exe")))] [(macosx) (if mred? (values "app" '(enter-packages) '(("App" "*.app"))) @@ -102,7 +103,7 @@ (if (regexp-match re (path->bytes path)) path (path-replace-suffix path sfx)))]) - (case (system-type) + (case (cross-system-type) [(windows) (fixup #rx#"[.][eE][xX][eE]$" #".exe")] [(macosx) (if mred? (fixup #rx#"[.][aA][pP][pP]$" #".app") @@ -118,7 +119,7 @@ dest)) (define exe-suffix? - (delay (equal? #"i386-cygwin" (path->bytes (system-library-subpath))))) + (delay (equal? #"i386-cygwin" (path->bytes (cross-system-library-subpath))))) ;; Find the magic point in the binary: (define (find-cmdline what rx) @@ -1343,7 +1344,7 @@ cmdline [aux null] [launcher? #f] - [variant (system-type 'gc)] + [variant (cross-system-type 'gc)] [collects-path #f]) (create-embedding-executable dest #:mred? mred? @@ -1374,7 +1375,7 @@ #:cmdline [cmdline null] #:aux [aux null] #:launcher? [launcher? #f] - #:variant [variant (system-type 'gc)] + #:variant [variant (cross-system-type 'gc)] #:collects-path [collects-path #f] #:collects-dest [collects-dest #f] #:on-extension [on-extension #f] @@ -1389,18 +1390,18 @@ (let ([m (assq 'forget-exe? aux)]) (or (not m) (not (cdr m)))))) - (define unix-starter? (and (eq? (system-type) 'unix) + (define unix-starter? (and (eq? (cross-system-type) 'unix) (let ([m (assq 'original-exe? aux)]) (or (not m) (not (cdr m)))))) - (define long-cmdline? (or (eq? (system-type) 'windows) - (eq? (system-type) 'macosx) + (define long-cmdline? (or (eq? (cross-system-type) 'windows) + (eq? (cross-system-type) 'macosx) unix-starter?)) (define relative? (let ([m (assq 'relative? aux)]) (and m (cdr m)))) (define collects-path-bytes (collects-path->bytes ((if (and mred? - (eq? 'macosx (system-type))) + (eq? 'macosx (cross-system-type))) mac-mred-collects-path-adjust values) collects-path))) @@ -1417,7 +1418,7 @@ (eprintf "Copying to ~s\n" dest)) (let-values ([(dest-exe orig-exe osx?) (cond - [(and mred? (eq? 'macosx (system-type))) + [(and mred? (eq? 'macosx (cross-system-type))) (values (prepare-macosx-mred exe dest aux variant) (mac-dest->executable (build-path (find-lib-dir) "Starter.app") #t) @@ -1452,7 +1453,7 @@ (delete-file dest))) (raise x))]) (define old-perms (ensure-writable dest-exe)) - (when (and (eq? 'macosx (system-type)) + (when (and (eq? 'macosx (cross-system-type)) (not unix-starter?)) (let ([m (or (assq 'framework-root aux) (and relative? '(framework-root . #f)))]) @@ -1475,7 +1476,7 @@ "/") dest mred?)))))) - (when (eq? 'windows (system-type)) + (when (eq? 'windows (cross-system-type)) (let ([m (or (assq 'dll-dir aux) (and relative? '(dll-dir . #f)))]) (if m @@ -1505,7 +1506,7 @@ ;; adjust relative path (since GRacket is off by one): (update-config-dir (mac-dest->executable dest mred?) "../../../etc/")] - [(eq? 'windows (system-type)) + [(eq? 'windows (cross-system-type)) (unless keep-exe? ;; adjust relative path (since GRacket is off by one): (update-config-dir dest "etc/"))]))) @@ -1539,7 +1540,7 @@ [decl-end-s (number->string decl-end)] [end-s (number->string end)]) (append (if launcher? - (if (and (eq? 'windows (system-type)) + (if (and (eq? 'windows (cross-system-type)) keep-exe?) ;; argv[0] replacement: (list (path->string @@ -1584,7 +1585,7 @@ (display "\0\0\0\0" out))]) (let-values ([(start decl-end end cmdline-end) (cond - [(eq? (system-type) 'windows) + [(eq? (cross-system-type) 'windows) ;; Add as a resource (define o (open-output-bytes)) (define decl-len (write-module o)) @@ -1604,7 +1605,7 @@ bstr)) (update-resources dest-exe pe new-rsrcs) (values 0 decl-len init-len (+ init-len cmdline-len))] - [(and (eq? (system-type) 'macosx) + [(and (eq? (cross-system-type) 'macosx) (not unix-starter?)) ;; For Mach-O, we know how to add a proper segment (define s (open-output-bytes)) @@ -1669,7 +1670,7 @@ [osx? ;; default path in `gracket' is off by one: (set-collects-path dest-exe #"../../../collects")] - [(eq? 'windows (system-type)) + [(eq? 'windows (cross-system-type)) (unless keep-exe? ;; off by one in this case, too: (set-collects-path dest-exe #"collects"))])]) @@ -1726,7 +1727,7 @@ "cmdline" #"\\[Replace me for EXE hack")))] [anotherpos (and mred? - (eq? 'windows (system-type)) + (eq? 'windows (cross-system-type)) (let ([m (assq 'single-instance? aux)]) (and m (not (cdr m)))) (with-input-from-file dest-exe @@ -1758,16 +1759,16 @@ (file-position out))]) (file-position out cmdpos) (fprintf out "~a...~a~a" - (if (and keep-exe? (eq? 'windows (system-type))) "*" "?") + (if (and keep-exe? (eq? 'windows (cross-system-type))) "*" "?") (integer->integer-bytes end 4 #t #f) (integer->integer-bytes (- new-end end) 4 #t #f))))) (lambda () (close-output-port out))) - (let ([m (and (eq? 'windows (system-type)) + (let ([m (and (eq? 'windows (cross-system-type)) (assq 'ico aux))]) (when m (replace-all-icos (read-icos (cdr m)) dest-exe))) - (let ([m (and (eq? 'windows (system-type)) + (let ([m (and (eq? 'windows (cross-system-type)) (assq 'subsystem aux))]) (when m (set-subsystem dest-exe (cdr m)))))])))) diff --git a/racket/collects/launcher/launcher.rkt b/racket/collects/launcher/launcher.rkt index 0cfec14e07..eb0b9fcda9 100644 --- a/racket/collects/launcher/launcher.rkt +++ b/racket/collects/launcher/launcher.rkt @@ -8,6 +8,7 @@ compiler/embed setup/dirs setup/variant + setup/cross-system compiler/private/winutf16) @@ -69,7 +70,7 @@ installed-desktop-path->icon-path) (define current-launcher-variant - (make-parameter (system-type 'gc) + (make-parameter (cross-system-type 'gc) (lambda (v) (unless (memq v '(3m script-3m cgc script-cgc)) (raise-type-error @@ -80,8 +81,8 @@ (define (variant-available? kind cased-kind-name variant) (cond - [(or (eq? 'unix (system-type)) - (and (eq? 'macosx (system-type)) + [(or (eq? 'unix (cross-system-type)) + (and (eq? 'macosx (cross-system-type)) (eq? kind 'mzscheme))) (let ([bin-dir (if (eq? kind 'mzscheme) (find-console-bin-dir) @@ -94,13 +95,13 @@ [(mzscheme) 'racket] [(mred) 'gracket]) (variant-suffix variant #f))))))] - [(eq? 'macosx (system-type)) + [(eq? 'macosx (cross-system-type)) ;; kind must be mred, because mzscheme case is caught above (directory-exists? (build-path (find-lib-dir) (format "~a~a.app" cased-kind-name (variant-suffix variant #f))))] - [(eq? 'windows (system-type)) + [(eq? 'windows (cross-system-type)) (file-exists? (build-path (if (eq? kind 'mzscheme) (find-console-bin-dir) (find-lib-dir)) @@ -111,7 +112,7 @@ (let* ([cased-kind-name (if (eq? kind 'mzscheme) "Racket" "GRacket")] - [normal-kind (system-type 'gc)] + [normal-kind (cross-system-type 'gc)] [alt-kind (if (eq? '3m normal-kind) 'cgc '3m)] @@ -121,7 +122,7 @@ [alt (if (variant-available? kind cased-kind-name alt-kind) (list alt-kind) null)] - [script (if (and (eq? 'macosx (system-type)) + [script (if (and (eq? 'macosx (cross-system-type)) (eq? kind 'mred) (pair? normal)) (if (eq? normal-kind '3m) @@ -167,7 +168,7 @@ (define (add-file-suffix path variant mred?) (let ([s (variant-suffix variant - (case (system-type) + (case (cross-system-type) [(unix) #f] [(windows) #t] [(macosx) (and mred? (not (script-variant? variant)))]))]) @@ -176,7 +177,7 @@ (path-replace-suffix path (string->bytes/utf-8 - (if (and (eq? 'windows (system-type)) + (if (and (eq? 'windows (cross-system-type)) (regexp-match #rx#"[.]exe$" (path->bytes path))) (format "~a.exe" s) s)))))) @@ -295,7 +296,7 @@ (define (has-exe? exe) (or (file-exists? (build-path "/usr/bin" exe)) (file-exists? (build-path "/bin" exe)))) - (let* ([has-readlink? (and (not (eq? 'macosx (system-type))) + (let* ([has-readlink? (and (not (eq? 'macosx (cross-system-type))) (has-exe? "readlink"))] [dest-explode (normalize+explode-path dest)] [bindir-explode (normalize+explode-path bindir)]) @@ -364,7 +365,7 @@ (cdr m) (variant-suffix variant #t) (cdr m) (variant-suffix variant #t))))] [x-flags? (and (eq? kind 'mred) - (eq? (system-type) 'unix) + (eq? (cross-system-type) 'unix) (not (script-variant? variant)))] [flags (let ([m (assq 'wm-class aux)]) (if m @@ -397,7 +398,7 @@ (if (and m (cdr m)) (find-lib-dir) (let ([p (path-only dest)]) - (if (eq? 'macosx (system-type)) + (if (eq? 'macosx (cross-system-type)) (build-path p 'up) p)))) (find-console-bin-dir))]) @@ -411,7 +412,7 @@ "librktdir" "bindir") (or alt-exe (case kind - [(mred) (if (eq? 'macosx (system-type)) + [(mred) (if (eq? 'macosx (cross-system-type)) (format "GRacket~a.app/Contents/MacOS/Gracket" (variant-suffix variant #t)) "gracket")] @@ -419,7 +420,7 @@ (if alt-exe "" (variant-suffix variant (and (eq? kind 'mred) - (eq? 'macosx (system-type))))) + (eq? 'macosx (cross-system-type))))) pre-str)] [args (format "~a~a ${1+\"$@\"}\n" @@ -516,7 +517,7 @@ extension)))) (define (check-desktop aux dest) - (when (eq? 'unix (system-type)) + (when (eq? 'unix (cross-system-type)) (let ([im (assoc 'install-mode aux)]) (when (and im (member (cdr im) '(main user))) (define user? (eq? (cdr im) 'user)) @@ -715,7 +716,7 @@ (close-output-port p))))) (define (get-maker) - (case (system-type) + (case (cross-system-type) [(unix) make-unix-launcher] [(windows) make-windows-launcher] [(macos) make-macos-launcher] @@ -880,7 +881,7 @@ (string-downcase (regexp-replace* #px"\\s" file "-"))) (define (sfx file mred?) - (case (system-type) + (case (cross-system-type) [(unix) (unix-sfx file mred?)] [(windows) (string-append (if mred? file (unix-sfx file mred?)) ".exe")] @@ -888,7 +889,7 @@ (define (program-launcher-path name mred? user?) (let* ([variant (current-launcher-variant)] - [mac-script? (and (eq? (system-type) 'macosx) + [mac-script? (and (eq? (cross-system-type) 'macosx) (script-variant? variant))]) (let ([p (add-file-suffix (build-path @@ -902,7 +903,7 @@ ((if mac-script? unix-sfx sfx) name mred?)) variant mred?)]) - (if (and (eq? (system-type) 'macosx) + (if (and (eq? (cross-system-type) 'macosx) (not (script-variant? variant))) (path-replace-suffix p #".app") p)))) @@ -913,7 +914,7 @@ (gracket-program-launcher-path name #:user? user?)) (define (racket-program-launcher-path name #:user? [user? #f]) - (case (system-type) + (case (cross-system-type) [(macosx) (add-file-suffix (build-path (if user? (find-user-console-bin-dir) @@ -935,7 +936,7 @@ #f) (define (gracket-launcher-is-actually-directory?) - (and (eq? 'macosx (system-type)) + (and (eq? 'macosx (cross-system-type)) (not (script-variant? (current-launcher-variant))))) (define (mred-launcher-is-actually-directory?) (gracket-launcher-is-actually-directory?)) @@ -963,16 +964,16 @@ (define (gracket-launcher-put-file-extension+style+filters) (put-file-extension+style+filters - (if (and (eq? 'macosx (system-type)) + (if (and (eq? 'macosx (cross-system-type)) (script-variant? (current-launcher-variant))) 'unix - (system-type)))) + (cross-system-type)))) (define (mred-launcher-put-file-extension+style+filters) (gracket-launcher-put-file-extension+style+filters)) (define (racket-launcher-put-file-extension+style+filters) (put-file-extension+style+filters - (if (eq? 'macosx (system-type)) 'unix (system-type)))) + (if (eq? 'macosx (cross-system-type)) 'unix (cross-system-type)))) (define (mzscheme-launcher-put-file-extension+style+filters) (racket-launcher-put-file-extension+style+filters)) @@ -991,7 +992,7 @@ ;; overwritten at that time. So we assume ;; that a Setup-PLT-style independent launcher ;; is always up-to-date. - [(eq? 'windows (system-type)) + [(eq? 'windows (cross-system-type)) (and (let ([m (assq 'independent? aux)]) (and m (cdr m))) (file-exists? dest))] ;; For any other setting, we could implement diff --git a/racket/collects/pkg/lib.rkt b/racket/collects/pkg/lib.rkt index 9cf0226ac2..f5589d499b 100644 --- a/racket/collects/pkg/lib.rkt +++ b/racket/collects/pkg/lib.rkt @@ -280,5 +280,5 @@ [pkg-directory->additional-installs (->* (path-string? string?) (#:namespace namespace? #:system-type (or/c #f symbol?) - #:system-library-subpath (or/c #f path?)) + #:system-library-subpath (or/c #f path-for-some-system?)) (listof (cons/c symbol? string?)))])) diff --git a/racket/collects/pkg/private/addl-installs.rkt b/racket/collects/pkg/private/addl-installs.rkt index 7fe41bfd95..d725eaeffa 100644 --- a/racket/collects/pkg/private/addl-installs.rkt +++ b/racket/collects/pkg/private/addl-installs.rkt @@ -111,6 +111,7 @@ (define v (i 'install-platform (lambda () #rx""))) (or (not (platform-spec? v)) (matching-platform? v + #:cross? #t #:system-type sys-type #:system-library-subpath sys-lib-subpath))) (set-union (extract-documents i) diff --git a/racket/collects/pkg/private/dep.rkt b/racket/collects/pkg/private/dep.rkt index 28a34eeb6c..5abdce4705 100644 --- a/racket/collects/pkg/private/dep.rkt +++ b/racket/collects/pkg/private/dep.rkt @@ -32,5 +32,5 @@ (define (dependency-this-platform? dep) (define p (dependency-lookup '#:platform dep)) - (or (not p) (matching-platform? p))) + (or (not p) (matching-platform? p #:cross? #t))) diff --git a/racket/collects/pkg/strip.rkt b/racket/collects/pkg/strip.rkt index 6c603b8bd4..6a40c01fad 100644 --- a/racket/collects/pkg/strip.rkt +++ b/racket/collects/pkg/strip.rkt @@ -9,6 +9,7 @@ racket/list racket/set racket/format + setup/cross-system setup/private/dylib setup/private/elf) @@ -425,11 +426,11 @@ (fixup uncopied))))) (unmove-tag 'move-foreign-libs find-user-lib-dir - (case (system-type) + (case (cross-system-type) [(macosx) adjust-dylib-path/uninstall] [else void]) - (case (system-type) + (case (cross-system-type) [(unix) copy-file/uninstall-elf-rpath] [else diff --git a/racket/collects/setup/cross-system.rkt b/racket/collects/setup/cross-system.rkt new file mode 100644 index 0000000000..1b1c565c25 --- /dev/null +++ b/racket/collects/setup/cross-system.rkt @@ -0,0 +1,77 @@ +#lang racket/base +(require "private/dirs.rkt") + +(provide cross-system-type + cross-system-library-subpath + cross-installation?) + +(define cross-system-table #f) + +(define system-type-symbols '(os word gc link machine so-suffix so-mode fs-change)) + +(define (compute-cross!) + (unless cross-system-table + (define lib-dir (find-lib-dir)) + (define ht (and lib-dir + (let ([f (build-path lib-dir "system.rktd")]) + (and (file-exists? f) + (let ([ht (call-with-input-file* + f + read)]) + (and (hash? ht) + (for/and ([sym (in-list (list* + 'library-subpath + 'library-subpath-convention + system-type-symbols))]) + (hash-ref ht sym #f)) + (not + (and (for/and ([sym (in-list system-type-symbols)] + #:unless (or (eq? sym 'machine) + (eq? sym 'gc))) + (equal? (hash-ref ht sym) (system-type sym))) + (equal? (bytes->path (hash-ref ht 'library-subpath) + (hash-ref ht 'library-subpath-convention)) + (system-library-subpath #f)))) + ht)))))) + (if ht + (set! cross-system-table ht) + (set! cross-system-table #hasheq())))) + +(define cross-system-type + (case-lambda + [() + (compute-cross!) + (or (hash-ref cross-system-table 'os #f) + (system-type 'os))] + [(mode) + (unless (memq mode system-type-symbols) + (raise-argument-error + 'cross-system-type + "(or/c 'os 'word 'gc 'link 'machine 'so-suffix 'so-mode 'fs-change)" + mode)) + (compute-cross!) + (or (hash-ref cross-system-table mode #f) + (system-type mode))])) + +(define (cross-system-library-subpath [mode (begin + (compute-cross!) + (cross-system-type 'gc))]) + (unless (memq mode '(#f 3m cgc)) + (raise-argument-error + 'cross-system-library-subtype + "(or/c #f '3m 'cgc)" + mode)) + (compute-cross!) + (define bstr (hash-ref cross-system-table 'library-subpath #f)) + (cond + [bstr + (define conv (hash-ref cross-system-table 'library-subpath-convention)) + (define path (bytes->path bstr conv)) + (case mode + [(#f cgc) path] + [(3m) (build-path path (bytes->path #"3m" conv))])] + [else (system-library-subpath mode)])) + +(define (cross-installation?) + (compute-cross!) + (positive? (hash-count cross-system-table))) diff --git a/racket/collects/setup/dirs.rkt b/racket/collects/setup/dirs.rkt index 6970af2ed8..f85c1bc45e 100644 --- a/racket/collects/setup/dirs.rkt +++ b/racket/collects/setup/dirs.rkt @@ -1,268 +1,15 @@ #lang racket/base - (require racket/promise compiler/private/winutf16 compiler/private/mach-o - '#%utils - (for-syntax racket/base)) + setup/cross-system + "private/dirs.rkt") -;; ---------------------------------------- -;; "config" - -(define (find-config-dir) - (find-main-config)) - -(provide find-config-dir) - -;; ---------------------------------------- -;; config: definitions - -(define config-table - (delay/sync - (let ([d (find-config-dir)]) - (if d - (let ([p (build-path d "config.rktd")]) - (if (file-exists? p) - (call-with-input-file* - p - (lambda (in) - (call-with-default-reading-parameterization - (lambda () - (read in))))) - #hash())) - #hash())))) - -(define (to-path l) - (cond [(string? l) (simplify-path (complete-path (string->path l)))] - [(bytes? l) (simplify-path (complete-path (bytes->path l)))] - [(list? l) (map to-path l)] - [else l])) - -(define (complete-path p) - (cond [(complete-path? p) p] - [else - (path->complete-path - p - (find-main-collects))])) - -(define-syntax-rule (define-config name key wrap) - (define name (delay/sync - (wrap - (hash-ref (force config-table) key #f))))) - -(define-config config:collects-search-dirs 'collects-search-dirs to-path) -(define-config config:doc-dir 'doc-dir to-path) -(define-config config:doc-search-dirs 'doc-search-dirs to-path) -(define-config config:dll-dir 'dll-dir to-path) -(define-config config:lib-dir 'lib-dir to-path) -(define-config config:lib-search-dirs 'lib-search-dirs to-path) -(define-config config:share-dir 'share-dir to-path) -(define-config config:apps-dir 'apps-dir to-path) -(define-config config:include-dir 'include-dir to-path) -(define-config config:include-search-dirs 'include-search-dirs to-path) -(define-config config:bin-dir 'bin-dir to-path) -(define-config config:man-dir 'man-dir to-path) -(define-config config:links-file 'links-file to-path) -(define-config config:links-search-files 'links-search-files to-path) -(define-config config:pkgs-dir 'pkgs-dir to-path) -(define-config config:pkgs-search-dirs 'pkgs-search-dirs to-path) -(define-config config:cgc-suffix 'cgc-suffix values) -(define-config config:3m-suffix '3m-suffix values) -(define-config config:absolute-installation? 'absolute-installation? (lambda (x) (and x #t))) -(define-config config:doc-search-url 'doc-search-url values) -(define-config config:doc-open-url 'doc-open-url values) -(define-config config:installation-name 'installation-name values) -(define-config config:build-stamp 'build-stamp values) - -(provide get-absolute-installation? - get-cgc-suffix - get-3m-suffix - get-doc-search-url - get-doc-open-url - get-installation-name - get-build-stamp) - -(define (get-absolute-installation?) (force config:absolute-installation?)) -(define (get-cgc-suffix) (force config:cgc-suffix)) -(define (get-3m-suffix) (force config:3m-suffix)) -(define (get-doc-search-url) (or (force config:doc-search-url) - "http://docs.racket-lang.org/local-redirect/index.html")) -(define (get-doc-open-url) (force config:doc-open-url)) -(define (get-installation-name) (or (force config:installation-name) - (version))) -(define (get-build-stamp) (force config:build-stamp)) - -;; ---------------------------------------- -;; "collects" - -(provide find-collects-dir - get-main-collects-search-dirs - find-user-collects-dir - get-collects-search-dirs) -(define (find-collects-dir) - (find-main-collects)) -(define (get-main-collects-search-dirs) - (combine-search (force config:collects-search-dirs) - (list (find-collects-dir)))) -(define user-collects-dir - (delay/sync (simplify-path (build-path (find-system-path 'addon-dir) - (get-installation-name) - "collects")))) -(define (find-user-collects-dir) - (force user-collects-dir)) -(define (get-collects-search-dirs) - (current-library-collection-paths)) - -;; ---------------------------------------- -;; Helpers - -(define (single p) (if p (list p) null)) -(define (extra a l) (if (and a (not (member (path->directory-path a) - (map path->directory-path l)))) - (append l (list a)) - l)) -(define (combine-search l default) - ;; Replace #f in list with default path: - (if l - (let loop ([l l]) - (cond - [(null? l) null] - [(not (car l)) (append default (loop (cdr l)))] - [else (cons (car l) (loop (cdr l)))])) - default)) -(define (cons-user u r) - (if (and u (use-user-specific-search-paths)) - (cons u r) - r)) -(define (get-false) #f) -(define (chain-to f) f) - -(define-syntax (define-finder stx) - (syntax-case stx (get-false chain-to) - [(_ provide config:id id user-id #:default user-default default) - #' - (begin - (define-finder provide config:id id get-false default) - (provide user-id) - (define user-dir - (delay/sync (simplify-path (build-path (find-system-path 'addon-dir) - (get-installation-name) - user-default)))) - (define (user-id) - (force user-dir)))] - [(_ provide config:id id user-id config:search-id search-id default) - #' - (begin - (define-finder provide config:id id user-id default) - (provide search-id) - (define (search-id) - (combine-search (force config:search-id) - (cons-user (user-id) (single (id))))))] - [(_ provide config:id id user-id config:search-id search-id - extra-search-dir default) - #' - (begin - (define-finder provide config:id id user-id default) - (provide search-id) - (define (search-id) - (combine-search (force config:search-id) - (extra (extra-search-dir) - (cons-user (user-id) (single (id)))))))] - [(_ provide config:id id get-false (chain-to get-default)) - (with-syntax ([dir (generate-temporaries #'(id))]) - #'(begin - (provide id) - (define dir - (delay/sync - (or (force config:id) (get-default)))) - (define (id) - (force dir))))] - [(_ provide config:id id get-false default) - (with-syntax ([dir (generate-temporaries #'(id))]) - #'(begin - (provide id) - (define dir - (delay/sync - (or (force config:id) - (let ([p (find-collects-dir)]) - (and p (simplify-path (build-path p 'up default))))))) - (define (id) - (force dir))))] - [(_ provide config:id id user-id default) - #'(define-finder provide config:id id user-id #:default default default)])) - -(define-syntax no-provide (syntax-rules () [(_ . rest) (begin)])) - -;; ---------------------------------------- -;; "doc" - -(define delayed-#f (delay/sync #f)) - -(provide find-doc-dir - find-user-doc-dir - get-doc-search-dirs) -(define-finder no-provide - config:doc-dir - find-doc-dir - find-user-doc-dir - delayed-#f - get-new-doc-search-dirs - "doc") -;; For now, include "doc" pseudo-collections in search path: -(define (get-doc-search-dirs) - (combine-search (force config:doc-search-dirs) - (append (get-new-doc-search-dirs) - (map (lambda (p) (build-path p "doc")) - (current-library-collection-paths))))) - -;; ---------------------------------------- -;; "include" - -(define-finder provide - config:include-dir - find-include-dir - find-user-include-dir - config:include-search-dirs - get-include-search-dirs - "include") - -;; ---------------------------------------- -;; "lib" - -(define-finder provide - config:lib-dir - find-lib-dir - find-user-lib-dir - config:lib-search-dirs - get-lib-search-dirs - "lib") - -;; ---------------------------------------- -;; "share" - -(define-finder provide - config:share-dir - find-share-dir - find-user-share-dir - "share") - -;; ---------------------------------------- -;; "apps" - -(define-finder provide - config:apps-dir - find-apps-dir - find-user-apps-dir #:default (build-path "share" "applications") - (chain-to (lambda () (build-path (find-share-dir) "applications")))) - -;; ---------------------------------------- -;; "man" - -(define-finder provide - config:man-dir - find-man-dir - find-user-man-dir - "man") +(provide (except-out (all-from-out "private/dirs.rkt") + config:dll-dir + config:bin-dir + define-finder) + find-dll-dir) ;; ---------------------------------------- ;; Executables @@ -271,7 +18,7 @@ config:bin-dir find-console-bin-dir find-user-console-bin-dir - (case (system-type) + (case (cross-system-type) [(windows) 'same] [(macosx unix) "bin"])) @@ -279,7 +26,7 @@ config:bin-dir find-gui-bin-dir find-user-gui-bin-dir - (case (system-type) + (case (cross-system-type) [(windows macosx) 'same] [(unix) "bin"])) @@ -289,106 +36,77 @@ (provide find-dll-dir) (define dll-dir (delay/sync - (case (system-type) + (case (cross-system-type) [(windows) - ;; Extract "lib" location from binary: - (let ([exe (parameterize ([current-directory (find-system-path 'orig-dir)]) - (find-executable-path (find-system-path 'exec-file)))]) - (and - exe - (with-input-from-file exe - (lambda () - (let ([m (regexp-match (byte-regexp - (bytes-append - (bytes->utf-16-bytes #"dLl dIRECTORy:") - #"((?:..)*?)\0\0")) - (current-input-port))]) - (unless m - (error "cannot find \"dLl dIRECTORy\" tag in binary")) - (let-values ([(dir name dir?) (split-path exe)]) - (if (regexp-match #rx#"^<" (cadr m)) - ;; no DLL dir in binary - #f - ;; resolve relative directory: - (let ([p (bytes->path (utf-16-bytes->bytes (cadr m)))]) - (path->complete-path p dir)))))))))] + (if (eq? (system-type) 'windows) + ;; Extract "lib" location from binary: + (let ([exe (parameterize ([current-directory (find-system-path 'orig-dir)]) + (find-executable-path (find-system-path 'exec-file)))]) + (and + exe + (with-input-from-file exe + (lambda () + (let ([m (regexp-match (byte-regexp + (bytes-append + (bytes->utf-16-bytes #"dLl dIRECTORy:") + #"((?:..)*?)\0\0")) + (current-input-port))]) + (unless m + (error "cannot find \"dLl dIRECTORy\" tag in binary")) + (let-values ([(dir name dir?) (split-path exe)]) + (if (regexp-match #rx#"^<" (cadr m)) + ;; no DLL dir in binary + #f + ;; resolve relative directory: + (let ([p (bytes->path (utf-16-bytes->bytes (cadr m)))]) + (path->complete-path p dir))))))))) + ;; Cross-compile: assume it's "lib" + (find-lib-dir))] [(macosx) - (let* ([exe (parameterize ([current-directory (find-system-path 'orig-dir)]) - (let loop ([p (find-executable-path - (find-system-path 'exec-file))]) - (and - p - (if (link-exists? p) - (loop (let-values ([(r) (resolve-path p)] - [(dir name dir?) (split-path p)]) - (if (and (path? dir) - (relative-path? r)) - (build-path dir r) - r))) - p))))] - [rel (and exe - (let ([l (get/set-dylib-path exe "Racket" #f)]) - (if (null? l) - #f - (car l))))]) - (cond - [(not rel) #f] ; no framework reference found!? - [(regexp-match - #rx#"^(@executable_path/)?(.*?)G?Racket.framework" - rel) - => (lambda (m) - (let ([b (caddr m)]) - (if (and (not (cadr m)) (bytes=? b #"")) - #f ; no path in exe - (simplify-path - (path->complete-path - (if (not (cadr m)) - (bytes->path b) - (let-values ([(dir name dir?) (split-path exe)]) - (if (bytes=? b #"") - dir - (build-path dir (bytes->path b))))) - (find-system-path 'orig-dir))))))] - [else (find-lib-dir)]))] + (if (eq? (system-type) 'macosx) + (let* ([exe (parameterize ([current-directory (find-system-path 'orig-dir)]) + (let loop ([p (find-executable-path + (find-system-path 'exec-file))]) + (and + p + (if (link-exists? p) + (loop (let-values ([(r) (resolve-path p)] + [(dir name dir?) (split-path p)]) + (if (and (path? dir) + (relative-path? r)) + (build-path dir r) + r))) + p))))] + [rel (and exe + (let ([l (get/set-dylib-path exe "Racket" #f)]) + (if (null? l) + #f + (car l))))]) + (cond + [(not rel) #f] ; no framework reference found!? + [(regexp-match + #rx#"^(@executable_path/)?(.*?)G?Racket.framework" + rel) + => (lambda (m) + (let ([b (caddr m)]) + (if (and (not (cadr m)) (bytes=? b #"")) + #f ; no path in exe + (simplify-path + (path->complete-path + (if (not (cadr m)) + (bytes->path b) + (let-values ([(dir name dir?) (split-path exe)]) + (if (bytes=? b #"") + dir + (build-path dir (bytes->path b))))) + (find-system-path 'orig-dir))))))] + [else (find-lib-dir)])) + ;; Cross-compile: assume it's "lib" + (find-lib-dir))] [else - (if (eq? 'shared (system-type 'link)) + (if (eq? 'shared (cross-system-type 'link)) (or (force config:dll-dir) (find-lib-dir)) #f)]))) (define (find-dll-dir) (force dll-dir)) -;; ---------------------------------------- -;; Links files - -(provide find-links-file - get-links-search-files - find-user-links-file) - -(define (find-links-file) - (or (force config:links-file) - (build-path (find-share-dir) "links.rktd"))) -(define (get-links-search-files) - (combine-search (force config:links-search-files) - (list (find-links-file)))) - -(define (find-user-links-file [vers (get-installation-name)]) - (build-path (find-system-path 'addon-dir) - vers - "links.rktd")) - -;; ---------------------------------------- -;; Packages - -(define-finder provide - config:pkgs-dir - find-pkgs-dir - get-false - config:pkgs-search-dirs - get-pkgs-search-dirs - (chain-to (lambda () (build-path (find-share-dir) "pkgs")))) - -(provide find-user-pkgs-dir) -(define (find-user-pkgs-dir [vers (get-installation-name)]) - (build-path (find-system-path 'addon-dir) - vers - "pkgs")) diff --git a/racket/collects/setup/matching-platform.rkt b/racket/collects/setup/matching-platform.rkt index 9e89e022b2..ca13f3fd3e 100644 --- a/racket/collects/setup/matching-platform.rkt +++ b/racket/collects/setup/matching-platform.rkt @@ -1,4 +1,5 @@ #lang racket/base +(require setup/cross-system) (provide platform-spec? matching-platform?) @@ -7,20 +8,27 @@ (or (symbol? p) (string? p) (regexp? p))) (define (matching-platform? p + #:cross? [cross? #f] #:system-type [sys-type #f] #:system-library-subpath [sys-lib-subpath #f]) (unless (platform-spec? p) (raise-argument-error 'matching-platform? "platform-spec?" p)) (unless (or (not sys-type) (symbol? sys-type)) (raise-argument-error 'matching-platform? "(or/c symbol? #f)" sys-type)) - (unless (or (not sys-lib-subpath) (path? sys-lib-subpath)) - (raise-argument-error 'matching-platform? "(or/c path? #f)" sys-lib-subpath)) + (unless (or (not sys-lib-subpath) (path-for-some-system? sys-lib-subpath)) + (raise-argument-error 'matching-platform? "(or/c path-for-some-system? #f)" sys-lib-subpath)) (cond [(symbol? p) - (eq? p (or sys-type (system-type)))] + (eq? p (or sys-type (if cross? + (cross-system-type) + (system-type))))] [else - (define s (path->string (or sys-lib-subpath - (system-library-subpath #f)))) + (define s (bytes->string/utf-8 + (path->bytes + (or sys-lib-subpath + (if cross? + (cross-system-library-subpath #f) + (system-library-subpath #f)))))) (cond [(regexp? p) (regexp-match? p s)] diff --git a/racket/collects/setup/parallel-do.rkt b/racket/collects/setup/parallel-do.rkt index 4d6d37b73c..fb2b4c4658 100644 --- a/racket/collects/setup/parallel-do.rkt +++ b/racket/collects/setup/parallel-do.rkt @@ -9,6 +9,7 @@ racket/path racket/class racket/stxparam + setup/dirs (for-syntax syntax/parse racket/base)) @@ -73,7 +74,10 @@ (define/public (spawn _id _module-path _funcname [initialmsg #f]) (set! module-path _module-path) (set! funcname _funcname) - (define worker-cmdline-list (list (current-executable-path) "-X" (path->string (current-collects-path)) "-e" "(eval(read))")) + (define worker-cmdline-list (list (current-executable-path) + "-X" (path->string (current-collects-path)) + "-G" (path->string (find-config-dir)) + "-e" "(eval(read))")) (define dynamic-require-cmd `((dynamic-require (string->path ,module-path) (quote ,funcname)) #f)) (let-values ([(_process-handle _out _in _err) (apply subprocess #f #f (current-error-port) worker-cmdline-list)]) (set! id _id) diff --git a/racket/collects/setup/private/dirs.rkt b/racket/collects/setup/private/dirs.rkt new file mode 100644 index 0000000000..4ad0e241bd --- /dev/null +++ b/racket/collects/setup/private/dirs.rkt @@ -0,0 +1,314 @@ +#lang racket/base +(require racket/promise + '#%utils + (for-syntax racket/base)) + +;; ---------------------------------------- +;; "config" + +(define (find-config-dir) + (find-main-config)) + +(provide find-config-dir) + +;; ---------------------------------------- +;; config: definitions + +(define config-table + (delay/sync + (let ([d (find-config-dir)]) + (if d + (let ([p (build-path d "config.rktd")]) + (if (file-exists? p) + (call-with-input-file* + p + (lambda (in) + (call-with-default-reading-parameterization + (lambda () + (read in))))) + #hash())) + #hash())))) + +(define (to-path l) + (cond [(string? l) (simplify-path (complete-path (string->path l)))] + [(bytes? l) (simplify-path (complete-path (bytes->path l)))] + [(list? l) (map to-path l)] + [else l])) + +(define (complete-path p) + (cond [(complete-path? p) p] + [else + (path->complete-path + p + (find-main-collects))])) + +(define-syntax-rule (define-config name key wrap) + (define name (delay/sync + (wrap + (hash-ref (force config-table) key #f))))) + +(define-config config:collects-search-dirs 'collects-search-dirs to-path) +(define-config config:doc-dir 'doc-dir to-path) +(define-config config:doc-search-dirs 'doc-search-dirs to-path) +(define-config config:dll-dir 'dll-dir to-path) +(define-config config:lib-dir 'lib-dir to-path) +(define-config config:lib-search-dirs 'lib-search-dirs to-path) +(define-config config:share-dir 'share-dir to-path) +(define-config config:apps-dir 'apps-dir to-path) +(define-config config:include-dir 'include-dir to-path) +(define-config config:include-search-dirs 'include-search-dirs to-path) +(define-config config:bin-dir 'bin-dir to-path) +(define-config config:man-dir 'man-dir to-path) +(define-config config:links-file 'links-file to-path) +(define-config config:links-search-files 'links-search-files to-path) +(define-config config:pkgs-dir 'pkgs-dir to-path) +(define-config config:pkgs-search-dirs 'pkgs-search-dirs to-path) +(define-config config:cgc-suffix 'cgc-suffix values) +(define-config config:3m-suffix '3m-suffix values) +(define-config config:absolute-installation? 'absolute-installation? (lambda (x) (and x #t))) +(define-config config:doc-search-url 'doc-search-url values) +(define-config config:doc-open-url 'doc-open-url values) +(define-config config:installation-name 'installation-name values) +(define-config config:build-stamp 'build-stamp values) + +(provide get-absolute-installation? + get-cgc-suffix + get-3m-suffix + get-doc-search-url + get-doc-open-url + get-installation-name + get-build-stamp) + +(define (get-absolute-installation?) (force config:absolute-installation?)) +(define (get-cgc-suffix) (force config:cgc-suffix)) +(define (get-3m-suffix) (force config:3m-suffix)) +(define (get-doc-search-url) (or (force config:doc-search-url) + "http://docs.racket-lang.org/local-redirect/index.html")) +(define (get-doc-open-url) (force config:doc-open-url)) +(define (get-installation-name) (or (force config:installation-name) + (version))) +(define (get-build-stamp) (force config:build-stamp)) + +;; ---------------------------------------- +;; "collects" + +(provide find-collects-dir + get-main-collects-search-dirs + find-user-collects-dir + get-collects-search-dirs) +(define (find-collects-dir) + (find-main-collects)) +(define (get-main-collects-search-dirs) + (combine-search (force config:collects-search-dirs) + (list (find-collects-dir)))) +(define user-collects-dir + (delay/sync (simplify-path (build-path (find-system-path 'addon-dir) + (get-installation-name) + "collects")))) +(define (find-user-collects-dir) + (force user-collects-dir)) +(define (get-collects-search-dirs) + (current-library-collection-paths)) + +;; ---------------------------------------- +;; Helpers + +(define (single p) (if p (list p) null)) +(define (extra a l) (if (and a (not (member (path->directory-path a) + (map path->directory-path l)))) + (append l (list a)) + l)) +(define (combine-search l default) + ;; Replace #f in list with default path: + (if l + (let loop ([l l]) + (cond + [(null? l) null] + [(not (car l)) (append default (loop (cdr l)))] + [else (cons (car l) (loop (cdr l)))])) + default)) +(define (cons-user u r) + (if (and u (use-user-specific-search-paths)) + (cons u r) + r)) +(define (get-false) #f) +(define (chain-to f) f) + +(define-syntax (define-finder stx) + (syntax-case stx (get-false chain-to) + [(_ provide config:id id user-id #:default user-default default) + #' + (begin + (define-finder provide config:id id get-false default) + (provide user-id) + (define user-dir + (delay/sync (simplify-path (build-path (find-system-path 'addon-dir) + (get-installation-name) + user-default)))) + (define (user-id) + (force user-dir)))] + [(_ provide config:id id user-id config:search-id search-id default) + #' + (begin + (define-finder provide config:id id user-id default) + (provide search-id) + (define (search-id) + (combine-search (force config:search-id) + (cons-user (user-id) (single (id))))))] + [(_ provide config:id id user-id config:search-id search-id + extra-search-dir default) + #' + (begin + (define-finder provide config:id id user-id default) + (provide search-id) + (define (search-id) + (combine-search (force config:search-id) + (extra (extra-search-dir) + (cons-user (user-id) (single (id)))))))] + [(_ provide config:id id get-false (chain-to get-default)) + (with-syntax ([dir (generate-temporaries #'(id))]) + #'(begin + (provide id) + (define dir + (delay/sync + (or (force config:id) (get-default)))) + (define (id) + (force dir))))] + [(_ provide config:id id get-false default) + (with-syntax ([dir (generate-temporaries #'(id))]) + #'(begin + (provide id) + (define dir + (delay/sync + (or (force config:id) + (let ([p (find-collects-dir)]) + (and p (simplify-path (build-path p 'up default))))))) + (define (id) + (force dir))))] + [(_ provide config:id id user-id default) + #'(define-finder provide config:id id user-id #:default default default)])) + +(define-syntax no-provide (syntax-rules () [(_ . rest) (begin)])) + +(provide define-finder) + +;; ---------------------------------------- +;; "doc" + +(define delayed-#f (delay/sync #f)) + +(provide find-doc-dir + find-user-doc-dir + get-doc-search-dirs) +(define-finder no-provide + config:doc-dir + find-doc-dir + find-user-doc-dir + delayed-#f + get-new-doc-search-dirs + "doc") +;; For now, include "doc" pseudo-collections in search path: +(define (get-doc-search-dirs) + (combine-search (force config:doc-search-dirs) + (append (get-new-doc-search-dirs) + (map (lambda (p) (build-path p "doc")) + (current-library-collection-paths))))) + +;; ---------------------------------------- +;; "include" + +(define-finder provide + config:include-dir + find-include-dir + find-user-include-dir + config:include-search-dirs + get-include-search-dirs + "include") + +;; ---------------------------------------- +;; "lib" + +(define-finder provide + config:lib-dir + find-lib-dir + find-user-lib-dir + config:lib-search-dirs + get-lib-search-dirs + "lib") + +;; ---------------------------------------- +;; "share" + +(define-finder provide + config:share-dir + find-share-dir + find-user-share-dir + "share") + +;; ---------------------------------------- +;; "apps" + +(define-finder provide + config:apps-dir + find-apps-dir + find-user-apps-dir #:default (build-path "share" "applications") + (chain-to (lambda () (build-path (find-share-dir) "applications")))) + +;; ---------------------------------------- +;; "man" + +(define-finder provide + config:man-dir + find-man-dir + find-user-man-dir + "man") + +;; ---------------------------------------- +;; Executables + +;; `setup/dirs` + +(provide config:bin-dir) + +;; ---------------------------------------- +;; DLLs + +;; See `setup/dirs` + +(provide config:dll-dir) + +;; ---------------------------------------- +;; Links files + +(provide find-links-file + get-links-search-files + find-user-links-file) + +(define (find-links-file) + (or (force config:links-file) + (build-path (find-share-dir) "links.rktd"))) +(define (get-links-search-files) + (combine-search (force config:links-search-files) + (list (find-links-file)))) + +(define (find-user-links-file [vers (get-installation-name)]) + (build-path (find-system-path 'addon-dir) + vers + "links.rktd")) + +;; ---------------------------------------- +;; Packages + +(define-finder provide + config:pkgs-dir + find-pkgs-dir + get-false + config:pkgs-search-dirs + get-pkgs-search-dirs + (chain-to (lambda () (build-path (find-share-dir) "pkgs")))) + +(provide find-user-pkgs-dir) +(define (find-user-pkgs-dir [vers (get-installation-name)]) + (build-path (find-system-path 'addon-dir) + vers + "pkgs")) diff --git a/racket/collects/setup/setup-core.rkt b/racket/collects/setup/setup-core.rkt index 12303c5342..909f2707a6 100644 --- a/racket/collects/setup/setup-core.rkt +++ b/racket/collects/setup/setup-core.rkt @@ -15,6 +15,7 @@ planet/planet-archives planet/private/planet-shared (only-in planet/resolver resolve-planet-path) + setup/cross-system "option.rkt" compiler/compiler @@ -880,7 +881,7 @@ (string? v) (symbol? v)) (error "entry is not regexp, string, or symbol:" v))))) - (matching-platform? sys)) + (matching-platform? sys #:cross? #t)) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Make zo ;; @@ -1407,7 +1408,7 @@ [(console) (path->relative-string/console-bin p)] [else (error 'make-launcher "internal error (~s)" kind)]) (let ([v (current-launcher-variant)]) - (if (eq? v (system-type 'gc)) "" (format " [~a]" v)))) + (if (eq? v (cross-system-type 'gc)) "" (format " [~a]" v)))) (make-launcher (or mzlf (if (cc-collection cc) @@ -1563,7 +1564,7 @@ (setup-printf "deleting" "launcher ~a" rel-exe-path) (delete-directory/files exe-path)]) ;; Clean up any associated .desktop file and icon file: - (when (eq? 'unix (system-type)) + (when (eq? 'unix (cross-system-type)) (let ([desktop (installed-executable-path->desktop-path exe-path user?)]) @@ -1780,11 +1781,11 @@ (error "entry is not a list of relative path strings:" l))) build-path this-platform? - (case (system-type) + (case (cross-system-type) [(macosx) adjust-dylib-path/install] [else void]) - (case (system-type) + (case (cross-system-type) [(unix) copy-file/install-elf-rpath] [else copy-file]))) @@ -1905,7 +1906,8 @@ ;; setup Body ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (setup-printf "version" "~a [~a]" (version) (system-type 'gc)) + (setup-printf "version" "~a" (version)) + (setup-printf "platform" "~a [~a]" (cross-system-library-subpath #f) (cross-system-type 'gc)) (setup-printf "installation name" "~a" (get-installation-name)) (setup-printf "variants" "~a" (string-join (map symbol->string (available-mzscheme-variants)) ", ")) (setup-printf "main collects" "~a" main-collects-dir) @@ -1943,7 +1945,7 @@ (when (make-launchers) (make-launchers-step)) (when (make-launchers) - (unless (eq? 'windows (system-type)) + (unless (eq? 'windows (cross-system-type)) (make-mans-step))) (when make-docs? diff --git a/racket/collects/setup/variant.rkt b/racket/collects/setup/variant.rkt index 09ead3e51e..01969f5044 100644 --- a/racket/collects/setup/variant.rkt +++ b/racket/collects/setup/variant.rkt @@ -1,23 +1,29 @@ #lang racket/base -(require setup/dirs racket/promise) +(require setup/dirs + setup/cross-system + racket/promise) (provide variant-suffix) (define plain-mz-is-cgc? (delay/sync - (let* ([dir (find-console-bin-dir)] - [exe (cond [(eq? 'windows (system-type)) "Racket.exe"] - [(equal? #".dll" (system-type 'so-suffix)) - ;; in cygwin so-suffix is ".dll" - "racket.exe"] - [else "racket"])] - [f (build-path dir exe)]) - (and (file-exists? f) - (with-input-from-file f - (lambda () - (regexp-match? #rx#"bINARy tYPe:..c" - (current-input-port)))))))) + (cond + [(cross-installation?) + (eq? 'cgc (cross-system-type 'gc))] + [else + (let* ([dir (find-console-bin-dir)] + [exe (cond [(eq? 'windows (system-type)) "Racket.exe"] + [(equal? #".dll" (system-type 'so-suffix)) + ;; in cygwin so-suffix is ".dll" + "racket.exe"] + [else "racket"])] + [f (build-path dir exe)]) + (and (file-exists? f) + (with-input-from-file f + (lambda () + (regexp-match? #rx#"bINARy tYPe:..c" + (current-input-port))))))]))) (define (variant-suffix variant cased?) (let ([r (case variant diff --git a/racket/src/racket/Makefile.in b/racket/src/racket/Makefile.in index 7c27d9b68a..1efdba7a87 100644 --- a/racket/src/racket/Makefile.in +++ b/racket/src/racket/Makefile.in @@ -86,6 +86,10 @@ common: $(MAKE) @FOREIGNTARGET@ cgc: + $(MAKE) cgc-core + $(MAKE) sysinfer@CGC@ + +cgc-core: $(MAKE) common $(MAKE) dynlib $(MAKE) mzlibrary @@ -98,9 +102,10 @@ cgc: cd dynsrc; $(MAKE) dynlib3m cd gc2; $(MAKE) ../racket@MMM@ cd gc2; $(MAKE) ../mzcom@MMM@ + $(MAKE) sysinfer@MMM@ both: - $(MAKE) cgc + $(MAKE) cgc-core $(MAKE) 3m oskit: @@ -157,6 +162,16 @@ no-cgc-needed: $(MAKE) mingw-other cd dynsrc; $(MAKE) ../starter@EXE_SUFFIX@ +ALL_CPPFLAGS = -I$(builddir) -I$(srcdir)/include -I$(srcdir)/src $(CPPFLAGS) @OPTIONS@ @GC2OPTIONS@ @MZOPTIONS@ +MKSYSTEM_ARGS = -cqu $(srcdir)/mksystem.rkt system.rktd "$(CPP) $(ALL_CPPFLAGS) $(srcdir)/src/systype.c" "@MMM_INSTALLED@" + +sysinfer@CGC@: + @RUN_RACKET_CGC@ $(MKSYSTEM_ARGS) "@RUN_RACKET_CGC@" "$(RUN_THIS_RACKET_CGC)" + +sysinfer@MMM@: + @RUN_RACKET_MMM@ $(MKSYSTEM_ARGS) "@RUN_RACKET_MMM@" "$(RUN_THIS_RACKET_MMM)" + + FOREIGN_USED_LIB = $(FOREIGN_OBJ) $(FOREIGN_LIB) FOREIGN_USED_OBJSLIB = $(FOREIGN_OBJSLIB) FOREIGN_NOT_USED_LIB = $(FOREIGN_OBJ) @@ -305,6 +320,7 @@ total_startup: headers: @RUN_RACKET_CGC@ -cqu $(srcdir)/mkincludes.rkt @DIRCVTPRE@"$(DESTDIR)$(includepltdir)"@DIRCVTPOST@ "$(srcdir)" . + cd ..; cp racket/system.rktd "$(DESTDIR)$(libpltdir)/system.rktd" $(srcdir)/src/schexn.h: $(srcdir)/src/makeexn $(RACKET) -um $(srcdir)/src/makeexn > $(srcdir)/src/schexn.h diff --git a/racket/src/racket/gc2/Makefile.in b/racket/src/racket/gc2/Makefile.in index 2e33b27767..42fb655448 100644 --- a/racket/src/racket/gc2/Makefile.in +++ b/racket/src/racket/gc2/Makefile.in @@ -292,7 +292,7 @@ $(XSRCDIR)/setjmpup.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/setjmpup.c $(SRCDIR)/setjmpup.c $(XSRCDIR)/sfs.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/sfs.c $(SRCDIR)/sfs.c -$(XSRCDIR)/string.c: $(XFORMDEP) +$(XSRCDIR)/string.c: $(XFORMDEP) $(SRCDIR)/systype.inc $(XFORM_SETUP) --cpp "$(CPP) -I../src $(ALL_CPPFLAGS)" @XFORMFLAGS@ -o $(XSRCDIR)/string.c $(SRCDIR)/string.c $(XSRCDIR)/struct.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/struct.c $(SRCDIR)/struct.c diff --git a/racket/src/racket/mksystem.rkt b/racket/src/racket/mksystem.rkt new file mode 100644 index 0000000000..67713ba1d6 --- /dev/null +++ b/racket/src/racket/mksystem.rkt @@ -0,0 +1,75 @@ +(module mkincludes '#%kernel + (#%require '#%min-stx) + ;; Arguments are + ;; [ <3m-exe-suffix> ] + (define-values (args) (current-command-line-arguments)) + + (define-values (ht) + (if (or (= (vector-length args) 1) + (equal? (vector-ref args (- (vector-length args) 1)) + (vector-ref args (- (vector-length args) 2)))) + ;; Not cross-compiling + (hash 'os (system-type 'os) + 'word (system-type 'word) + 'gc (if (= (vector-length args) 1) + '3m ; GC mode for suffixless executables + (if (string=? "" (vector-ref args 2)) + '3m + 'cgc)) + 'link (system-type 'link) + 'machine (bytes->string/utf-8 (path->bytes (system-library-subpath #f))) + 'so-suffix (system-type 'so-suffix) + 'so-mode (system-type 'so-mode) + 'fs-change (system-type 'fs-change) + 'library-subpath (path->bytes (system-library-subpath #f)) + 'library-subpath-convention (system-path-convention-type)) + ;; Cross-compiling; use `cpp` to get details + (begin + (printf "Extracting system information for cross-compile\n") + (let-values ([(p out in err) + (subprocess #f #f #f "/bin/sh" "-c" (vector-ref args 1))]) + (close-output-port in) + (letrec-values ([(read-all) (lambda () + (let-values ([(s) (read-bytes 4096 out)]) + (if (eof-object? s) + #"" + (bytes-append s (read-all)))))]) + (let-values ([(expanded) (read-all)]) + (let-values ([(get-string) + (lambda (var) + (let-values ([(m) (regexp-match (string-append " " var " = ([^\n;]*);") + expanded)]) + (if m + (bytes->string/utf-8 + (regexp-replace* #rx"\\\\\\\\" + (regexp-replace* #rx"^\"|\" *\"|\"$" (cadr m) "") + "\\\\")) + (error 'mksystem "not found in cpp output: ~e" var))))]) + (let-values ([(get-symbol) + (lambda (var) (string->symbol (get-string var)))] + [(get-int) + (lambda (var) (string->number (get-string var)))]) + (let-values ([(library-subpath) + (get-string "system_library_subpath")] + [(os) (get-symbol "system_type_os")]) + (hash 'os os + 'word (* 8 (get-int "system_pointer_size")) + 'gc (if (string=? "" (vector-ref args 2)) + '3m + 'cgc) + 'link (get-symbol "system_type_link") + 'machine library-subpath + 'so-suffix (string->bytes/utf-8 (get-string "system_type_so_suffix")) + 'so-mode (get-symbol "system_type_so_mode") + 'fs-change '#(#f #f #f #f) + 'library-subpath (string->bytes/utf-8 library-subpath) + 'library-subpath-convention (if (eq? os 'windows) + 'windows + 'unix))))))))))) + + (call-with-output-file + (vector-ref args 0) + (lambda (o) + (write ht o) + (newline o)) + 'truncate/replace)) diff --git a/racket/src/racket/src/Makefile.in b/racket/src/racket/src/Makefile.in index e47890dfb0..6be8335605 100644 --- a/racket/src/racket/src/Makefile.in +++ b/racket/src/racket/src/Makefile.in @@ -419,7 +419,7 @@ sfs.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h $(srcdir)/mzmark_sfs.inc string.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h $(srcdir)/schvers.h $(srcdir)/mzmark_string.inc $(srcdir)/strops.inc \ - $(srcdir)/schustr.inc + $(srcdir)/schustr.inc $(srcdir)/systype.inc struct.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h $(srcdir)/mzmark_struct.inc syntax.@LTO@: $(COMMON_HEADERS) \ diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 403bb94c3b..25734056ff 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "6.2.900.10" +#define MZSCHEME_VERSION "6.2.900.11" #define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_Y 2 #define MZSCHEME_VERSION_Z 900 -#define MZSCHEME_VERSION_W 10 +#define MZSCHEME_VERSION_W 11 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/racket/src/racket/src/string.c b/racket/src/racket/src/string.c index abb3544a5a..f794a5d324 100644 --- a/racket/src/racket/src/string.c +++ b/racket/src/racket/src/string.c @@ -2723,23 +2723,13 @@ void *scheme_environment_variables_to_block(Scheme_Object *ev, int *_need_free) static void machine_details(char *s); +#include "systype.inc" + static Scheme_Object *system_type(int argc, Scheme_Object *argv[]) { if (argc) { if (SAME_OBJ(argv[0], link_symbol)) { -#if defined(OS_X) && !defined(XONX) - return scheme_intern_symbol("framework"); -#else -# ifdef DOS_FILE_SYSTEM - return scheme_intern_symbol("dll"); -# else -# ifdef MZ_USES_SHARED_LIB - return scheme_intern_symbol("shared"); -# else - return scheme_intern_symbol("static"); -# endif -# endif -#endif + return scheme_intern_symbol(MZ_SYSTEM_TYPE_LINK); } if (SAME_OBJ(argv[0], machine_symbol)) { @@ -2759,27 +2749,11 @@ static Scheme_Object *system_type(int argc, Scheme_Object *argv[]) } if (SAME_OBJ(argv[0], so_suffix_symbol)) { -#ifdef DOS_FILE_SYSTEM - return scheme_make_byte_string(".dll"); -#else -# ifdef OS_X - return scheme_make_byte_string(".dylib"); -# else -# ifdef USE_CYGWIN_SO_SUFFIX - return scheme_make_byte_string(".dll"); -# else - return scheme_make_byte_string(".so"); -# endif -# endif -#endif + return scheme_make_byte_string(MZ_SYSTEM_TYPE_SO_SUFFIX); } if (SAME_OBJ(argv[0], so_mode_symbol)) { -#ifdef USE_DLOPEN_GLOBAL_BY_DEFAULT - return scheme_intern_symbol("global"); -#else - return scheme_intern_symbol("local"); -#endif + return scheme_intern_symbol(MZ_SYSTEM_TYPE_SO_MODE); } diff --git a/racket/src/racket/src/systype.c b/racket/src/racket/src/systype.c new file mode 100644 index 0000000000..fb75a14a5d --- /dev/null +++ b/racket/src/racket/src/systype.c @@ -0,0 +1,16 @@ +/* This file is run through `cpp` by "../mysystem.rkt" + in cross-compilation mode. */ + +#include "schpriv.h" +#include "systype.inc" +#ifndef SCHEME_PLATFORM_LIBRARY_SUBPATH +# include "schsys.h" +#endif + +string system_type_os = SYSTEM_TYPE_NAME; +string system_type_link = MZ_SYSTEM_TYPE_LINK; +string system_type_so_suffix = MZ_SYSTEM_TYPE_SO_SUFFIX; +string system_type_so_mode = MZ_SYSTEM_TYPE_SO_MODE; +string system_library_subpath = SCHEME_PLATFORM_LIBRARY_SUBPATH; + +int system_pointer_size = SIZEOF_VOID_P; diff --git a/racket/src/racket/src/systype.inc b/racket/src/racket/src/systype.inc new file mode 100644 index 0000000000..448d5fb088 --- /dev/null +++ b/racket/src/racket/src/systype.inc @@ -0,0 +1,37 @@ + +/* Some answers for `system-type`, also consulted for cross-compilation */ + +#if defined(OS_X) && !defined(XONX) +# define MZ_SYSTEM_TYPE_LINK "framework" +#else +# ifdef DOS_FILE_SYSTEM +# define MZ_SYSTEM_TYPE_LINK "dll" +# else +# ifdef MZ_USES_SHARED_LIB +# define MZ_SYSTEM_TYPE_LINK "shared" +# else +# define MZ_SYSTEM_TYPE_LINK "static" +# endif +# endif +#endif + +#ifdef DOS_FILE_SYSTEM +# define MZ_SYSTEM_TYPE_SO_SUFFIX ".dll" +#else +# ifdef OS_X +# define MZ_SYSTEM_TYPE_SO_SUFFIX ".dylib" +# else +# ifdef USE_CYGWIN_SO_SUFFIX +# define MZ_SYSTEM_TYPE_SO_SUFFIX ".dll" +# else +# define MZ_SYSTEM_TYPE_SO_SUFFIX ".so" +# endif +# endif +#endif + + +#ifdef USE_DLOPEN_GLOBAL_BY_DEFAULT +# define MZ_SYSTEM_TYPE_SO_MODE "global" +#else +# define MZ_SYSTEM_TYPE_SO_MODE "local" +#endif diff --git a/racket/src/worksp/gc2/make.rkt b/racket/src/worksp/gc2/make.rkt index 057a04584c..b6f09a35e1 100644 --- a/racket/src/worksp/gc2/make.rkt +++ b/racket/src/worksp/gc2/make.rkt @@ -413,3 +413,6 @@ (copy-file/diff "mzdyn3m.exp" "../../../lib/msvc/mzdyn3m.exp") (copy-file/diff "mzdyn3m.obj" "../../../lib/msvc/mzdyn3m.obj") + +(parameterize ([current-command-line-arguments (vector "../../../lib/system.rktd")]) + (dynamic-require "../../racket/mksystem.rkt" #f)) diff --git a/racket/src/worksp/racket/racket.vcproj b/racket/src/worksp/racket/racket.vcproj index cb07b21109..6461624e1c 100644 --- a/racket/src/worksp/racket/racket.vcproj +++ b/racket/src/worksp/racket/racket.vcproj @@ -60,7 +60,7 @@ />