alien tweaks
parent
8b842cc543
commit
b0b5f4f79d
|
@ -6,10 +6,6 @@ namespaces parser ;
|
|||
|
||||
UNION: c-ptr byte-array alien displaced-alien ;
|
||||
|
||||
: NULL ( -- null )
|
||||
#! C null value.
|
||||
0 <alien> ;
|
||||
|
||||
M: alien hashcode ( obj -- n )
|
||||
alien-address >fixnum ;
|
||||
|
||||
|
|
|
@ -140,7 +140,7 @@ GENERIC: task-container ( task -- vector )
|
|||
: init-fdsets ( -- read write except )
|
||||
read-fdset get [ read-tasks get init-fdset ] keep
|
||||
write-fdset get [ write-tasks get init-fdset ] keep
|
||||
NULL ;
|
||||
f ;
|
||||
|
||||
: io-multiplex ( timeout -- )
|
||||
>r FD_SETSIZE init-fdsets r> make-timeval select drop
|
||||
|
|
|
@ -23,7 +23,7 @@ END-STRUCT
|
|||
|
||||
: make-timeval ( ms -- timeval )
|
||||
dup -1 = [
|
||||
drop NULL
|
||||
drop f
|
||||
] [
|
||||
1000 /mod 1000 *
|
||||
<timeval>
|
||||
|
|
|
@ -70,8 +70,8 @@ CONSTANT: WAIT_TIMEOUT 258 ;
|
|||
|
||||
: win32-error-message ( id -- string )
|
||||
4096 <buffer> dup >r >r >r
|
||||
FORMAT_MESSAGE_FROM_SYSTEM NULL r>
|
||||
LANG_NEUTRAL SUBLANG_DEFAULT MAKELANGID r> buffer-ptr <alien> 4096 NULL
|
||||
FORMAT_MESSAGE_FROM_SYSTEM f r>
|
||||
LANG_NEUTRAL SUBLANG_DEFAULT MAKELANGID r> buffer-ptr <alien> 4096 f
|
||||
FormatMessage r> 2dup buffer-reset nip dup buffer-contents
|
||||
swap buffer-free ;
|
||||
|
||||
|
|
|
@ -47,7 +47,7 @@ GENERIC: expire
|
|||
GetLastError expected-error? [ drop f ] unless ;
|
||||
|
||||
: add-completion ( handle -- )
|
||||
completion-port get NULL 1 CreateIoCompletionPort drop ;
|
||||
completion-port get f 1 CreateIoCompletionPort drop ;
|
||||
|
||||
: get-access ( -- file-mode )
|
||||
"file-mode" get uncons
|
||||
|
@ -67,7 +67,7 @@ GENERIC: expire
|
|||
: win32-open-file ( file r w -- handle )
|
||||
[
|
||||
cons "file-mode" set
|
||||
get-access get-sharemode NULL get-create FILE_FLAG_OVERLAPPED NULL
|
||||
get-access get-sharemode f get-create FILE_FLAG_OVERLAPPED f
|
||||
CreateFile dup INVALID_HANDLE_VALUE = [ win32-throw-error ] when
|
||||
dup add-completion
|
||||
] with-scope ;
|
||||
|
@ -125,7 +125,7 @@ C: io-callback ( -- callback )
|
|||
rot [ queue-error ] unless ;
|
||||
|
||||
: win32-init-stdio ( -- )
|
||||
INVALID_HANDLE_VALUE NULL NULL 1 CreateIoCompletionPort
|
||||
INVALID_HANDLE_VALUE f f 1 CreateIoCompletionPort
|
||||
completion-port set
|
||||
<io-queue> io-queue set ;
|
||||
|
||||
|
|
|
@ -46,7 +46,7 @@ SYMBOL: socket
|
|||
] unless ;
|
||||
|
||||
: new-socket ( -- socket )
|
||||
AF_INET SOCK_STREAM 0 NULL NULL WSA_FLAG_OVERLAPPED WSASocket ;
|
||||
AF_INET SOCK_STREAM 0 f f WSA_FLAG_OVERLAPPED WSASocket ;
|
||||
|
||||
: setup-sockaddr ( port -- sockaddr )
|
||||
<sockaddr-in> swap
|
||||
|
@ -110,7 +110,7 @@ IN: io
|
|||
[
|
||||
stream get alloc-io-callback init-overlapped
|
||||
>r >r >r socket get r> r>
|
||||
buffer-ptr <alien> 0 32 32 NULL r> AcceptEx
|
||||
buffer-ptr <alien> 0 32 32 f r> AcceptEx
|
||||
[ handle-socket-error ] unless stop
|
||||
] callcc1 pending-error drop
|
||||
swap dup add-completion <win32-stream> <line-reader>
|
||||
|
|
|
@ -49,7 +49,7 @@ SYMBOL: cutoff
|
|||
0 over set-overlapped-ext-internal-high
|
||||
fileptr get dup 0 ? over set-overlapped-ext-offset
|
||||
0 over set-overlapped-ext-offset-high
|
||||
NULL over set-overlapped-ext-event ;
|
||||
f over set-overlapped-ext-event ;
|
||||
|
||||
: update-file-pointer ( whence -- )
|
||||
file-size get [ fileptr [ + ] change ] [ drop ] ifte ;
|
||||
|
@ -61,7 +61,7 @@ SYMBOL: cutoff
|
|||
update-timeout [
|
||||
stream get alloc-io-callback init-overlapped >r
|
||||
handle get out-buffer get [ buffer@ ] keep buffer-length
|
||||
NULL r> WriteFile [ handle-io-error ] unless stop
|
||||
f r> WriteFile [ handle-io-error ] unless stop
|
||||
] callcc1 pending-error
|
||||
|
||||
dup update-file-pointer
|
||||
|
@ -89,7 +89,7 @@ M: string do-write ( str -- )
|
|||
stream get alloc-io-callback init-overlapped >r
|
||||
handle get in-buffer get [ buffer@ ] keep
|
||||
buffer-capacity file-size get [ fileptr get - min ] when*
|
||||
NULL r>
|
||||
f r>
|
||||
ReadFile [ handle-io-error ] unless stop
|
||||
] callcc1 pending-error
|
||||
|
||||
|
@ -157,7 +157,7 @@ M: win32-stream expire ( stream -- )
|
|||
|
||||
C: win32-stream ( handle -- stream )
|
||||
swap [
|
||||
dup NULL GetFileSize dup -1 = not [
|
||||
dup f GetFileSize dup -1 = not [
|
||||
file-size set
|
||||
] [ drop f file-size set ] ifte
|
||||
handle set
|
||||
|
|
|
@ -13,7 +13,7 @@ void primitive_expired(void)
|
|||
drepl(F);
|
||||
}
|
||||
|
||||
INLINE void* alien_offset(CELL object)
|
||||
void* alien_offset(CELL object)
|
||||
{
|
||||
ALIEN *alien;
|
||||
F_ARRAY *array;
|
||||
|
@ -32,6 +32,8 @@ INLINE void* alien_offset(CELL object)
|
|||
case DISPLACED_ALIEN_TYPE:
|
||||
d = untag_displaced_alien_fast(object);
|
||||
return alien_offset(d->alien) + d->displacement;
|
||||
case F_TYPE:
|
||||
return NULL;
|
||||
default:
|
||||
type_error(ALIEN_TYPE,object);
|
||||
return (void*)-1; /* can't happen */
|
||||
|
|
|
@ -25,6 +25,8 @@ void primitive_alien(void);
|
|||
void primitive_displaced_alien(void);
|
||||
void primitive_alien_address(void);
|
||||
|
||||
void* alien_offset(CELL object);
|
||||
|
||||
void fixup_alien(ALIEN* alien);
|
||||
void fixup_displaced_alien(DISPLACED_ALIEN* d);
|
||||
void collect_displaced_alien(DISPLACED_ALIEN* d);
|
||||
|
|
|
@ -150,10 +150,13 @@ char *to_c_string_unchecked(F_STRING *s)
|
|||
}
|
||||
|
||||
/* FFI calls this */
|
||||
char *unbox_c_string(void)
|
||||
char* unbox_c_string(void)
|
||||
{
|
||||
CELL str = dpop();
|
||||
return (str ? to_c_string(untag_string(str)) : NULL);
|
||||
if(type_of(str) == STRING_TYPE)
|
||||
return to_c_string(untag_string(str));
|
||||
else
|
||||
return (char*)alien_offset(str);
|
||||
}
|
||||
|
||||
/* FFI calls this */
|
||||
|
|
Loading…
Reference in New Issue