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