unmaintained/alien/inline/inline.factor

   1 ! Copyright (C) 2009 Jeremy Hughes.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.inline.compiler alien.inline.types
   4 alien.libraries alien.parser arrays assocs effects fry
   5 generalizations grouping io.directories io.files
   6 io.files.info io.files.temp kernel lexer math math.order
   7 math.ranges multiline namespaces sequences source-files
   8 splitting strings system vocabs.loader vocabs.parser words
   9 alien.c-types alien.structs make parser continuations ;
  10 IN: alien.inline
  11
  12 SYMBOL: c-library
  13 SYMBOL: library-is-c++
  14 SYMBOL: linker-args
  15 SYMBOL: c-strings
  16
  17 <PRIVATE
  18 : cleanup-variables ( -- )
  19     { c-library library-is-c++ linker-args c-strings }
  20     [ off ] each ;
  21
  22 : arg-list ( types -- params )
  23     CHAR: a swap length CHAR: a + [a,b]
  24     [ 1string ] map ;
  25
  26 : compile-library? ( -- ? )
  27     c-library get library-path dup exists? [
  28         file get [
  29             path>>
  30             [ file-info modified>> ] bi@ <=> +lt+ =
  31         ] [ drop t ] if*
  32     ] [ drop t ] if ;
  33
  34 : compile-library ( -- )
  35     library-is-c++ get [ C++ ] [ C ] if
  36     linker-args get
  37     c-strings get "\n" join
  38     c-library get compile-to-library ;
  39
  40 : c-library-name ( name -- name' )
  41     [ current-vocab name>> % "_" % % ] "" make ;
  42 PRIVATE>
  43
  44 : parse-arglist ( parameters return -- types effect )
  45     [ 2 group unzip [ "," ?tail drop ] map ]
  46     [ [ { } ] [ 1array ] if-void ]
  47     bi* <effect> ;
  48
  49 : append-function-body ( prototype-str body -- str )
  50     [ swap % " {\n" % % "\n}\n" % ] "" make ;
  51
  52 : function-types-effect ( -- function types effect )
  53     scan scan swap ")" parse-tokens
  54     [ "(" subseq? not ] filter swap parse-arglist ;
  55
  56 : prototype-string ( function types effect -- str )
  57     [ [ cify-type ] map ] dip
  58     types-effect>params-return cify-type -rot
  59     [ " " join ] map ", " join
  60     "(" prepend ")" append 3array " " join
  61     library-is-c++ get [ "extern \"C\" " prepend ] when ;
  62
  63 : prototype-string' ( function types return -- str )
  64     [ dup arg-list ] <effect> prototype-string ;
  65
  66 : factor-function ( function types effect -- word quot effect )
  67     annotate-effect [ c-library get ] 3dip
  68     [ [ factorize-type ] map ] dip
  69     types-effect>params-return factorize-type -roll
  70     concat make-function ;
  71
  72 : define-c-library ( name -- )
  73     c-library-name [ c-library set ] [ "c-library" set ] bi
  74     V{ } clone c-strings set
  75     V{ } clone linker-args set ;
  76
  77 : compile-c-library ( -- )
  78     compile-library? [ compile-library ] when
  79     c-library get dup library-path cdecl add-library ;
  80
  81 : define-c-function ( function types effect body -- )
  82     [
  83         [ factor-function define-declared ]
  84         [ prototype-string ] 3bi
  85     ] dip append-function-body c-strings get push ;
  86
  87 : define-c-function' ( function effect body -- )
  88     [
  89         [ in>> ] keep
  90         [ factor-function define-declared ]
  91         [ out>> prototype-string' ] 3bi
  92     ] dip append-function-body c-strings get push ;
  93
  94 : c-link-to ( str -- )
  95     "-l" prepend linker-args get push ;
  96
  97 : c-use-framework ( str -- )
  98     "-framework" swap linker-args get '[ _ push ] bi@ ;
  99
 100 : c-link-to/use-framework ( str -- )
 101     os macosx? [ c-use-framework ] [ c-link-to ] if ;
 102
 103 : c-include ( str -- )
 104     "#include " prepend c-strings get push ;
 105
 106 : define-c-typedef ( old new -- )
 107     [ typedef ] [
 108         [ swap "typedef " % % " " % % ";" % ]
 109         "" make c-strings get push
 110     ] 2bi ;
 111
 112 : define-c-struct ( name fields -- )
 113     [ current-vocab swap define-struct ] [
 114         over
 115         [
 116             "typedef struct " % "_" % % " {\n" %
 117             [ first2 swap % " " % % ";\n" % ] each
 118             "} " % % ";\n" %
 119         ] "" make c-strings get push
 120     ] 2bi ;
 121
 122 : delete-inline-library ( name -- )
 123     c-library-name [ remove-library ]
 124     [ library-path dup exists? [ delete-file ] [ drop ] if ] bi ;
 125
 126 : with-c-library ( name quot -- )
 127     [ [ define-c-library ] dip call compile-c-library ]
 128     [ cleanup-variables ] [ ] cleanup ; inline
 129
 130 : raw-c ( str -- )
 131     [ "\n" % % "\n" % ] "" make c-strings get push ;