More Win32 IO work; FFI updates

library/io/buffer.factor

@@ -25,7 +25,7 @@
 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
-IN: buffer
+IN: kernel-internals
 
 USE: alien
 USE: errors
@@ -36,49 +36,76 @@ USE: namespaces
 USE: strings
 USE: win32-api
 
+SYMBOL: buf-size
+SYMBOL: buf-ptr
+SYMBOL: buf-fill
+SYMBOL: buf-pos
+
 : imalloc ( size -- address )
     "int" "libc" "malloc" [ "int" ] alien-invoke ;
 
 : ifree ( address -- )
     "void" "libc" "free" [ "int" ] alien-invoke ;
 
+: irealloc ( address size -- address )
+    "int" "libc" "realloc" [ "int" "int" ] alien-invoke ;
+
 : <buffer> ( size -- buffer )
     #! Allocates and returns a new buffer.
     <namespace> [
-        dup "size" set
+        dup buf-size set
-        imalloc "buffer" set
+        imalloc buf-ptr set
-        0 "fill" set
+        0 buf-fill set
-        0 "pos" set
+        0 buf-pos set
     ] extend ;
 
 : buffer-free ( buffer -- )
     #! Frees the C memory associated with the buffer.
-    [ "buffer" get ifree ] bind ;
+    [ buf-ptr get ifree ] bind ;
 
 : buffer-contents ( buffer -- string )
     #! Returns the current contents of the buffer.
     [
-        "buffer" get "pos" get + 
+        buf-ptr get buf-pos get + 
-        "fill" get "pos" get - 
+        buf-fill get buf-pos get - 
         memory>string 
     ] bind ;
 
+: buffer-first-n ( count buffer -- string )
+    [
+        buf-fill get buf-pos get - min
+        buf-ptr get buf-pos get +
+        swap memory>string
+    ] bind ;
+
 : buffer-reset ( count buffer -- )
     #! Reset the position to 0 and the fill pointer to count.
-    [ 0 "pos" set "fill" set ] bind ;
+    [ 0 buf-pos set buf-fill set ] bind ;
 
 : buffer-consume ( count buffer -- )
     #! Consume count characters from the beginning of the buffer.
-    [ "pos" [ + "fill" get min ] change ] bind ;
+    [
+        buf-pos [ + buf-fill get min ] change 
+        buf-pos get buf-fill get = [ 
+            0 buf-pos set 0 buf-fill set 
+        ] when
+    ] bind ;
 
 : buffer-length ( buffer -- length )
     #! Returns the amount of unconsumed input in the buffer.
-    [ "fill" get "pos" get - max ] bind ;
+    [ buf-fill get buf-pos get - 0 max ] bind ;
+
+: buffer-size ( buffer -- size )
+    [ buf-size get ] bind ;
+
+: buffer-capacity ( buffer -- int )
+    #! Returns the amount of data that may be added to the buffer.
+    [ buf-size get buf-fill get - ] bind ;
 
 : buffer-set ( string buffer -- )
     #! Set the contents of a buffer to string.
     [ 
-        dup "buffer" get string>memory
+        dup buf-ptr get string>memory
         str-length namespace buffer-reset
     ] bind ;
 
@@ -86,19 +113,27 @@ USE: win32-api
     #! Appends a string to the end of the buffer. If it doesn't fit,
     #! an error is thrown.
     [ 
-        dup "size" get "fill" get - swap str-length < [
+        dup buf-size get buf-fill get - swap str-length < [
             "Buffer overflow" throw
         ] when
-        dup "buffer" get "fill" get + string>memory
+        dup buf-ptr get buf-fill get + string>memory
-        "fill" [ swap str-length + ] change
+        buf-fill [ swap str-length + ] change
     ] bind ;
 
-: buffer-fill ( buffer quot -- )
+: buffer-extend ( length buffer -- )
-    #! Execute quot with buffer as its argument, passing its result to
+    #! Increases the size of the buffer by length.
-    #! buffer-reset.
+    [
-    swap dup >r swap call r> buffer-reset ; inline
+        buf-size get + dup buf-ptr get swap irealloc 
+        buf-ptr set buf-size set
+    ] bind ;
+
+: buffer-fill ( count buffer -- )
+    #! Increases the fill pointer by count.
+    [ buf-fill [ + ] change ] bind ;
 
 : buffer-ptr ( buffer -- pointer )
     #! Returns the memory address of the buffer area.
-    [ "buffer" get ] bind ;
+    [ buf-ptr get ] bind ;
 
+: buffer-pos ( buffer -- int )
+    [ buf-ptr get buf-pos get + ] bind ;

library/io/win32-console.factor

@@ -84,3 +84,5 @@ M: win32-console-stream fwrite-attr ( string style stream -- )
 C: win32-console-stream ( stream -- stream )
     [ delegate set -11 GetStdHandle handle set ] extend ;
 
+global [ [ <win32-console-stream> ] smart-term-hook set ] bind
+

library/io/win32-io-internals.factor

@@ -27,20 +27,42 @@
 
 IN: win32-io-internals
 USE: alien
+USE: errors
 USE: kernel
+USE: kernel-internals
 USE: lists
 USE: math
 USE: namespaces
+USE: prettyprint
+USE: vectors
 USE: win32-api
 
+SYMBOL: completion-port
+SYMBOL: io-queue
+SYMBOL: free-list
+SYMBOL: callbacks
+
+: handle-io-error ( -- )
+    #! If a write or read call fails unexpectedly, throw an error.
+    GetLastError [ 
+        ERROR_IO_PENDING ERROR_HANDLE_EOF ERROR_SUCCESS 
+    ] contains? [ 
+        win32-throw-error 
+    ] unless ;
+
 : win32-init-stdio ( -- )
     INVALID_HANDLE_VALUE NULL NULL 1 CreateIoCompletionPort
-    "completion-port" set ;
+    completion-port set 
+    
+    <namespace> [
+        32 <vector> callbacks set
+        f free-list set
+    ] extend io-queue set ;
 
 : get-access ( -- file-mode )
-    0 "file-mode" get uncons >r 
+    "file-mode" get uncons 
-    [ GENERIC_WRITE ] [ 0 ] ifte bitor r>
+    [ GENERIC_WRITE ] [ 0 ] ifte >r
-    [ GENERIC_READ ] [ 0 ] ifte bitor ;
+    [ GENERIC_READ ] [ 0 ] ifte r> bitor ;
 
 : get-sharemode ( -- share-mode )
     FILE_SHARE_READ FILE_SHARE_WRITE bitor FILE_SHARE_DELETE bitor ;
@@ -57,6 +79,53 @@ USE: win32-api
         cons "file-mode" set
         get-access get-sharemode NULL get-create FILE_FLAG_OVERLAPPED NULL 
         CreateFile dup INVALID_HANDLE_VALUE = [ win32-throw-error ] when
-        dup "completion-port" get NULL 1 CreateIoCompletionPort drop
+        dup completion-port get NULL 1 CreateIoCompletionPort drop
     ] with-scope ;
 
+BEGIN-STRUCT: indirect-pointer
+    FIELD: int value
+END-STRUCT
+
+: num-callbacks ( -- len )
+    #! Returns the length of the callback vector.
+    io-queue get [ callbacks get vector-length ] bind ;
+
+: set-callback-quot ( quot index -- )
+    io-queue get [
+        dup >r callbacks get vector-nth car swap cons
+        r> callbacks get set-vector-nth
+    ] bind ;
+
+: new-overlapped ( -- index )
+    #! Allocates and returns a new entry for the io queue.
+    #! The new index in the callback vector is returned.
+    io-queue get [
+        "overlapped-ext" c-type [ "width" get ] bind imalloc <alien>
+        dup num-callbacks swap
+        set-overlapped-ext-user-data
+        unit num-callbacks dup >r callbacks get set-vector-nth r>
+    ] bind ;
+
+: alloc-io-task ( quot -- overlapped )
+    io-queue get [
+        free-list get [
+            uncons free-list set
+        ] [ new-overlapped ] ifte*
+        [ set-callback-quot ] keep 
+        callbacks get vector-nth car
+    ] bind ;
+
+: get-io-callback ( index -- callback )
+    #! Returns and frees the io queue entry at index.
+    io-queue get [
+        dup free-list [ cons ] change
+        callbacks get vector-nth cdr
+    ] bind ;
+
+: win32-next-io-task ( -- quot )
+    completion-port get <indirect-pointer> dup >r <indirect-pointer> 
+    <indirect-pointer> dup >r INFINITE GetQueuedCompletionStatus
+    [ handle-io-error ] unless
+    r> r> indirect-pointer-value swap indirect-pointer-value <alien> 
+    overlapped-ext-user-data get-io-callback call ;
+

library/io/win32-stream.factor

@@ -27,38 +27,122 @@
 
 IN: win32-stream
 USE: alien
-USE: buffer
+USE: continuations
 USE: generic
 USE: kernel
+USE: kernel-internals
 USE: lists
 USE: math
 USE: namespaces
+USE: prettyprint
 USE: stdio
 USE: streams
+USE: strings
+USE: threads
 USE: win32-api
 USE: win32-io-internals
 
 TRAITS: win32-stream
-GENERIC: update-file-pointer
+
+SYMBOL: handle
+SYMBOL: in-buffer
+SYMBOL: out-buffer
+SYMBOL: fileptr
+SYMBOL: file-size
+
+: init-overlapped ( overlapped -- overlapped )
+    0 over set-overlapped-ext-internal
+    0 over set-overlapped-ext-internal-high
+    fileptr get over set-overlapped-ext-offset
+    0 over set-overlapped-ext-offset-high
+    0 over set-overlapped-ext-event ;
+
+: update-file-pointer ( whence -- )
+    file-size get [ fileptr [ + ] change ] when ;
+
+: flush-output ( -- ) 
+    [
+        alloc-io-task init-overlapped >r
+        handle get out-buffer get [ buffer-pos ] keep buffer-length
+        NULL r> WriteFile [ handle-io-error ] unless win32-next-io-task
+    ] callcc1
+
+    dup out-buffer get [ buffer-consume ] keep 
+    swap namespace update-file-pointer
+    buffer-length 0 > [ flush-output ] when ;
+
+: do-write ( str -- )
+    dup str-length out-buffer get buffer-capacity <= [
+        out-buffer get buffer-append
+    ] [
+        dup str-length out-buffer get buffer-size > [
+            dup str-length out-buffer get buffer-extend do-write
+        ] [ flush-output do-write ] ifte
+    ] ifte ;
+
+: fill-input ( -- ) 
+    [
+        alloc-io-task init-overlapped >r
+        handle get in-buffer get [ buffer-pos ] keep 
+        buffer-capacity file-size get [ fileptr get - min ] when*
+        NULL r>
+        ReadFile [ handle-io-error ] unless win32-next-io-task
+    ] callcc1
+
+    dup in-buffer get buffer-fill
+    namespace update-file-pointer ;
+
+: consume-input ( count -- str ) 
+    in-buffer get buffer-length 0 = [ fill-input ] when
+    in-buffer get buffer-size min
+    dup in-buffer get buffer-first-n
+    swap in-buffer get buffer-consume ;
+
+: do-read-count ( sbuf count -- str )
+    dup 0 = [ 
+        drop sbuf>str 
+    ] [
+        dup consume-input
+        dup str-length dup 0 = [
+            3drop dup sbuf-length 0 > [ sbuf>str ] [ drop f ] ifte
+        ] [
+            >r swap r> - >r swap [ sbuf-append ] keep r> do-read-count
+        ] ifte
+    ] ifte ;
 
 M: win32-stream fwrite-attr ( str style stream -- )
-    nip fwrite ;
+    nip [ do-write ] bind ;
 
 M: win32-stream freadln ( stream -- str )
     drop f ;
 
 M: win32-stream fread# ( count stream -- str )
-    drop f ;
+    [ dup <sbuf> swap do-read-count ] bind ;
 
 M: win32-stream fflush ( stream -- )
-    drop ;
+    [ flush-output ] bind ;
 
 M: win32-stream fclose ( stream -- )
-    [ "handle" get CloseHandle drop "buffer" get buffer-free ] bind ;
+    [
+        flush-output
+        handle get CloseHandle drop 
+        in-buffer get buffer-free 
+        out-buffer get buffer-free
+    ] bind ;
 
 C: win32-stream ( handle -- stream )
-    [ "handle" set 4096 <buffer> "buffer" set 0 "fp" set ] extend ;
+    [
+        dup NULL GetFileSize dup INVALID_FILE_SIZE = not [
+            file-size set
+        ] [ drop f file-size set ] ifte
+        handle set 
+        4096 <buffer> in-buffer set 
+        4096 <buffer> out-buffer set
+        0 fileptr set 
+    ] extend ;
 
 : <win32-filecr> ( path -- stream )
     t f win32-open-file <win32-stream> ;
 
+: <win32-filecw> ( path -- stream )
+    f t win32-open-file <win32-stream> ;

library/win32/win32-errors.factor

@@ -29,8 +29,20 @@ IN: win32-api
 USE: buffer
 USE: errors
 USE: kernel
+USE: kernel-internals
+USE: lists
 USE: math
+USE: parser
 USE: alien
+USE: words
+
+: CONSTANT: CREATE 
+    [ [ [ parsed ] each ] cons define-compound POSTPONE: parsing ] 
+    [ ] ; parsing
+
+CONSTANT: ERROR_SUCCESS 0 ;
+CONSTANT: ERROR_HANDLE_EOF 38 ;
+CONSTANT: ERROR_IO_PENDING 997 ;
 
 : FORMAT_MESSAGE_ALLOCATE_BUFFER HEX: 00000100 ;
 : FORMAT_MESSAGE_IGNORE_INSERTS  HEX: 00000200 ;

library/win32/win32-io.factor

@@ -70,10 +70,16 @@ END-STRUCT
 : STD_ERROR_HANDLE  -12 ;
 
 : INVALID_HANDLE_VALUE -1 <alien> ;
+: INVALID_FILE_SIZE HEX: FFFFFFFF ;
+
+: INFINITE HEX: FFFFFFFF ;
 
 : GetStdHandle ( id -- handle )
     "void*" "kernel32" "GetStdHandle" [ "int" ] alien-invoke ; 
 
+: GetFileSize ( handle out -- int )
+    "int" "kernel32" "GetFileSize" [ "void*" "void*" ] alien-invoke ; 
+
 : SetConsoleTextAttribute ( handle attrs -- ? )
     "bool" "kernel32" "SetConsoleTextAttribute" [ "void*" "int" ] 
     alien-invoke ;
@@ -99,6 +105,12 @@ END-STRUCT
     [ "void*" "void*" "void*" "int" ]
     alien-invoke ;
 
+: GetQueuedCompletionStatus 
+    ( port out-len out-key out-overlapped timeout -- ? )
+    "bool" "kernel32" "GetQueuedCompletionStatus"
+    [ "void*" "void*" "void*" "void*" "int" ]
+    alien-invoke ;
+
 : CreateFile ( name access sharemode security create flags template -- handle )
     "void*" "kernel32" "CreateFileA"
     [ "char*" "int" "int" "void*" "int" "int" "void*" ]

native/ffi.c

@@ -1,5 +1,35 @@
 #include "factor.h"
 
+void primitive_dlopen(void)
+{
+	maybe_garbage_collection();
+	dpush(tag_object(ffi_dlopen(untag_string(dpop()))));
+}
+
+void primitive_dlsym(void)
+{
+	DLL *dll;	
+	F_STRING *sym;
+
+	maybe_garbage_collection();
+
+	dll = untag_dll(dpop());
+	sym = untag_string(dpop());
+	dpush(tag_cell(ffi_dlsym(dll, sym)));
+}
+
+void primitive_dlclose(void)
+{
+	maybe_garbage_collection();
+	ffi_dlclose(untag_dll(dpop()));
+}
+
+void primitive_dlsym_self(void)
+{
+	maybe_garbage_collection();
+	dpush(tag_cell(ffi_dlsym(NULL, untag_string(dpop()))));
+}
+
 DLL* untag_dll(CELL tagged)
 {
 	DLL* dll = (DLL*)UNTAG(tagged);

native/ffi.h

@@ -18,6 +18,10 @@ INLINE ALIEN* untag_alien(CELL tagged)
 	return (ALIEN*)UNTAG(tagged);
 }
 
+DLL *ffi_dlopen(F_STRING *path);
+void *ffi_dlsym(DLL *dll, F_STRING *symbol);
+void ffi_dlclose(DLL *dll);
+
 void primitive_dlopen(void);
 void primitive_dlsym(void);
 void primitive_dlsym_self(void);

native/relocate.c

@@ -106,8 +106,7 @@ void relocate_primitive(F_REL* rel, bool relative)
 void relocate_dlsym(F_REL* rel, bool relative)
 {
 	F_STRING* str = untag_string(get(rel->argument));
-	char* c_str = to_c_string(str);
+	put(rel->offset,(CELL)ffi_dlsym(NULL,str)
-	put(rel->offset,(CELL)dlsym(NULL,c_str)
 		- (relative ? rel->offset + CELLS : 0));
 }
 

native/unix/ffi.c

@@ -1,16 +1,12 @@
 #include "../factor.h"
 
-void primitive_dlopen(void)
+DLL *ffi_dlopen(F_STRING *path)
 {
 #ifdef FFI
-	char* path;
 	void* dllptr;
 	DLL* dll;
 	
-	maybe_garbage_collection();
+	dllptr = dlopen(to_c_string(path), RTLD_LAZY);
-	
-	path = unbox_c_string();
-	dllptr = dlopen(path,RTLD_LAZY);
 
 	if(dllptr == NULL)
 	{
@@ -20,47 +16,31 @@ void primitive_dlopen(void)
 
 	dll = allot_object(DLL_TYPE,sizeof(DLL));
 	dll->dll = dllptr;
-	dpush(tag_object(dll));
+	return dll;
 #else
 	general_error(ERROR_FFI_DISABLED,F);
 #endif
 }
 
-void primitive_dlsym(void)
+void *ffi_dlsym(DLL *dll, F_STRING *symbol)
 {
 #ifdef FFI
-	DLL* dll = untag_dll(dpop());
+	void* sym = dlsym(dll ? dll->dll : NULL, to_c_string(symbol));
-	void* sym = dlsym(dll->dll,unbox_c_string());
 	if(sym == NULL)
 	{
 		general_error(ERROR_FFI,tag_object(
 			from_c_string(dlerror())));
 	}
-	dpush(tag_cell((CELL)sym));
+	return sym;
 #else
 	general_error(ERROR_FFI_DISABLED,F);
 #endif
 }
 
-void primitive_dlsym_self(void)
-{
-#if defined(FFI)
-	void* sym = dlsym(NULL,unbox_c_string());
-	if(sym == NULL)
-	{
-		general_error(ERROR_FFI,tag_object(
-			from_c_string(dlerror())));
-	}
-	dpush(tag_cell((CELL)sym));
-#else
-	general_error(ERROR_FFI_DISABLED,F);
-#endif
-}
 
-void primitive_dlclose(void)
+void ffi_dlclose(DLL *dll)
 {
 #ifdef FFI
-	DLL* dll = untag_dll(dpop());
 	if(dlclose(dll->dll) == -1)
 	{
 		general_error(ERROR_FFI,tag_object(

native/win32/ffi.c

@@ -1,66 +1,46 @@
 #include "../factor.h"
 
-void primitive_dlopen (void)
+DLL *ffi_dlopen (F_STRING *path)
 {
 #ifdef FFI
-	char *path;
 	HMODULE module;
 	DLL *dll;
 
-	maybe_garbage_collection();
+	module = LoadLibrary(to_c_string(path));
-
-	path = unbox_c_string();
-	module = LoadLibrary(path);
 
 	if (!module)
 		general_error(ERROR_FFI, tag_object(last_error()));
 
 	dll = allot_object(DLL_TYPE, sizeof(DLL));
 	dll->dll = module;
-	dpush(tag_object(dll));
+
+	return dll;
 #else
 	general_error(ERROR_FFI_DISABLED, F);
 #endif
 }
 
-void primitive_dlsym (void)
+void *ffi_dlsym (DLL *dll, F_STRING *symbol)
 {
 #ifdef FFI
-	DLL *dll = untag_dll(dpop());
+	void *sym = GetProcAddress(dll ? (HMODULE)dll->dll : GetModuleHandle(NULL),
-	void *sym = GetProcAddress((HMODULE)dll->dll, unbox_c_string());
+		to_c_string(symbol));
-
 
 	if (!sym)
 		general_error(ERROR_FFI, tag_object(last_error()));
 
-	dpush(tag_cell((CELL)sym));
+	return sym;
 #else
 	general_error(ERROR_FFI_DISABLED, F);
 #endif
 }
 
-void primitive_dlclose (void)
+void ffi_dlclose (DLL *dll)
 {
 #ifdef FFI
-	DLL *dll = untag_dll(dpop());
 	FreeLibrary((HMODULE)dll->dll);
 	dll->dll = NULL;
 #else
 	general_error(ERROR_FFI_DISABLED, F);
 #endif
-}
+}
-
-void primitive_dlsym_self (void)
-{
-#ifdef FFI
-	void *sym = GetProcAddress(GetModuleHandle(NULL), unbox_c_string());
-
-	if(sym == NULL)
-	{
-		general_error(ERROR_FFI, tag_object(last_error()));
-	}
-	dpush(tag_cell((CELL)sym));
-#else
-	general_error(ERROR_FFI_DISABLED, F);
-#endif
-}