diff --git a/basis/alien/inline/compiler/compiler.factor b/basis/alien/inline/compiler/compiler.factor index 0ac702478b..b5a7861d6b 100644 --- a/basis/alien/inline/compiler/compiler.factor +++ b/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 -- ) - [ "lib" prepend library-suffix append ] [ ".o" append ] bi - [ temp-file ] bi@ 2array - os { - { [ dup linux? ] - [ drop { "gcc" "-shared" "-o" } ] } - { [ dup macosx? ] - [ drop { "gcc" "-g" "-prebind" "-dynamiclib" "-o" } ] } - [ name>> "unimplemented for: " prepend throw ] - } cond prepend prepend try-process ; +:: link-object ( lang args name -- ) + args name [ "lib" prepend library-suffix append ] + [ ".o" append ] bi [ temp-file ] bi@ 2array + lang link-command try-process ; :: compile-to-library ( lang args contents name -- ) lang contents name compile-to-object - args name link-object ; + lang args name link-object ; diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 9a9f2eb683..ae4a95497a 100644 --- a/basis/alien/inline/inline.factor +++ b/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 -alien.parser arrays assocs effects fry generalizations grouping -io.files io.files.info io.files.temp kernel lexer math -math.order math.ranges multiline namespaces sequences splitting -strings system vocabs.loader vocabs.parser words ; +USING: accessors alien.inline.compiler alien.inline.types +alien.libraries alien.parser arrays assocs effects fry +generalizations grouping io.files io.files.info io.files.temp +kernel lexer math math.order math.ranges multiline namespaces +sequences splitting strings system vocabs.loader +vocabs.parser words ; IN: alien.inline > ] [ out>> ] bi [ - zip - [ over pointer-to-primitive? [ ">" prepend ] when ] - assoc-map unzip - ] dip ; - - : 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 diff --git a/basis/alien/inline/types/authors.txt b/basis/alien/inline/types/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/basis/alien/inline/types/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/basis/alien/inline/types/types.factor b/basis/alien/inline/types/types.factor new file mode 100644 index 0000000000..acc62a81a2 --- /dev/null +++ b/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 ;