~ chicken-core (chicken-5) 09bf6acd1ad76ea2e4e75a62258de97a80c72c43
commit 09bf6acd1ad76ea2e4e75a62258de97a80c72c43
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Nov 27 21:22:40 2012 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Dec 12 22:34:04 2012 +0100
Added support for 64-bit Windows. Since Win64 is an LLP64 platform, references to "long" and some other data-types and C-runtime library functions have been aliased with macros.
diff --git a/README b/README
index d0190e0c..c933bff9 100644
--- a/README
+++ b/README
@@ -236,6 +236,11 @@
LLVM version of gcc and with "clang", the LLVM-based C compiler,
just set C_COMPILER to "llvm-gcc" or "clang".
+ LINKER=
+ Selects the linker to be used for creating executables and
+ dynamic libraries from compiled C code. This should normally
+ be the same as C_COMPILER.
+
PROFILE_OBJECTS=
This variable allows you to profile (parts of) Chicken itself.
Just pass in a whitespace-separated list of objects, without
@@ -481,6 +486,14 @@
MSYS tools (in case you have some of them, in particular the
sh.exe UNIX shell) are *NOT* visible in your PATH.
+ - 64-bit Windows is supported, invoke mingw32-make with the
+ "ARCH=x86-64" argument (this is currently not detected
+ auto- matically). The build has been tested on Windows 7
+ with the SJLJ binary package from "MinGW-builds", which
+ can be found here:
+
+ http://sourceforge.net/projects/mingwbuilds/
+
- Cygwin will not be able to find the chicken shared libraries
until Windows is rebooted.
diff --git a/chicken.h b/chicken.h
index 516b607d..e128332e 100644
--- a/chicken.h
+++ b/chicken.h
@@ -68,6 +68,8 @@
# define C_SIXTY_FOUR
# elif defined(__mips64) && (!defined(__GNUC__) || _MIPS_SZPTR == 64)
# define C_SIXTY_FOUR
+# elif defined(__MINGW64__)
+# define C_SIXTY_FOUR
# endif
#endif
@@ -91,6 +93,10 @@
# define C_SOLARIS
#endif
+#ifdef __MINGW64__
+# define C_LLP
+#endif
+
/* Headers */
@@ -497,7 +503,11 @@ static inline int isinf_ld (long double x)
#define C_F64_LOCATIVE 9
#ifdef C_SIXTY_FOUR
-# define C_word long
+# ifdef C_LLP
+# define C_word __int64
+# else
+# define C_word long
+# endif
# define C_u32 uint32_t
# define C_s32 int32_t
#else
@@ -520,6 +530,18 @@ static inline int isinf_ld (long double x)
#define C_uword unsigned C_word
#define C_header C_uword
+#if defined(C_LLP) && defined(C_SIXTY_FOUR)
+# define C_long __int64
+# define C_LONG_MAX LONG_LONG_MAX
+# define C_LONG_MIN LONG_LONG_MIN
+#else
+# define C_long long
+# define C_LONG_MAX LONG_MAX
+# define C_LONG_MIN LONG_MIN
+#endif
+
+#define C_ulong unsigned C_long
+
#ifdef __cplusplus
# define C_text(x) ((C_char *)(x))
#else
@@ -833,6 +855,7 @@ DECL_C_PROC_p0 (128, 1,0,0,0,0,0,0,0)
# define C_realloc realloc
# define C_strdup strdup
# define C_strtol strtol
+# define C_strtoll strtoll
# define C_strtod strtod
# define C_strtoul strtoul
# define C_fopen fopen
@@ -929,6 +952,12 @@ extern double trunc(double);
# include "chicken-libc-stubs.h"
#endif
+#ifdef C_LLP
+# define C_strtow C_strtoll
+#else
+# define C_strtow C_strtol
+#endif
+
#define C_id(x) (x)
#define C_return(x) return(x)
#define C_resize_stack(n) C_do_resize_stack(n)
@@ -1525,7 +1554,7 @@ C_varextern C_TLS C_word
*C_temporary_stack,
*C_temporary_stack_bottom,
*C_stack_limit;
-C_varextern C_TLS long
+C_varextern C_TLS C_long
C_timer_interrupt_counter,
C_initial_timer_interrupt_period;
C_varextern C_TLS C_byte
@@ -1538,7 +1567,7 @@ C_varextern C_TLS int C_gui_mode;
C_varextern C_TLS void (C_fcall *C_restart_trampoline)(void *proc) C_regparm C_noret;
C_varextern C_TLS void (*C_pre_gc_hook)(int mode);
-C_varextern C_TLS void (*C_post_gc_hook)(int mode, long ms);
+C_varextern C_TLS void (*C_post_gc_hook)(int mode, C_long ms);
C_varextern C_TLS void (*C_panic_hook)(C_char *msg);
C_varextern C_TLS int
@@ -1756,7 +1785,7 @@ C_fctexport void C_ccall C_filter_heap_objects(C_word x, C_word closure, C_word
C_fctexport C_word *C_a_i(C_word **a, int n);
#endif
-C_fctexport time_t C_fcall C_seconds(long *ms) C_regparm;
+C_fctexport time_t C_fcall C_seconds(C_long *ms) C_regparm;
C_fctexport C_word C_a_i_list(C_word **a, int c, ...);
C_fctexport C_word C_a_i_string(C_word **a, int c, ...);
C_fctexport C_word C_a_i_record(C_word **a, int c, ...);
@@ -2052,14 +2081,14 @@ C_inline C_word C_unsigned_int_to_num(C_word **ptr, C_uword n)
}
-C_inline C_word C_long_to_num(C_word **ptr, long n)
+C_inline C_word C_long_to_num(C_word **ptr, C_long n)
{
if(C_fitsinfixnump(n)) return C_fix(n);
else return C_flonum(ptr, (double)n);
}
-C_inline C_word C_unsigned_long_to_num(C_word **ptr, unsigned long n)
+C_inline C_word C_unsigned_long_to_num(C_word **ptr, C_ulong n)
{
if(C_ufitsinfixnump(n)) return C_fix(n);
else return C_flonum(ptr, (double)n);
@@ -2118,17 +2147,17 @@ C_inline void *C_scheme_or_c_pointer(C_word x)
}
-C_inline long C_num_to_long(C_word x)
+C_inline C_long C_num_to_long(C_word x)
{
if(x & C_FIXNUM_BIT) return C_unfix(x);
- else return (long)C_flonum_magnitude(x);
+ else return (C_long)C_flonum_magnitude(x);
}
-C_inline unsigned long C_num_to_unsigned_long(C_word x)
+C_inline C_ulong C_num_to_unsigned_long(C_word x)
{
if(x & C_FIXNUM_BIT) return C_unfix(x);
- else return (unsigned long)C_flonum_magnitude(x);
+ else return (C_ulong)C_flonum_magnitude(x);
}
diff --git a/posixwin.scm b/posixwin.scm
index 5b5d0b70..982cd2c2 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -477,7 +477,7 @@ redir_io()
return 1;
}
-static int C_fcall
+static C_word C_fcall
run_process(char *cmdline)
{
PROCESS_INFORMATION pi;
@@ -501,14 +501,14 @@ run_process(char *cmdline)
CloseHandle(C_rd0);
CloseHandle(C_wr1);
C_rd0 = C_wr1 = INVALID_HANDLE_VALUE;
- return (int)pi.hProcess;
+ return (C_word)pi.hProcess;
}
else
return set_last_errno();
}
-static int C_fcall
-pipe_write(int hpipe, void* buf, int count)
+static C_word C_fcall
+pipe_write(C_word hpipe, void* buf, int count)
{
DWORD done = 0;
if (WriteFile((HANDLE)hpipe, buf, count, &done, NULL))
@@ -517,8 +517,8 @@ pipe_write(int hpipe, void* buf, int count)
return set_last_errno();
}
-static int C_fcall
-pipe_read(int hpipe)
+static C_word C_fcall
+pipe_read(C_word hpipe)
{
DWORD done = 0;
/* TODO:
@@ -536,7 +536,7 @@ pipe_read(int hpipe)
}
static int C_fcall
-pipe_ready(int hpipe)
+pipe_ready(C_word hpipe)
{
DWORD avail = 0;
if (PeekNamedPipe((HANDLE)hpipe, NULL, 0, NULL, &avail, NULL) && avail)
@@ -561,7 +561,7 @@ pipe_ready(int hpipe)
#define close_handle(h) CloseHandle((HANDLE)h)
static int C_fcall
-process_wait(int h, int t)
+process_wait(C_word h, C_word t)
{
if (WaitForSingleObject((HANDLE)h, (t ? 0 : INFINITE)) == WAIT_OBJECT_0)
{
@@ -764,7 +764,7 @@ get_netinfo()
*/
static int C_fcall
C_process(const char * app, const char * cmdlin, const char ** env,
- int * phandle,
+ C_word * phandle,
int * pstdin_fd, int * pstdout_fd, int * pstderr_fd,
int params)
{
@@ -802,7 +802,7 @@ C_process(const char * app, const char * cmdlin, const char ** env,
HANDLE parent_end;
if (modes[i]=='r') { child_io_handles[i]=a; parent_end=b; }
else { parent_end=a; child_io_handles[i]=b; }
- success = (io_fds[i] = _open_osfhandle((long)parent_end,0)) >= 0;
+ success = (io_fds[i] = _open_osfhandle((C_word)parent_end,0)) >= 0;
}
}
}
@@ -875,7 +875,7 @@ C_process(const char * app, const char * cmdlin, const char ** env,
if (success)
{
- *phandle = (int)child_process;
+ *phandle = (C_word)child_process;
*pstdin_fd = io_fds[0];
*pstdout_fd = io_fds[1];
*pstderr_fd = io_fds[2];
diff --git a/runtime.c b/runtime.c
index 48ec0e29..f4babdff 100644
--- a/runtime.c
+++ b/runtime.c
@@ -196,6 +196,12 @@ extern void _C_do_apply_hack(void *proc, C_word *args, int count) C_noret;
# define UWORD_COUNT_FORMAT_STRING "%u"
#endif
+#ifdef C_LLP
+# define LONG_FORMAT_STRING "%lldf"
+#else
+# define LONG_FORMAT_STRING "%ld"
+#endif
+
#define GC_MINOR 0
#define GC_MAJOR 1
#define GC_REALLOC 2
@@ -205,7 +211,7 @@ extern void _C_do_apply_hack(void *proc, C_word *args, int count) C_noret;
#define nmax(x, y) ((x) > (y) ? (x) : (y))
#define nmin(x, y) ((x) < (y) ? (x) : (y))
-#define percentage(n, p) ((long)(((double)(n) * (double)p) / 100))
+#define percentage(n, p) ((C_long)(((double)(n) * (double)p) / 100))
#define is_fptr(x) (((x) & C_GC_FORWARDING_BIT) != 0)
#define ptr_to_fptr(x) ((((x) >> FORWARDING_BIT_SHIFT) & 1) | C_GC_FORWARDING_BIT | ((x) & ~1))
@@ -260,6 +266,10 @@ extern void _C_do_apply_hack(void *proc, C_word *args, int count) C_noret;
#define C_pte(name) pt[ i ].id = #name; pt[ i++ ].ptr = (void *)name;
+#ifndef SIGBUS
+# define SIGBUS 0
+#endif
+
/* Type definitions: */
@@ -313,7 +323,7 @@ C_TLS C_word
*C_temporary_stack_bottom,
*C_temporary_stack_limit,
*C_stack_limit;
-C_TLS long
+C_TLS C_long
C_timer_interrupt_counter,
C_initial_timer_interrupt_period;
C_TLS C_byte
@@ -326,7 +336,7 @@ C_TLS int (*C_gc_mutation_hook)(C_word *slot, C_word val);
C_TLS void (*C_gc_trace_hook)(C_word *var, int mode);
C_TLS void (*C_panic_hook)(C_char *msg) = NULL;
C_TLS void (*C_pre_gc_hook)(int mode) = NULL;
-C_TLS void (*C_post_gc_hook)(int mode, long ms) = NULL;
+C_TLS void (*C_post_gc_hook)(int mode, C_long ms) = NULL;
C_TLS void (C_fcall *C_restart_trampoline)(void *proc) C_regparm C_noret;
C_TLS int
@@ -1366,7 +1376,7 @@ C_word arg_val(C_char *arg)
{
int len;
C_char *end;
- long val, mul = 1;
+ C_long val, mul = 1;
if (arg == NULL) panic(C_text("illegal runtime-option argument"));
@@ -1387,7 +1397,7 @@ C_word arg_val(C_char *arg)
default: mul = 1;
}
- val = strtol(arg, &end, 10);
+ val = C_strtow(arg, &end, 10);
if((mul != 1 ? end[ 1 ] != '\0' : end[ 0 ] != '\0'))
panic(C_text("invalid runtime-option argument suffix"));
@@ -1418,7 +1428,7 @@ C_word CHICKEN_run(void *toplevel)
stack_bottom = C_stack_pointer;
if(debug_mode)
- C_dbg(C_text("debug"), C_text("stack bottom is 0x%lx.\n"), (long)stack_bottom);
+ C_dbg(C_text("debug"), C_text("stack bottom is 0x%lx.\n"), (C_word)stack_bottom);
/* The point of (usually) no return... */
#ifdef HAVE_SIGSETJMP
@@ -1811,7 +1821,7 @@ C_regparm double C_fcall C_milliseconds(void)
}
-C_regparm time_t C_fcall C_seconds(long *ms)
+C_regparm time_t C_fcall C_seconds(C_long *ms)
{
#ifdef C_NONUNIX
if(ms != NULL) *ms = 0;
@@ -3064,7 +3074,7 @@ C_regparm void C_fcall C_reclaim(void *trampoline, void *proc)
if(gc_mode == GC_MAJOR) gc_count_1 = 0;
- if(C_post_gc_hook != NULL) C_post_gc_hook(gc_mode, (long)tgc);
+ if(C_post_gc_hook != NULL) C_post_gc_hook(gc_mode, (C_long)tgc);
/* Unwind stack completely */
#ifdef HAVE_SIGSETJMP
@@ -3279,10 +3289,10 @@ C_regparm void C_fcall C_rereclaim2(C_uword size, int double_plus)
if(gc_report_flag) {
C_dbg(C_text("GC"), C_text("(old) fromspace: \tstart=" UWORD_FORMAT_STRING
", \tlimit=" UWORD_FORMAT_STRING "\n"),
- (long)fromspace_start, (long)C_fromspace_limit);
+ (C_word)fromspace_start, (C_word)C_fromspace_limit);
C_dbg(C_text("GC"), C_text("(old) tospace: \tstart=" UWORD_FORMAT_STRING
", \tlimit=" UWORD_FORMAT_STRING "\n"),
- (long)tospace_start, (long)tospace_limit);
+ (C_word)tospace_start, (C_word)tospace_limit);
}
heap_size = size;
@@ -3397,10 +3407,10 @@ C_regparm void C_fcall C_rereclaim2(C_uword size, int double_plus)
C_dbg(C_text("GC"), C_text("resized heap to %d bytes\n"), heap_size);
C_dbg(C_text("GC"), C_text("(new) fromspace: \tstart=" UWORD_FORMAT_STRING
", \tlimit=" UWORD_FORMAT_STRING "\n"),
- (long)fromspace_start, (long)C_fromspace_limit);
+ (C_word)fromspace_start, (C_word)C_fromspace_limit);
C_dbg(C_text("GC"), C_text("(new) tospace: \tstart=" UWORD_FORMAT_STRING
", \tlimit=" UWORD_FORMAT_STRING "\n"),
- (long)tospace_start, (long)tospace_limit);
+ (C_word)tospace_start, (C_word)tospace_limit);
}
if(C_post_gc_hook != NULL) C_post_gc_hook(GC_REALLOC, 0);
@@ -4454,7 +4464,7 @@ C_regparm C_word C_fcall C_establish_signal_handler(C_word signum, C_word reason
C_regparm C_word C_fcall C_copy_block(C_word from, C_word to)
{
int n = C_header_size(from);
- long bytes;
+ C_long bytes;
if(C_header_bits(from) & C_BYTEBLOCK_BIT) {
bytes = n;
@@ -4472,7 +4482,7 @@ C_regparm C_word C_fcall C_copy_block(C_word from, C_word to)
C_regparm C_word C_fcall C_evict_block(C_word from, C_word ptr)
{
int n = C_header_size(from);
- long bytes;
+ C_long bytes;
C_word *p = (C_word *)C_pointer_address(ptr);
if(C_header_bits(from) & C_BYTEBLOCK_BIT) bytes = n;
@@ -7100,7 +7110,7 @@ void C_ccall C_gc(C_word c, C_word closure, C_word k, ...)
{
int f;
C_word arg;
- long size = 0;
+ C_long size = 0;
va_list v;
va_start(v, k);
@@ -7546,7 +7556,7 @@ static int from_n_nary(C_char *str, int base, double *r)
C_regparm C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word *fix, double *flo)
{
- unsigned long ln;
+ C_ulong ln;
C_word n;
C_char *eptr, *eptr2;
double fn;
@@ -7578,9 +7588,9 @@ C_regparm C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word
if(C_strpbrk(str, "xX\0") != NULL) return 0;
errno = 0;
- n = C_strtol(str, &eptr, radix);
+ n = C_strtow(str, &eptr, radix);
- if(((n == LONG_MAX || n == LONG_MIN) && errno == ERANGE) || *eptr != '\0') {
+ if(((n == C_LONG_MAX || n == C_LONG_MIN) && errno == ERANGE) || *eptr != '\0') {
if(radix != 10)
return from_n_nary(str, radix, flo) ? 2 : 0;
@@ -7659,9 +7669,9 @@ void C_ccall C_number_to_string(C_word c, C_word closure, C_word k, C_word num,
switch(radix) {
#ifdef C_SIXTY_FOUR
- case 8: C_sprintf(p = buffer + 1, C_text("%lo"), num); break;
- case 10: C_sprintf(p = buffer + 1, C_text("%ld"), num); break;
- case 16: C_sprintf(p = buffer + 1, C_text("%lx"), num); break;
+ case 8: C_sprintf(p = buffer + 1, C_text("%llo"), num); break;
+ case 10: C_sprintf(p = buffer + 1, C_text("%lld"), num); break;
+ case 16: C_sprintf(p = buffer + 1, C_text("%llx"), num); break;
#else
case 8: C_sprintf(p = buffer + 1, C_text("%o"), num); break;
case 10: C_sprintf(p = buffer + 1, C_text("%d"), num); break;
@@ -7748,8 +7758,9 @@ C_fixnum_to_string(C_word c, C_word self, C_word k, C_word num)
C_word *a, s;
int n;
+ /*XXX is this necessary? */
#ifdef C_SIXTY_FOUR
- C_sprintf(buffer, C_text("%ld"), C_unfix(num));
+ C_sprintf(buffer, C_text(LONG_FORMAT_STRING), C_unfix(num));
#else
C_sprintf(buffer, C_text("%d"), C_unfix(num));
#endif
@@ -8779,7 +8790,11 @@ C_regparm C_word C_fcall C_i_o_fixnum_times(C_word n1, C_word n2)
C_word x1, x2;
C_uword x1u, x2u;
#ifdef C_SIXTY_FOUR
+# ifdef C_LLP
+ C_uword c = 1ULL<<63ULL;
+# else
C_uword c = 1UL<<63UL;
+# endif
#else
C_uword c = 1UL<<31UL;
#endif
@@ -8804,7 +8819,7 @@ C_regparm C_word C_fcall C_i_o_fixnum_quotient(C_word n1, C_word n2)
{
C_word x1, x2;
#ifdef C_SIXTY_FOUR
- static long eight_0 = 0x8000000000000000L;
+ static C_long eight_0 = 0x8000000000000000L;
#else
static int eight_0 = 0x80000000;
#endif
@@ -8891,7 +8906,7 @@ static C_regparm C_uword C_fcall decode_size(C_char **str)
static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
C_word *dest)
{
- unsigned long bits = *((*str)++) & 0xff;
+ C_ulong bits = *((*str)++) & 0xff;
C_word *data, *dptr, val;
C_uword size;
@@ -9121,10 +9136,10 @@ C_dump_heap_state(C_word c, C_word closure, C_word k)
}
-static unsigned long
+static C_ulong
hdump_hash(C_word key)
{
- return (unsigned long)key % HDUMP_TABLE_SIZE;
+ return (C_ulong)key % HDUMP_TABLE_SIZE;
}
diff --git a/tcp.scm b/tcp.scm
index 238923ce..490ed8da 100644
--- a/tcp.scm
+++ b/tcp.scm
@@ -44,8 +44,12 @@
# define socklen_t int
static WSADATA wsa;
# define fcntl(a, b, c) 0
-# define EWOULDBLOCK 0
-# define EINPROGRESS 0
+# ifndef EWOULDBLOCK
+# define EWOULDBLOCK 0
+# endif
+# ifndef EINPROGRESS
+# define EINPROGRESS 0
+# endif
# define typecorrect_getsockopt(socket, level, optname, optval, optlen) \
getsockopt(socket, level, optname, (char *)optval, optlen)
#else
Trap