basis/libc/libc.factor

   1 ! Copyright (C) 2004, 2005 Mackenzie Straight
   2 ! Copyright (C) 2007, 2010 Slava Pestov
   3 ! Copyright (C) 2007, 2008 Doug Coleman
   4 ! See http://factorcode.org/license.txt for BSD license.
   5 USING: accessors alien alien.c-types alien.destructors
   6 alien.syntax destructors destructors.private kernel math
   7 namespaces sequences sets summary system vocabs ;
   8 IN: libc
   9
  10 HOOK: strerror os ( errno -- str )
  11
  12 LIBRARY: factor
  13
  14 FUNCTION-ALIAS: errno
  15     int err_no ( )
  16
  17 FUNCTION-ALIAS: set-errno
  18     void set_err_no ( int err-no )
  19
  20 : clear-errno ( -- )
  21     0 set-errno ;
  22
  23 : preserve-errno ( quot -- )
  24     errno [ call ] dip set-errno ; inline
  25
  26 LIBRARY: libc
  27
  28 FUNCTION-ALIAS: (malloc)
  29     void* malloc ( size_t size )
  30
  31 FUNCTION-ALIAS: (calloc)
  32     void* calloc ( size_t count,  size_t size )
  33
  34 FUNCTION-ALIAS: (free)
  35     void free ( void* alien )
  36
  37 FUNCTION-ALIAS: (realloc)
  38     void* realloc ( void* alien, size_t size )
  39
  40 FUNCTION-ALIAS: strerror_unsafe
  41     char* strerror ( int errno )
  42
  43 ! Add a default strerror even though it's not threadsafe
  44 M: object strerror strerror_unsafe ;
  45
  46 ERROR: libc-error errno message ;
  47
  48 : (throw-errno) ( errno -- * ) dup strerror libc-error ;
  49
  50 : throw-errno ( -- * ) errno (throw-errno) ;
  51
  52 : io-error ( n -- ) 0 < [ throw-errno ] when ;
  53
  54 <PRIVATE
  55
  56 ! We stick malloc-ptr instances in the global disposables set
  57 TUPLE: malloc-ptr value continuation ;
  58
  59 M: malloc-ptr hashcode* value>> hashcode* ;
  60
  61 M: malloc-ptr equal?
  62     over malloc-ptr? [ [ value>> ] same? ] [ 2drop f ] if ;
  63
  64 : <malloc-ptr> ( value -- malloc-ptr )
  65     malloc-ptr new swap >>value ;
  66
  67 PRIVATE>
  68
  69 ERROR: bad-ptr ;
  70
  71 M: bad-ptr summary
  72     drop "Memory allocation failed" ;
  73
  74 : check-ptr ( c-ptr -- c-ptr )
  75     [ bad-ptr ] unless* ;
  76
  77 ERROR: realloc-error ptr size ;
  78
  79 M: realloc-error summary
  80     drop "Memory reallocation failed" ;
  81
  82 <PRIVATE
  83
  84 : add-malloc ( alien -- alien )
  85     dup <malloc-ptr> register-disposable ;
  86
  87 : delete-malloc ( alien -- )
  88     [ <malloc-ptr> unregister-disposable ] when* ;
  89
  90 : malloc-exists? ( alien -- ? )
  91     <malloc-ptr> disposables get in? ;
  92
  93 PRIVATE>
  94
  95 : malloc ( size -- alien )
  96     (malloc) check-ptr add-malloc ;
  97
  98 : calloc ( count size -- alien )
  99     (calloc) check-ptr add-malloc ;
 100
 101 : realloc ( alien size -- newalien )
 102     [ >c-ptr ] dip
 103     over malloc-exists? [ realloc-error ] unless
 104     [ drop ] [ (realloc) check-ptr ] 2bi
 105     [ delete-malloc ] [ add-malloc ] bi* ;
 106
 107 : free ( alien -- )
 108     >c-ptr [ delete-malloc ] [ (free) ] bi ;
 109
 110 FUNCTION: void memset ( void* buf, int char, size_t size )
 111
 112 FUNCTION: void memcpy ( void* dst, void* src, ulong size )
 113
 114 FUNCTION: int memcmp ( void* a, void* b, ulong size )
 115
 116 : memory= ( a b size -- ? ) memcmp 0 = ; inline
 117
 118 FUNCTION: size_t strlen ( c-string alien )
 119
 120 FUNCTION: int system ( c-string command )
 121
 122 DESTRUCTOR: free
 123
 124 ! For libc.linux, libc.windows, libc.macosx...
 125 << "libc." os name>> append require >>