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 compiler.errors
   4 io.backend kernel namespaces destructors sequences strings
   5 system io.pathnames fry combinators vocabs ;
   6 IN: alien.libraries
   7
   8 PRIMITIVE: dll-valid? ( dll -- ? )
   9 PRIMITIVE: (dlopen) ( path -- dll )
  10 PRIMITIVE: (dlsym) ( name dll -- alien )
  11 PRIMITIVE: dlclose ( dll -- )
  12 PRIMITIVE: (dlsym-raw) ( name dll -- alien )
  13
  14 : dlopen ( path -- dll ) native-string>alien (dlopen) ;
  15
  16 : dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ;
  17
  18 : dlsym-raw ( name dll -- alien ) [ string>symbol ] dip (dlsym-raw) ;
  19
  20 HOOK: dlerror os ( -- message/f )
  21
  22 SYMBOL: libraries
  23
  24 libraries [ H{ } clone ] initialize
  25
  26 TUPLE: library { path string } dll dlerror { abi abi initial: cdecl } ;
  27
  28 C: <library> library
  29
  30 : lookup-library ( name -- library/f ) libraries get at ;
  31
  32 : open-dll ( path -- dll dll-error/f )
  33     [ dlopen dup dll-valid? [ f ] [ dlerror ] if ]
  34     [ f f ] if* ;
  35
  36 : make-library ( path abi -- library )
  37     [ dup open-dll ] dip <library> ;
  38
  39 GENERIC: library-dll ( obj -- dll )
  40
  41 M: f library-dll ;
  42
  43 M: library library-dll
  44     dup [ dll>> ] when ;
  45
  46 M: string library-dll ( library -- dll )
  47     lookup-library library-dll ;
  48
  49 : dlsym? ( function library -- alien/f )
  50     library-dll dlsym ;
  51
  52 M: dll dispose dlclose ;
  53
  54 M: library dispose dll>> [ dispose ] when* ;
  55
  56 : remove-library ( name -- )
  57     libraries get delete-at* [ dispose ] [ drop ] if ;
  58
  59 : same-library? ( library path abi -- ? )
  60     [ swap path>> = ] [ swap abi>> = ] bi-curry* bi and ;
  61
  62 : add-library? ( name path abi -- ? )
  63     [ lookup-library ] 2dip '[ _ _ same-library? not ] [ t ] if* ;
  64
  65 : add-library ( name path abi -- )
  66     3dup add-library? [
  67         [ 2drop remove-library ]
  68         [ nipd make-library ]
  69         [ 2drop libraries get set-at ] 3tri
  70     ] [ 3drop ] if ;
  71
  72 : change-dll ( library path abi -- )
  73     swap >>abi
  74     swap >>path
  75     [ dispose ]
  76     [ path>> open-dll ]
  77     [ swap >>dlerror swap >>dll drop ] tri ;
  78
  79 : update-library ( name path abi -- )
  80     pick lookup-library [
  81         [ 2over same-library? not ] keep swap
  82         [ change-dll drop ] [ 4drop ] if
  83     ] [
  84         make-library swap libraries get set-at
  85     ] if* ;
  86
  87 : library-abi ( library -- abi )
  88     lookup-library [ abi>> ] [ cdecl ] if* ;
  89
  90 : address-of ( name library -- value )
  91     2dup library-dll dlsym-raw
  92     [ 2nip ] [ no-such-symbol ] if* ;
  93
  94 SYMBOL: deploy-libraries
  95
  96 deploy-libraries [ V{ } clone ] initialize
  97
  98 : deploy-library ( name -- )
  99     dup libraries get key?
 100     [ deploy-libraries get 2dup member? [ 2drop ] [ push ] if ]
 101     [ "deploy-library failure" no-such-library ] if ;
 102
 103 HOOK: >deployed-library-path os ( path -- path' )
 104
 105 {
 106     { [ os windows? ] [ "alien.libraries.windows" ] }
 107     { [ os unix? ] [ "alien.libraries.unix" ] }
 108 } cond require