Fix win32 for .74 release

Makefile.win32

@@ -6,28 +6,28 @@ DEFAULT_LIBS = -lm
 
 STRIP = strip
 
-WIN32_OBJS = native\win32\ffi.o native\win32\file.o native\win32\io.o \
+WIN32_OBJS = native\win32\ffi.o native\win32\file.o \
-	native\win32\misc.o native\win32\read.o native\win32\write.o \
+	native\win32\misc.o \
 	native\win32\run.o
 
-OBJS = $(WIN32_OBJS) native/arithmetic.o native/array.o native/bignum.o \
+OBJS = $(WIN32_OBJS) native\arithmetic.o native\array.o native\bignum.o \
-	native/s48_bignum.o \
+	native\s48_bignum.o \
-	native/complex.o native/cons.o native/error.o \
+	native\complex.o native\cons.o native\error.o \
-	native/factor.o native/fixnum.o \
+	native\factor.o native\fixnum.o \
-	native/float.o native/gc.o \
+	native\float.o native\gc.o \
-	native/image.o native/memory.o \
+	native\image.o native\memory.o \
-	native/misc.o native/primitives.o \
+	native\misc.o native\primitives.o \
-	native/ratio.o native/relocate.o \
+	native\ratio.o native\relocate.o \
-	native/run.o \
+	native\run.o \
-	native/sbuf.o native/stack.o \
+	native\sbuf.o native\stack.o \
-	native/string.o native/types.o native/vector.o \
+	native\string.o native\types.o native\vector.o \
-	native/word.o native/compiler.o \
+	native\word.o native\compiler.o \
-	native/alien.o native/dll.o \
+	native\alien.o native\dll.o \
-	native/boolean.o \
+	native\boolean.o \
-	native/debug.o \
+	native\debug.o \
-	native/hashtable.o \
+	native\hashtable.o \
-	native/icache.o \
+	native\icache.o \
-	native/io.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
+

library/win32/win32-io-internals.factor

@@ -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

library/win32/win32-server.factor

@@ -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 )
+: sockaddr> ( sockaddr -- port host )
-    dup sockaddr-in-port ntohs swap sockaddr-in-addr inet-ntoa
+    dup sockaddr-in-port ntohs swap sockaddr-in-addr inet-ntoa ;
-    [ , ":" , unparse , ] make-string ;
 
-: 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>
         [

library/win32/win32-stream.factor

@@ -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

native/win32/ffi.c

@@ -1,5 +1,9 @@
 #include "../factor.h"
 
+void init_ffi (void)
+{
+}
+
 void ffi_dlopen (DLL *dll)
 {
 	HMODULE module;

native/win32/file.c

@@ -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;

native/win32/io.c

@@ -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);
-}

native/win32/read.c

@@ -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

native/win32/write.c

@@ -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;
-	}
-}