system-type: add 'os* and 'arch modes
The 'os* mode is like 'os, but it provides a more specific result for Unix variants, such as 'linux on Linux. The 'os* and 'arch modes together are the information that we've previously accessed indirectly via `(system-library-subpath #f)`. Closes #3510
This commit is contained in:
Matthew Flatt
parent
153e417862
commit
39d5adc745
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
@title[#:tag "runtime"]{Environment and Runtime Information}
|
||||
|
||||
@defproc[(system-type [mode (or/c 'os 'word 'vm 'gc 'link 'machine 'target-machine
|
||||
@defproc[(system-type [mode (or/c 'os 'os* 'arch 'word 'vm 'gc 'link 'machine 'target-machine
|
||||
'so-suffix 'so-mode 'fs-change 'cross)
|
||||
'os])
|
||||
(or/c symbol? string? bytes? exact-positive-integer? vector? #f)]{
|
||||
|
|
@ -22,6 +22,19 @@ In @indexed-racket['os] mode,
|
|||
@item{@indexed-racket['macosx]}
|
||||
]
|
||||
|
||||
@margin-note{Prior to the introduction of @racket['os*] and
|
||||
@racket['arch] modes, @racket[(system-library-subpath #f)] could be
|
||||
used to obtain this information somewhat indirectly.}
|
||||
|
||||
In @indexed-racket['os*] mode, the result is similar to @racket['os]
|
||||
mode, but refined to a specific operating system, such as
|
||||
@racket['linux] or @racket['freebsd], instead of a generic
|
||||
@racket['unix] classification.
|
||||
|
||||
In @indexed-racket['arch] mode, the result is a symbol representing an
|
||||
architecture. Possible results include @racket['x86_64], @racket['i386],
|
||||
@racket['aarch64], @racket['arm] (32-bit), and @racket['ppc] (32-bit).
|
||||
|
||||
In @indexed-racket['word] mode, the result is either @racket[32] or
|
||||
@racket[64] to indicate whether Racket is running as a 32-bit program
|
||||
or 64-bit program.
|
||||
|
|
@ -55,8 +68,8 @@ In @indexed-racket['link] mode, the possible symbol results are:
|
|||
@item{@indexed-racket['framework] (Mac OS)}
|
||||
]
|
||||
|
||||
Future ports of Racket may expand the list of @racket['os], @racket['vm],
|
||||
@racket['gc], and @racket['link] results.
|
||||
Future ports of Racket may expand the list of @racket['os], @racket['os*],
|
||||
@racket['arch], @racket['vm], @racket['gc], and @racket['link] results.
|
||||
|
||||
In @indexed-racket['machine] mode, then the result is a string, which
|
||||
contains further details about the current machine in a
|
||||
|
|
@ -118,7 +131,8 @@ The possible symbols are:
|
|||
|
||||
@history[#:changed "6.8.0.2" @elem{Added @racket['vm] mode.}
|
||||
#:changed "6.9.0.1" @elem{Added @racket['cross] mode.}
|
||||
#:changed "7.1.0.6" @elem{Added @racket['target-machine] mode.}]}
|
||||
#:changed "7.1.0.6" @elem{Added @racket['target-machine] mode.}
|
||||
#:changed "7.9.0.6" @elem{Added @racket['os*] and @racket['arch] modes.}]}
|
||||
|
||||
|
||||
@defproc[(system-language+country) string?]{
|
||||
|
|
|
|||
|
|
@ -3037,7 +3037,10 @@
|
|||
(test (system-type) system-type 'os)
|
||||
(test #t string? (system-type 'machine))
|
||||
(test #t symbol? (system-type 'link))
|
||||
(test #t symbol? (system-type 'os*))
|
||||
(test #t symbol? (system-type 'arch))
|
||||
(test #t relative-path? (system-library-subpath))
|
||||
(test #t relative-path? (system-library-subpath #f))
|
||||
|
||||
(test #t pair? (memv (system-type 'word) '(32 64)))
|
||||
(test (fixnum? (expt 2 32)) = (system-type 'word) 64)
|
||||
|
|
|
|||
|
|
@ -15,6 +15,8 @@
|
|||
(vector-ref args (- (vector-length args) 2))))
|
||||
;; Not cross-compiling
|
||||
(hash 'os (system-type 'os)
|
||||
'os* (system-type 'os*)
|
||||
'arch (system-type 'arch)
|
||||
'word (system-type 'word)
|
||||
'gc (if (= (vector-length args) 1)
|
||||
'3m ; GC mode for suffixless executables
|
||||
|
|
@ -58,8 +60,12 @@
|
|||
(lambda (var) (string->number (get-string var)))])
|
||||
(let-values ([(library-subpath)
|
||||
(get-string "system_library_subpath")]
|
||||
[(os) (get-symbol "system_type_os")])
|
||||
[(os) (get-symbol "system_type_os")]
|
||||
[(os*) (get-symbol "system_type_os_star")]
|
||||
[(arch) (get-symbol "system_type_arch")])
|
||||
(hash 'os os
|
||||
'os* os*
|
||||
'arch arch
|
||||
'word (* 8 (get-int "system_pointer_size"))
|
||||
'gc (if (string=? "" (vector-ref args 2))
|
||||
'3m
|
||||
|
|
|
|||
|
|
@ -30,18 +30,20 @@
|
|||
# include <errno.h>
|
||||
# ifdef ECHRNG
|
||||
/* Solaris */
|
||||
# define SCHEME_OS "solaris"
|
||||
# if defined(__i386__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-solaris"
|
||||
# define SCHEME_ARCH "i386"
|
||||
# elif defined(__x86_64)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "x86_64-solaris"
|
||||
# define SCHEME_ARCH "x86_64"
|
||||
# else
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "sparc-solaris"
|
||||
# define SCHEME_ARCH "sparc"
|
||||
# endif
|
||||
# else
|
||||
/* SunOS4 */
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "sparc-sunos4"
|
||||
# define NO_STRERROR_AVAILABLE
|
||||
# define USE_ON_EXIT_FOR_ATEXIT
|
||||
# define SCHEME_OS "sunos4"
|
||||
# define SCHEME_ARCH "sparc"
|
||||
# define NO_STRERROR_AVAILABLE
|
||||
# define USE_ON_EXIT_FOR_ATEXIT
|
||||
# endif
|
||||
|
||||
# define PREFER_MMAP_LARGE_BLOCKS
|
||||
|
|
@ -66,7 +68,8 @@
|
|||
|
||||
# if defined(_IBMR2)
|
||||
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "rs6k-aix"
|
||||
# define SCHEME_OS "rs6k"
|
||||
# define SCHEME_ARCH "aix"
|
||||
|
||||
# include "uconfig.h"
|
||||
|
||||
|
|
@ -81,58 +84,58 @@
|
|||
#if defined(__linux__)
|
||||
|
||||
# ifdef __ANDROID__
|
||||
# define SPLS_LINUX "android"
|
||||
# define SCHEME_OS "android"
|
||||
# else
|
||||
# define SPLS_LINUX "linux"
|
||||
# define SCHEME_OS "linux"
|
||||
# endif
|
||||
|
||||
# if defined(__i386__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-" SPLS_LINUX
|
||||
# define SCHEME_ARCH "i386"
|
||||
# define REGISTER_POOR_MACHINE
|
||||
# define MZ_TRY_EXTFLONUMS
|
||||
# define ASM_DBLPREC_CONTROL_87
|
||||
# endif
|
||||
# if defined(__powerpc__) && !defined(__powerpc64__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "ppc-" SPLS_LINUX
|
||||
# define SCHEME_ARCH "ppc"
|
||||
# endif
|
||||
# if defined(__powerpc64__)
|
||||
# if defined(__LITTLE_ENDIAN__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "ppc64le-" SPLS_LINUX
|
||||
# define SCHEME_ARCH "ppc64le"
|
||||
# else
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "ppc64-" SPLS_LINUX
|
||||
# define SCHEME_ARCH "ppc64"
|
||||
# endif
|
||||
# endif
|
||||
# if defined(__mc68000__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "m68k-" SPLS_LINUX
|
||||
# define SCHEME_ARCH "m68k"
|
||||
# endif
|
||||
# if defined(mips)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "mips-" SPLS_LINUX
|
||||
# define SCHEME_ARCH "mips"
|
||||
# endif
|
||||
# if defined(__alpha__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "alpha-" SPLS_LINUX
|
||||
# define SCHEME_ARCH "alpha"
|
||||
# endif
|
||||
# if defined(__hppa__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "hppa-" SPLS_LINUX
|
||||
# define SCHEME_ARCH "hppa"
|
||||
# endif
|
||||
# if defined(__sparc__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "sparc-" SPLS_LINUX
|
||||
# define SCHEME_ARCH "sparc"
|
||||
# define FLUSH_SPARC_REGISTER_WINDOWS
|
||||
# endif
|
||||
# if defined(__arm__) || defined(__thumb__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "arm-" SPLS_LINUX
|
||||
# define SCHEME_ARCH "arm"
|
||||
# define FFI_CALLBACK_NEED_INT_CLEAR
|
||||
# endif
|
||||
# if defined(__aarch64__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "aarch64-" SPLS_LINUX
|
||||
# define SCHEME_ARCH "aarch64"
|
||||
# endif
|
||||
# if defined(__x86_64__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "x86_64-" SPLS_LINUX
|
||||
# define SCHEME_ARCH "x86_64"
|
||||
# define REGISTER_POOR_MACHINE
|
||||
# define ASM_DBLPREC_CONTROL_87
|
||||
# define MZ_TRY_EXTFLONUMS
|
||||
# endif
|
||||
# ifndef SCHEME_PLATFORM_LIBRARY_SUBPATH
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "unknown-" SPLS_LINUX
|
||||
# define SCHEME_ARCH "unknown"
|
||||
# endif
|
||||
|
||||
# include "uconfig.h"
|
||||
|
|
@ -174,14 +177,16 @@
|
|||
|
||||
#if defined(__NetBSD__)
|
||||
|
||||
#define SCHEME_OS "netbsd"
|
||||
|
||||
#if defined(__i386__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-netbsd"
|
||||
# define SCHEME_ARCH "i386"
|
||||
#elif defined(__powerpc__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "ppc-netbsd"
|
||||
# define SCHEME_ARCH "ppc"
|
||||
#elif defined(__x86_64__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "x86_64-netbsd"
|
||||
# define SCHEME_ARCH "x86_64"
|
||||
#else
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "netbsd"
|
||||
# define SCHEME_ARCH "unknown"
|
||||
#endif
|
||||
|
||||
# include "uconfig.h"
|
||||
|
|
@ -480,10 +485,13 @@
|
|||
|
||||
# ifdef _WIN64
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "win32\\x86_64"
|
||||
# define SCHEME_ARCH "x86_64"
|
||||
# else
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "win32\\i386"
|
||||
# define SCHEME_ARCH "i386"
|
||||
# endif
|
||||
|
||||
# define SCHEME_OS "windows"
|
||||
# define SYSTEM_TYPE_NAME "windows"
|
||||
# define DOS_FILE_SYSTEM
|
||||
|
||||
|
|
@ -592,7 +600,8 @@
|
|||
|
||||
#if defined(__CYGWIN32__)
|
||||
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-cygwin"
|
||||
# define SCHEME_OS "cygwin"
|
||||
# define SCHEME_ARCH "i386"
|
||||
|
||||
# include "uconfig.h"
|
||||
|
||||
|
|
@ -621,23 +630,23 @@
|
|||
# if defined(OS_X) || defined(XONX)
|
||||
|
||||
# if defined(XONX)
|
||||
# define SPLS_MAC "darwin"
|
||||
# define SCHEME_OS "darwin"
|
||||
# elif TARGET_OS_IPHONE
|
||||
# define SPLS_MAC "ios"
|
||||
# define SCHEME_OS "ios"
|
||||
# else
|
||||
# define SPLS_MAC "macosx"
|
||||
# define SCHEME_OS "macosx"
|
||||
# endif
|
||||
|
||||
# if defined(__POWERPC__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "ppc-" SPLS_MAC
|
||||
# define SCHEME_ARCH "ppc"
|
||||
# elif defined(__arm__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "arm-" SPLS_MAC
|
||||
# define SCHEME_ARCH "arm"
|
||||
# elif defined(__arm64__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "arm64-" SPLS_MAC
|
||||
# define SCHEME_ARCH "aarch64"
|
||||
# elif defined(__x86_64__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "x86_64-" SPLS_MAC
|
||||
# define SCHEME_ARCH "x86_64"
|
||||
# else
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-" SPLS_MAC
|
||||
# define SCHEME_ARCH "i386"
|
||||
# endif
|
||||
|
||||
# include "uconfig.h"
|
||||
|
|
@ -696,7 +705,8 @@
|
|||
|
||||
# if defined(__APPLE__) && defined(__MACH__) && defined(__i386__) && !defined(OS_X)
|
||||
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-darwin"
|
||||
# define SCHEME_OS "darwin"
|
||||
# define SCHEME_ARCH "i386"
|
||||
|
||||
# include "uconfig.h"
|
||||
|
||||
|
|
@ -714,8 +724,12 @@
|
|||
|
||||
#if defined(__QNX__)
|
||||
|
||||
# define SCHEME_OS "qnx"
|
||||
|
||||
#if defined(__i386__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-qnx"
|
||||
# define SCHEME_ARCH "i386"
|
||||
#else
|
||||
# define SCHEME_ARCH "unknown"
|
||||
#endif
|
||||
# define ASSUME_FIXED_STACK_SIZE
|
||||
|
||||
|
|
@ -741,14 +755,16 @@
|
|||
|
||||
#if defined(__DragonFly__)
|
||||
|
||||
# define SCHEME_OS "dragonfly"
|
||||
|
||||
# if defined(__i386__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-dragonfly"
|
||||
# define SCHEME_ARCH "i386"
|
||||
# define REGISTER_POOR_MACHINE
|
||||
# define MZ_USE_JIT_I386
|
||||
# define ASM_DBLPREC_CONTROL_87
|
||||
# define MZ_TRY_EXTFLONUMS
|
||||
# elif defined(__amd64__)
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "amd64-dragonfly"
|
||||
# define SCHEME_ARCH "aarch64"
|
||||
# define REGISTER_POOR_MACHINE
|
||||
# define MZ_USE_JIT_X86_64
|
||||
# define ASM_DBLPREC_CONTROL_87
|
||||
|
|
@ -779,6 +795,9 @@
|
|||
|
||||
/************** (END KNOWN ARCHITECTURE/SYSTEMS) ****************/
|
||||
|
||||
#ifndef SCHEME_PLATFORM_LIBRARY_SUBPATH
|
||||
# define SCHEME_PLATFORM_LIBRARY_SUBPATH SCHEME_ARCH "-" SCHEME_OS
|
||||
#endif
|
||||
|
||||
/***** (BEGIN CONFIGURATION FLAG DESCRPTIONS AND DEFAULTS) ******/
|
||||
|
||||
|
|
@ -794,6 +813,12 @@
|
|||
/* SYSTEM_TYPE_NAME must be a string; this will be converted into
|
||||
a symbol for the result of (system-type) */
|
||||
|
||||
/* SCHEME_OS must be a string; this converted into a symbol for the
|
||||
result of (system-type 'os*) */
|
||||
|
||||
/* SCHEME_ARCH must be a string; this converted into a symbol for the
|
||||
result of (system-type 'arch) */
|
||||
|
||||
/* SCHEME_PLATFORM_LIBRARY_SUBPATH must be a string; if it is
|
||||
undefined, it is automatically generated into a file named
|
||||
"schsys.h" into the same directory as .o files and #included
|
||||
|
|
|
|||
|
|
@ -171,10 +171,11 @@ static void cache_locale_or_close(int to_bytes, rktio_converter_t *cd, char *le)
|
|||
|
||||
#define portable_isspace(x) (((x) < 128) && isspace(x))
|
||||
|
||||
ROSYM static Scheme_Object *sys_symbol;
|
||||
ROSYM static Scheme_Object *sys_symbol, *sys_os_symbol, *sys_arch_symbol;
|
||||
ROSYM static Scheme_Object *link_symbol, *machine_symbol, *vm_symbol, *gc_symbol;
|
||||
ROSYM static Scheme_Object *so_suffix_symbol, *so_mode_symbol, *word_symbol;
|
||||
ROSYM static Scheme_Object *os_symbol, *fs_change_symbol, *target_machine_symbol, *cross_symbol;
|
||||
ROSYM static Scheme_Object *os_symbol, *os_star_symbol, *arch_symbol;
|
||||
ROSYM static Scheme_Object *fs_change_symbol, *target_machine_symbol, *cross_symbol;
|
||||
ROSYM static Scheme_Object *racket_symbol, *cgc_symbol, *_3m_symbol, *cs_symbol;
|
||||
ROSYM static Scheme_Object *force_symbol, *infer_symbol;
|
||||
ROSYM static Scheme_Object *platform_3m_path, *platform_cgc_path, *platform_cs_path;
|
||||
|
|
@ -218,7 +219,11 @@ scheme_init_string (Scheme_Startup_Env *env)
|
|||
Scheme_Object *p;
|
||||
|
||||
REGISTER_SO(sys_symbol);
|
||||
REGISTER_SO(sys_os_symbol);
|
||||
REGISTER_SO(sys_arch_symbol);
|
||||
sys_symbol = scheme_intern_symbol(SYSTEM_TYPE_NAME);
|
||||
sys_os_symbol = scheme_intern_symbol(SCHEME_OS);
|
||||
sys_arch_symbol = scheme_intern_symbol(SCHEME_ARCH);
|
||||
|
||||
REGISTER_SO(link_symbol);
|
||||
REGISTER_SO(machine_symbol);
|
||||
|
|
@ -228,6 +233,8 @@ scheme_init_string (Scheme_Startup_Env *env)
|
|||
REGISTER_SO(so_mode_symbol);
|
||||
REGISTER_SO(word_symbol);
|
||||
REGISTER_SO(os_symbol);
|
||||
REGISTER_SO(os_star_symbol);
|
||||
REGISTER_SO(arch_symbol);
|
||||
REGISTER_SO(fs_change_symbol);
|
||||
REGISTER_SO(target_machine_symbol);
|
||||
REGISTER_SO(cross_symbol);
|
||||
|
|
@ -239,6 +246,8 @@ scheme_init_string (Scheme_Startup_Env *env)
|
|||
so_mode_symbol = scheme_intern_symbol("so-mode");
|
||||
word_symbol = scheme_intern_symbol("word");
|
||||
os_symbol = scheme_intern_symbol("os");
|
||||
os_star_symbol = scheme_intern_symbol("os*");
|
||||
arch_symbol = scheme_intern_symbol("arch");
|
||||
fs_change_symbol = scheme_intern_symbol("fs-change");
|
||||
target_machine_symbol = scheme_intern_symbol("target-machine");
|
||||
cross_symbol = scheme_intern_symbol("cross");
|
||||
|
|
@ -2441,10 +2450,18 @@ static Scheme_Object *system_type(int argc, Scheme_Object *argv[])
|
|||
return (cross_compile_mode ? force_symbol : infer_symbol);
|
||||
}
|
||||
|
||||
if (SAME_OBJ(argv[0], os_star_symbol)) {
|
||||
return sys_os_symbol;
|
||||
}
|
||||
|
||||
if (SAME_OBJ(argv[0], arch_symbol)) {
|
||||
return sys_arch_symbol;
|
||||
}
|
||||
|
||||
if (!SAME_OBJ(argv[0], os_symbol)) {
|
||||
scheme_wrong_contract("system-type",
|
||||
("(or/c 'os 'word 'link 'machine 'target-machine\n"
|
||||
" 'vm 'gc 'so-suffix 'so-mode 'word 'fs-change 'cross)"),
|
||||
("(or/c 'os 'os* 'arch 'word 'link 'machine 'target-machine\n"
|
||||
" 'vm 'gc 'so-suffix 'so-mode 'word 'fs-change 'cross)"),
|
||||
0, argc, argv);
|
||||
return NULL;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -8,6 +8,8 @@
|
|||
#endif
|
||||
|
||||
string system_type_os = SYSTEM_TYPE_NAME;
|
||||
string system_type_os_star = SCHEME_OS;
|
||||
string system_type_arch = SCHEME_ARCH;
|
||||
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;
|
||||
|
|
|
|||
|
|
@ -478,7 +478,7 @@ common-install:
|
|||
$(MAKE) common-@INSTALL_LIBS_ENABLE@-libs
|
||||
|
||||
system-install:
|
||||
$(RACKET) -cu "$(srcdir)/gen-system.rkt" $(DESTDIR)$(libpltdir)/system$(CS_INSTALLED).rktd $(TARGET_MACH) @CROSS_COMPILE_TARGET_KIND@
|
||||
$(RACKET) -cu "$(srcdir)/gen-system.rkt" $(DESTDIR)$(libpltdir)/system$(CS_INSTALLED).rktd $(TARGET_MACH) @CROSS_COMPILE_TARGET_KIND@ "$(srcdir)"
|
||||
|
||||
include-install:
|
||||
$(ICP) $(srcdir)/api.h "$(DESTDIR)$(includepltdir)/racketcs.h"
|
||||
|
|
|
|||
|
|
@ -1,59 +1,130 @@
|
|||
(module gen-system '#%kernel
|
||||
|
||||
;; Command-line argument: <dest-file> <target-machine> <cross-target-machine>
|
||||
|
||||
;; This file includes various inferences for cross-compilation, so it has
|
||||
;; to be updated for new cross-compilation targets.
|
||||
;; Command-line argument: <dest-file> <target-machine> <cross-target-machine> <srcdir>
|
||||
|
||||
(define-values (machine) (string->symbol (vector-ref (current-command-line-arguments) 1)))
|
||||
(define-values (srcdir) (vector-ref (current-command-line-arguments) 3))
|
||||
|
||||
(define-values (machine-lookup)
|
||||
(lambda (l default)
|
||||
(define-values (definitions)
|
||||
(call-with-input-file
|
||||
(build-path srcdir 'up "rumble" "system.ss")
|
||||
(lambda (i)
|
||||
(letrec-values ([(loop)
|
||||
(lambda ()
|
||||
(let-values ([(v) (read i)])
|
||||
(if (eof-object? v)
|
||||
null
|
||||
(cons v (loop)))))])
|
||||
(loop)))))
|
||||
|
||||
(define-values (lookup)
|
||||
(lambda (key)
|
||||
(letrec-values ([(loop)
|
||||
(lambda (l)
|
||||
(if (null? l)
|
||||
(error 'lookup "could not find ~e" key)
|
||||
(let-values ([(a) (car l)])
|
||||
(if (eq? 'define (car a))
|
||||
(if (eq? key (cadr a))
|
||||
(parse-cond (caddr a))
|
||||
(loop (cdr l)))
|
||||
(loop (cdr l))))))])
|
||||
(loop definitions))))
|
||||
|
||||
(define-values (parse-cond)
|
||||
(lambda (e)
|
||||
(if (matches? e '(case (machine-type) . _))
|
||||
(letrec-values ([(loop)
|
||||
(lambda (l)
|
||||
(if (null? l)
|
||||
(error 'parse-cond "no match")
|
||||
(let-values ([(a) (car l)])
|
||||
(if (matches? a '[else _])
|
||||
(parse-expr (cadr a))
|
||||
(if (matches? a '[_ _])
|
||||
(if (memq machine (car a))
|
||||
(parse-expr (cadr a))
|
||||
(loop (cdr l)))
|
||||
(loop (cdr l)))))))])
|
||||
(loop (cddr e)))
|
||||
(error 'parse-cond "could not parse ~e" e))))
|
||||
|
||||
(define-values (parse-expr)
|
||||
(lambda (e)
|
||||
(if (matches? e '(quote _))
|
||||
(cadr e)
|
||||
(if (matches? e '(string->utf8 _))
|
||||
(string->bytes/utf-8 (cadr e))
|
||||
(if (matches? e '(if unix-style-macos? _ _))
|
||||
(if (eq? (system-type) 'macosx)
|
||||
(parse-expr (cadddr e))
|
||||
(parse-expr (caddr e)))
|
||||
(if (matches? e '(if unix-link-shared? _ _))
|
||||
;; Currently assuming shared-library mode is not a cross compile:
|
||||
(if (eq? (system-type 'link) 'shared)
|
||||
(parse-expr (cadddr e))
|
||||
(parse-expr (caddr e)))
|
||||
(error 'parse-expr "could not parse ~e" e)))))))
|
||||
|
||||
(define-values (matches?)
|
||||
(lambda (e pat)
|
||||
(if (eq? pat '_)
|
||||
#t
|
||||
(if (pair? pat)
|
||||
(if (pair? e)
|
||||
(if (matches? (car e) (car pat))
|
||||
(matches? (cdr e) (cdr pat))
|
||||
#f)
|
||||
#f)
|
||||
(equal? e pat)))))
|
||||
|
||||
(define-values (memq)
|
||||
(lambda (a l)
|
||||
(if (null? l)
|
||||
default
|
||||
(if (eq? (caar l) machine)
|
||||
(cdar l)
|
||||
(machine-lookup (cdr l) default)))))
|
||||
#f
|
||||
(if (eq? a (car l))
|
||||
#t
|
||||
(memq a (cdr l))))))
|
||||
|
||||
;; Check for cross-compile to Windows:
|
||||
(define-values (windows?) (machine-lookup '((ta6nt . #t)
|
||||
(a6nt . #t)
|
||||
(ti3nt . #t)
|
||||
(i3nt . #t))
|
||||
#f))
|
||||
(define-values (os) (lookup 'os-symbol))
|
||||
(define-values (os*) (lookup 'os*-symbol))
|
||||
(define-values (arch) (lookup 'arch-symbol))
|
||||
(define-values (link) (lookup 'link-symbol))
|
||||
(define-values (so-suffix) (lookup 'so-suffix-bytes))
|
||||
|
||||
(define-values (lib-subpath)
|
||||
(machine-lookup '((ta6nt . "win32\\x86_64")
|
||||
(a6nt . "win32\\x86_64")
|
||||
(ti3nt . "win32\\i386")
|
||||
(i3nt . "win32\\i386")
|
||||
(tarm32le . "arm-linux")
|
||||
(arm32le . "arm-linux")
|
||||
(tarm64le . "aarch64-linux")
|
||||
(arm64le . "aarch64-linux"))
|
||||
(bytes->string/utf-8 (path->bytes (system-library-subpath #f)))))
|
||||
(if (eq? machine 'ta6nt)
|
||||
"win32\\x86_64"
|
||||
(if (eq? machine 'a6nt)
|
||||
"win32\\x86_64"
|
||||
(if (eq? machine 'ti3nt)
|
||||
"win32\\i386"
|
||||
(if (eq? machine 'ti3nt)
|
||||
"win32\\i386"
|
||||
(format "~a-~a" arch os*))))))
|
||||
|
||||
(define-values (ht)
|
||||
(hash 'os (if windows? 'windows (system-type 'os))
|
||||
'word (machine-lookup '((ta6nt . 64)
|
||||
(a6nt . 64)
|
||||
(ti3nt . 32)
|
||||
(i3nt . 32)
|
||||
(tarm32le . 32)
|
||||
(arm32le . 32)
|
||||
(tarm64le . 64)
|
||||
(arm64le . 64))
|
||||
(system-type 'word))
|
||||
(hash 'os os
|
||||
'os* os*
|
||||
'arch arch
|
||||
'word (if (eq? arch 'i386)
|
||||
32
|
||||
(if (eq? arch 'arm)
|
||||
32
|
||||
(if (eq? arch 'ppc)
|
||||
32
|
||||
64)))
|
||||
'gc 'cs
|
||||
'vm 'chez-scheme
|
||||
'link (if windows? 'windows (system-type 'link))
|
||||
'link link
|
||||
'machine lib-subpath
|
||||
'library-subpath (string->bytes/utf-8 lib-subpath)
|
||||
'library-subpath-convention (if windows? 'windows 'unix)
|
||||
'so-suffix (if windows? #".dll" (system-type 'so-suffix))
|
||||
'library-subpath-convention (if (eq? os 'windows) 'windows 'unix)
|
||||
'so-suffix so-suffix
|
||||
'so-mode 'local
|
||||
'fs-change (if windows?
|
||||
'fs-change (if (eq? os 'windows)
|
||||
'#(supported scalable low-latency #f)
|
||||
;; Warning: not necessarily right for cross compilation:
|
||||
(system-type 'fs-change))
|
||||
'target-machine (if (equal? "any" (vector-ref (current-command-line-arguments) 2))
|
||||
#f
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
;; Check to make we're using a build of Chez Scheme
|
||||
;; that has all the features we need.
|
||||
(define-values (need-maj need-min need-sub need-dev)
|
||||
(values 9 5 3 49))
|
||||
(values 9 5 3 50))
|
||||
|
||||
(unless (guard (x [else #f]) (eval 'scheme-fork-version-number))
|
||||
(error 'compile-file
|
||||
|
|
|
|||
|
|
@ -1,11 +1,4 @@
|
|||
|
||||
(define system-type
|
||||
(case-lambda
|
||||
[() (system-type* 'os)]
|
||||
[(mode) (if (eq? mode 'vm)
|
||||
'chez-scheme
|
||||
(system-type* mode))]))
|
||||
|
||||
(define unix-style-macos?
|
||||
(meta-cond
|
||||
[(getenv "PLT_CS_MAKE_UNIX_STYLE_MACOS") #t]
|
||||
|
|
@ -22,37 +15,112 @@
|
|||
(define fs-change-properties '#(#f #f #f #f))
|
||||
(define (set-fs-change-properties! vec) (set! fs-change-properties vec))
|
||||
|
||||
(define (system-type* mode)
|
||||
(case mode
|
||||
[(vm) 'chez-scheme]
|
||||
[(os) (case (machine-type)
|
||||
[(a6osx ta6osx i3osx ti3osx)
|
||||
(if unix-style-macos? 'unix 'macosx)]
|
||||
[(a6nt ta6nt i3nt ti3nt) 'windows]
|
||||
[else 'unix])]
|
||||
[(word) (if (> (fixnum-width) 32) 64 32)]
|
||||
[(gc) 'cs]
|
||||
[(link) (case (and (not unix-style-macos?)
|
||||
(machine-type))
|
||||
[(a6osx ta6osx i3osx ti3osx) 'framework]
|
||||
[(a6nt ta6nt i3nt ti3nt) 'windows]
|
||||
[else (if unix-link-shared?
|
||||
'shared
|
||||
'static)])]
|
||||
[(machine) (get-machine-info)]
|
||||
[(so-suffix) (case (machine-type)
|
||||
[(a6osx ta6osx i3osx ti3osx) (string->utf8 ".dylib")]
|
||||
[(a6nt ta6nt i3nt ti3nt) (string->utf8 ".dll")]
|
||||
[else (string->utf8 ".so")])]
|
||||
[(so-mode) 'local]
|
||||
[(fs-change) fs-change-properties]
|
||||
[(target-machine) (machine-type)]
|
||||
[(cross) cross-mode]
|
||||
[else (raise-argument-error 'system-type
|
||||
(string-append
|
||||
"(or/c 'os 'word 'vm 'gc 'link 'machine 'target-machine\n"
|
||||
" 'so-suffix 'so-mode 'fs-change 'cross)")
|
||||
mode)]))
|
||||
;; Definitons like `os-symbol` are also parsed by "../c/gen-system.rkt"
|
||||
|
||||
(define os-symbol
|
||||
(case (machine-type)
|
||||
[(a6osx ta6osx i3osx ti3osx arm64osx tarm64osx)
|
||||
(if unix-style-macos? 'unix 'macosx)]
|
||||
[(a6nt ta6nt i3nt ti3nt) 'windows]
|
||||
[else 'unix]))
|
||||
|
||||
(define os*-symbol
|
||||
(case (machine-type)
|
||||
[(a6osx ta6osx i3osx ti3osx) (if unix-style-macos?
|
||||
'darwin
|
||||
'macosx)]
|
||||
[(a6nt ta6nt i3nt ti3nt) 'windows]
|
||||
[(a6le ta6le i3le ti3le
|
||||
arm32le tarm32le arm64le tarm64le
|
||||
ppc32le tppc32le)
|
||||
'linux]
|
||||
[(a6ob ta6ob i3ob ti3ob) 'openbsd]
|
||||
[(a6fb ta6fb i3fb ti3fb) 'freebsd]
|
||||
[(a6nb ta6nb i3nb ti3nb) 'netbsd]
|
||||
[(a6s2 ta6s2 i3s2 ti3s2) 'solaris]
|
||||
[(i3qnx) 'qnx]
|
||||
[else (error 'system-type "internal error: unknown operating system")]))
|
||||
|
||||
(define arch-symbol
|
||||
(case (machine-type)
|
||||
[(a6osx ta6osx
|
||||
a6nt ta6nt
|
||||
a6le ta6le
|
||||
a6ob ta6ob
|
||||
a6fb ta6fb
|
||||
a6s2 ta6s2)
|
||||
'x86_64]
|
||||
[(i3osx ti3osx
|
||||
i3nt ti3nt
|
||||
i3le ti3le
|
||||
i3ob ti3ob
|
||||
i3fb ti3fb
|
||||
i3s2 ti3s2
|
||||
i3qnx)
|
||||
'i386]
|
||||
[(arm32le tarm32le) 'arm]
|
||||
[(arm64le tarm64le arm64osx tarm64osx) 'aarch64]
|
||||
[(ppc32le tppc32le) 'ppc]
|
||||
[else (error 'system-type "internal error: unknown architecture")]))
|
||||
|
||||
(define link-symbol
|
||||
(case (machine-type)
|
||||
[(a6osx ta6osx i3osx ti3osx arm64osx tarm64osx)
|
||||
(if unix-style-macos?
|
||||
'static
|
||||
'framework)]
|
||||
[(a6nt ta6nt i3nt ti3nt) 'windows]
|
||||
[else (if unix-link-shared?
|
||||
'shared
|
||||
'static)]))
|
||||
|
||||
(define so-suffix-bytes
|
||||
(case (machine-type)
|
||||
[(a6osx ta6osx i3osx ti3osx arm64osx tarm64osx) (string->utf8 ".dylib")]
|
||||
[(a6nt ta6nt i3nt ti3nt) (string->utf8 ".dll")]
|
||||
[else (string->utf8 ".so")]))
|
||||
|
||||
;; Force inline of some common cases, so optimization can use
|
||||
;; the resulting constant:
|
||||
(define-syntax system-type
|
||||
(lambda (stx)
|
||||
(syntax-case stx (quote)
|
||||
[(_ 'key) (case (#%syntax->datum #'key)
|
||||
[(vm) #''chez-scheme]
|
||||
[(os) #'os-symbol]
|
||||
[(os*) #'os*-symbol]
|
||||
[(arch) #'arch-symbol]
|
||||
[(word) #'(if (> (fixnum-width) 32) 64 32)]
|
||||
[(gc) #''cs]
|
||||
[else #'(system-type* 'key)])]
|
||||
[(_ arg ...) #'(system-type* arg ...)]
|
||||
[_ #'system-type*])))
|
||||
|
||||
(define system-type*
|
||||
(|#%name|
|
||||
system-type
|
||||
(case-lambda
|
||||
[() (system-type* 'os)]
|
||||
[(mode)
|
||||
(case mode
|
||||
[(vm) 'chez-scheme]
|
||||
[(os) os-symbol]
|
||||
[(os*) os*-symbol]
|
||||
[(arch) arch-symbol]
|
||||
[(word) (if (> (fixnum-width) 32) 64 32)]
|
||||
[(gc) 'cs]
|
||||
[(link) link-symbol]
|
||||
[(machine) (get-machine-info)]
|
||||
[(so-suffix) so-suffix-bytes]
|
||||
[(so-mode) 'local]
|
||||
[(fs-change) fs-change-properties]
|
||||
[(target-machine) (machine-type)]
|
||||
[(cross) cross-mode]
|
||||
[else (raise-argument-error 'system-type
|
||||
(string-append
|
||||
"(or/c 'os 'os* 'arch 'word 'vm 'gc 'link 'machine 'target-machine\n"
|
||||
" 'so-suffix 'so-mode 'fs-change 'cross)")
|
||||
mode)])])))
|
||||
|
||||
(define (system-path-convention-type)
|
||||
(case (machine-type)
|
||||
|
|
@ -64,23 +132,9 @@
|
|||
(case (machine-type)
|
||||
[(a6nt ta6nt) "win32\\x86_64"]
|
||||
[(i3nt ti3nt) "win32\\i386"]
|
||||
[(a6osx ta6osx) (if unix-style-macos? "x86_64-darwin" "x86_64-macosx")]
|
||||
[(i3osx ti3osx) (if unix-style-macos? "i386-darwin" "i386-macosx")]
|
||||
[(a6le ta6le) "x86_64-linux"]
|
||||
[(i3le ti3le) "i386-linux"]
|
||||
[(arm32le tarm32le) "arm-linux"]
|
||||
[(arm64le tarm64le) "aarch64-linux"]
|
||||
[(ppc32le tppc32le) "ppc-linux"]
|
||||
[(i3ob ti3ob) "i386-openbsd"]
|
||||
[(a6ob ta6ob) "x86_64-openbsd"]
|
||||
[(i3ob ti3ob) "i386-openbsd"]
|
||||
[(a6fb ta6fb) "x86_64-freebsd"]
|
||||
[(i3fb ti3fb) "i386-freebsd"]
|
||||
[(a6nb ta6nb) "x86_64-netbsd"]
|
||||
[(i3nb ti3nb) "i386-netbsd"]
|
||||
[(a6s2 ta6s2) "x86_64-solaris"]
|
||||
[(i3s2 ti3s2) "i386-solaris"]
|
||||
[else "unix"])
|
||||
[else (string-append (symbol->string arch-symbol)
|
||||
"-"
|
||||
(symbol->string os*-symbol))])
|
||||
(let-syntax ([suffix
|
||||
(lambda (stx)
|
||||
(or (getenv "PLT_CS_SLSP_SUFFIX")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user