core/alien/alien.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs kernel math namespaces sequences system
   4 kernel.private byte-arrays arrays init ;
   5 IN: alien
   6
   7 ! Some predicate classes used by the compiler for optimization
   8 ! purposes
   9 PREDICATE: simple-alien < alien underlying>> not ;
  10
  11 UNION: simple-c-ptr
  12 simple-alien POSTPONE: f byte-array ;
  13
  14 DEFER: pinned-c-ptr?
  15
  16 PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ;
  17
  18 UNION: pinned-c-ptr
  19     pinned-alien POSTPONE: f ;
  20
  21 GENERIC: expired? ( c-ptr -- ? ) flushable
  22
  23 M: alien expired? expired>> ;
  24
  25 M: f expired? drop t ;
  26
  27 : <alien> ( address -- alien )
  28     f <displaced-alien> { simple-c-ptr } declare ; inline
  29
  30 : <bad-alien> ( -- alien )
  31     -1 <alien> t >>expired ; inline
  32
  33 M: alien equal?
  34     over alien? [
  35         2dup [ expired? ] either? [
  36             [ expired? ] both?
  37         ] [
  38             [ alien-address ] bi@ =
  39         ] if
  40     ] [
  41         2drop f
  42     ] if ;
  43
  44 SYMBOL: libraries
  45
  46 libraries global [ H{ } assoc-like ] change-at
  47
  48 TUPLE: library path abi dll ;
  49
  50 : library ( name -- library ) libraries get at ;
  51
  52 : <library> ( path abi -- library )
  53     over dup [ dlopen ] when \ library boa ;
  54
  55 : load-library ( name -- dll )
  56     library dup [ dll>> ] when ;
  57
  58 : add-library ( name path abi -- )
  59     <library> swap libraries get set-at ;
  60
  61 ERROR: alien-callback-error ;
  62
  63 : alien-callback ( return parameters abi quot -- alien )
  64     alien-callback-error ;
  65
  66 ERROR: alien-indirect-error ;
  67
  68 : alien-indirect ( ... funcptr return parameters abi -- )
  69     alien-indirect-error ;
  70
  71 ERROR: alien-invoke-error library symbol ;
  72
  73 : alien-invoke ( ... return library function parameters -- ... )
  74     2over alien-invoke-error ;
  75
  76 ! Callbacks are registered in a global hashtable. If you clear
  77 ! this hashtable, they will all be blown away by code GC, beware.
  78 SYMBOL: callbacks
  79
  80 [ H{ } clone callbacks set-global ] "alien" add-init-hook