Merge branch 'inlinec' of git://github.com/jedahu/factor

basis/alien/inline/compiler/compiler.factor

@@ -21,23 +21,33 @@ SYMBOL: C++
         { C++ [ ".cpp" ] }
     } case ;
 
+: compiler ( lang -- str )
+    {
+        { C [ "gcc" ] }
+        { C++ [ "g++" ] }
+    } case ;
+
+: link-command ( in out lang -- descr )
+    compiler os {
+        { [ dup linux? ]
+          [ drop { "-shared" "-o" } ] }
+        { [ dup macosx? ]
+          [ drop { "-g" "-prebind" "-dynamiclib" "-o" } ] }
+        [ name>> "unimplemented for: " prepend throw ]
+    } cond swap prefix prepend prepend ;
+
 :: compile-to-object ( lang contents name -- )
     name ".o" append temp-file
     contents name lang src-suffix append temp-file
     [ ascii set-file-contents ] keep 2array
-    { "gcc" "-fPIC" "-c" "-o" } prepend try-process ;
+    { "-fPIC" "-c" "-o" } lang compiler prefix prepend
+    try-process ;
 
-: link-object ( args name -- )
+:: link-object ( lang args name -- )
-    [ "lib" prepend library-suffix append ] [ ".o" append ] bi
+    args name [ "lib" prepend library-suffix append ]
-    [ temp-file ] bi@ 2array
+    [ ".o" append ] bi [ temp-file ] bi@ 2array
-    os {
+    lang link-command try-process ;
-        { [ dup linux? ]
-            [ drop { "gcc" "-shared" "-o" } ] }
-        { [ dup macosx? ]
-            [ drop { "gcc" "-g" "-prebind" "-dynamiclib" "-o" } ] }
-        [ name>> "unimplemented for: " prepend throw ]
-    } cond prepend prepend try-process ;
 
 :: compile-to-library ( lang args contents name -- )
     lang contents name compile-to-object
-    args name link-object ;
+    lang args name link-object ;

basis/alien/inline/inline.factor

@@ -1,10 +1,11 @@
 ! Copyright (C) 2009 Jeremy Hughes.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.inline.compiler alien.libraries
+USING: accessors alien.inline.compiler alien.inline.types
-alien.parser arrays assocs effects fry generalizations grouping
+alien.libraries alien.parser arrays assocs effects fry
-io.files io.files.info io.files.temp kernel lexer math
+generalizations grouping io.files io.files.info io.files.temp
-math.order math.ranges multiline namespaces sequences splitting
+kernel lexer math math.order math.ranges multiline namespaces
-strings system vocabs.loader vocabs.parser words ;
+sequences splitting strings system vocabs.loader
+vocabs.parser words ;
 IN: alien.inline
 
 <PRIVATE
@@ -13,35 +14,14 @@ SYMBOL: library-is-c++
 SYMBOL: compiler-args
 SYMBOL: c-strings
 
-: annotate-effect ( types effect -- types effect' )
-    [ in>> ] [ out>> ] bi [
-        zip
-        [ over pointer-to-primitive? [ ">" prepend ] when ]
-        assoc-map unzip
-    ] dip <effect> ;
-
-
 : function-types-effect ( -- function types effect )
     scan scan swap ")" parse-tokens
     [ "(" subseq? not ] filter swap parse-arglist ;
 
-: types-effect>params-return ( types effect -- params return )
-    [ in>> zip ]
-    [ nip out>> dup length 0 > [ first ] [ drop "void" ] if ]
-    2bi ;
-
 : arg-list ( types -- params )
     CHAR: a swap length CHAR: a + [a,b]
     [ 1string ] map ;
 
-: factorize-type ( str -- str' )
-    "const-" ?head drop
-    "unsigned-" ?head [ "u" prepend ] when
-    "long-" ?head [ "long" prepend ] when ;
-
-: cify-type ( str -- str' )
-    { { CHAR: - CHAR: space } } substitute ;
-
 : factor-function ( function types effect -- word quot effect )
     annotate-effect [ c-library get ] 3dip
     [ [ factorize-type ] map ] dip

basis/alien/inline/types/authors.txt

@@ -0,0 +1 @@
+Jeremy Hughes

basis/alien/inline/types/types.factor

@@ -0,0 +1,47 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types assocs combinators.short-circuit
+continuations effects fry kernel math memoize sequences
+splitting ;
+IN: alien.inline.types
+
+: factorize-type ( str -- str' )
+    "const-" ?head drop
+    "unsigned-" ?head [ "u" prepend ] when
+    "long-" ?head [ "long" prepend ] when ;
+
+: cify-type ( str -- str' )
+    { { CHAR: - CHAR: space } } substitute ;
+
+: const-type? ( str -- ? )
+    "const-" head? ;
+
+MEMO: resolved-primitives ( -- seq )
+    primitive-types [ resolve-typedef ] map ;
+
+: primitive-type? ( type -- ? )
+    [
+        factorize-type resolve-typedef [ resolved-primitives ] dip
+        '[ _ = ] any?
+    ] [ 2drop f ] recover ;
+
+: pointer? ( type -- ? )
+    [ "*" tail? ] [ "&" tail? ] bi or ;
+
+: type-sans-pointer ( type -- type' )
+    [ '[ _ = ] "*&" swap any? ] trim-tail ;
+
+: pointer-to-primitive? ( type -- ? )
+    { [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ;
+
+: types-effect>params-return ( types effect -- params return )
+    [ in>> zip ]
+    [ nip out>> dup length 0 > [ first ] [ drop "void" ] if ]
+    2bi ;
+
+: annotate-effect ( types effect -- types effect' )
+    [ in>> ] [ out>> ] bi [
+        zip
+        [ over pointer-to-primitive? [ ">" prepend ] when ]
+        assoc-map unzip
+    ] dip <effect> ;