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: alien alien.c-types alien.syntax assocs continuations
   6 alien.destructors kernel namespaces accessors sets summary
   7 destructors destructors.private ;
   8 IN: libc
   9
  10 LIBRARY: factor
  11
  12 FUNCTION-ALIAS: errno
  13     int err_no ( ) ;
  14
  15 FUNCTION-ALIAS: set-errno
  16     void set_err_no ( int err-no ) ;
  17
  18 : clear-errno ( -- )
  19     0 set-errno ;
  20
  21 : preserve-errno ( quot -- )
  22     errno [ call ] dip set-errno ; inline
  23
  24 LIBRARY: libc
  25
  26 FUNCTION-ALIAS: (malloc)
  27     void* malloc ( size_t size ) ;
  28
  29 FUNCTION-ALIAS: (calloc)
  30     void* calloc ( size_t count,  size_t size ) ;
  31
  32 FUNCTION-ALIAS: (free)
  33     void free ( void* alien ) ;
  34
  35 FUNCTION-ALIAS: (realloc)
  36     void* realloc ( void* alien, size_t size ) ;
  37
  38 <PRIVATE
  39
  40 ! We stick malloc-ptr instances in the global disposables set
  41 TUPLE: malloc-ptr value continuation ;
  42
  43 M: malloc-ptr hashcode* value>> hashcode* ;
  44
  45 M: malloc-ptr equal?
  46     over malloc-ptr? [ [ value>> ] bi@ = ] [ 2drop f ] if ;
  47
  48 : <malloc-ptr> ( value -- malloc-ptr )
  49     malloc-ptr new swap >>value ;
  50
  51 PRIVATE>
  52
  53 ERROR: bad-ptr ;
  54
  55 M: bad-ptr summary
  56     drop "Memory allocation failed" ;
  57
  58 : check-ptr ( c-ptr -- c-ptr )
  59     [ bad-ptr ] unless* ;
  60
  61 ERROR: realloc-error ptr size ;
  62
  63 M: realloc-error summary
  64     drop "Memory reallocation failed" ;
  65
  66 <PRIVATE
  67
  68 : add-malloc ( alien -- alien )
  69     dup <malloc-ptr> register-disposable ;
  70
  71 : delete-malloc ( alien -- )
  72     [ <malloc-ptr> unregister-disposable ] when* ;
  73
  74 : malloc-exists? ( alien -- ? )
  75     <malloc-ptr> disposables get key? ;
  76
  77 PRIVATE>
  78
  79 : malloc ( size -- alien )
  80     (malloc) check-ptr add-malloc ;
  81
  82 : calloc ( count size -- alien )
  83     (calloc) check-ptr add-malloc ;
  84
  85 : realloc ( alien size -- newalien )
  86     [ >c-ptr ] dip
  87     over malloc-exists? [ realloc-error ] unless
  88     [ drop ] [ (realloc) check-ptr ] 2bi
  89     [ delete-malloc ] [ add-malloc ] bi* ;
  90
  91 : free ( alien -- )
  92     >c-ptr [ delete-malloc ] [ (free) ] bi ;
  93
  94 FUNCTION: void memset ( void* buf, int char, size_t size ) ;
  95
  96 FUNCTION: void memcpy ( void* dst, void* src, ulong size ) ;
  97
  98 FUNCTION: int memcmp ( void* a, void* b, ulong size ) ;
  99
 100 : memory= ( a b size -- ? )
 101     memcmp 0 = ;
 102
 103 FUNCTION: size_t strlen ( c-string alien ) ;
 104
 105 FUNCTION: int system ( c-string command ) ;
 106
 107 DESTRUCTOR: free
 108 DESTRUCTOR: (free)