libc: adding memmove

[factor.git] / basis / libc / libc.factor

diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor
index 7a55b1547363f065d64a91048a5dbb776a154e6c..644f35954a846553fa9db57a509682ae9be521a8 100644 (file)
--- a/basis/libc/libc.factor
+++ b/basis/libc/libc.factor
@@ -1,33 +1,68 @@
 ! Copyright (C) 2004, 2005 Mackenzie Straight
-! Copyright (C) 2007, 2009 Slava Pestov
+! Copyright (C) 2007, 2010 Slava Pestov
 ! Copyright (C) 2007, 2008 Doug Coleman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien assocs continuations alien.destructors kernel
-namespaces accessors sets summary ;
+USING: accessors alien alien.c-types alien.destructors
+alien.syntax destructors destructors.private kernel math
+namespaces sequences sets summary system vocabs ;
 IN: libc
 
-: errno ( -- int )
-    "int" "factor" "err_no" { } alien-invoke ;
+HOOK: strerror os ( errno -- str )
+
+LIBRARY: factor
+
+FUNCTION-ALIAS: errno
+    int err_no ( )
+
+FUNCTION-ALIAS: set-errno
+    void set_err_no ( int err-no )
 
 : clear-errno ( -- )
-    "void" "factor" "clear_err_no" { } alien-invoke ;
+    0 set-errno ;
 
-<PRIVATE
+: preserve-errno ( quot -- )
+    errno [ call ] dip set-errno ; inline
+
+LIBRARY: libc
+
+FUNCTION-ALIAS: (malloc)
+    void* malloc ( size_t size )
+
+FUNCTION-ALIAS: (calloc)
+    void* calloc ( size_t count,  size_t size )
+
+FUNCTION-ALIAS: (free)
+    void free ( void* alien )
+
+FUNCTION-ALIAS: (realloc)
+    void* realloc ( void* alien, size_t size )
+
+FUNCTION-ALIAS: strerror_unsafe
+    char* strerror ( int errno )
+
+! Add a default strerror even though it's not threadsafe
+M: object strerror strerror_unsafe ;
+
+ERROR: libc-error errno message ;
 
-: (malloc) ( size -- alien )
-    "void*" "libc" "malloc" { "ulong" } alien-invoke ;
+: (throw-errno) ( errno -- * ) dup strerror libc-error ;
 
-: (calloc) ( count size -- alien )
-    "void*" "libc" "calloc" { "ulong" "ulong" } alien-invoke ;
+: throw-errno ( -- * ) errno (throw-errno) ;
 
-: (free) ( alien -- )
-    "void" "libc" "free" { "void*" } alien-invoke ;
+: io-error ( n -- ) 0 < [ throw-errno ] when ;
 
-: (realloc) ( alien size -- newalien )
-    "void*" "libc" "realloc" { "void*" "ulong" } alien-invoke ;
+<PRIVATE
+
+! We stick malloc-ptr instances in the global disposables set
+TUPLE: malloc-ptr value continuation ;
+
+M: malloc-ptr hashcode* value>> hashcode* ;
 
-: mallocs ( -- assoc )
-    \ mallocs [ H{ } clone ] initialize-alien ;
+M: malloc-ptr equal?
+    over malloc-ptr? [ [ value>> ] same? ] [ 2drop f ] if ;
+
+: <malloc-ptr> ( value -- malloc-ptr )
+    malloc-ptr new swap >>value ;
 
 PRIVATE>
 
@@ -39,11 +74,6 @@ M: bad-ptr summary
 : check-ptr ( c-ptr -- c-ptr )
     [ bad-ptr ] unless* ;
 
-ERROR: double-free ;
-
-M: double-free summary
-    drop "Free failed since memory is not allocated" ;
-
 ERROR: realloc-error ptr size ;
 
 M: realloc-error summary
@@ -52,16 +82,13 @@ M: realloc-error summary
 <PRIVATE
 
 : add-malloc ( alien -- alien )
-    dup mallocs conjoin ;
+    dup <malloc-ptr> register-disposable ;
 
 : delete-malloc ( alien -- )
-    [
-        mallocs delete-at*
-        [ drop ] [ double-free ] if
-    ] when* ;
+    [ <malloc-ptr> unregister-disposable ] when* ;
 
 : malloc-exists? ( alien -- ? )
-    mallocs key? ;
+    <malloc-ptr> disposables get in? ;
 
 PRIVATE>
 
@@ -80,10 +107,21 @@ PRIVATE>
 : free ( alien -- )
     >c-ptr [ delete-malloc ] [ (free) ] bi ;
 
-: memcpy ( dst src size -- )
-    "void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ;
+FUNCTION: void memset ( void* buf, int char, size_t size )
 
-: strlen ( alien -- len )
-    "size_t" "libc" "strlen" { "char*" } alien-invoke ;
+FUNCTION: void memcpy ( void* dst, void* src, ulong size )
+
+FUNCTION: void memmove ( void* dst, void* src, ulong size )
+
+FUNCTION: int memcmp ( void* a, void* b, ulong size )
+
+: memory= ( a b size -- ? ) memcmp 0 = ; inline
+
+FUNCTION: size_t strlen ( c-string alien )
+
+FUNCTION: int system ( c-string command )
 
 DESTRUCTOR: free
+
+! For libc.linux, libc.windows, libc.macosx...
+<< "libc." os name>> append require >>