Paste: alien.compile

USING: accessors arrays combinators fry generalizations
io.encodings.ascii io.files io.files.temp io.launcher kernel
sequences system ;
IN: alien.compile

: library-suffix ( -- str )
    os {
        { [ dup macosx? ]  [ drop ".dylib" ] }
        { [ dup unix? ]    [ drop ".so" ] }
        { [ dup windows? ] [ drop ".dll" ] }
    } cond ;

: src-suffix ( lang -- str )
    {
        { "C" [ ".c" ] }
        { "C++" [ ".cpp" ] }
    } case ;

: compile-to-object ( lang contents name -- )
    rot '[ _ src-suffix append ] [ ".o" append ] bi
    [ temp-file ] bi@
    [ tuck ascii set-file-contents ] dip
    swap 2array { "gcc" "-fPIC" "-c" "-o" } 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 ;

: compile-to-library ( lang args contents name -- )
    [ [ nip ] dip compile-to-object ] 4 nkeep
    nip link-object drop ;

Annotation: alien.c-syntax

USING: accessors alien.compile alien.libraries alien.parser
arrays fry generalizations io.files io.files.info io.files.temp
kernel lexer math.order multiline namespaces sequences system
vocabs.loader vocabs.parser words ;
IN: alien.c-syntax

<PRIVATE
: (C-LIBRARY:) ( -- )
    scan "c-library" set
    V{ } clone "c-library-vector" set
    V{ } clone "c-compiler-args" set ;

: (C-LINK:) ( -- )
    "-l" scan append "c-compiler-args" get push ;

: (C-FRAMEWORK:) ( -- )
    "-framework" scan "c-compiler-args" get '[ _ push ] bi@ ;

: return-library-function-params ( -- return library function params )
    scan "c-library" get scan ")" parse-tokens
    [ "(" subseq? not ] filter [
        [ dup CHAR: - = [ drop CHAR: space ] when ] map
    ] 3dip ;

: factor-function ( return library functions params -- )
    [ dup "const " head? [ 6 tail ] when ] 3dip
    make-function define-declared ;

: (C-FUNCTION:) ( return library function params -- str )
    [ nip ] dip
    " " join "(" prepend ")" append 3array " " join
    "library-is-c++" get [ "extern \"C\" " prepend ] when ;

: library-path ( -- str )
    "lib" "c-library" get library-suffix
    3array concat temp-file ;

: compile-library? ( -- ? )
    library-path dup exists? [
        current-vocab vocab-source-path
        [ file-info modified>> ] bi@ <=> +lt+ =
    ] [ drop t ] if ;

: compile-library ( -- )
    "library-is-c++" get [ "C++" ] [ "C" ] if
    "c-compiler-args" get
    "c-library-vector" get "\n" join
    "c-library" get compile-to-library ;

: (;C-LIBRARY) ( -- )
    compile-library? [ compile-library ] when
    "c-library" get library-path "cdecl" add-library ;
PRIVATE>

SYNTAX: C-LIBRARY: (C-LIBRARY:) ;

SYNTAX: COMPILE-AS-C++ t "library-is-c++" set ;

SYNTAX: C-LINK: (C-LINK:) ;

SYNTAX: C-FRAMEWORK: (C-FRAMEWORK:) ;

SYNTAX: C-LINK/FRAMEWORK:
    os macosx? [ (C-FRAMEWORK:) ] [ (C-LINK:) ] if ;

SYNTAX: C-INCLUDE:
    "#include " scan append "c-library-vector" get push ;

SYNTAX: C-FUNCTION:
    return-library-function-params
    [ factor-function ]
    4 nkeep (C-FUNCTION:)
    " {\n" append parse-here append "\n}\n" append
    "c-library-vector" get push ;

SYNTAX: ;C-LIBRARY (;C-LIBRARY) ;

Annotation: example

USING: alien alien.accessors alien.c-syntax alien.c-types
alien.libraries alien.strings alien.syntax generalizations io
io.encodings.binary io.encodings.utf8 io.files.temp
io.streams.byte-array kernel math parser sequences struct-arrays
system unix.utilities words ;

IN: smoke.ffi

TYPEDEF: short Smoke::Index
TYPEDEF: short Index

TYPEDEF: void QString

C-STRUCT: ModuleIndex
    { "Smoke*" "smoke" }
    { "Index" "index" } ;

TYPEDEF: ModuleIndex Smoke::ModuleIndex

C-STRUCT: Class
    { "char*" "className" } ! Name of the class
    { "bool" "external" }   ! Whether the class is in another module
    { "Index" "parents" }   ! Index into inheritanceList
    { "void*" "classFn" }   ! Calls any method in the class
    { "void*" "enumFn" }    ! Handles enum pointers
    { "ushort" "flags" } ;  ! ClassFlags

TYPEDEF: Class Smoke::Class

C-STRUCT: Method
    { "Index" "classId" }  ! Index into classes
    { "Index" "name" }     ! Index into methodNames; real name
    { "Index" "args" }     ! Index into argumentList
    { "uchar" "numArgs" }  ! Number of arguments
    { "uchar" "flags" }    ! MethodFlags (const/static/etc...)
    { "Index" "ret" }      ! Index into types for the return type
    { "Index" "method" } ; ! Passed to Class.classFn, to call method

TYPEDEF: Method Smoke::Method

C-STRUCT: Type
    { "char*" "name" }     ! Stringified type name
    { "Index" "classId" }  ! Index into classes. -1 for none
    { "ushort" "flags" } ; ! TypeFlags

TYPEDEF: Type Smoke::Type

C-STRUCT: MethodMap
    { "Index" "classId" }  ! Index into classes
    { "Index" "name" }     ! Index into methodNames; munged name
    { "Index" "method" } ; ! Index into methods

TYPEDEF: MethodMap Smoke::MethodMap

C-LIBRARY: smoke-ffi

COMPILE-AS-C++

C-LINK/FRAMEWORK: QtCore
C-LINK: smokeqt

C-INCLUDE: <smoke.h>
C-INCLUDE: <smoke/qt_smoke.h>
C-INCLUDE: <QtCore/QString>

C-FUNCTION: void smoke_init_qt ( )
    init_qt_Smoke();
;

C-FUNCTION: Smoke* smoke_qt ( )
    return qt_Smoke;
;

C-FUNCTION: void delete_smoke_qt ( )
    delete qt_Smoke;
;

C-FUNCTION: Smoke::Type* smoke_types ( Smoke* s )
    return s->types;
;

C-FUNCTION: Smoke::Class* smoke_classes ( Smoke* s )
    return s->classes;
;

C-FUNCTION: Smoke::Method* smoke_methods ( Smoke* s )
    return s->methods;
;

C-FUNCTION: Smoke::Index* smoke_inheritanceList ( Smoke* s )
    return s->inheritanceList;
;

C-FUNCTION: Smoke::Index* smoke_argumentList ( Smoke* s )
    return s->argumentList;
;

C-FUNCTION: Smoke::Index* smoke_ambiguousMethodList ( Smoke* s )
    return s->ambiguousMethodList;
;

C-FUNCTION: Smoke::MethodMap* smoke_methodMaps ( Smoke* s )
    return s->methodMaps;
;

C-FUNCTION: const-char** smoke_methodNames ( Smoke* s )
    return s->methodNames;
;

C-FUNCTION: Smoke::Index smoke_numTypes ( Smoke* s )
    return s->numTypes;
;

C-FUNCTION: Smoke::Index smoke_numClasses ( Smoke* s )
    return s->numClasses;
;

C-FUNCTION: Smoke::Index smoke_numMethods ( Smoke* s )
    return s->numMethods;
;

C-FUNCTION: Smoke::Index smoke_numMethodMaps ( Smoke* s )
    return s->numMethodMaps;
;

C-FUNCTION: Smoke::Index smoke_numMethodNames ( Smoke* s )
    return s->numMethodNames;
;

C-FUNCTION: Smoke::ModuleIndex smoke_findClass ( char* c, Smoke* s )
    return s->findClass(c);
;

C-FUNCTION: Smoke::ModuleIndex smoke_findMethod ( char* c, char* name, Smoke* s )
    return s->findMethod(c, name);
;

C-FUNCTION: void smoke_callMethod ( Smoke::Class c, Smoke::Index m, void* obj, Smoke::StackItem* args )
    (*c.classFn)(m, obj, args);
;

C-FUNCTION: QString* QString_new (  )
    return new QString();
;

C-FUNCTION: void QString_delete  ( QString* o )
    delete o;
;

C-FUNCTION: int QString_length ( QString* o )
    return o->length();
;

C-FUNCTION: void QString_set_length ( int n, QString* o )
    o->resize(n);
;

C-FUNCTION: void QString_reserve ( int n, QString* o )
    o->reserve(n);
;

C-FUNCTION: int QString_capacity ( QString* o )
    return o->capacity();
;

C-FUNCTION: ushort QString_nth_unsafe ( int n, QString* s )
    return s->at(n).unicode();
;

C-FUNCTION: void QString_set_nth_unsafe ( int c, int n, QString* s )
    s->replace(n, 1, QChar(c));
;

C-FUNCTION: QString* QString_from_utf8 ( char* str, int n )
    return new QString(QString::fromUtf8(str, n));
;

C-FUNCTION: const-char* QString_to_utf8 ( QString* s )
    return s->toUtf8().constData();
;

;C-LIBRARY


! enum TypeFlags
CONSTANT: tf_elem  HEX:  F
CONSTANT: tf_stack HEX: 10
CONSTANT: tf_ptr   HEX: 20
CONSTANT: tf_ref   HEX: 30
CONSTANT: tf_const HEX: 40

! enum ClassFlags
CONSTANT: cf_constructor HEX:  1
CONSTANT: cf_deepcopy    HEX:  2
CONSTANT: cf_virtual     HEX:  4
CONSTANT: cf_undefined   HEX: 10

! enum MethodFlags
CONSTANT: mf_static    HEX:  1
CONSTANT: mf_const     HEX:  2
CONSTANT: mf_copyctor  HEX:  4
CONSTANT: mf_internal  HEX:  8
CONSTANT: mf_enum      HEX: 10
CONSTANT: mf_ctor      HEX: 20
CONSTANT: mf_dtor      HEX: 40
CONSTANT: mf_protected HEX: 80

New Annotation