basis/alien/libraries/libraries.factor

   1 ! Copyright (C) 2009, 2010 Slava Pestov, Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.strings assocs io.backend
   4 kernel namespaces destructors sequences strings
   5 system io.pathnames fry combinators vocabs ;
   6 IN: alien.libraries
   7
   8 : dlopen ( path -- dll ) native-string>alien (dlopen) ;
   9
  10 : dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ;
  11
  12 : dlsym-raw ( name dll -- alien ) [ string>symbol ] dip (dlsym-raw) ;
  13
  14 HOOK: dlerror os ( -- message/f )
  15
  16 SYMBOL: libraries
  17
  18 libraries [ H{ } clone ] initialize
  19
  20 TUPLE: library { path string } { abi abi initial: cdecl } dll dlerror ;
  21
  22 ERROR: no-library name ;
  23
  24 : library ( name -- library ) libraries get at ;
  25
  26 : <library> ( path abi -- library )
  27     over dup
  28     [ dlopen dup dll-valid? [ f ] [ dlerror ] if ] [ f ] if
  29     \ library boa ;
  30
  31 : library-dll ( library -- dll )
  32     dup [ dll>> ] when ;
  33
  34 : load-library ( name -- dll )
  35     library library-dll ;
  36
  37 M: dll dispose dlclose ;
  38
  39 M: library dispose dll>> [ dispose ] when* ;
  40
  41 : remove-library ( name -- )
  42     libraries get delete-at* [ dispose ] [ drop ] if ;
  43
  44 : add-library? ( name path abi -- ? )
  45     [ library ] 2dip
  46     '[ [ path>> _ = ] [ abi>> _ = ] bi and not ] [ t ] if* ;
  47
  48 : add-library ( name path abi -- )
  49     3dup add-library? [
  50         [ 2drop remove-library ]
  51         [ <library> swap libraries get set-at ] 3bi
  52     ] [ 3drop ] if ;
  53
  54 : library-abi ( library -- abi )
  55     library [ abi>> ] [ cdecl ] if* ;
  56
  57 ERROR: no-such-symbol name library ;
  58
  59 : address-of ( name library -- value )
  60     2dup load-library dlsym-raw [ 2nip ] [ no-such-symbol ] if* ;
  61
  62 SYMBOL: deploy-libraries
  63
  64 deploy-libraries [ V{ } clone ] initialize
  65
  66 : deploy-library ( name -- )
  67     dup libraries get key?
  68     [ deploy-libraries get 2dup member? [ 2drop ] [ push ] if ]
  69     [ no-library ] if ;
  70
  71 HOOK: >deployed-library-path os ( path -- path' )
  72
  73 << {
  74     { [ os windows? ] [ "alien.libraries.windows" ] }
  75     { [ os unix? ] [ "alien.libraries.unix" ] }
  76 } cond require >>