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