basis/libc/libc.factor

   1 ! Copyright (C) 2004, 2005 Mackenzie Straight
   2 ! Copyright (C) 2007, 2008 Slava Pestov
   3 ! Copyright (C) 2007, 2008 Doug Coleman
   4 ! See http://factorcode.org/license.txt for BSD license.
   5 USING: alien assocs continuations destructors kernel
   6 namespaces accessors sets summary ;
   7 IN: libc
   8
   9 <PRIVATE
  10
  11 : (malloc) ( size -- alien )
  12     "void*" "libc" "malloc" { "ulong" } alien-invoke ;
  13
  14 : (calloc) ( count size -- alien )
  15     "void*" "libc" "calloc" { "ulong" "ulong" } alien-invoke ;
  16
  17 : (free) ( alien -- )
  18     "void" "libc" "free" { "void*" } alien-invoke ;
  19
  20 : (realloc) ( alien size -- newalien )
  21     "void*" "libc" "realloc" { "void*" "ulong" } alien-invoke ;
  22
  23 SYMBOL: malloc-expiry
  24
  25 : mallocs ( -- assoc )
  26     malloc-expiry get-global expired? [
  27         -1 <alien> malloc-expiry set-global
  28         H{ } clone dup \ mallocs set-global
  29     ] [
  30         \ mallocs get-global
  31     ] if ;
  32
  33 PRIVATE>
  34
  35 ERROR: bad-ptr ;
  36
  37 M: bad-ptr summary
  38     drop "Memory allocation failed" ;
  39
  40 : check-ptr ( c-ptr -- c-ptr )
  41     [ bad-ptr ] unless* ;
  42
  43 ERROR: double-free ;
  44
  45 M: double-free summary
  46     drop "Free failed since memory is not allocated" ;
  47
  48 ERROR: realloc-error ptr size ;
  49
  50 M: realloc-error summary
  51     drop "Memory reallocation failed" ;
  52
  53 <PRIVATE
  54
  55 : add-malloc ( alien -- )
  56     mallocs conjoin ;
  57
  58 : delete-malloc ( alien -- )
  59     [
  60         mallocs delete-at*
  61         [ double-free ] unless drop
  62     ] when* ;
  63
  64 : malloc-exists? ( alien -- ? )
  65     mallocs key? ;
  66
  67 PRIVATE>
  68
  69 : malloc ( size -- alien )
  70     (malloc) check-ptr
  71     dup add-malloc ;
  72
  73 : calloc ( count size -- alien )
  74     (calloc) check-ptr
  75     dup add-malloc ;
  76
  77 : realloc ( alien size -- newalien )
  78     over malloc-exists? [ realloc-error ] unless
  79     dupd (realloc) check-ptr
  80     swap delete-malloc
  81     dup add-malloc ;
  82
  83 : free ( alien -- )
  84     dup delete-malloc
  85     (free) ;
  86
  87 : memcpy ( dst src size -- )
  88     "void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ;
  89
  90 : with-malloc ( size quot -- )
  91     swap 1 calloc [ swap keep ] [ free ] [ ] cleanup ; inline
  92
  93 : strlen ( alien -- len )
  94     "size_t" "libc" "strlen" { "char*" } alien-invoke ;
  95
  96 <PRIVATE
  97
  98 ! Memory allocations
  99 TUPLE: memory-destructor alien disposed ;
 100
 101 M: memory-destructor dispose* alien>> free ;
 102
 103 PRIVATE>
 104
 105 : &free ( alien -- alien )
 106     dup f memory-destructor boa &dispose drop ; inline
 107
 108 : |free ( alien -- alien )
 109     dup f memory-destructor boa |dispose drop ; inline