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 ;
   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 SYMBOL: malloc-expiry
  30
  31 : mallocs ( -- assoc )
  32     malloc-expiry get-global expired? [
  33         -1 <alien> malloc-expiry set-global
  34         H{ } clone dup \ mallocs set-global
  35     ] [
  36         \ mallocs get-global
  37     ] if ;
  38
  39 PRIVATE>
  40
  41 ERROR: bad-ptr ;
  42
  43 M: bad-ptr summary
  44     drop "Memory allocation failed" ;
  45
  46 : check-ptr ( c-ptr -- c-ptr )
  47     [ bad-ptr ] unless* ;
  48
  49 ERROR: double-free ;
  50
  51 M: double-free summary
  52     drop "Free failed since memory is not allocated" ;
  53
  54 ERROR: realloc-error ptr size ;
  55
  56 M: realloc-error summary
  57     drop "Memory reallocation failed" ;
  58
  59 <PRIVATE
  60
  61 : add-malloc ( alien -- alien )
  62     dup mallocs conjoin ;
  63
  64 : delete-malloc ( alien -- )
  65     [
  66         mallocs delete-at*
  67         [ drop ] [ double-free ] if
  68     ] when* ;
  69
  70 : malloc-exists? ( alien -- ? )
  71     mallocs key? ;
  72
  73 PRIVATE>
  74
  75 : malloc ( size -- alien )
  76     (malloc) check-ptr add-malloc ;
  77
  78 : calloc ( count size -- alien )
  79     (calloc) check-ptr add-malloc ;
  80
  81 : realloc ( alien size -- newalien )
  82     [ >c-ptr ] dip
  83     over malloc-exists? [ realloc-error ] unless
  84     [ drop ] [ (realloc) check-ptr ] 2bi
  85     [ delete-malloc ] [ add-malloc ] bi* ;
  86
  87 : free ( alien -- )
  88     >c-ptr [ delete-malloc ] [ (free) ] bi ;
  89
  90 : memcpy ( dst src size -- )
  91     "void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ;
  92
  93 : strlen ( alien -- len )
  94     "size_t" "libc" "strlen" { "char*" } alien-invoke ;
  95
  96 DESTRUCTOR: free