basis/libc/libc.factor

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