Fix win32 for .74 release
Mackenzie Straight
parent
407554c185
commit
65fd70641f
|
|
@ -6,28 +6,28 @@ DEFAULT_LIBS = -lm
|
|||
|
||||
STRIP = strip
|
||||
|
||||
WIN32_OBJS = native\win32\ffi.o native\win32\file.o native\win32\io.o \
|
||||
native\win32\misc.o native\win32\read.o native\win32\write.o \
|
||||
WIN32_OBJS = native\win32\ffi.o native\win32\file.o \
|
||||
native\win32\misc.o \
|
||||
native\win32\run.o
|
||||
|
||||
OBJS = $(WIN32_OBJS) native/arithmetic.o native/array.o native/bignum.o \
|
||||
native/s48_bignum.o \
|
||||
native/complex.o native/cons.o native/error.o \
|
||||
native/factor.o native/fixnum.o \
|
||||
native/float.o native/gc.o \
|
||||
native/image.o native/memory.o \
|
||||
native/misc.o native/primitives.o \
|
||||
native/ratio.o native/relocate.o \
|
||||
native/run.o \
|
||||
native/sbuf.o native/stack.o \
|
||||
native/string.o native/types.o native/vector.o \
|
||||
native/word.o native/compiler.o \
|
||||
native/alien.o native/dll.o \
|
||||
native/boolean.o \
|
||||
native/debug.o \
|
||||
native/hashtable.o \
|
||||
native/icache.o \
|
||||
native/io.o
|
||||
OBJS = $(WIN32_OBJS) native\arithmetic.o native\array.o native\bignum.o \
|
||||
native\s48_bignum.o \
|
||||
native\complex.o native\cons.o native\error.o \
|
||||
native\factor.o native\fixnum.o \
|
||||
native\float.o native\gc.o \
|
||||
native\image.o native\memory.o \
|
||||
native\misc.o native\primitives.o \
|
||||
native\ratio.o native\relocate.o \
|
||||
native\run.o \
|
||||
native\sbuf.o native\stack.o \
|
||||
native\string.o native\types.o native\vector.o \
|
||||
native\word.o native\compiler.o \
|
||||
native\alien.o native\dll.o \
|
||||
native\boolean.o \
|
||||
native\debug.o \
|
||||
native\hashtable.o \
|
||||
native\icache.o \
|
||||
native\io.o
|
||||
|
||||
default:
|
||||
@echo "Run 'make' with one of the following parameters:"
|
||||
|
|
@ -55,3 +55,9 @@ clean:
|
|||
.c.o:
|
||||
$(CC) -c $(CFLAGS) -o $@ $<
|
||||
|
||||
.S.o:
|
||||
$(CC) -c $(CFLAGS) -o $@ $<
|
||||
|
||||
native\icache.o: native\icache.s
|
||||
$(CC) -c $(CFLAGS) -o $@ native\icache.S
|
||||
|
||||
|
|
|
|||
|
|
@ -142,7 +142,7 @@ END-STRUCT
|
|||
INVALID_HANDLE_VALUE NULL NULL 1 CreateIoCompletionPort
|
||||
completion-port set
|
||||
|
||||
<< null-stream f >> stdio set
|
||||
! << null-stream f >> stdio set
|
||||
|
||||
<namespace> [
|
||||
32 <vector> callbacks set
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ USING: alien errors generic kernel kernel-internals lists math namespaces
|
|||
win32-io-internals io-internals ;
|
||||
|
||||
TUPLE: win32-server this ;
|
||||
TUPLE: win32-client-stream host ;
|
||||
TUPLE: win32-client-stream host port ;
|
||||
SYMBOL: winsock
|
||||
SYMBOL: socket
|
||||
|
||||
|
|
@ -55,27 +55,28 @@ SYMBOL: socket
|
|||
AF_INET over set-sockaddr-in-family ;
|
||||
|
||||
: bind-socket ( port socket -- )
|
||||
swap setup-sockaddr "sockaddr-in" size wsa-bind 0 = [
|
||||
swap setup-sockaddr "sockaddr-in" c-size wsa-bind 0 = [
|
||||
handle-socket-error
|
||||
] unless ;
|
||||
|
||||
: listen-socket ( socket -- )
|
||||
20 wsa-listen 0 = [ handle-socket-error ] unless ;
|
||||
|
||||
: sockaddr>string ( sockaddr -- string )
|
||||
dup sockaddr-in-port ntohs swap sockaddr-in-addr inet-ntoa
|
||||
[ , ":" , unparse , ] make-string ;
|
||||
: sockaddr> ( sockaddr -- port host )
|
||||
dup sockaddr-in-port ntohs swap sockaddr-in-addr inet-ntoa ;
|
||||
|
||||
: extract-remote-host ( buffer -- host )
|
||||
: extract-remote-host ( buffer -- port host )
|
||||
buffer-ptr <alien> 0 32 32 <indirect-pointer> <indirect-pointer>
|
||||
<indirect-pointer> dup >r <indirect-pointer>
|
||||
GetAcceptExSockaddrs r> indirect-pointer-value <alien> sockaddr>string ;
|
||||
GetAcceptExSockaddrs r> indirect-pointer-value <alien> sockaddr> ;
|
||||
|
||||
C: win32-client-stream ( buf stream -- stream )
|
||||
[ set-delegate extract-remote-host ] keep
|
||||
[ set-win32-client-stream-host ] keep ;
|
||||
[ set-win32-client-stream-host ] keep
|
||||
[ set-win32-client-stream-port ] keep ;
|
||||
|
||||
M: win32-client-stream client-stream-host win32-client-stream-host ;
|
||||
M: win32-client-stream client-stream-port win32-client-stream-port ;
|
||||
|
||||
C: win32-server ( port -- server )
|
||||
swap <namespace> [
|
||||
|
|
@ -87,7 +88,8 @@ C: win32-server ( port -- server )
|
|||
M: win32-server stream-close ( server -- )
|
||||
win32-server-this [ socket get CloseHandle drop ] bind ;
|
||||
|
||||
M: win32-server accept ( server -- client )
|
||||
IN: streams
|
||||
: accept ( server -- client )
|
||||
win32-server-this [
|
||||
new-socket 64 <buffer>
|
||||
[
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ SYMBOL: file-size
|
|||
0 over set-overlapped-ext-internal-high
|
||||
fileptr get dup 0 ? over set-overlapped-ext-offset
|
||||
0 over set-overlapped-ext-offset-high
|
||||
0 over set-overlapped-ext-event ;
|
||||
NULL over set-overlapped-ext-event ;
|
||||
|
||||
: update-file-pointer ( whence -- )
|
||||
file-size get [ fileptr [ + ] change ] [ drop ] ifte ;
|
||||
|
|
@ -87,7 +87,7 @@ M: string do-write ( str -- )
|
|||
ReadFile [ handle-io-error ] unless stop
|
||||
] callcc1 pending-error
|
||||
|
||||
dup in-buffer get >buffer update-file-pointer ;
|
||||
dup in-buffer get n>buffer update-file-pointer ;
|
||||
|
||||
: consume-input ( count -- str )
|
||||
in-buffer get buffer-length 0 = [ fill-input ] when
|
||||
|
|
|
|||
|
|
@ -1,5 +1,9 @@
|
|||
#include "../factor.h"
|
||||
|
||||
void init_ffi (void)
|
||||
{
|
||||
}
|
||||
|
||||
void ffi_dlopen (DLL *dll)
|
||||
{
|
||||
HMODULE module;
|
||||
|
|
|
|||
|
|
@ -1,50 +1,5 @@
|
|||
#include "../factor.h"
|
||||
|
||||
void primitive_open_file(void)
|
||||
{
|
||||
bool write = unbox_boolean();
|
||||
bool read = unbox_boolean();
|
||||
char *path;
|
||||
DWORD mode = 0, create = 0;
|
||||
HANDLE fp;
|
||||
SECURITY_ATTRIBUTES sa;
|
||||
|
||||
path = unbox_c_string();
|
||||
|
||||
mode |= write ? GENERIC_WRITE : 0;
|
||||
mode |= read ? GENERIC_READ : 0;
|
||||
|
||||
if (read && write)
|
||||
create = OPEN_ALWAYS;
|
||||
else if (read)
|
||||
create = OPEN_EXISTING;
|
||||
else if (write)
|
||||
create = CREATE_ALWAYS;
|
||||
|
||||
sa.nLength = sizeof(SECURITY_ATTRIBUTES);
|
||||
sa.lpSecurityDescriptor = NULL;
|
||||
sa.bInheritHandle = true;
|
||||
|
||||
fp = CreateFile(
|
||||
path,
|
||||
mode,
|
||||
FILE_SHARE_DELETE|FILE_SHARE_READ|FILE_SHARE_WRITE,
|
||||
&sa,
|
||||
create,
|
||||
/* FILE_FLAG_OVERLAPPED TODO */0,
|
||||
NULL);
|
||||
|
||||
if (fp == INVALID_HANDLE_VALUE)
|
||||
{
|
||||
io_error(__FUNCTION__);
|
||||
}
|
||||
else
|
||||
{
|
||||
dpush(read ? tag_object(port(PORT_READ, (CELL)fp)) : F);
|
||||
dpush(write ? tag_object(port(PORT_WRITE, (CELL)fp)) : F);
|
||||
}
|
||||
}
|
||||
|
||||
void primitive_stat(void)
|
||||
{
|
||||
F_STRING *path;
|
||||
|
|
|
|||
|
|
@ -1,43 +0,0 @@
|
|||
#include "../factor.h"
|
||||
|
||||
HANDLE completion_port = INVALID_HANDLE_VALUE;
|
||||
CELL callback_list = F;
|
||||
|
||||
void init_io (void)
|
||||
{
|
||||
userenv[STDIN_ENV] = tag_object(port(PORT_READ, (CELL)GetStdHandle(STD_INPUT_HANDLE)));
|
||||
userenv[STDOUT_ENV] = tag_object(port(PORT_WRITE, (CELL)GetStdHandle(STD_OUTPUT_HANDLE)));
|
||||
}
|
||||
|
||||
void primitive_add_copy_io_task (void)
|
||||
{
|
||||
io_error(__FUNCTION__);
|
||||
}
|
||||
|
||||
void primitive_close (void)
|
||||
{
|
||||
F_PORT *port = untag_port(dpop());
|
||||
|
||||
CloseHandle((HANDLE)port->fd);
|
||||
port->closed = true;
|
||||
}
|
||||
|
||||
void primitive_next_io_task (void)
|
||||
{
|
||||
maybe_garbage_collection();
|
||||
|
||||
if (callback_list != F)
|
||||
{
|
||||
F_CONS *cons = untag_cons(callback_list);
|
||||
CELL car = cons->car;
|
||||
callback_list = cons->cdr;
|
||||
dpush(car);
|
||||
}
|
||||
else
|
||||
dpush(F);
|
||||
}
|
||||
|
||||
void collect_io_tasks (void)
|
||||
{
|
||||
copy_object(&callback_list);
|
||||
}
|
||||
|
|
@ -1,131 +0,0 @@
|
|||
#include "../factor.h"
|
||||
|
||||
void primitive_add_read_count_io_task (void)
|
||||
{
|
||||
callback_list = cons(dpop(), callback_list);
|
||||
dpop(); dpop();
|
||||
}
|
||||
|
||||
void primitive_add_read_line_io_task (void)
|
||||
{
|
||||
dpop(); dpop();
|
||||
}
|
||||
|
||||
void primitive_can_read_count (void)
|
||||
{
|
||||
dpop(); dpop();
|
||||
box_boolean(true);
|
||||
}
|
||||
|
||||
void primitive_can_read_line (void)
|
||||
{
|
||||
dpop();
|
||||
box_boolean(true);
|
||||
}
|
||||
|
||||
void primitive_read_count_8 (void)
|
||||
{
|
||||
F_PORT *port;
|
||||
F_FIXNUM len;
|
||||
DWORD out_len;
|
||||
char *buf;
|
||||
F_SBUF *result;
|
||||
unsigned int i;
|
||||
|
||||
maybe_garbage_collection();
|
||||
|
||||
port = untag_port(dpop());
|
||||
len = to_fixnum(dpop());
|
||||
buf = malloc(len);
|
||||
|
||||
if (!ReadFile((HANDLE)port->fd, buf, len, &out_len, NULL))
|
||||
io_error(__FUNCTION__);
|
||||
|
||||
result = sbuf(out_len);
|
||||
|
||||
for (i = 0; i < out_len; ++i)
|
||||
set_sbuf_nth(result, i, buf[i] & 0xFF);
|
||||
|
||||
free(buf);
|
||||
dpush(tag_object(result));
|
||||
}
|
||||
|
||||
static void fill_buffer(F_PORT *port)
|
||||
{
|
||||
DWORD read_len;
|
||||
F_STRING *buffer = untag_string(port->buffer);
|
||||
|
||||
if (port->buf_pos)
|
||||
return;
|
||||
|
||||
if (!ReadFile((HANDLE)port->fd, buffer+1, BUF_SIZE, &read_len, NULL))
|
||||
io_error(__FUNCTION__);
|
||||
|
||||
port->buf_pos += read_len;
|
||||
}
|
||||
|
||||
static void unfill_buffer(F_PORT *port, int len)
|
||||
{
|
||||
F_STRING *buffer = untag_string(port->buffer);
|
||||
|
||||
memmove(buffer+1, ((char *)(buffer+1))+len, port->buf_pos - len);
|
||||
port->buf_pos -= len;
|
||||
}
|
||||
|
||||
#define GETBUF(n) (bget((CELL)buffer + sizeof(F_STRING) + (n)))
|
||||
|
||||
void primitive_read_line_8 (void)
|
||||
{
|
||||
F_PORT *port;
|
||||
F_SBUF *result;
|
||||
F_STRING *buffer;
|
||||
int i;
|
||||
bool got_line = false;
|
||||
|
||||
maybe_garbage_collection();
|
||||
|
||||
port = untag_port(dpop());
|
||||
buffer = untag_string(port->buffer);
|
||||
result = sbuf(LINE_SIZE);
|
||||
|
||||
while (!got_line)
|
||||
{
|
||||
fill_buffer(port);
|
||||
|
||||
for (i = 0; i < port->buf_pos; ++i)
|
||||
{
|
||||
BYTE ch = GETBUF(i);
|
||||
|
||||
if (ch == '\r')
|
||||
{
|
||||
got_line = true;
|
||||
if (i < port->buf_pos - 1 && GETBUF(i+1) == '\n')
|
||||
++i;
|
||||
++i;
|
||||
break;
|
||||
}
|
||||
else if (ch == '\n')
|
||||
{
|
||||
got_line = true;
|
||||
if (i < port->buf_pos - 1 && GETBUF(i+1) == '\r')
|
||||
++i;
|
||||
++i;
|
||||
break;
|
||||
}
|
||||
|
||||
set_sbuf_nth(result, result->top, ch);
|
||||
}
|
||||
|
||||
if (i == 0)
|
||||
got_line = true;
|
||||
else
|
||||
unfill_buffer(port, i);
|
||||
}
|
||||
|
||||
if (result->top || i)
|
||||
dpush(tag_object(result));
|
||||
else
|
||||
dpush(F);
|
||||
}
|
||||
|
||||
#undef GETBUF
|
||||
|
|
@ -1,55 +0,0 @@
|
|||
#include "../factor.h"
|
||||
|
||||
void primitive_add_write_io_task (void)
|
||||
{
|
||||
maybe_garbage_collection();
|
||||
|
||||
callback_list = cons(dpop(), callback_list);
|
||||
dpop();
|
||||
}
|
||||
|
||||
void primitive_can_write (void)
|
||||
{
|
||||
dpop(); dpop();
|
||||
box_boolean(true);
|
||||
}
|
||||
|
||||
void write_char_8 (F_PORT *port, F_FIXNUM ch)
|
||||
{
|
||||
DWORD ignore;
|
||||
BYTE buf = (BYTE)ch;
|
||||
WriteFile((HANDLE)port->fd, &buf, 1, &ignore, NULL);
|
||||
}
|
||||
|
||||
void write_string_8 (F_PORT *port, F_STRING *str)
|
||||
{
|
||||
DWORD ignore;
|
||||
WriteFile((HANDLE)port->fd, to_c_string_unchecked(str),
|
||||
string_capacity(str), &ignore, NULL);
|
||||
}
|
||||
|
||||
void primitive_write_8 (void)
|
||||
{
|
||||
F_PORT *port;
|
||||
CELL text, type;
|
||||
|
||||
maybe_garbage_collection();
|
||||
|
||||
port = untag_port(dpop());
|
||||
text = dpop();
|
||||
type = type_of(text);
|
||||
|
||||
switch (type)
|
||||
{
|
||||
case FIXNUM_TYPE:
|
||||
case BIGNUM_TYPE:
|
||||
write_char_8(port, to_fixnum(text));
|
||||
break;
|
||||
case STRING_TYPE:
|
||||
write_string_8(port, untag_string(text));
|
||||
break;
|
||||
default:
|
||||
type_error(STRING_TYPE, text);
|
||||
break;
|
||||
}
|
||||
}
|
||||
Loading…
Reference in New Issue