! 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
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
- imalloc "buffer" set
- 0 "fill" set
- 0 "pos" set
+ dup buf-size set
+ imalloc buf-ptr set
+ 0 buf-fill 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 +
- "fill" get "pos" get -
+ buf-ptr get buf-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 ;
#! 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
- "fill" [ swap str-length + ] change
+ dup buf-ptr get buf-fill get + string>memory
+ buf-fill [ swap str-length + ] change
+ ] bind ;
+
+: buffer-extend ( length buffer -- )
+ #! Increases the size of the buffer by length.
+ [
+ buf-size get + dup buf-ptr get swap irealloc
+ buf-ptr set buf-size set
] bind ;
-: buffer-fill ( buffer quot -- )
- #! Execute quot with buffer as its argument, passing its result to
- #! buffer-reset.
- swap dup >r swap call r> buffer-reset ; inline
+: 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 ;
C: win32-console-stream ( stream -- stream )
[ delegate set -11 GetStdHandle handle set ] extend ;
+global [ [ <win32-console-stream> ] smart-term-hook set ] bind
+
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
- [ GENERIC_WRITE ] [ 0 ] ifte bitor r>
- [ GENERIC_READ ] [ 0 ] ifte bitor ;
+ "file-mode" get uncons
+ [ GENERIC_WRITE ] [ 0 ] ifte >r
+ [ GENERIC_READ ] [ 0 ] ifte r> bitor ;
: get-sharemode ( -- share-mode )
FILE_SHARE_READ FILE_SHARE_WRITE bitor FILE_SHARE_DELETE bitor ;
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 ;
+
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> ;
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 ;
: 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 ;
[ "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*" ]
#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);
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);
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)dlsym(NULL,c_str)
+ put(rel->offset,(CELL)ffi_dlsym(NULL,str)
- (relative ? rel->offset + CELLS : 0));
}
#include "../factor.h"
-void primitive_dlopen(void)
+DLL *ffi_dlopen(F_STRING *path)
{
#ifdef FFI
- char* path;
void* dllptr;
DLL* dll;
- maybe_garbage_collection();
-
- path = unbox_c_string();
- dllptr = dlopen(path,RTLD_LAZY);
+ dllptr = dlopen(to_c_string(path), RTLD_LAZY);
if(dllptr == NULL)
{
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,unbox_c_string());
+ void* sym = dlsym(dll ? dll->dll : NULL, to_c_string(symbol));
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(
#include "../factor.h"
-void primitive_dlopen (void)
+DLL *ffi_dlopen (F_STRING *path)
{
#ifdef FFI
- char *path;
HMODULE module;
DLL *dll;
- maybe_garbage_collection();
-
- path = unbox_c_string();
- module = LoadLibrary(path);
+ module = LoadLibrary(to_c_string(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((HMODULE)dll->dll, unbox_c_string());
-
+ void *sym = GetProcAddress(dll ? (HMODULE)dll->dll : GetModuleHandle(NULL),
+ 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
-}
+}
\ No newline at end of file
projects / factor.git / commitdiff