1 ! Copyright (C) 2004, 2005 Mackenzie Straight
2 ! Copyright (C) 2007, 2009 Slava Pestov
3 ! Copyright (C) 2007, 2008 Doug Coleman
4 ! See http://factorcode.org/license.txt for BSD license.
5 USING: alien alien.c-types assocs continuations alien.destructors kernel
6 namespaces accessors sets summary destructors destructors.private ;
10 int "factor" "err_no" { } alien-invoke ;
12 : set-errno ( int -- )
13 void "factor" "set_err_no" { int } alien-invoke ;
18 : preserve-errno ( quot -- )
19 errno [ call ] dip set-errno ; inline
23 : (malloc) ( size -- alien )
24 void* "libc" "malloc" { ulong } alien-invoke ;
26 : (calloc) ( count size -- alien )
27 void* "libc" "calloc" { ulong ulong } alien-invoke ;
30 void "libc" "free" { void* } alien-invoke ;
32 : (realloc) ( alien size -- newalien )
33 void* "libc" "realloc" { void* ulong } alien-invoke ;
35 ! We stick malloc-ptr instances in the global disposables set
36 TUPLE: malloc-ptr value continuation ;
38 M: malloc-ptr hashcode* value>> hashcode* ;
41 over malloc-ptr? [ [ value>> ] bi@ = ] [ 2drop f ] if ;
43 : <malloc-ptr> ( value -- malloc-ptr )
44 malloc-ptr new swap >>value ;
51 drop "Memory allocation failed" ;
53 : check-ptr ( c-ptr -- c-ptr )
56 ERROR: realloc-error ptr size ;
58 M: realloc-error summary
59 drop "Memory reallocation failed" ;
63 : add-malloc ( alien -- alien )
64 dup <malloc-ptr> register-disposable ;
66 : delete-malloc ( alien -- )
67 [ <malloc-ptr> unregister-disposable ] when* ;
69 : malloc-exists? ( alien -- ? )
70 <malloc-ptr> disposables get key? ;
74 : malloc ( size -- alien )
75 (malloc) check-ptr add-malloc ;
77 : calloc ( count size -- alien )
78 (calloc) check-ptr add-malloc ;
80 : realloc ( alien size -- newalien )
82 over malloc-exists? [ realloc-error ] unless
83 [ drop ] [ (realloc) check-ptr ] 2bi
84 [ delete-malloc ] [ add-malloc ] bi* ;
87 >c-ptr [ delete-malloc ] [ (free) ] bi ;
89 : memcpy ( dst src size -- )
90 void "libc" "memcpy" { void* void* ulong } alien-invoke ;
92 : memcmp ( a b size -- cmp )
93 int "libc" "memcmp" { void* void* ulong } alien-invoke ;
95 : memory= ( a b size -- ? )
98 : strlen ( alien -- len )
99 size_t "libc" "strlen" { c-string } alien-invoke ;