+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2005, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel kernel.private math namespaces
-make sequences strings words effects combinators alien.c-types ;
-IN: alien.structs.fields
-
-TUPLE: field-spec name offset type reader writer ;
-
-: reader-word ( class name vocab -- word )
- [ "-" glue ] dip create dup make-deprecated ;
-
-: writer-word ( class name vocab -- word )
- [ [ swap "set-" % % "-" % % ] "" make ] dip create dup make-deprecated ;
-
-: <field-spec> ( struct-name vocab type field-name -- spec )
- field-spec new
- 0 >>offset
- swap >>name
- swap >>type
- 3dup name>> swap reader-word >>reader
- 3dup name>> swap writer-word >>writer
- 2nip ;
-
-: align-offset ( offset type -- offset )
- c-type-align align ;
-
-: struct-offsets ( specs -- size )
- 0 [
- [ type>> align-offset ] keep
- [ (>>offset) ] [ type>> heap-size + ] 2bi
- ] reduce ;
-
-: define-struct-slot-word ( word quot spec effect -- )
- [ offset>> prefix ] dip define-inline ;
-
-: define-getter ( spec -- )
- [ reader>> ] [ type>> c-type-getter-boxer ] [ ] tri
- (( c-ptr -- value )) define-struct-slot-word ;
-
-: define-setter ( spec -- )
- [ writer>> ] [ type>> c-setter ] [ ] tri
- (( value c-ptr -- )) define-struct-slot-word ;
-
-: define-field ( spec -- )
- [ define-getter ] [ define-setter ] bi ;
+++ /dev/null
-Struct field implementation and reflection support
+++ /dev/null
-USING: alien.c-types alien.data strings help.markup help.syntax alien.syntax
-sequences io arrays kernel words assocs namespaces ;
-IN: alien.structs
-
-ARTICLE: "c-structs" "C structure types"
-"A " { $snippet "struct" } " in C is essentially a block of memory with the value of each structure field stored at a fixed offset from the start of the block. The C library interface provides some utilities to define words which read and write structure fields given a base address."
-{ $subsection POSTPONE: C-STRUCT: }
-"Great care must be taken when working with C structures since no type or bounds checking is possible."
-$nl
-"An example:"
-{ $code
- "C-STRUCT: XVisualInfo"
- " { \"Visual*\" \"visual\" }"
- " { \"VisualID\" \"visualid\" }"
- " { \"int\" \"screen\" }"
- " { \"uint\" \"depth\" }"
- " { \"int\" \"class\" }"
- " { \"ulong\" \"red_mask\" }"
- " { \"ulong\" \"green_mask\" }"
- " { \"ulong\" \"blue_mask\" }"
- " { \"int\" \"colormap_size\" }"
- " { \"int\" \"bits_per_rgb\" } ;"
-}
-"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
-$nl
-"Arrays of C structures can be created with the " { $vocab-link "specialized-arrays" } " vocabulary." ;
-
-ARTICLE: "c-unions" "C unions"
-"A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
-{ $subsection POSTPONE: C-UNION: }
-"C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
-$nl
-"Arrays of C unions can be created with the " { $vocab-link "specialized-arrays" } " vocabulary." ;
+++ /dev/null
-USING: alien alien.syntax alien.c-types alien.data kernel tools.test
-sequences system libc words vocabs namespaces layouts ;
-IN: alien.structs.tests
-
-C-STRUCT: bar
- { "int" "x" }
- { { "int" 8 } "y" } ;
-
-[ 36 ] [ "bar" heap-size ] unit-test
-[ t ] [ \ <displaced-alien> "bar" c-type-getter memq? ] unit-test
-
-C-STRUCT: align-test
- { "int" "x" }
- { "double" "y" } ;
-
-os winnt? cpu x86? and [
- [ 16 ] [ "align-test" heap-size ] unit-test
-
- cell 4 = [
- C-STRUCT: one
- { "long" "a" } { "double" "b" } { "int" "c" } ;
-
- [ 24 ] [ "one" heap-size ] unit-test
- ] when
-] when
-
-CONSTANT: MAX_FOOS 30
-
-C-STRUCT: foox
- { { "int" MAX_FOOS } "x" } ;
-
-[ 120 ] [ "foox" heap-size ] unit-test
-
-C-UNION: barx
- { "int" MAX_FOOS }
- "float" ;
-
-[ 120 ] [ "barx" heap-size ] unit-test
-
-"help" vocab [
- "print-topic" "help" lookup "help" set
- [ ] [ \ foox-x "help" get execute ] unit-test
- [ ] [ \ set-foox-x "help" get execute ] unit-test
-] when
-
-C-STRUCT: nested
- { "int" "x" } ;
-
-C-STRUCT: nested-2
- { "nested" "y" } ;
-
-[ 4 ] [
- "nested-2" <c-object>
- "nested" <c-object>
- 4 over set-nested-x
- over set-nested-2-y
- nested-2-y
- nested-x
-] unit-test
+++ /dev/null
-! Copyright (C) 2004, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs generic hashtables kernel kernel.private
-math namespaces parser sequences strings words libc fry
-alien.c-types alien.structs.fields cpu.architecture math.order
-quotations byte-arrays ;
-IN: alien.structs
-
-TUPLE: struct-type < abstract-c-type fields return-in-registers? ;
-
-INSTANCE: struct-type value-type
-
-M: struct-type c-type ;
-
-M: struct-type c-type-stack-align? drop f ;
-
-: if-value-struct ( ctype true false -- )
- [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
-
-M: struct-type unbox-parameter
- [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
-
-M: struct-type box-parameter
- [ %box-large-struct ] [ box-parameter ] if-value-struct ;
-
-: if-small-struct ( c-type true false -- ? )
- [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
-
-M: struct-type unbox-return
- [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
-
-M: struct-type box-return
- [ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
-
-M: struct-type stack-size
- [ heap-size ] [ stack-size ] if-value-struct ;
-
-M: struct-type c-struct? drop t ;
-
-: (define-struct) ( name size align fields class -- )
- [ [ align ] keep ] 2dip new
- byte-array >>class
- byte-array >>boxed-class
- swap >>fields
- swap >>align
- swap >>size
- swap typedef ;
-
-: make-fields ( name vocab fields -- fields )
- [ first2 <field-spec> ] with with map ;
-
-: compute-struct-align ( types -- n )
- [ c-type-align ] [ max ] map-reduce ;
-
-: define-struct ( name vocab fields -- )
- [ 2drop ] [ make-fields ] 3bi
- [ struct-offsets ] keep
- [ [ type>> ] map compute-struct-align ] keep
- [ struct-type (define-struct) ] keep
- [ define-field ] each ; deprecated
-
-: define-union ( name members -- )
- [ [ heap-size ] [ max ] map-reduce ] keep
- compute-struct-align f struct-type (define-struct) ; deprecated
-
-: offset-of ( field struct -- offset )
- c-types get at fields>>
- [ name>> = ] with find nip offset>> ;
-
-USE: vocabs.loader
-"specialized-arrays" require
+++ /dev/null
-C structure support
IN: alien.syntax
-USING: alien alien.c-types alien.parser alien.structs
-classes.struct help.markup help.syntax ;
+USING: alien alien.c-types alien.parser classes.struct help.markup help.syntax ;
HELP: DLL"
{ $syntax "DLL\" path\"" }
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." }
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
-HELP: C-STRUCT:
-{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: STRUCT: } " word." }
-{ $syntax "C-STRUCT: name pairs... ;" }
-{ $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } }
-{ $description "Defines a C struct layout and accessor words." }
-{ $notes "C type names are documented in " { $link "c-types-specs" } "." } ;
-
-HELP: C-UNION:
-{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: UNION-STRUCT: } " word." }
-{ $syntax "C-UNION: name members... ;" }
-{ $values { "name" "a new C type name" } { "members" "a sequence of C types" } }
-{ $description "Defines a new C type sized to fit its largest member." }
-{ $notes "C type names are documented in " { $link "c-types-specs" } "." }
-{ $examples { $code "C-UNION: event \"active-event\" \"keyboard-event\" \"mouse-event\" ;" } } ;
-
HELP: C-ENUM:
{ $syntax "C-ENUM: words... ;" }
{ $values { "words" "a sequence of word names" } }
HELP: c-struct?
{ $values { "type" "a string" } { "?" "a boolean" } }
-{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: C-STRUCT: } "." } ;
+{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: STRUCT: } "." } ;
HELP: define-function
{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
! Copyright (C) 2005, 2009 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays alien alien.c-types alien.structs
+USING: accessors arrays alien alien.c-types
alien.arrays alien.strings kernel math namespaces parser
sequences words quotations math.parser splitting grouping
effects assocs combinators lexer strings.parser alien.parser
SYNTAX: TYPEDEF:
scan-c-type CREATE-C-TYPE typedef ;
-SYNTAX: C-STRUCT:
- scan current-vocab parse-definition define-struct ; deprecated
-
-SYNTAX: C-UNION:
- scan parse-definition define-union ; deprecated
-
SYNTAX: C-ENUM:
";" parse-tokens
[ [ create-in ] dip define-constant ] each-index ;
kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types
alien.strings alien.arrays alien.complex alien.libraries sets libc
-continuations.private fry cpu.architecture classes locals
+continuations.private fry cpu.architecture classes classes.struct locals
source-files.errors slots parser generic.parser
compiler.errors
compiler.alien
compiler.cfg.builder
compiler.codegen.fixup
compiler.utilities ;
-QUALIFIED: classes.struct
-QUALIFIED: alien.structs
IN: compiler.codegen
SYMBOL: insn-counts
M: object flatten-value-type 1array ;
-M: alien.structs:struct-type flatten-value-type ( type -- types )
- stack-size cell align (flatten-int-type) ;
-
-M: classes.struct:struct-c-type flatten-value-type ( type -- types )
+M: struct-c-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
M: long-long-type flatten-value-type ( type -- types )
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays sequences math splitting make assocs kernel
-layouts system alien.c-types cpu.architecture
+layouts system alien.c-types classes.struct cpu.architecture
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 compiler.codegen
compiler.cfg.registers ;
-QUALIFIED: alien.structs
-QUALIFIED: classes.struct
IN: cpu.x86.64.unix
M: int-regs param-regs
flatten-small-struct
] if ;
-M: alien.structs:struct-type flatten-value-type ( type -- seq )
- flatten-struct ;
-M: classes.struct:struct-c-type flatten-value-type ( type -- seq )
+M: struct-c-type flatten-value-type ( type -- seq )
flatten-struct ;
M: x86.64 return-struct-in-registers? ( c-type -- ? )
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.cxx.parser alien.marshall
-alien.inline.types classes.mixin classes.tuple kernel namespaces
-assocs sequences parser classes.parser alien.marshall.syntax
-interpolate locals effects io strings make vocabs.parser words
-generic fry quotations ;
-IN: alien.cxx
-
-<PRIVATE
-: class-mixin ( str -- word )
- create-class-in [ define-mixin-class ] keep ;
-
-: class-tuple-word ( word -- word' )
- "#" append create-in ;
-
-: define-class-tuple ( word mixin -- )
- [ drop class-wrapper { } define-tuple-class ]
- [ add-mixin-instance ] 2bi ;
-PRIVATE>
-
-: define-c++-class ( name superclass-mixin -- )
- [ [ class-tuple-word ] [ class-mixin ] bi dup ] dip
- add-mixin-instance define-class-tuple ;
-
-:: define-c++-method ( class-name generic name types effect virtual -- )
- [ name % "_" % class-name { { CHAR: : CHAR: _ } } substitute % ] "" make :> name'
- effect [ in>> "self" suffix ] [ out>> ] bi <effect> :> effect'
- types class-name "*" append suffix :> types'
- effect in>> "," join :> args
- class-name virtual [ "#" append ] unless current-vocab lookup :> class
- SBUF" " clone dup [ I[ return self->${name}(${args});]I ] with-output-stream >string :> body
- name' types' effect' body define-c-marshalled
- class generic create-method name' current-vocab lookup 1quotation define ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: parser lexer alien.inline ;
-IN: alien.cxx.parser
-
-: parse-c++-class-definition ( -- class superclass-mixin )
- scan scan-word ;
-
-: parse-c++-method-definition ( -- class-name generic name types effect )
- scan scan-word function-types-effect ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.cxx.syntax alien.inline.syntax
-alien.marshall.syntax alien.marshall accessors kernel ;
-IN: alien.cxx.syntax.tests
-
-DELETE-C-LIBRARY: test
-C-LIBRARY: test
-
-COMPILE-AS-C++
-
-C-INCLUDE: <string>
-
-C-TYPEDEF: std::string string
-
-C++-CLASS: std::string c++-root
-
-GENERIC: to-string ( obj -- str )
-
-C++-METHOD: std::string to-string const-char* c_str ( )
-
-CM-FUNCTION: std::string* new_string ( const-char* s )
- return new std::string(s);
-;
-
-;C-LIBRARY
-
-ALIAS: <std::string> new_string
-
-{ 1 1 } [ new_string ] must-infer-as
-{ 1 1 } [ c_str_std__string ] must-infer-as
-[ t ] [ "abc" <std::string> std::string? ] unit-test
-[ "abc" ] [ "abc" <std::string> to-string ] unit-test
-
-
-DELETE-C-LIBRARY: inheritance
-C-LIBRARY: inheritance
-
-COMPILE-AS-C++
-
-C-INCLUDE: <cstring>
-
-<RAW-C
-class alpha {
- public:
- alpha(const char* s) {
- str = s;
- };
- const char* render() {
- return str;
- };
- virtual const char* chop() {
- return str;
- };
- virtual int length() {
- return strlen(str);
- };
- const char* str;
-};
-
-class beta : alpha {
- public:
- beta(const char* s) : alpha(s + 1) { };
- const char* render() {
- return str + 1;
- };
- virtual const char* chop() {
- return str + 2;
- };
-};
-RAW-C>
-
-C++-CLASS: alpha c++-root
-C++-CLASS: beta alpha
-
-CM-FUNCTION: alpha* new_alpha ( const-char* s )
- return new alpha(s);
-;
-
-CM-FUNCTION: beta* new_beta ( const-char* s )
- return new beta(s);
-;
-
-ALIAS: <alpha> new_alpha
-ALIAS: <beta> new_beta
-
-GENERIC: render ( obj -- obj )
-GENERIC: chop ( obj -- obj )
-GENERIC: length ( obj -- n )
-
-C++-METHOD: alpha render const-char* render ( )
-C++-METHOD: beta render const-char* render ( )
-C++-VIRTUAL: alpha chop const-char* chop ( )
-C++-VIRTUAL: beta chop const-char* chop ( )
-C++-VIRTUAL: alpha length int length ( )
-
-;C-LIBRARY
-
-{ 1 1 } [ render_alpha ] must-infer-as
-{ 1 1 } [ chop_beta ] must-infer-as
-{ 1 1 } [ length_alpha ] must-infer-as
-[ t ] [ "x" <alpha> alpha#? ] unit-test
-[ t ] [ "x" <alpha> alpha? ] unit-test
-[ t ] [ "x" <beta> alpha? ] unit-test
-[ f ] [ "x" <beta> alpha#? ] unit-test
-[ 5 ] [ "hello" <alpha> length ] unit-test
-[ 4 ] [ "hello" <beta> length ] unit-test
-[ "hello" ] [ "hello" <alpha> render ] unit-test
-[ "llo" ] [ "hello" <beta> render ] unit-test
-[ "ello" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying render ] unit-test
-[ "hello" ] [ "hello" <alpha> chop ] unit-test
-[ "lo" ] [ "hello" <beta> chop ] unit-test
-[ "lo" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying chop ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.cxx alien.cxx.parser ;
-IN: alien.cxx.syntax
-
-SYNTAX: C++-CLASS:
- parse-c++-class-definition define-c++-class ;
-
-SYNTAX: C++-METHOD:
- parse-c++-method-definition f define-c++-method ;
-
-SYNTAX: C++-VIRTUAL:
- parse-c++-method-definition t define-c++-method ;
+++ /dev/null
-Jeremy Hughes
+++ /dev/null
-Jeremy Hughes
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel strings words.symbol sequences ;
-IN: alien.inline.compiler
-
-HELP: C
-{ $var-description "A symbol representing C source." } ;
-
-HELP: C++
-{ $var-description "A symbol representing C++ source." } ;
-
-HELP: compile-to-library
-{ $values
- { "lang" symbol } { "args" sequence } { "contents" string } { "name" string }
-}
-{ $description "Compiles and links " { $snippet "contents" } " into a shared library called " { $snippet "libname.suffix" }
- "in " { $snippet "resource:alien-inline-libs" } ". " { $snippet "suffix" } " is OS specific. "
- { $snippet "args" } " is a sequence of arguments for the linking stage." }
-{ $notes
- { $list
- "C and C++ are the only supported languages."
- { "Source and object files are placed in " { $snippet "resource:temp" } "." } }
-} ;
-
-HELP: compiler
-{ $values
- { "lang" symbol }
- { "str" string }
-}
-{ $description "Returns a compiler name based on OS and source language." }
-{ $see-also compiler-descr } ;
-
-HELP: compiler-descr
-{ $values
- { "lang" symbol }
- { "descr" "a process description" }
-}
-{ $description "Returns a compiler process description based on OS and source language." }
-{ $see-also compiler } ;
-
-HELP: inline-library-file
-{ $values
- { "name" string }
- { "path" "a pathname string" }
-}
-{ $description "Appends " { $snippet "name" } " to the " { $link inline-libs-directory } "." } ;
-
-HELP: inline-libs-directory
-{ $values
- { "path" "a pathname string" }
-}
-{ $description "The directory where libraries created using " { $snippet "alien.inline" } " are stored." } ;
-
-HELP: library-path
-{ $values
- { "str" string }
- { "path" "a pathname string" }
-}
-{ $description "Converts " { $snippet "name" } " into a full path to the corresponding inline library." } ;
-
-HELP: library-suffix
-{ $values
- { "str" string }
-}
-{ $description "The appropriate shared library suffix for the current OS." } ;
-
-HELP: link-descr
-{ $values
- { "lang" "a language" }
- { "descr" sequence }
-}
-{ $description "Returns part of a process description. OS dependent." } ;
-
-ARTICLE: "alien.inline.compiler" "Inline C compiler"
-{ $vocab-link "alien.inline.compiler" }
-;
-
-ABOUT: "alien.inline.compiler"
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators fry generalizations
-io.encodings.ascii io.files io.files.temp io.launcher kernel
-locals make sequences system vocabs.parser words io.directories
-io.pathnames ;
-IN: alien.inline.compiler
-
-SYMBOL: C
-SYMBOL: C++
-
-: inline-libs-directory ( -- path )
- "alien-inline-libs" resource-path dup make-directories ;
-
-: inline-library-file ( name -- path )
- inline-libs-directory prepend-path ;
-
-: library-suffix ( -- str )
- os {
- { [ dup macosx? ] [ drop ".dylib" ] }
- { [ dup unix? ] [ drop ".so" ] }
- { [ dup windows? ] [ drop ".dll" ] }
- } cond ;
-
-: library-path ( str -- path )
- '[ "lib" % _ % library-suffix % ] "" make inline-library-file ;
-
-HOOK: compiler os ( lang -- str )
-
-M: word compiler
- {
- { C [ "gcc" ] }
- { C++ [ "g++" ] }
- } case ;
-
-M: openbsd compiler
- {
- { C [ "gcc" ] }
- { C++ [ "eg++" ] }
- } case ;
-
-M: windows compiler
- {
- { C [ "gcc" ] }
- { C++ [ "g++" ] }
- } case ;
-
-HOOK: compiler-descr os ( lang -- descr )
-
-M: word compiler-descr compiler 1array ;
-M: macosx compiler-descr
- call-next-method cpu x86.64?
- [ { "-arch" "x86_64" } append ] when ;
-
-HOOK: link-descr os ( lang -- descr )
-
-M: word link-descr drop { "-shared" "-o" } ;
-M: macosx link-descr
- drop { "-g" "-prebind" "-dynamiclib" "-o" }
- cpu x86.64? [ { "-arch" "x86_64" } prepend ] when ;
-M: windows link-descr
- {
- { C [ { "-mno-cygwin" "-shared" "-o" } ] }
- { C++ [ { "-lstdc++" "-mno-cygwin" "-shared" "-o" } ] }
- } case ;
-
-<PRIVATE
-: src-suffix ( lang -- str )
- {
- { C [ ".c" ] }
- { C++ [ ".cpp" ] }
- } case ;
-
-: link-command ( args in out lang -- descr )
- [ 2array ] dip [ compiler 1array ] [ link-descr ] bi
- append 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
- lang compiler-descr { "-fPIC" "-c" "-o" } append prepend
- try-process ;
-
-:: link-object ( lang args name -- )
- args name [ library-path ]
- [ ".o" append temp-file ] bi
- lang link-command try-process ;
-PRIVATE>
-
-:: compile-to-library ( lang args contents name -- )
- lang contents name compile-to-object
- lang args name link-object ;
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel strings effects quotations ;
-IN: alien.inline
-
-<PRIVATE
-: $binding-note ( x -- )
- drop
- { "This word requires that certain variables are correctly bound. "
- "Call " { $link POSTPONE: define-c-library } " to set them up." } print-element ;
-PRIVATE>
-
-HELP: compile-c-library
-{ $description "Writes, compiles, and links code generated since last invocation of " { $link POSTPONE: define-c-library } ". "
- "Also calls " { $snippet "add-library" } ". "
- "This word does nothing if the shared library is younger than the factor source file." }
-{ $notes $binding-note } ;
-
-HELP: c-use-framework
-{ $values
- { "str" string }
-}
-{ $description "OS X only. Adds " { $snippet "-framework name" } " to linker command." }
-{ $notes $binding-note }
-{ $see-also c-link-to c-link-to/use-framework } ;
-
-HELP: define-c-function
-{ $values
- { "function" "function name" } { "types" "a sequence of C types" } { "effect" effect } { "body" string }
-}
-{ $description "Defines a C function and a factor word which calls it." }
-{ $notes
- { $list
- { "The number of " { $snippet "types" } " must match the " { $snippet "in" } " count of the " { $snippet "effect" } "." }
- { "There must be only one " { $snippet "out" } " element. It must be a legal C return type with dashes (-) instead of spaces." }
- $binding-note
- }
-}
-{ $see-also POSTPONE: define-c-function' } ;
-
-HELP: define-c-function'
-{ $values
- { "function" "function name" } { "effect" effect } { "body" string }
-}
-{ $description "Defines a C function and a factor word which calls it. See " { $link define-c-function } " for more information." }
-{ $notes
- { $list
- { "Each effect element must be a legal C type with dashes (-) instead of spaces. "
- "C argument names will be generated alphabetically, starting with " { $snippet "a" } "." }
- $binding-note
- }
-}
-{ $see-also define-c-function } ;
-
-HELP: c-include
-{ $values
- { "str" string }
-}
-{ $description "Appends an include line to the C library in scope." }
-{ $notes $binding-note } ;
-
-HELP: define-c-library
-{ $values
- { "name" string }
-}
-{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " words can be used after this one." } ;
-
-HELP: c-link-to
-{ $values
- { "str" string }
-}
-{ $description "Adds " { $snippet "-lname" } " to linker command." }
-{ $notes $binding-note }
-{ $see-also c-use-framework c-link-to/use-framework } ;
-
-HELP: c-link-to/use-framework
-{ $values
- { "str" string }
-}
-{ $description "Equivalent to " { $link c-use-framework } " on OS X and " { $link c-link-to } " everywhere else." }
-{ $notes $binding-note }
-{ $see-also c-link-to c-use-framework } ;
-
-HELP: define-c-struct
-{ $values
- { "name" string } { "fields" "type/name pairs" }
-}
-{ $description "Defines a C struct and factor words which operate on it." }
-{ $notes $binding-note } ;
-
-HELP: define-c-typedef
-{ $values
- { "old" "C type" } { "new" "C type" }
-}
-{ $description "Define C and factor typedefs." }
-{ $notes $binding-note } ;
-
-HELP: delete-inline-library
-{ $values
- { "name" string }
-}
-{ $description "Delete the shared library file corresponding to " { $snippet "name" } "." }
-{ $notes "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " } ;
-
-HELP: with-c-library
-{ $values
- { "name" string } { "quot" quotation }
-}
-{ $description "Calls " { $link define-c-library } ", then the quotation, then " { $link compile-c-library } ", then sets all variables bound by " { $snippet "define-c-library" } " to " { $snippet "f" } "." } ;
-
-HELP: raw-c
-{ $values { "str" string } }
-{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.inline.compiler alien.inline.types
-alien.libraries alien.parser arrays assocs effects fry
-generalizations grouping io.directories io.files
-io.files.info io.files.temp kernel lexer math math.order
-math.ranges multiline namespaces sequences source-files
-splitting strings system vocabs.loader vocabs.parser words
-alien.c-types alien.structs make parser continuations ;
-IN: alien.inline
-
-SYMBOL: c-library
-SYMBOL: library-is-c++
-SYMBOL: linker-args
-SYMBOL: c-strings
-
-<PRIVATE
-: cleanup-variables ( -- )
- { c-library library-is-c++ linker-args c-strings }
- [ off ] each ;
-
-: arg-list ( types -- params )
- CHAR: a swap length CHAR: a + [a,b]
- [ 1string ] map ;
-
-: compile-library? ( -- ? )
- c-library get library-path dup exists? [
- file get [
- path>>
- [ file-info modified>> ] bi@ <=> +lt+ =
- ] [ drop t ] if*
- ] [ drop t ] if ;
-
-: compile-library ( -- )
- library-is-c++ get [ C++ ] [ C ] if
- linker-args get
- c-strings get "\n" join
- c-library get compile-to-library ;
-
-: c-library-name ( name -- name' )
- [ current-vocab name>> % "_" % % ] "" make ;
-PRIVATE>
-
-: parse-arglist ( parameters return -- types effect )
- [ 2 group unzip [ "," ?tail drop ] map ]
- [ [ { } ] [ 1array ] if-void ]
- bi* <effect> ;
-
-: append-function-body ( prototype-str body -- str )
- [ swap % " {\n" % % "\n}\n" % ] "" make ;
-
-: function-types-effect ( -- function types effect )
- scan scan swap ")" parse-tokens
- [ "(" subseq? not ] filter swap parse-arglist ;
-
-: prototype-string ( function types effect -- str )
- [ [ cify-type ] map ] dip
- types-effect>params-return cify-type -rot
- [ " " join ] map ", " join
- "(" prepend ")" append 3array " " join
- library-is-c++ get [ "extern \"C\" " prepend ] when ;
-
-: prototype-string' ( function types return -- str )
- [ dup arg-list ] <effect> prototype-string ;
-
-: factor-function ( function types effect -- word quot effect )
- annotate-effect [ c-library get ] 3dip
- [ [ factorize-type ] map ] dip
- types-effect>params-return factorize-type -roll
- concat make-function ;
-
-: define-c-library ( name -- )
- c-library-name [ c-library set ] [ "c-library" set ] bi
- V{ } clone c-strings set
- V{ } clone linker-args set ;
-
-: compile-c-library ( -- )
- compile-library? [ compile-library ] when
- c-library get dup library-path "cdecl" add-library ;
-
-: define-c-function ( function types effect body -- )
- [
- [ factor-function define-declared ]
- [ prototype-string ] 3bi
- ] dip append-function-body c-strings get push ;
-
-: define-c-function' ( function effect body -- )
- [
- [ in>> ] keep
- [ factor-function define-declared ]
- [ out>> prototype-string' ] 3bi
- ] dip append-function-body c-strings get push ;
-
-: c-link-to ( str -- )
- "-l" prepend linker-args get push ;
-
-: c-use-framework ( str -- )
- "-framework" swap linker-args get '[ _ push ] bi@ ;
-
-: c-link-to/use-framework ( str -- )
- os macosx? [ c-use-framework ] [ c-link-to ] if ;
-
-: c-include ( str -- )
- "#include " prepend c-strings get push ;
-
-: define-c-typedef ( old new -- )
- [ typedef ] [
- [ swap "typedef " % % " " % % ";" % ]
- "" make c-strings get push
- ] 2bi ;
-
-: define-c-struct ( name fields -- )
- [ current-vocab swap define-struct ] [
- over
- [
- "typedef struct " % "_" % % " {\n" %
- [ first2 swap % " " % % ";\n" % ] each
- "} " % % ";\n" %
- ] "" make c-strings get push
- ] 2bi ;
-
-: delete-inline-library ( name -- )
- c-library-name [ remove-library ]
- [ library-path dup exists? [ delete-file ] [ drop ] if ] bi ;
-
-: with-c-library ( name quot -- )
- [ [ define-c-library ] dip call compile-c-library ]
- [ cleanup-variables ] [ ] cleanup ; inline
-
-: raw-c ( str -- )
- [ "\n" % % "\n" % ] "" make c-strings get push ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax alien.inline ;
-IN: alien.inline.syntax
-
-HELP: ;C-LIBRARY
-{ $syntax ";C-LIBRARY" }
-{ $description "Writes, compiles, and links code generated since previous invocation of " { $link POSTPONE: C-LIBRARY: } "." }
-{ $see-also POSTPONE: compile-c-library } ;
-
-HELP: C-FRAMEWORK:
-{ $syntax "C-FRAMEWORK: name" }
-{ $description "OS X only. Link to named framework. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
-{ $see-also POSTPONE: c-use-framework } ;
-
-HELP: C-FUNCTION:
-{ $syntax "C-FUNCTION: return name ( args ... )\nbody\n;" }
-{ $description "Appends a function to the C library in scope and defines an FFI word that calls it." }
-{ $examples
- { $example
- "USING: alien.inline.syntax prettyprint ;"
- "IN: cmath.ffi"
- ""
- "C-LIBRARY: cmathlib"
- ""
- "C-FUNCTION: int add ( int a, int b )"
- " return a + b;"
- ";"
- ""
- ";C-LIBRARY"
- ""
- "1 2 add ."
- "3" }
-}
-{ $see-also POSTPONE: define-c-function } ;
-
-HELP: C-INCLUDE:
-{ $syntax "C-INCLUDE: name" }
-{ $description "Appends an include line to the C library in scope." }
-{ $see-also POSTPONE: c-include } ;
-
-HELP: C-LIBRARY:
-{ $syntax "C-LIBRARY: name" }
-{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " syntax can be used after this word." }
-{ $examples
- { $example
- "USING: alien.inline.syntax ;"
- "IN: rectangle.ffi"
- ""
- "C-LIBRARY: rectlib"
- ""
- "C-STRUCTURE: rectangle { \"int\" \"width\" } { \"int\" \"height\" } ;"
- ""
- "C-FUNCTION: int area ( rectangle c )"
- " return c.width * c.height;"
- ";"
- ""
- ";C-LIBRARY"
- "" }
-}
-{ $see-also POSTPONE: define-c-library } ;
-
-HELP: C-LINK/FRAMEWORK:
-{ $syntax "C-LINK/FRAMEWORK: name" }
-{ $description "Equivalent to " { $link POSTPONE: C-FRAMEWORK: } " on OS X and " { $link POSTPONE: C-LINK: } " everywhere else." }
-{ $see-also POSTPONE: c-link-to/use-framework } ;
-
-HELP: C-LINK:
-{ $syntax "C-LINK: name" }
-{ $description "Link to named library. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
-{ $see-also POSTPONE: c-link-to } ;
-
-HELP: C-STRUCTURE:
-{ $syntax "C-STRUCTURE: name pairs ... ;" }
-{ $description "Like " { $snippet "C-STRUCT:" } " but also generates equivalent C code."}
-{ $see-also POSTPONE: define-c-struct } ;
-
-HELP: C-TYPEDEF:
-{ $syntax "C-TYPEDEF: old new" }
-{ $description "Like " { $snippet "TYPEDEF:" } " but generates a C typedef statement too." }
-{ $see-also POSTPONE: define-c-typedef } ;
-
-HELP: COMPILE-AS-C++
-{ $syntax "COMPILE-AS-C++" }
-{ $description "Insert this word anywhere between " { $link POSTPONE: C-LIBRARY: } " and " { $link POSTPONE: ;C-LIBRARY } " and the generated code will be treated as C++ with " { $snippet "extern \"C\"" } " prepended to each function prototype." } ;
-
-HELP: DELETE-C-LIBRARY:
-{ $syntax "DELETE-C-LIBRARY: name" }
-{ $description "Deletes the shared library file corresponding to " { $snippet "name" } " . " }
-{ $notes
- { $list
- { "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " }
- "This word is mainly useful for unit tests."
- }
-}
-{ $see-also POSTPONE: delete-inline-library } ;
-
-HELP: <RAW-C
-{ $syntax "<RAW-C code RAW-C>" }
-{ $description "Insert a (multiline) string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.inline alien.inline.syntax io.directories io.files
-kernel namespaces tools.test alien.c-types alien.data alien.structs ;
-IN: alien.inline.syntax.tests
-
-DELETE-C-LIBRARY: test
-C-LIBRARY: test
-
-C-FUNCTION: const-int add ( int a, int b )
- return a + b;
-;
-
-C-TYPEDEF: double bigfloat
-
-C-FUNCTION: bigfloat smaller ( bigfloat a )
- return a / 10;
-;
-
-C-STRUCTURE: rectangle
- { "int" "width" }
- { "int" "height" } ;
-
-C-FUNCTION: int area ( rectangle c )
- return c.width * c.height;
-;
-
-;C-LIBRARY
-
-{ 2 1 } [ add ] must-infer-as
-[ 5 ] [ 2 3 add ] unit-test
-
-[ t ] [ "double" "bigfloat" [ resolve-typedef ] bi@ = ] unit-test
-{ 1 1 } [ smaller ] must-infer-as
-[ 1.0 ] [ 10 smaller ] unit-test
-
-[ t ] [ "rectangle" resolve-typedef struct-type? ] unit-test
-{ 1 1 } [ area ] must-infer-as
-[ 20 ] [
- "rectangle" <c-object>
- 4 over set-rectangle-width
- 5 over set-rectangle-height
- area
-] unit-test
-
-
-DELETE-C-LIBRARY: cpplib
-C-LIBRARY: cpplib
-
-COMPILE-AS-C++
-
-C-INCLUDE: <string>
-
-C-FUNCTION: const-char* hello ( )
- std::string s("hello world");
- return s.c_str();
-;
-
-;C-LIBRARY
-
-{ 0 1 } [ hello ] must-infer-as
-[ "hello world" ] [ hello ] unit-test
-
-
-DELETE-C-LIBRARY: compile-error
-C-LIBRARY: compile-error
-
-C-FUNCTION: char* breakme ( )
- return not a string;
-;
-
-<< [ compile-c-library ] must-fail >>
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.inline lexer multiline namespaces parser ;
-IN: alien.inline.syntax
-
-
-SYNTAX: C-LIBRARY: scan define-c-library ;
-
-SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
-
-SYNTAX: C-LINK: scan c-link-to ;
-
-SYNTAX: C-FRAMEWORK: scan c-use-framework ;
-
-SYNTAX: C-LINK/FRAMEWORK: scan c-link-to/use-framework ;
-
-SYNTAX: C-INCLUDE: scan c-include ;
-
-SYNTAX: C-FUNCTION:
- function-types-effect parse-here define-c-function ;
-
-SYNTAX: C-TYPEDEF: scan scan define-c-typedef ;
-
-SYNTAX: C-STRUCTURE:
- scan parse-definition define-c-struct ;
-
-SYNTAX: ;C-LIBRARY compile-c-library ;
-
-SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ;
-
-SYNTAX: <RAW-C "RAW-C>" parse-multiline-string raw-c ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! 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 strings peg.ebnf make words ;
-IN: alien.inline.types
-
-: cify-type ( str -- str' )
- dup word? [ name>> ] when
- { { CHAR: - CHAR: space } } substitute ;
-
-: factorize-type ( str -- str' )
- cify-type
- "const " ?head drop
- "unsigned " ?head [ "u" prepend ] when
- "long " ?head [ "long" prepend ] when
- " const" ?tail drop ;
-
-: const-pointer? ( str -- ? )
- cify-type { [ " const" tail? ] [ "&" tail? ] } 1|| ;
-
-: pointer-to-const? ( str -- ? )
- cify-type "const " head? ;
-
-: template-class? ( str -- ? )
- [ CHAR: < = ] any? ;
-
-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 -- ? )
- factorize-type [ "*" tail? ] [ "&" tail? ] bi or ;
-
-: type-sans-pointer ( type -- type' )
- factorize-type [ '[ _ = ] "*&" swap any? ] trim-tail ;
-
-: pointer-to-primitive? ( type -- ? )
- factorize-type
- { [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ;
-
-: pointer-to-non-const-primitive? ( str -- ? )
- {
- [ pointer-to-const? not ]
- [ factorize-type pointer-to-primitive? ]
- } 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> ;
-
-TUPLE: c++-type name params ptr ;
-C: <c++-type> c++-type
-
-EBNF: (parse-c++-type)
-dig = [0-9]
-alpha = [a-zA-Z]
-alphanum = [1-9a-zA-Z]
-name = [_a-zA-Z] [_a-zA-Z1-9:]* => [[ first2 swap prefix >string ]]
-ptr = [*&] => [[ empty? not ]]
-
-param = "," " "* type " "* => [[ third ]]
-
-params = "<" " "* type " "* param* ">" => [[ [ 4 swap nth ] [ third ] bi prefix ]]
-
-type = name " "* params? " "* ptr? => [[ { 0 2 4 } [ swap nth ] with map first3 <c++-type> ]]
-;EBNF
-
-: parse-c++-type ( str -- c++-type )
- factorize-type (parse-c++-type) ;
-
-DEFER: c++-type>string
-
-: params>string ( params -- str )
- [ "<" % [ c++-type>string ] map "," join % ">" % ] "" make ;
-
-: c++-type>string ( c++-type -- str )
- [
- [ name>> % ]
- [ params>> [ params>string % ] when* ]
- [ ptr>> [ "*" % ] when ]
- tri
- ] "" make ;
-
-GENERIC: c++-type ( obj -- c++-type/f )
-
-M: object c++-type drop f ;
-
-M: c++-type c-type ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations sequences
-strings alien alien.c-types alien.data math byte-arrays ;
-IN: alien.marshall
-
-<PRIVATE
-: $memory-note ( arg -- )
- drop "This word returns a pointer to unmanaged memory."
- print-element ;
-
-: $c-ptr-note ( arg -- )
- drop "Does nothing if its argument is a non false c-ptr."
- print-element ;
-
-: $see-article ( arg -- )
- drop { "See " { $vocab-link "alien.inline" } "." }
- print-element ;
-PRIVATE>
-
-HELP: ?malloc-byte-array
-{ $values
- { "c-type" c-type }
- { "alien" alien }
-}
-{ $description "Does nothing if input is an alien, otherwise assumes it is a byte array and calls "
- { $snippet "malloc-byte-array" } "."
-}
-{ $notes $memory-note } ;
-
-HELP: alien-wrapper
-{ $var-description "For wrapping C pointers in a structure factor can dispatch on." } ;
-
-HELP: unmarshall-cast
-{ $values
- { "alien-wrapper" alien-wrapper }
- { "alien-wrapper'" alien-wrapper }
-}
-{ $description "Called immediately after unmarshalling. Useful for automatically casting to subtypes." } ;
-
-HELP: marshall-bool
-{ $values
- { "?" "a generalized boolean" }
- { "n" "0 or 1" }
-}
-{ $description "Marshalls objects to bool." }
-{ $notes "Will treat " { $snippet "0" } " as " { $snippet "t" } "." } ;
-
-HELP: marshall-bool*
-{ $values
- { "?/seq" "t/f or sequence" }
- { "alien" alien }
-}
-{ $description "When the argument is a sequence, returns a pointer to an array of bool, "
- "otherwise returns a pointer to a single bool value."
-}
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-bool**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description "Takes a one or two dimensional array of generalized booleans "
- "and returns a pointer to the equivalent C structure."
-}
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-primitive
-{ $values
- { "n" number }
- { "n" number }
-}
-{ $description "Marshall numbers to C primitives."
- $nl
- "Factor marshalls numbers to primitives for FFI calls, so all "
- "this word does is convert " { $snippet "t" } " to " { $snippet "1" }
- ", " { $snippet "f" } " to " { $snippet "0" } ", and lets anything else "
- "pass through untouched."
-} ;
-
-HELP: marshall-char*
-{ $values
- { "n/seq" "number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-char**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-char**-or-strings
-{ $values
- { "seq" "a sequence of strings" }
- { "alien" alien }
-}
-{ $description "Marshalls an array of strings or characters to an array of C strings." }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-char*-or-string
-{ $values
- { "n/string" "a number or string" }
- { "alien" alien }
-}
-{ $description "Marshalls a string to a C string or a number to a pointer to " { $snippet "char" } "." }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-double*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-double**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-float*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-float**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-int*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-int**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-long*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-long**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-longlong*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-longlong**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-non-pointer
-{ $values
- { "alien-wrapper/byte-array" "an alien-wrapper or byte-array" }
- { "byte-array" byte-array }
-}
-{ $description "Converts argument to a byte array." }
-{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
-
-HELP: marshall-pointer
-{ $values
- { "obj" object }
- { "alien" alien }
-}
-{ $description "Converts argument to a C pointer." }
-{ $notes "Can marshall the following types: " { $snippet "alien, f, byte-array, alien-wrapper, struct-array" } "." } ;
-
-HELP: marshall-short*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-short**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-uchar*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-uchar**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-uint*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-uint**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-ulong*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-ulong**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-ulonglong*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-ulonglong**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-ushort*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-ushort**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-void**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description "Marshalls a sequence of objects to an array of pointers to void." }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshaller
-{ $values
- { "type" "a C type string" }
- { "quot" quotation }
-}
-{ $description "Given a C type, returns a quotation that will marshall its argument to that type." } ;
-
-HELP: out-arg-unmarshaller
-{ $values
- { "type" "a C type string" }
- { "quot" quotation }
-}
-{ $description "Like " { $link unmarshaller } " but returns an empty quotation "
- "for all types except pointers to non-const primitives."
-} ;
-
-HELP: class-unmarshaller
-{ $values
- { "type" " a C type string" }
- { "quot/f" quotation }
-}
-{ $description "If in the vocab in which this word is called, there is a subclass of " { $link alien-wrapper }
- " named after the type argument, " { $snippet "pointer-unmarshaller" } " will return a quotation which "
- "wraps its argument in an instance of that subclass. In any other case it returns an empty quotation."
-}
-{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
-
-HELP: primitive-marshaller
-{ $values
- { "type" "a C type string" }
- { "quot/f" "a quotation or f" }
-}
-{ $description "Returns a quotation to marshall objects to the argument type." }
-{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
-
-HELP: primitive-unmarshaller
-{ $values
- { "type" "a C type string" }
- { "quot/f" "a quotation or f" }
-}
-{ $description "Returns a quotation to unmarshall objects from the argument type." }
-{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
-
-HELP: struct-field-unmarshaller
-{ $values
- { "type" "a C type string" }
- { "quot" quotation }
-}
-{ $description "Like " { $link unmarshaller } " but returns a quotation that "
- "does not call " { $snippet "free" } " on its argument."
-}
-{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
-
-HELP: struct-primitive-unmarshaller
-{ $values
- { "type" "a C type string" }
- { "quot/f" "a quotation or f" }
-}
-{ $description "Like " { $link primitive-unmarshaller } " but returns a quotation that "
- "does not call " { $snippet "free" } " on its argument." }
-{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
-
-HELP: struct-unmarshaller
-{ $values
- { "type" "a C type string" }
- { "quot/f" quotation }
-}
-{ $description "Returns a quotation which wraps its argument in the subclass of "
- { $link struct-wrapper } " which matches the " { $snippet "type" } " arg."
-}
-{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
-
-HELP: struct-wrapper
-{ $var-description "For wrapping C structs in a structure factor can dispatch on." } ;
-
-HELP: unmarshall-bool
-{ $values
- { "n" number }
- { "?" "a boolean" }
-}
-{ $description "Unmarshalls a number to a boolean." } ;
-
-HELP: unmarshall-bool*
-{ $values
- { "alien" alien }
- { "?" "a boolean" }
-}
-{ $description "Unmarshalls a C pointer to a boolean." } ;
-
-HELP: unmarshall-bool*-free
-{ $values
- { "alien" alien }
- { "?" "a boolean" }
-}
-{ $description "Unmarshalls a C pointer to a boolean and frees the pointer." } ;
-
-HELP: unmarshall-char*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-char*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-char*-to-string
-{ $values
- { "alien" alien }
- { "string" string }
-}
-{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string." } ;
-
-HELP: unmarshall-char*-to-string-free
-{ $values
- { "alien" alien }
- { "string" string }
-}
-{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string and frees the pointer." } ;
-
-HELP: unmarshall-double*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-double*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-float*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-float*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-int*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-int*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-long*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-long*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-longlong*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-longlong*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-short*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-short*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-uchar*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-uchar*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-uint*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-uint*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-ulong*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-ulong*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-ulonglong*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-ulonglong*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-ushort*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-ushort*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshaller
-{ $values
- { "type" "a C type string" }
- { "quot" quotation }
-}
-{ $description "Given a C type, returns a quotation that will unmarshall values of that type." } ;
-
-ARTICLE: "alien.marshall" "C marshalling"
-{ $vocab-link "alien.marshall" } " provides alien wrappers and marshalling words for the "
-"automatic marshalling and unmarshalling of C function arguments, return values, and output parameters."
-
-{ $subheading "Important words" }
-"Wrap an alien:" { $subsection alien-wrapper }
-"Wrap a struct:" { $subsection struct-wrapper }
-"Get the marshaller for a C type:" { $subsection marshaller }
-"Get the unmarshaller for a C type:" { $subsection unmarshaller }
-"Get the unmarshaller for an output parameter:" { $subsection out-arg-unmarshaller }
-"Get the unmarshaller for a struct field:" { $subsection struct-field-unmarshaller }
-$nl
-"Other marshalling and unmarshalling words in this vocabulary are not intended to be "
-"invoked directly."
-$nl
-"Most marshalling words allow non false c-ptrs to pass through unchanged."
-
-{ $subheading "Primitive marshallers" }
-{ $subsection marshall-primitive } "for marshalling primitive values."
-{ $subsection marshall-int* }
- "marshalls a number or sequence of numbers. If argument is a sequence, returns a pointer "
- "to a C array, otherwise returns a pointer to a single value."
-{ $subsection marshall-int** }
-"marshalls a 1D or 2D array of numbers. Returns an array of pointers to arrays."
-
-{ $subheading "Primitive unmarshallers" }
-{ $snippet "unmarshall-<prim>*" } " and " { $snippet "unmarshall-<prim>*-free" }
-" for all values of " { $snippet "<prim>" } " in " { $link primitive-types } "."
-{ $subsection unmarshall-int* }
-"unmarshalls a pointer to primitive. Returns a number. "
-"Assumes the pointer is not an array (if it is, only the first value is returned). "
-"C functions that return arrays are not handled correctly by " { $snippet "alien.marshall" }
-" and must be unmarshalled by hand."
-{ $subsection unmarshall-int*-free }
-"unmarshalls a pointer to primitive, and then frees the pointer."
-$nl
-"Primitive values require no unmarshalling. The factor FFI already does this."
-;
-
-ABOUT: "alien.marshall"
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.inline.types
-alien.marshall.private alien.strings byte-arrays classes
-combinators combinators.short-circuit destructors fry
-io.encodings.utf8 kernel libc sequences alien.data
-specialized-arrays strings unix.utilities vocabs.parser
-words libc.private locals generalizations math ;
-FROM: alien.c-types => float short ;
-SPECIALIZED-ARRAY: bool
-SPECIALIZED-ARRAY: char
-SPECIALIZED-ARRAY: double
-SPECIALIZED-ARRAY: float
-SPECIALIZED-ARRAY: int
-SPECIALIZED-ARRAY: long
-SPECIALIZED-ARRAY: longlong
-SPECIALIZED-ARRAY: short
-SPECIALIZED-ARRAY: uchar
-SPECIALIZED-ARRAY: uint
-SPECIALIZED-ARRAY: ulong
-SPECIALIZED-ARRAY: ulonglong
-SPECIALIZED-ARRAY: ushort
-SPECIALIZED-ARRAY: void*
-IN: alien.marshall
-
-<< primitive-types [ [ void* = ] [ bool = ] bi or not ]
-filter [ define-primitive-marshallers ] each >>
-
-TUPLE: alien-wrapper { underlying alien } ;
-TUPLE: struct-wrapper < alien-wrapper disposed ;
-TUPLE: class-wrapper < alien-wrapper disposed ;
-
-MIXIN: c++-root
-
-GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
-
-M: alien-wrapper unmarshall-cast ;
-M: struct-wrapper unmarshall-cast ;
-
-M: struct-wrapper dispose* underlying>> free ;
-
-M: class-wrapper c++-type class name>> parse-c++-type ;
-
-: marshall-pointer ( obj -- alien )
- {
- { [ dup alien? ] [ ] }
- { [ dup not ] [ ] }
- { [ dup byte-array? ] [ malloc-byte-array ] }
- { [ dup alien-wrapper? ] [ underlying>> ] }
- } cond ;
-
-: marshall-primitive ( n -- n )
- [ bool>arg ] ptr-pass-through ;
-
-ALIAS: marshall-void* marshall-pointer
-
-: marshall-void** ( seq -- alien )
- [ marshall-void* ] void*-array{ } map-as malloc-underlying ;
-
-: (marshall-char*-or-string) ( n/string -- alien )
- dup string?
- [ utf8 string>alien malloc-byte-array ]
- [ (marshall-char*) ] if ;
-
-: marshall-char*-or-string ( n/string -- alien )
- [ (marshall-char*-or-string) ] ptr-pass-through ;
-
-: (marshall-char**-or-strings) ( seq -- alien )
- [ marshall-char*-or-string ] void*-array{ } map-as
- malloc-underlying ;
-
-: marshall-char**-or-strings ( seq -- alien )
- [ (marshall-char**-or-strings) ] ptr-pass-through ;
-
-: marshall-bool ( ? -- n )
- >boolean [ 1 ] [ 0 ] if ;
-
-: (marshall-bool*) ( ?/seq -- alien )
- [ marshall-bool <bool> malloc-byte-array ]
- [ >bool-array malloc-underlying ]
- marshall-x* ;
-
-: marshall-bool* ( ?/seq -- alien )
- [ (marshall-bool*) ] ptr-pass-through ;
-
-: (marshall-bool**) ( seq -- alien )
- [ marshall-bool* ] map >void*-array malloc-underlying ;
-
-: marshall-bool** ( seq -- alien )
- [ (marshall-bool**) ] ptr-pass-through ;
-
-: unmarshall-bool ( n -- ? )
- 0 = not ;
-
-: unmarshall-bool* ( alien -- ? )
- *bool unmarshall-bool ;
-
-: unmarshall-bool*-free ( alien -- ? )
- [ *bool unmarshall-bool ] keep add-malloc free ;
-
-: primitive-marshaller ( type -- quot/f )
- {
- { "bool" [ [ ] ] }
- { "boolean" [ [ marshall-bool ] ] }
- { "char" [ [ marshall-primitive ] ] }
- { "uchar" [ [ marshall-primitive ] ] }
- { "short" [ [ marshall-primitive ] ] }
- { "ushort" [ [ marshall-primitive ] ] }
- { "int" [ [ marshall-primitive ] ] }
- { "uint" [ [ marshall-primitive ] ] }
- { "long" [ [ marshall-primitive ] ] }
- { "ulong" [ [ marshall-primitive ] ] }
- { "long" [ [ marshall-primitive ] ] }
- { "ulong" [ [ marshall-primitive ] ] }
- { "float" [ [ marshall-primitive ] ] }
- { "double" [ [ marshall-primitive ] ] }
- { "bool*" [ [ marshall-bool* ] ] }
- { "boolean*" [ [ marshall-bool* ] ] }
- { "char*" [ [ marshall-char*-or-string ] ] }
- { "uchar*" [ [ marshall-uchar* ] ] }
- { "short*" [ [ marshall-short* ] ] }
- { "ushort*" [ [ marshall-ushort* ] ] }
- { "int*" [ [ marshall-int* ] ] }
- { "uint*" [ [ marshall-uint* ] ] }
- { "long*" [ [ marshall-long* ] ] }
- { "ulong*" [ [ marshall-ulong* ] ] }
- { "longlong*" [ [ marshall-longlong* ] ] }
- { "ulonglong*" [ [ marshall-ulonglong* ] ] }
- { "float*" [ [ marshall-float* ] ] }
- { "double*" [ [ marshall-double* ] ] }
- { "bool&" [ [ marshall-bool* ] ] }
- { "boolean&" [ [ marshall-bool* ] ] }
- { "char&" [ [ marshall-char* ] ] }
- { "uchar&" [ [ marshall-uchar* ] ] }
- { "short&" [ [ marshall-short* ] ] }
- { "ushort&" [ [ marshall-ushort* ] ] }
- { "int&" [ [ marshall-int* ] ] }
- { "uint&" [ [ marshall-uint* ] ] }
- { "long&" [ [ marshall-long* ] ] }
- { "ulong&" [ [ marshall-ulong* ] ] }
- { "longlong&" [ [ marshall-longlong* ] ] }
- { "ulonglong&" [ [ marshall-ulonglong* ] ] }
- { "float&" [ [ marshall-float* ] ] }
- { "double&" [ [ marshall-double* ] ] }
- { "void*" [ [ marshall-void* ] ] }
- { "bool**" [ [ marshall-bool** ] ] }
- { "boolean**" [ [ marshall-bool** ] ] }
- { "char**" [ [ marshall-char**-or-strings ] ] }
- { "uchar**" [ [ marshall-uchar** ] ] }
- { "short**" [ [ marshall-short** ] ] }
- { "ushort**" [ [ marshall-ushort** ] ] }
- { "int**" [ [ marshall-int** ] ] }
- { "uint**" [ [ marshall-uint** ] ] }
- { "long**" [ [ marshall-long** ] ] }
- { "ulong**" [ [ marshall-ulong** ] ] }
- { "longlong**" [ [ marshall-longlong** ] ] }
- { "ulonglong**" [ [ marshall-ulonglong** ] ] }
- { "float**" [ [ marshall-float** ] ] }
- { "double**" [ [ marshall-double** ] ] }
- { "void**" [ [ marshall-void** ] ] }
- [ drop f ]
- } case ;
-
-: marshall-non-pointer ( alien-wrapper/byte-array -- byte-array )
- {
- { [ dup byte-array? ] [ ] }
- { [ dup alien-wrapper? ]
- [ [ underlying>> ] [ class name>> heap-size ] bi
- memory>byte-array ] }
- } cond ;
-
-
-: marshaller ( type -- quot )
- factorize-type dup primitive-marshaller [ nip ] [
- pointer?
- [ [ marshall-pointer ] ]
- [ [ marshall-non-pointer ] ] if
- ] if* ;
-
-
-: unmarshall-char*-to-string ( alien -- string )
- utf8 alien>string ;
-
-: unmarshall-char*-to-string-free ( alien -- string )
- [ unmarshall-char*-to-string ] keep add-malloc free ;
-
-: primitive-unmarshaller ( type -- quot/f )
- {
- { "bool" [ [ ] ] }
- { "boolean" [ [ unmarshall-bool ] ] }
- { "char" [ [ ] ] }
- { "uchar" [ [ ] ] }
- { "short" [ [ ] ] }
- { "ushort" [ [ ] ] }
- { "int" [ [ ] ] }
- { "uint" [ [ ] ] }
- { "long" [ [ ] ] }
- { "ulong" [ [ ] ] }
- { "longlong" [ [ ] ] }
- { "ulonglong" [ [ ] ] }
- { "float" [ [ ] ] }
- { "double" [ [ ] ] }
- { "bool*" [ [ unmarshall-bool*-free ] ] }
- { "boolean*" [ [ unmarshall-bool*-free ] ] }
- { "char*" [ [ ] ] }
- { "uchar*" [ [ unmarshall-uchar*-free ] ] }
- { "short*" [ [ unmarshall-short*-free ] ] }
- { "ushort*" [ [ unmarshall-ushort*-free ] ] }
- { "int*" [ [ unmarshall-int*-free ] ] }
- { "uint*" [ [ unmarshall-uint*-free ] ] }
- { "long*" [ [ unmarshall-long*-free ] ] }
- { "ulong*" [ [ unmarshall-ulong*-free ] ] }
- { "longlong*" [ [ unmarshall-long*-free ] ] }
- { "ulonglong*" [ [ unmarshall-ulong*-free ] ] }
- { "float*" [ [ unmarshall-float*-free ] ] }
- { "double*" [ [ unmarshall-double*-free ] ] }
- { "bool&" [ [ unmarshall-bool*-free ] ] }
- { "boolean&" [ [ unmarshall-bool*-free ] ] }
- { "char&" [ [ ] ] }
- { "uchar&" [ [ unmarshall-uchar*-free ] ] }
- { "short&" [ [ unmarshall-short*-free ] ] }
- { "ushort&" [ [ unmarshall-ushort*-free ] ] }
- { "int&" [ [ unmarshall-int*-free ] ] }
- { "uint&" [ [ unmarshall-uint*-free ] ] }
- { "long&" [ [ unmarshall-long*-free ] ] }
- { "ulong&" [ [ unmarshall-ulong*-free ] ] }
- { "longlong&" [ [ unmarshall-longlong*-free ] ] }
- { "ulonglong&" [ [ unmarshall-ulonglong*-free ] ] }
- { "float&" [ [ unmarshall-float*-free ] ] }
- { "double&" [ [ unmarshall-double*-free ] ] }
- [ drop f ]
- } case ;
-
-: struct-primitive-unmarshaller ( type -- quot/f )
- {
- { "bool" [ [ unmarshall-bool ] ] }
- { "boolean" [ [ unmarshall-bool ] ] }
- { "char" [ [ ] ] }
- { "uchar" [ [ ] ] }
- { "short" [ [ ] ] }
- { "ushort" [ [ ] ] }
- { "int" [ [ ] ] }
- { "uint" [ [ ] ] }
- { "long" [ [ ] ] }
- { "ulong" [ [ ] ] }
- { "longlong" [ [ ] ] }
- { "ulonglong" [ [ ] ] }
- { "float" [ [ ] ] }
- { "double" [ [ ] ] }
- { "bool*" [ [ unmarshall-bool* ] ] }
- { "boolean*" [ [ unmarshall-bool* ] ] }
- { "char*" [ [ ] ] }
- { "uchar*" [ [ unmarshall-uchar* ] ] }
- { "short*" [ [ unmarshall-short* ] ] }
- { "ushort*" [ [ unmarshall-ushort* ] ] }
- { "int*" [ [ unmarshall-int* ] ] }
- { "uint*" [ [ unmarshall-uint* ] ] }
- { "long*" [ [ unmarshall-long* ] ] }
- { "ulong*" [ [ unmarshall-ulong* ] ] }
- { "longlong*" [ [ unmarshall-long* ] ] }
- { "ulonglong*" [ [ unmarshall-ulong* ] ] }
- { "float*" [ [ unmarshall-float* ] ] }
- { "double*" [ [ unmarshall-double* ] ] }
- { "bool&" [ [ unmarshall-bool* ] ] }
- { "boolean&" [ [ unmarshall-bool* ] ] }
- { "char&" [ [ unmarshall-char* ] ] }
- { "uchar&" [ [ unmarshall-uchar* ] ] }
- { "short&" [ [ unmarshall-short* ] ] }
- { "ushort&" [ [ unmarshall-ushort* ] ] }
- { "int&" [ [ unmarshall-int* ] ] }
- { "uint&" [ [ unmarshall-uint* ] ] }
- { "long&" [ [ unmarshall-long* ] ] }
- { "ulong&" [ [ unmarshall-ulong* ] ] }
- { "longlong&" [ [ unmarshall-longlong* ] ] }
- { "ulonglong&" [ [ unmarshall-ulonglong* ] ] }
- { "float&" [ [ unmarshall-float* ] ] }
- { "double&" [ [ unmarshall-double* ] ] }
- [ drop f ]
- } case ;
-
-
-: ?malloc-byte-array ( c-type -- alien )
- dup alien? [ malloc-byte-array ] unless ;
-
-:: x-unmarshaller ( type type-quot superclass def clean -- quot/f )
- type type-quot call current-vocab lookup [
- dup superclasses superclass swap member?
- [ def call ] [ drop clean call f ] if
- ] [ clean call f ] if* ; inline
-
-: struct-unmarshaller ( type -- quot/f )
- [ ] \ struct-wrapper
- [ '[ ?malloc-byte-array _ new swap >>underlying ] ]
- [ ]
- x-unmarshaller ;
-
-: class-unmarshaller ( type -- quot/f )
- [ type-sans-pointer "#" append ] \ class-wrapper
- [ '[ _ new swap >>underlying ] ]
- [ ]
- x-unmarshaller ;
-
-: non-primitive-unmarshaller ( type -- quot/f )
- {
- { [ dup pointer? ] [ class-unmarshaller ] }
- [ struct-unmarshaller ]
- } cond ;
-
-: unmarshaller ( type -- quot )
- factorize-type {
- [ primitive-unmarshaller ]
- [ non-primitive-unmarshaller ]
- [ drop [ ] ]
- } 1|| ;
-
-: struct-field-unmarshaller ( type -- quot )
- factorize-type {
- [ struct-primitive-unmarshaller ]
- [ non-primitive-unmarshaller ]
- [ drop [ ] ]
- } 1|| ;
-
-: out-arg-unmarshaller ( type -- quot )
- dup pointer-to-non-const-primitive?
- [ factorize-type primitive-unmarshaller ]
- [ drop [ drop ] ] if ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.inline arrays
-combinators fry functors kernel lexer libc macros math
-sequences specialized-arrays libc.private
-combinators.short-circuit alien.data ;
-SPECIALIZED-ARRAY: void*
-IN: alien.marshall.private
-
-: bool>arg ( ? -- 1/0/obj )
- {
- { t [ 1 ] }
- { f [ 0 ] }
- [ ]
- } case ;
-
-MACRO: marshall-x* ( num-quot seq-quot -- alien )
- '[ bool>arg dup number? _ _ if ] ;
-
-: ptr-pass-through ( obj quot -- alien )
- over { [ c-ptr? ] [ ] } 1&& [ drop ] [ call ] if ; inline
-
-: malloc-underlying ( obj -- alien )
- underlying>> malloc-byte-array ;
-
-FUNCTOR: define-primitive-marshallers ( TYPE -- )
-<TYPE> IS <${TYPE}>
-*TYPE IS *${TYPE}
->TYPE-array IS >${TYPE}-array
-marshall-TYPE DEFINES marshall-${TYPE}
-(marshall-TYPE*) DEFINES (marshall-${TYPE}*)
-(marshall-TYPE**) DEFINES (marshall-${TYPE}**)
-marshall-TYPE* DEFINES marshall-${TYPE}*
-marshall-TYPE** DEFINES marshall-${TYPE}**
-marshall-TYPE*-free DEFINES marshall-${TYPE}*-free
-marshall-TYPE**-free DEFINES marshall-${TYPE}**-free
-unmarshall-TYPE* DEFINES unmarshall-${TYPE}*
-unmarshall-TYPE*-free DEFINES unmarshall-${TYPE}*-free
-WHERE
-<PRIVATE
-: (marshall-TYPE*) ( n/seq -- alien )
- [ <TYPE> malloc-byte-array ]
- [ >TYPE-array malloc-underlying ]
- marshall-x* ;
-PRIVATE>
-: marshall-TYPE* ( n/seq -- alien )
- [ (marshall-TYPE*) ] ptr-pass-through ;
-<PRIVATE
-: (marshall-TYPE**) ( seq -- alien )
- [ marshall-TYPE* ] void*-array{ } map-as malloc-underlying ;
-PRIVATE>
-: marshall-TYPE** ( seq -- alien )
- [ (marshall-TYPE**) ] ptr-pass-through ;
-: unmarshall-TYPE* ( alien -- n )
- *TYPE ; inline
-: unmarshall-TYPE*-free ( alien -- n )
- [ unmarshall-TYPE* ] keep add-malloc free ;
-;FUNCTOR
-
-SYNTAX: PRIMITIVE-MARSHALLERS:
-";" parse-tokens [ define-primitive-marshallers ] each ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: classes help.markup help.syntax kernel quotations words
-alien.marshall.structs strings alien.structs alien.marshall ;
-IN: alien.marshall.structs
-
-HELP: define-marshalled-struct
-{ $values
- { "name" string } { "vocab" "a vocabulary specifier" } { "fields" "an alist" }
-}
-{ $description "Calls " { $link define-struct } " and " { $link define-struct-tuple } "." } ;
-
-HELP: define-struct-tuple
-{ $values
- { "name" string }
-}
-{ $description "Defines a subclass of " { $link struct-wrapper } ", a constructor, "
- "and accessor words."
-} ;
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.marshall arrays assocs
-classes.tuple combinators destructors generalizations generic
-kernel libc locals parser quotations sequences slots words
-alien.structs lexer vocabs.parser fry effects alien.data ;
-IN: alien.marshall.structs
-
-<PRIVATE
-: define-struct-accessor ( class name quot -- )
- [ "accessors" create create-method dup make-inline ] dip define ;
-
-: define-struct-getter ( class name word type -- )
- [ ">>" append \ underlying>> ] 2dip
- struct-field-unmarshaller \ call 4array >quotation
- define-struct-accessor ;
-
-: define-struct-setter ( class name word type -- )
- [ "(>>" prepend ")" append ] 2dip
- marshaller [ underlying>> ] \ bi* roll 4array >quotation
- define-struct-accessor ;
-
-: define-struct-accessors ( class name type reader writer -- )
- [ dup define-protocol-slot ] 3dip
- [ drop swap define-struct-getter ]
- [ nip swap define-struct-setter ] 5 nbi ;
-
-: define-struct-constructor ( class -- )
- {
- [ name>> "<" prepend ">" append create-in ]
- [ '[ _ new ] ]
- [ name>> '[ _ malloc-object >>underlying ] append ]
- [ name>> 1array ]
- } cleave { } swap <effect> define-declared ;
-PRIVATE>
-
-:: define-struct-tuple ( name -- )
- name create-in :> class
- class struct-wrapper { } define-tuple-class
- class define-struct-constructor
- name c-type fields>> [
- class swap
- {
- [ name>> { { CHAR: space CHAR: - } } substitute ]
- [ type>> ] [ reader>> ] [ writer>> ]
- } cleave define-struct-accessors
- ] each ;
-
-: define-marshalled-struct ( name vocab fields -- )
- [ define-struct ] [ 2drop define-struct-tuple ] 3bi ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations words
-alien.inline alien.syntax effects alien.marshall
-alien.marshall.structs strings sequences alien.inline.syntax ;
-IN: alien.marshall.syntax
-
-HELP: CM-FUNCTION:
-{ $syntax "CM-FUNCTION: return name args\n body\n;" }
-{ $description "Like " { $link POSTPONE: C-FUNCTION: } " but with marshalling "
- "of arguments and return values."
-}
-{ $examples
- { $example
- "USING: alien.inline.syntax alien.marshall.syntax prettyprint ;"
- "IN: example"
- ""
- "C-LIBRARY: exlib"
- ""
- "C-INCLUDE: <stdio.h>"
- "C-INCLUDE: <stdlib.h>"
- "CM-FUNCTION: char* sum_diff ( const-int a, const-int b, int* x, int* y )"
- " *x = a + b;"
- " *y = a - b;"
- " char* s = (char*) malloc(sizeof(char) * 64);"
- " sprintf(s, \"sum %i, diff %i\", *x, *y);"
- " return s;"
- ";"
- ""
- ";C-LIBRARY"
- ""
- "8 5 0 0 sum_diff . . ."
- "3\n13\n\"sum 13, diff 3\""
- }
-}
-{ $see-also define-c-marshalled POSTPONE: C-FUNCTION: POSTPONE: M-FUNCTION: } ;
-
-HELP: CM-STRUCTURE:
-{ $syntax "CM-STRUCTURE: name fields ... ;" }
-{ $description "Like " { $link POSTPONE: C-STRUCTURE: } " but with marshalling of fields. "
- "Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words."
-}
-{ $see-also POSTPONE: C-STRUCTURE: POSTPONE: M-STRUCTURE: } ;
-
-HELP: M-FUNCTION:
-{ $syntax "M-FUNCTION: return name args ;" }
-{ $description "Like " { $link POSTPONE: FUNCTION: } " but with marshalling "
- "of arguments and return values."
-}
-{ $see-also marshalled-function POSTPONE: C-FUNCTION: POSTPONE: CM-FUNCTION: } ;
-
-HELP: M-STRUCTURE:
-{ $syntax "M-STRUCTURE: name fields ... ;" }
-{ $description "Like " { $link POSTPONE: C-STRUCT: } " but with marshalling of fields. "
- "Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words."
-}
-{ $see-also define-marshalled-struct POSTPONE: C-STRUCTURE: POSTPONE: CM-STRUCTURE: } ;
-
-HELP: define-c-marshalled
-{ $values
- { "name" string } { "types" sequence } { "effect" effect } { "body" string }
-}
-{ $description "Defines a C function and a factor word which calls it with marshalling of "
- "args and return values."
-}
-{ $see-also define-c-marshalled' } ;
-
-HELP: define-c-marshalled'
-{ $values
- { "name" string } { "effect" effect } { "body" string }
-}
-{ $description "Like " { $link define-c-marshalled } ". "
- "The effect elements must be C type strings."
-} ;
-
-HELP: marshalled-function
-{ $values
- { "name" string } { "types" sequence } { "effect" effect }
- { "word" word } { "quot" quotation } { "effect" effect }
-}
-{ $description "Defines a word which calls the named C function. Arguments, "
- "return value, and output parameters are marshalled and unmarshalled."
-} ;
-
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.inline.syntax alien.marshall.syntax destructors
-tools.test accessors kernel ;
-IN: alien.marshall.syntax.tests
-
-DELETE-C-LIBRARY: test
-C-LIBRARY: test
-
-C-INCLUDE: <stdlib.h>
-C-INCLUDE: <string.h>
-C-INCLUDE: <stdbool.h>
-
-CM-FUNCTION: void outarg1 ( int* a )
- *a += 2;
-;
-
-CM-FUNCTION: unsigned-long* outarg2 ( unsigned-long a, unsigned-long* b )
- unsigned long* x = malloc(sizeof(unsigned long*));
- *b = 10 + *b;
- *x = a + *b;
- return x;
-;
-
-CM-STRUCTURE: wedge
- { "double" "degrees" } ;
-
-CM-STRUCTURE: sundial
- { "double" "radius" }
- { "wedge" "wedge" } ;
-
-CM-FUNCTION: double hours ( sundial* d )
- return d->wedge.degrees / 30;
-;
-
-CM-FUNCTION: void change_time ( double hours, sundial* d )
- d->wedge.degrees = hours * 30;
-;
-
-CM-FUNCTION: bool c_not ( bool p )
- return !p;
-;
-
-CM-FUNCTION: char* upcase ( const-char* s )
- int len = strlen(s);
- char* t = malloc(sizeof(char) * len);
- int i;
- for (i = 0; i < len; i++)
- t[i] = toupper(s[i]);
- t[i] = '\0';
- return t;
-;
-
-;C-LIBRARY
-
-{ 1 1 } [ outarg1 ] must-infer-as
-[ 3 ] [ 1 outarg1 ] unit-test
-[ 3 ] [ t outarg1 ] unit-test
-[ 2 ] [ f outarg1 ] unit-test
-
-{ 2 2 } [ outarg2 ] must-infer-as
-[ 18 15 ] [ 3 5 outarg2 ] unit-test
-
-{ 1 1 } [ hours ] must-infer-as
-[ 5.0 ] [ <sundial> <wedge> 150 >>degrees >>wedge hours ] unit-test
-
-{ 2 0 } [ change_time ] must-infer-as
-[ 150.0 ] [ 5 <sundial> <wedge> 11 >>degrees >>wedge [ change_time ] keep wedge>> degrees>> ] unit-test
-
-{ 1 1 } [ c_not ] must-infer-as
-[ f ] [ "x" c_not ] unit-test
-[ f ] [ 0 c_not ] unit-test
-
-{ 1 1 } [ upcase ] must-infer-as
-[ "ABC" ] [ "abc" upcase ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.inline alien.inline.types alien.marshall
-combinators effects generalizations kernel locals make namespaces
-quotations sequences words alien.marshall.structs lexer parser
-vocabs.parser multiline ;
-IN: alien.marshall.syntax
-
-:: marshalled-function ( name types effect -- word quot effect )
- name types effect factor-function
- [ in>> ]
- [ out>> types [ pointer-to-non-const-primitive? ] filter append ]
- bi <effect>
- [
- [
- types [ marshaller ] map , \ spread , ,
- types length , \ nkeep ,
- types [ out-arg-unmarshaller ] map
- effect out>> dup empty?
- [ drop ] [ first unmarshaller prefix ] if
- , \ spread ,
- ] [ ] make
- ] dip ;
-
-: define-c-marshalled ( name types effect body -- )
- [
- [ marshalled-function define-declared ]
- [ prototype-string ] 3bi
- ] dip append-function-body c-strings get push ;
-
-: define-c-marshalled' ( name effect body -- )
- [
- [ in>> ] keep
- [ marshalled-function define-declared ]
- [ out>> prototype-string' ] 3bi
- ] dip append-function-body c-strings get push ;
-
-SYNTAX: CM-FUNCTION:
- function-types-effect parse-here define-c-marshalled ;
-
-SYNTAX: M-FUNCTION:
- function-types-effect marshalled-function define-declared ;
-
-SYNTAX: M-STRUCTURE:
- scan current-vocab parse-definition
- define-marshalled-struct ;
-
-SYNTAX: CM-STRUCTURE:
- scan current-vocab parse-definition
- [ define-marshalled-struct ] [ nip define-c-struct ] 3bi ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.cxx.parser alien.marshall
+alien.inline.types classes.mixin classes.tuple kernel namespaces
+assocs sequences parser classes.parser alien.marshall.syntax
+interpolate locals effects io strings make vocabs.parser words
+generic fry quotations ;
+IN: alien.cxx
+
+<PRIVATE
+: class-mixin ( str -- word )
+ create-class-in [ define-mixin-class ] keep ;
+
+: class-tuple-word ( word -- word' )
+ "#" append create-in ;
+
+: define-class-tuple ( word mixin -- )
+ [ drop class-wrapper { } define-tuple-class ]
+ [ add-mixin-instance ] 2bi ;
+PRIVATE>
+
+: define-c++-class ( name superclass-mixin -- )
+ [ [ class-tuple-word ] [ class-mixin ] bi dup ] dip
+ add-mixin-instance define-class-tuple ;
+
+:: define-c++-method ( class-name generic name types effect virtual -- )
+ [ name % "_" % class-name { { CHAR: : CHAR: _ } } substitute % ] "" make :> name'
+ effect [ in>> "self" suffix ] [ out>> ] bi <effect> :> effect'
+ types class-name "*" append suffix :> types'
+ effect in>> "," join :> args
+ class-name virtual [ "#" append ] unless current-vocab lookup :> class
+ SBUF" " clone dup [ I[ return self->${name}(${args});]I ] with-output-stream >string :> body
+ name' types' effect' body define-c-marshalled
+ class generic create-method name' current-vocab lookup 1quotation define ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser lexer alien.inline ;
+IN: alien.cxx.parser
+
+: parse-c++-class-definition ( -- class superclass-mixin )
+ scan scan-word ;
+
+: parse-c++-method-definition ( -- class-name generic name types effect )
+ scan scan-word function-types-effect ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test alien.cxx.syntax alien.inline.syntax
+alien.marshall.syntax alien.marshall accessors kernel ;
+IN: alien.cxx.syntax.tests
+
+DELETE-C-LIBRARY: test
+C-LIBRARY: test
+
+COMPILE-AS-C++
+
+C-INCLUDE: <string>
+
+C-TYPEDEF: std::string string
+
+C++-CLASS: std::string c++-root
+
+GENERIC: to-string ( obj -- str )
+
+C++-METHOD: std::string to-string const-char* c_str ( )
+
+CM-FUNCTION: std::string* new_string ( const-char* s )
+ return new std::string(s);
+;
+
+;C-LIBRARY
+
+ALIAS: <std::string> new_string
+
+{ 1 1 } [ new_string ] must-infer-as
+{ 1 1 } [ c_str_std__string ] must-infer-as
+[ t ] [ "abc" <std::string> std::string? ] unit-test
+[ "abc" ] [ "abc" <std::string> to-string ] unit-test
+
+
+DELETE-C-LIBRARY: inheritance
+C-LIBRARY: inheritance
+
+COMPILE-AS-C++
+
+C-INCLUDE: <cstring>
+
+<RAW-C
+class alpha {
+ public:
+ alpha(const char* s) {
+ str = s;
+ };
+ const char* render() {
+ return str;
+ };
+ virtual const char* chop() {
+ return str;
+ };
+ virtual int length() {
+ return strlen(str);
+ };
+ const char* str;
+};
+
+class beta : alpha {
+ public:
+ beta(const char* s) : alpha(s + 1) { };
+ const char* render() {
+ return str + 1;
+ };
+ virtual const char* chop() {
+ return str + 2;
+ };
+};
+RAW-C>
+
+C++-CLASS: alpha c++-root
+C++-CLASS: beta alpha
+
+CM-FUNCTION: alpha* new_alpha ( const-char* s )
+ return new alpha(s);
+;
+
+CM-FUNCTION: beta* new_beta ( const-char* s )
+ return new beta(s);
+;
+
+ALIAS: <alpha> new_alpha
+ALIAS: <beta> new_beta
+
+GENERIC: render ( obj -- obj )
+GENERIC: chop ( obj -- obj )
+GENERIC: length ( obj -- n )
+
+C++-METHOD: alpha render const-char* render ( )
+C++-METHOD: beta render const-char* render ( )
+C++-VIRTUAL: alpha chop const-char* chop ( )
+C++-VIRTUAL: beta chop const-char* chop ( )
+C++-VIRTUAL: alpha length int length ( )
+
+;C-LIBRARY
+
+{ 1 1 } [ render_alpha ] must-infer-as
+{ 1 1 } [ chop_beta ] must-infer-as
+{ 1 1 } [ length_alpha ] must-infer-as
+[ t ] [ "x" <alpha> alpha#? ] unit-test
+[ t ] [ "x" <alpha> alpha? ] unit-test
+[ t ] [ "x" <beta> alpha? ] unit-test
+[ f ] [ "x" <beta> alpha#? ] unit-test
+[ 5 ] [ "hello" <alpha> length ] unit-test
+[ 4 ] [ "hello" <beta> length ] unit-test
+[ "hello" ] [ "hello" <alpha> render ] unit-test
+[ "llo" ] [ "hello" <beta> render ] unit-test
+[ "ello" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying render ] unit-test
+[ "hello" ] [ "hello" <alpha> chop ] unit-test
+[ "lo" ] [ "hello" <beta> chop ] unit-test
+[ "lo" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying chop ] unit-test
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.cxx alien.cxx.parser ;
+IN: alien.cxx.syntax
+
+SYNTAX: C++-CLASS:
+ parse-c++-class-definition define-c++-class ;
+
+SYNTAX: C++-METHOD:
+ parse-c++-method-definition f define-c++-method ;
+
+SYNTAX: C++-VIRTUAL:
+ parse-c++-method-definition t define-c++-method ;
--- /dev/null
+Jeremy Hughes
--- /dev/null
+Jeremy Hughes
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel strings words.symbol sequences ;
+IN: alien.inline.compiler
+
+HELP: C
+{ $var-description "A symbol representing C source." } ;
+
+HELP: C++
+{ $var-description "A symbol representing C++ source." } ;
+
+HELP: compile-to-library
+{ $values
+ { "lang" symbol } { "args" sequence } { "contents" string } { "name" string }
+}
+{ $description "Compiles and links " { $snippet "contents" } " into a shared library called " { $snippet "libname.suffix" }
+ "in " { $snippet "resource:alien-inline-libs" } ". " { $snippet "suffix" } " is OS specific. "
+ { $snippet "args" } " is a sequence of arguments for the linking stage." }
+{ $notes
+ { $list
+ "C and C++ are the only supported languages."
+ { "Source and object files are placed in " { $snippet "resource:temp" } "." } }
+} ;
+
+HELP: compiler
+{ $values
+ { "lang" symbol }
+ { "str" string }
+}
+{ $description "Returns a compiler name based on OS and source language." }
+{ $see-also compiler-descr } ;
+
+HELP: compiler-descr
+{ $values
+ { "lang" symbol }
+ { "descr" "a process description" }
+}
+{ $description "Returns a compiler process description based on OS and source language." }
+{ $see-also compiler } ;
+
+HELP: inline-library-file
+{ $values
+ { "name" string }
+ { "path" "a pathname string" }
+}
+{ $description "Appends " { $snippet "name" } " to the " { $link inline-libs-directory } "." } ;
+
+HELP: inline-libs-directory
+{ $values
+ { "path" "a pathname string" }
+}
+{ $description "The directory where libraries created using " { $snippet "alien.inline" } " are stored." } ;
+
+HELP: library-path
+{ $values
+ { "str" string }
+ { "path" "a pathname string" }
+}
+{ $description "Converts " { $snippet "name" } " into a full path to the corresponding inline library." } ;
+
+HELP: library-suffix
+{ $values
+ { "str" string }
+}
+{ $description "The appropriate shared library suffix for the current OS." } ;
+
+HELP: link-descr
+{ $values
+ { "lang" "a language" }
+ { "descr" sequence }
+}
+{ $description "Returns part of a process description. OS dependent." } ;
+
+ARTICLE: "alien.inline.compiler" "Inline C compiler"
+{ $vocab-link "alien.inline.compiler" }
+;
+
+ABOUT: "alien.inline.compiler"
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators fry generalizations
+io.encodings.ascii io.files io.files.temp io.launcher kernel
+locals make sequences system vocabs.parser words io.directories
+io.pathnames ;
+IN: alien.inline.compiler
+
+SYMBOL: C
+SYMBOL: C++
+
+: inline-libs-directory ( -- path )
+ "alien-inline-libs" resource-path dup make-directories ;
+
+: inline-library-file ( name -- path )
+ inline-libs-directory prepend-path ;
+
+: library-suffix ( -- str )
+ os {
+ { [ dup macosx? ] [ drop ".dylib" ] }
+ { [ dup unix? ] [ drop ".so" ] }
+ { [ dup windows? ] [ drop ".dll" ] }
+ } cond ;
+
+: library-path ( str -- path )
+ '[ "lib" % _ % library-suffix % ] "" make inline-library-file ;
+
+HOOK: compiler os ( lang -- str )
+
+M: word compiler
+ {
+ { C [ "gcc" ] }
+ { C++ [ "g++" ] }
+ } case ;
+
+M: openbsd compiler
+ {
+ { C [ "gcc" ] }
+ { C++ [ "eg++" ] }
+ } case ;
+
+M: windows compiler
+ {
+ { C [ "gcc" ] }
+ { C++ [ "g++" ] }
+ } case ;
+
+HOOK: compiler-descr os ( lang -- descr )
+
+M: word compiler-descr compiler 1array ;
+M: macosx compiler-descr
+ call-next-method cpu x86.64?
+ [ { "-arch" "x86_64" } append ] when ;
+
+HOOK: link-descr os ( lang -- descr )
+
+M: word link-descr drop { "-shared" "-o" } ;
+M: macosx link-descr
+ drop { "-g" "-prebind" "-dynamiclib" "-o" }
+ cpu x86.64? [ { "-arch" "x86_64" } prepend ] when ;
+M: windows link-descr
+ {
+ { C [ { "-mno-cygwin" "-shared" "-o" } ] }
+ { C++ [ { "-lstdc++" "-mno-cygwin" "-shared" "-o" } ] }
+ } case ;
+
+<PRIVATE
+: src-suffix ( lang -- str )
+ {
+ { C [ ".c" ] }
+ { C++ [ ".cpp" ] }
+ } case ;
+
+: link-command ( args in out lang -- descr )
+ [ 2array ] dip [ compiler 1array ] [ link-descr ] bi
+ append 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
+ lang compiler-descr { "-fPIC" "-c" "-o" } append prepend
+ try-process ;
+
+:: link-object ( lang args name -- )
+ args name [ library-path ]
+ [ ".o" append temp-file ] bi
+ lang link-command try-process ;
+PRIVATE>
+
+:: compile-to-library ( lang args contents name -- )
+ lang contents name compile-to-object
+ lang args name link-object ;
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel strings effects quotations ;
+IN: alien.inline
+
+<PRIVATE
+: $binding-note ( x -- )
+ drop
+ { "This word requires that certain variables are correctly bound. "
+ "Call " { $link POSTPONE: define-c-library } " to set them up." } print-element ;
+PRIVATE>
+
+HELP: compile-c-library
+{ $description "Writes, compiles, and links code generated since last invocation of " { $link POSTPONE: define-c-library } ". "
+ "Also calls " { $snippet "add-library" } ". "
+ "This word does nothing if the shared library is younger than the factor source file." }
+{ $notes $binding-note } ;
+
+HELP: c-use-framework
+{ $values
+ { "str" string }
+}
+{ $description "OS X only. Adds " { $snippet "-framework name" } " to linker command." }
+{ $notes $binding-note }
+{ $see-also c-link-to c-link-to/use-framework } ;
+
+HELP: define-c-function
+{ $values
+ { "function" "function name" } { "types" "a sequence of C types" } { "effect" effect } { "body" string }
+}
+{ $description "Defines a C function and a factor word which calls it." }
+{ $notes
+ { $list
+ { "The number of " { $snippet "types" } " must match the " { $snippet "in" } " count of the " { $snippet "effect" } "." }
+ { "There must be only one " { $snippet "out" } " element. It must be a legal C return type with dashes (-) instead of spaces." }
+ $binding-note
+ }
+}
+{ $see-also POSTPONE: define-c-function' } ;
+
+HELP: define-c-function'
+{ $values
+ { "function" "function name" } { "effect" effect } { "body" string }
+}
+{ $description "Defines a C function and a factor word which calls it. See " { $link define-c-function } " for more information." }
+{ $notes
+ { $list
+ { "Each effect element must be a legal C type with dashes (-) instead of spaces. "
+ "C argument names will be generated alphabetically, starting with " { $snippet "a" } "." }
+ $binding-note
+ }
+}
+{ $see-also define-c-function } ;
+
+HELP: c-include
+{ $values
+ { "str" string }
+}
+{ $description "Appends an include line to the C library in scope." }
+{ $notes $binding-note } ;
+
+HELP: define-c-library
+{ $values
+ { "name" string }
+}
+{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " words can be used after this one." } ;
+
+HELP: c-link-to
+{ $values
+ { "str" string }
+}
+{ $description "Adds " { $snippet "-lname" } " to linker command." }
+{ $notes $binding-note }
+{ $see-also c-use-framework c-link-to/use-framework } ;
+
+HELP: c-link-to/use-framework
+{ $values
+ { "str" string }
+}
+{ $description "Equivalent to " { $link c-use-framework } " on OS X and " { $link c-link-to } " everywhere else." }
+{ $notes $binding-note }
+{ $see-also c-link-to c-use-framework } ;
+
+HELP: define-c-struct
+{ $values
+ { "name" string } { "fields" "type/name pairs" }
+}
+{ $description "Defines a C struct and factor words which operate on it." }
+{ $notes $binding-note } ;
+
+HELP: define-c-typedef
+{ $values
+ { "old" "C type" } { "new" "C type" }
+}
+{ $description "Define C and factor typedefs." }
+{ $notes $binding-note } ;
+
+HELP: delete-inline-library
+{ $values
+ { "name" string }
+}
+{ $description "Delete the shared library file corresponding to " { $snippet "name" } "." }
+{ $notes "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " } ;
+
+HELP: with-c-library
+{ $values
+ { "name" string } { "quot" quotation }
+}
+{ $description "Calls " { $link define-c-library } ", then the quotation, then " { $link compile-c-library } ", then sets all variables bound by " { $snippet "define-c-library" } " to " { $snippet "f" } "." } ;
+
+HELP: raw-c
+{ $values { "str" string } }
+{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.inline.compiler alien.inline.types
+alien.libraries alien.parser arrays assocs effects fry
+generalizations grouping io.directories io.files
+io.files.info io.files.temp kernel lexer math math.order
+math.ranges multiline namespaces sequences source-files
+splitting strings system vocabs.loader vocabs.parser words
+alien.c-types alien.structs make parser continuations ;
+IN: alien.inline
+
+SYMBOL: c-library
+SYMBOL: library-is-c++
+SYMBOL: linker-args
+SYMBOL: c-strings
+
+<PRIVATE
+: cleanup-variables ( -- )
+ { c-library library-is-c++ linker-args c-strings }
+ [ off ] each ;
+
+: arg-list ( types -- params )
+ CHAR: a swap length CHAR: a + [a,b]
+ [ 1string ] map ;
+
+: compile-library? ( -- ? )
+ c-library get library-path dup exists? [
+ file get [
+ path>>
+ [ file-info modified>> ] bi@ <=> +lt+ =
+ ] [ drop t ] if*
+ ] [ drop t ] if ;
+
+: compile-library ( -- )
+ library-is-c++ get [ C++ ] [ C ] if
+ linker-args get
+ c-strings get "\n" join
+ c-library get compile-to-library ;
+
+: c-library-name ( name -- name' )
+ [ current-vocab name>> % "_" % % ] "" make ;
+PRIVATE>
+
+: parse-arglist ( parameters return -- types effect )
+ [ 2 group unzip [ "," ?tail drop ] map ]
+ [ [ { } ] [ 1array ] if-void ]
+ bi* <effect> ;
+
+: append-function-body ( prototype-str body -- str )
+ [ swap % " {\n" % % "\n}\n" % ] "" make ;
+
+: function-types-effect ( -- function types effect )
+ scan scan swap ")" parse-tokens
+ [ "(" subseq? not ] filter swap parse-arglist ;
+
+: prototype-string ( function types effect -- str )
+ [ [ cify-type ] map ] dip
+ types-effect>params-return cify-type -rot
+ [ " " join ] map ", " join
+ "(" prepend ")" append 3array " " join
+ library-is-c++ get [ "extern \"C\" " prepend ] when ;
+
+: prototype-string' ( function types return -- str )
+ [ dup arg-list ] <effect> prototype-string ;
+
+: factor-function ( function types effect -- word quot effect )
+ annotate-effect [ c-library get ] 3dip
+ [ [ factorize-type ] map ] dip
+ types-effect>params-return factorize-type -roll
+ concat make-function ;
+
+: define-c-library ( name -- )
+ c-library-name [ c-library set ] [ "c-library" set ] bi
+ V{ } clone c-strings set
+ V{ } clone linker-args set ;
+
+: compile-c-library ( -- )
+ compile-library? [ compile-library ] when
+ c-library get dup library-path "cdecl" add-library ;
+
+: define-c-function ( function types effect body -- )
+ [
+ [ factor-function define-declared ]
+ [ prototype-string ] 3bi
+ ] dip append-function-body c-strings get push ;
+
+: define-c-function' ( function effect body -- )
+ [
+ [ in>> ] keep
+ [ factor-function define-declared ]
+ [ out>> prototype-string' ] 3bi
+ ] dip append-function-body c-strings get push ;
+
+: c-link-to ( str -- )
+ "-l" prepend linker-args get push ;
+
+: c-use-framework ( str -- )
+ "-framework" swap linker-args get '[ _ push ] bi@ ;
+
+: c-link-to/use-framework ( str -- )
+ os macosx? [ c-use-framework ] [ c-link-to ] if ;
+
+: c-include ( str -- )
+ "#include " prepend c-strings get push ;
+
+: define-c-typedef ( old new -- )
+ [ typedef ] [
+ [ swap "typedef " % % " " % % ";" % ]
+ "" make c-strings get push
+ ] 2bi ;
+
+: define-c-struct ( name fields -- )
+ [ current-vocab swap define-struct ] [
+ over
+ [
+ "typedef struct " % "_" % % " {\n" %
+ [ first2 swap % " " % % ";\n" % ] each
+ "} " % % ";\n" %
+ ] "" make c-strings get push
+ ] 2bi ;
+
+: delete-inline-library ( name -- )
+ c-library-name [ remove-library ]
+ [ library-path dup exists? [ delete-file ] [ drop ] if ] bi ;
+
+: with-c-library ( name quot -- )
+ [ [ define-c-library ] dip call compile-c-library ]
+ [ cleanup-variables ] [ ] cleanup ; inline
+
+: raw-c ( str -- )
+ [ "\n" % % "\n" % ] "" make c-strings get push ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax alien.inline ;
+IN: alien.inline.syntax
+
+HELP: ;C-LIBRARY
+{ $syntax ";C-LIBRARY" }
+{ $description "Writes, compiles, and links code generated since previous invocation of " { $link POSTPONE: C-LIBRARY: } "." }
+{ $see-also POSTPONE: compile-c-library } ;
+
+HELP: C-FRAMEWORK:
+{ $syntax "C-FRAMEWORK: name" }
+{ $description "OS X only. Link to named framework. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
+{ $see-also POSTPONE: c-use-framework } ;
+
+HELP: C-FUNCTION:
+{ $syntax "C-FUNCTION: return name ( args ... )\nbody\n;" }
+{ $description "Appends a function to the C library in scope and defines an FFI word that calls it." }
+{ $examples
+ { $example
+ "USING: alien.inline.syntax prettyprint ;"
+ "IN: cmath.ffi"
+ ""
+ "C-LIBRARY: cmathlib"
+ ""
+ "C-FUNCTION: int add ( int a, int b )"
+ " return a + b;"
+ ";"
+ ""
+ ";C-LIBRARY"
+ ""
+ "1 2 add ."
+ "3" }
+}
+{ $see-also POSTPONE: define-c-function } ;
+
+HELP: C-INCLUDE:
+{ $syntax "C-INCLUDE: name" }
+{ $description "Appends an include line to the C library in scope." }
+{ $see-also POSTPONE: c-include } ;
+
+HELP: C-LIBRARY:
+{ $syntax "C-LIBRARY: name" }
+{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " syntax can be used after this word." }
+{ $examples
+ { $example
+ "USING: alien.inline.syntax ;"
+ "IN: rectangle.ffi"
+ ""
+ "C-LIBRARY: rectlib"
+ ""
+ "C-STRUCTURE: rectangle { \"int\" \"width\" } { \"int\" \"height\" } ;"
+ ""
+ "C-FUNCTION: int area ( rectangle c )"
+ " return c.width * c.height;"
+ ";"
+ ""
+ ";C-LIBRARY"
+ "" }
+}
+{ $see-also POSTPONE: define-c-library } ;
+
+HELP: C-LINK/FRAMEWORK:
+{ $syntax "C-LINK/FRAMEWORK: name" }
+{ $description "Equivalent to " { $link POSTPONE: C-FRAMEWORK: } " on OS X and " { $link POSTPONE: C-LINK: } " everywhere else." }
+{ $see-also POSTPONE: c-link-to/use-framework } ;
+
+HELP: C-LINK:
+{ $syntax "C-LINK: name" }
+{ $description "Link to named library. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
+{ $see-also POSTPONE: c-link-to } ;
+
+HELP: C-STRUCTURE:
+{ $syntax "C-STRUCTURE: name pairs ... ;" }
+{ $description "Like " { $snippet "C-STRUCT:" } " but also generates equivalent C code."}
+{ $see-also POSTPONE: define-c-struct } ;
+
+HELP: C-TYPEDEF:
+{ $syntax "C-TYPEDEF: old new" }
+{ $description "Like " { $snippet "TYPEDEF:" } " but generates a C typedef statement too." }
+{ $see-also POSTPONE: define-c-typedef } ;
+
+HELP: COMPILE-AS-C++
+{ $syntax "COMPILE-AS-C++" }
+{ $description "Insert this word anywhere between " { $link POSTPONE: C-LIBRARY: } " and " { $link POSTPONE: ;C-LIBRARY } " and the generated code will be treated as C++ with " { $snippet "extern \"C\"" } " prepended to each function prototype." } ;
+
+HELP: DELETE-C-LIBRARY:
+{ $syntax "DELETE-C-LIBRARY: name" }
+{ $description "Deletes the shared library file corresponding to " { $snippet "name" } " . " }
+{ $notes
+ { $list
+ { "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " }
+ "This word is mainly useful for unit tests."
+ }
+}
+{ $see-also POSTPONE: delete-inline-library } ;
+
+HELP: <RAW-C
+{ $syntax "<RAW-C code RAW-C>" }
+{ $description "Insert a (multiline) string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.inline alien.inline.syntax io.directories io.files
+kernel namespaces tools.test alien.c-types alien.data alien.structs ;
+IN: alien.inline.syntax.tests
+
+DELETE-C-LIBRARY: test
+C-LIBRARY: test
+
+C-FUNCTION: const-int add ( int a, int b )
+ return a + b;
+;
+
+C-TYPEDEF: double bigfloat
+
+C-FUNCTION: bigfloat smaller ( bigfloat a )
+ return a / 10;
+;
+
+C-STRUCTURE: rectangle
+ { "int" "width" }
+ { "int" "height" } ;
+
+C-FUNCTION: int area ( rectangle c )
+ return c.width * c.height;
+;
+
+;C-LIBRARY
+
+{ 2 1 } [ add ] must-infer-as
+[ 5 ] [ 2 3 add ] unit-test
+
+[ t ] [ "double" "bigfloat" [ resolve-typedef ] bi@ = ] unit-test
+{ 1 1 } [ smaller ] must-infer-as
+[ 1.0 ] [ 10 smaller ] unit-test
+
+[ t ] [ "rectangle" resolve-typedef struct-type? ] unit-test
+{ 1 1 } [ area ] must-infer-as
+[ 20 ] [
+ "rectangle" <c-object>
+ 4 over set-rectangle-width
+ 5 over set-rectangle-height
+ area
+] unit-test
+
+
+DELETE-C-LIBRARY: cpplib
+C-LIBRARY: cpplib
+
+COMPILE-AS-C++
+
+C-INCLUDE: <string>
+
+C-FUNCTION: const-char* hello ( )
+ std::string s("hello world");
+ return s.c_str();
+;
+
+;C-LIBRARY
+
+{ 0 1 } [ hello ] must-infer-as
+[ "hello world" ] [ hello ] unit-test
+
+
+DELETE-C-LIBRARY: compile-error
+C-LIBRARY: compile-error
+
+C-FUNCTION: char* breakme ( )
+ return not a string;
+;
+
+<< [ compile-c-library ] must-fail >>
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.inline lexer multiline namespaces parser ;
+IN: alien.inline.syntax
+
+
+SYNTAX: C-LIBRARY: scan define-c-library ;
+
+SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
+
+SYNTAX: C-LINK: scan c-link-to ;
+
+SYNTAX: C-FRAMEWORK: scan c-use-framework ;
+
+SYNTAX: C-LINK/FRAMEWORK: scan c-link-to/use-framework ;
+
+SYNTAX: C-INCLUDE: scan c-include ;
+
+SYNTAX: C-FUNCTION:
+ function-types-effect parse-here define-c-function ;
+
+SYNTAX: C-TYPEDEF: scan scan define-c-typedef ;
+
+SYNTAX: C-STRUCTURE:
+ scan parse-definition define-c-struct ;
+
+SYNTAX: ;C-LIBRARY compile-c-library ;
+
+SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ;
+
+SYNTAX: <RAW-C "RAW-C>" parse-multiline-string raw-c ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! 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 strings peg.ebnf make words ;
+IN: alien.inline.types
+
+: cify-type ( str -- str' )
+ dup word? [ name>> ] when
+ { { CHAR: - CHAR: space } } substitute ;
+
+: factorize-type ( str -- str' )
+ cify-type
+ "const " ?head drop
+ "unsigned " ?head [ "u" prepend ] when
+ "long " ?head [ "long" prepend ] when
+ " const" ?tail drop ;
+
+: const-pointer? ( str -- ? )
+ cify-type { [ " const" tail? ] [ "&" tail? ] } 1|| ;
+
+: pointer-to-const? ( str -- ? )
+ cify-type "const " head? ;
+
+: template-class? ( str -- ? )
+ [ CHAR: < = ] any? ;
+
+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 -- ? )
+ factorize-type [ "*" tail? ] [ "&" tail? ] bi or ;
+
+: type-sans-pointer ( type -- type' )
+ factorize-type [ '[ _ = ] "*&" swap any? ] trim-tail ;
+
+: pointer-to-primitive? ( type -- ? )
+ factorize-type
+ { [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ;
+
+: pointer-to-non-const-primitive? ( str -- ? )
+ {
+ [ pointer-to-const? not ]
+ [ factorize-type pointer-to-primitive? ]
+ } 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> ;
+
+TUPLE: c++-type name params ptr ;
+C: <c++-type> c++-type
+
+EBNF: (parse-c++-type)
+dig = [0-9]
+alpha = [a-zA-Z]
+alphanum = [1-9a-zA-Z]
+name = [_a-zA-Z] [_a-zA-Z1-9:]* => [[ first2 swap prefix >string ]]
+ptr = [*&] => [[ empty? not ]]
+
+param = "," " "* type " "* => [[ third ]]
+
+params = "<" " "* type " "* param* ">" => [[ [ 4 swap nth ] [ third ] bi prefix ]]
+
+type = name " "* params? " "* ptr? => [[ { 0 2 4 } [ swap nth ] with map first3 <c++-type> ]]
+;EBNF
+
+: parse-c++-type ( str -- c++-type )
+ factorize-type (parse-c++-type) ;
+
+DEFER: c++-type>string
+
+: params>string ( params -- str )
+ [ "<" % [ c++-type>string ] map "," join % ">" % ] "" make ;
+
+: c++-type>string ( c++-type -- str )
+ [
+ [ name>> % ]
+ [ params>> [ params>string % ] when* ]
+ [ ptr>> [ "*" % ] when ]
+ tri
+ ] "" make ;
+
+GENERIC: c++-type ( obj -- c++-type/f )
+
+M: object c++-type drop f ;
+
+M: c++-type c-type ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations sequences
+strings alien alien.c-types alien.data math byte-arrays ;
+IN: alien.marshall
+
+<PRIVATE
+: $memory-note ( arg -- )
+ drop "This word returns a pointer to unmanaged memory."
+ print-element ;
+
+: $c-ptr-note ( arg -- )
+ drop "Does nothing if its argument is a non false c-ptr."
+ print-element ;
+
+: $see-article ( arg -- )
+ drop { "See " { $vocab-link "alien.inline" } "." }
+ print-element ;
+PRIVATE>
+
+HELP: ?malloc-byte-array
+{ $values
+ { "c-type" c-type }
+ { "alien" alien }
+}
+{ $description "Does nothing if input is an alien, otherwise assumes it is a byte array and calls "
+ { $snippet "malloc-byte-array" } "."
+}
+{ $notes $memory-note } ;
+
+HELP: alien-wrapper
+{ $var-description "For wrapping C pointers in a structure factor can dispatch on." } ;
+
+HELP: unmarshall-cast
+{ $values
+ { "alien-wrapper" alien-wrapper }
+ { "alien-wrapper'" alien-wrapper }
+}
+{ $description "Called immediately after unmarshalling. Useful for automatically casting to subtypes." } ;
+
+HELP: marshall-bool
+{ $values
+ { "?" "a generalized boolean" }
+ { "n" "0 or 1" }
+}
+{ $description "Marshalls objects to bool." }
+{ $notes "Will treat " { $snippet "0" } " as " { $snippet "t" } "." } ;
+
+HELP: marshall-bool*
+{ $values
+ { "?/seq" "t/f or sequence" }
+ { "alien" alien }
+}
+{ $description "When the argument is a sequence, returns a pointer to an array of bool, "
+ "otherwise returns a pointer to a single bool value."
+}
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-bool**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description "Takes a one or two dimensional array of generalized booleans "
+ "and returns a pointer to the equivalent C structure."
+}
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-primitive
+{ $values
+ { "n" number }
+ { "n" number }
+}
+{ $description "Marshall numbers to C primitives."
+ $nl
+ "Factor marshalls numbers to primitives for FFI calls, so all "
+ "this word does is convert " { $snippet "t" } " to " { $snippet "1" }
+ ", " { $snippet "f" } " to " { $snippet "0" } ", and lets anything else "
+ "pass through untouched."
+} ;
+
+HELP: marshall-char*
+{ $values
+ { "n/seq" "number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-char**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-char**-or-strings
+{ $values
+ { "seq" "a sequence of strings" }
+ { "alien" alien }
+}
+{ $description "Marshalls an array of strings or characters to an array of C strings." }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-char*-or-string
+{ $values
+ { "n/string" "a number or string" }
+ { "alien" alien }
+}
+{ $description "Marshalls a string to a C string or a number to a pointer to " { $snippet "char" } "." }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-double*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-double**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-float*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-float**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-int*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-int**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-long*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-long**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-longlong*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-longlong**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-non-pointer
+{ $values
+ { "alien-wrapper/byte-array" "an alien-wrapper or byte-array" }
+ { "byte-array" byte-array }
+}
+{ $description "Converts argument to a byte array." }
+{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
+
+HELP: marshall-pointer
+{ $values
+ { "obj" object }
+ { "alien" alien }
+}
+{ $description "Converts argument to a C pointer." }
+{ $notes "Can marshall the following types: " { $snippet "alien, f, byte-array, alien-wrapper, struct-array" } "." } ;
+
+HELP: marshall-short*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-short**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-uchar*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-uchar**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-uint*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-uint**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ulong*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ulong**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ulonglong*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ulonglong**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ushort*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ushort**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-void**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description "Marshalls a sequence of objects to an array of pointers to void." }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot" quotation }
+}
+{ $description "Given a C type, returns a quotation that will marshall its argument to that type." } ;
+
+HELP: out-arg-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot" quotation }
+}
+{ $description "Like " { $link unmarshaller } " but returns an empty quotation "
+ "for all types except pointers to non-const primitives."
+} ;
+
+HELP: class-unmarshaller
+{ $values
+ { "type" " a C type string" }
+ { "quot/f" quotation }
+}
+{ $description "If in the vocab in which this word is called, there is a subclass of " { $link alien-wrapper }
+ " named after the type argument, " { $snippet "pointer-unmarshaller" } " will return a quotation which "
+ "wraps its argument in an instance of that subclass. In any other case it returns an empty quotation."
+}
+{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
+
+HELP: primitive-marshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot/f" "a quotation or f" }
+}
+{ $description "Returns a quotation to marshall objects to the argument type." }
+{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
+
+HELP: primitive-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot/f" "a quotation or f" }
+}
+{ $description "Returns a quotation to unmarshall objects from the argument type." }
+{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
+
+HELP: struct-field-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot" quotation }
+}
+{ $description "Like " { $link unmarshaller } " but returns a quotation that "
+ "does not call " { $snippet "free" } " on its argument."
+}
+{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
+
+HELP: struct-primitive-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot/f" "a quotation or f" }
+}
+{ $description "Like " { $link primitive-unmarshaller } " but returns a quotation that "
+ "does not call " { $snippet "free" } " on its argument." }
+{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
+
+HELP: struct-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot/f" quotation }
+}
+{ $description "Returns a quotation which wraps its argument in the subclass of "
+ { $link struct-wrapper } " which matches the " { $snippet "type" } " arg."
+}
+{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
+
+HELP: struct-wrapper
+{ $var-description "For wrapping C structs in a structure factor can dispatch on." } ;
+
+HELP: unmarshall-bool
+{ $values
+ { "n" number }
+ { "?" "a boolean" }
+}
+{ $description "Unmarshalls a number to a boolean." } ;
+
+HELP: unmarshall-bool*
+{ $values
+ { "alien" alien }
+ { "?" "a boolean" }
+}
+{ $description "Unmarshalls a C pointer to a boolean." } ;
+
+HELP: unmarshall-bool*-free
+{ $values
+ { "alien" alien }
+ { "?" "a boolean" }
+}
+{ $description "Unmarshalls a C pointer to a boolean and frees the pointer." } ;
+
+HELP: unmarshall-char*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-char*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-char*-to-string
+{ $values
+ { "alien" alien }
+ { "string" string }
+}
+{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string." } ;
+
+HELP: unmarshall-char*-to-string-free
+{ $values
+ { "alien" alien }
+ { "string" string }
+}
+{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string and frees the pointer." } ;
+
+HELP: unmarshall-double*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-double*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-float*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-float*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-int*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-int*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-long*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-long*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-longlong*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-longlong*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-short*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-short*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-uchar*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-uchar*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-uint*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-uint*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ulong*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ulong*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ulonglong*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ulonglong*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ushort*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ushort*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot" quotation }
+}
+{ $description "Given a C type, returns a quotation that will unmarshall values of that type." } ;
+
+ARTICLE: "alien.marshall" "C marshalling"
+{ $vocab-link "alien.marshall" } " provides alien wrappers and marshalling words for the "
+"automatic marshalling and unmarshalling of C function arguments, return values, and output parameters."
+
+{ $subheading "Important words" }
+"Wrap an alien:" { $subsection alien-wrapper }
+"Wrap a struct:" { $subsection struct-wrapper }
+"Get the marshaller for a C type:" { $subsection marshaller }
+"Get the unmarshaller for a C type:" { $subsection unmarshaller }
+"Get the unmarshaller for an output parameter:" { $subsection out-arg-unmarshaller }
+"Get the unmarshaller for a struct field:" { $subsection struct-field-unmarshaller }
+$nl
+"Other marshalling and unmarshalling words in this vocabulary are not intended to be "
+"invoked directly."
+$nl
+"Most marshalling words allow non false c-ptrs to pass through unchanged."
+
+{ $subheading "Primitive marshallers" }
+{ $subsection marshall-primitive } "for marshalling primitive values."
+{ $subsection marshall-int* }
+ "marshalls a number or sequence of numbers. If argument is a sequence, returns a pointer "
+ "to a C array, otherwise returns a pointer to a single value."
+{ $subsection marshall-int** }
+"marshalls a 1D or 2D array of numbers. Returns an array of pointers to arrays."
+
+{ $subheading "Primitive unmarshallers" }
+{ $snippet "unmarshall-<prim>*" } " and " { $snippet "unmarshall-<prim>*-free" }
+" for all values of " { $snippet "<prim>" } " in " { $link primitive-types } "."
+{ $subsection unmarshall-int* }
+"unmarshalls a pointer to primitive. Returns a number. "
+"Assumes the pointer is not an array (if it is, only the first value is returned). "
+"C functions that return arrays are not handled correctly by " { $snippet "alien.marshall" }
+" and must be unmarshalled by hand."
+{ $subsection unmarshall-int*-free }
+"unmarshalls a pointer to primitive, and then frees the pointer."
+$nl
+"Primitive values require no unmarshalling. The factor FFI already does this."
+;
+
+ABOUT: "alien.marshall"
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types alien.inline.types
+alien.marshall.private alien.strings byte-arrays classes
+combinators combinators.short-circuit destructors fry
+io.encodings.utf8 kernel libc sequences alien.data
+specialized-arrays strings unix.utilities vocabs.parser
+words libc.private locals generalizations math ;
+FROM: alien.c-types => float short ;
+SPECIALIZED-ARRAY: bool
+SPECIALIZED-ARRAY: char
+SPECIALIZED-ARRAY: double
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: long
+SPECIALIZED-ARRAY: longlong
+SPECIALIZED-ARRAY: short
+SPECIALIZED-ARRAY: uchar
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: ulong
+SPECIALIZED-ARRAY: ulonglong
+SPECIALIZED-ARRAY: ushort
+SPECIALIZED-ARRAY: void*
+IN: alien.marshall
+
+<< primitive-types [ [ void* = ] [ bool = ] bi or not ]
+filter [ define-primitive-marshallers ] each >>
+
+TUPLE: alien-wrapper { underlying alien } ;
+TUPLE: struct-wrapper < alien-wrapper disposed ;
+TUPLE: class-wrapper < alien-wrapper disposed ;
+
+MIXIN: c++-root
+
+GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
+
+M: alien-wrapper unmarshall-cast ;
+M: struct-wrapper unmarshall-cast ;
+
+M: struct-wrapper dispose* underlying>> free ;
+
+M: class-wrapper c++-type class name>> parse-c++-type ;
+
+: marshall-pointer ( obj -- alien )
+ {
+ { [ dup alien? ] [ ] }
+ { [ dup not ] [ ] }
+ { [ dup byte-array? ] [ malloc-byte-array ] }
+ { [ dup alien-wrapper? ] [ underlying>> ] }
+ } cond ;
+
+: marshall-primitive ( n -- n )
+ [ bool>arg ] ptr-pass-through ;
+
+ALIAS: marshall-void* marshall-pointer
+
+: marshall-void** ( seq -- alien )
+ [ marshall-void* ] void*-array{ } map-as malloc-underlying ;
+
+: (marshall-char*-or-string) ( n/string -- alien )
+ dup string?
+ [ utf8 string>alien malloc-byte-array ]
+ [ (marshall-char*) ] if ;
+
+: marshall-char*-or-string ( n/string -- alien )
+ [ (marshall-char*-or-string) ] ptr-pass-through ;
+
+: (marshall-char**-or-strings) ( seq -- alien )
+ [ marshall-char*-or-string ] void*-array{ } map-as
+ malloc-underlying ;
+
+: marshall-char**-or-strings ( seq -- alien )
+ [ (marshall-char**-or-strings) ] ptr-pass-through ;
+
+: marshall-bool ( ? -- n )
+ >boolean [ 1 ] [ 0 ] if ;
+
+: (marshall-bool*) ( ?/seq -- alien )
+ [ marshall-bool <bool> malloc-byte-array ]
+ [ >bool-array malloc-underlying ]
+ marshall-x* ;
+
+: marshall-bool* ( ?/seq -- alien )
+ [ (marshall-bool*) ] ptr-pass-through ;
+
+: (marshall-bool**) ( seq -- alien )
+ [ marshall-bool* ] map >void*-array malloc-underlying ;
+
+: marshall-bool** ( seq -- alien )
+ [ (marshall-bool**) ] ptr-pass-through ;
+
+: unmarshall-bool ( n -- ? )
+ 0 = not ;
+
+: unmarshall-bool* ( alien -- ? )
+ *bool unmarshall-bool ;
+
+: unmarshall-bool*-free ( alien -- ? )
+ [ *bool unmarshall-bool ] keep add-malloc free ;
+
+: primitive-marshaller ( type -- quot/f )
+ {
+ { "bool" [ [ ] ] }
+ { "boolean" [ [ marshall-bool ] ] }
+ { "char" [ [ marshall-primitive ] ] }
+ { "uchar" [ [ marshall-primitive ] ] }
+ { "short" [ [ marshall-primitive ] ] }
+ { "ushort" [ [ marshall-primitive ] ] }
+ { "int" [ [ marshall-primitive ] ] }
+ { "uint" [ [ marshall-primitive ] ] }
+ { "long" [ [ marshall-primitive ] ] }
+ { "ulong" [ [ marshall-primitive ] ] }
+ { "long" [ [ marshall-primitive ] ] }
+ { "ulong" [ [ marshall-primitive ] ] }
+ { "float" [ [ marshall-primitive ] ] }
+ { "double" [ [ marshall-primitive ] ] }
+ { "bool*" [ [ marshall-bool* ] ] }
+ { "boolean*" [ [ marshall-bool* ] ] }
+ { "char*" [ [ marshall-char*-or-string ] ] }
+ { "uchar*" [ [ marshall-uchar* ] ] }
+ { "short*" [ [ marshall-short* ] ] }
+ { "ushort*" [ [ marshall-ushort* ] ] }
+ { "int*" [ [ marshall-int* ] ] }
+ { "uint*" [ [ marshall-uint* ] ] }
+ { "long*" [ [ marshall-long* ] ] }
+ { "ulong*" [ [ marshall-ulong* ] ] }
+ { "longlong*" [ [ marshall-longlong* ] ] }
+ { "ulonglong*" [ [ marshall-ulonglong* ] ] }
+ { "float*" [ [ marshall-float* ] ] }
+ { "double*" [ [ marshall-double* ] ] }
+ { "bool&" [ [ marshall-bool* ] ] }
+ { "boolean&" [ [ marshall-bool* ] ] }
+ { "char&" [ [ marshall-char* ] ] }
+ { "uchar&" [ [ marshall-uchar* ] ] }
+ { "short&" [ [ marshall-short* ] ] }
+ { "ushort&" [ [ marshall-ushort* ] ] }
+ { "int&" [ [ marshall-int* ] ] }
+ { "uint&" [ [ marshall-uint* ] ] }
+ { "long&" [ [ marshall-long* ] ] }
+ { "ulong&" [ [ marshall-ulong* ] ] }
+ { "longlong&" [ [ marshall-longlong* ] ] }
+ { "ulonglong&" [ [ marshall-ulonglong* ] ] }
+ { "float&" [ [ marshall-float* ] ] }
+ { "double&" [ [ marshall-double* ] ] }
+ { "void*" [ [ marshall-void* ] ] }
+ { "bool**" [ [ marshall-bool** ] ] }
+ { "boolean**" [ [ marshall-bool** ] ] }
+ { "char**" [ [ marshall-char**-or-strings ] ] }
+ { "uchar**" [ [ marshall-uchar** ] ] }
+ { "short**" [ [ marshall-short** ] ] }
+ { "ushort**" [ [ marshall-ushort** ] ] }
+ { "int**" [ [ marshall-int** ] ] }
+ { "uint**" [ [ marshall-uint** ] ] }
+ { "long**" [ [ marshall-long** ] ] }
+ { "ulong**" [ [ marshall-ulong** ] ] }
+ { "longlong**" [ [ marshall-longlong** ] ] }
+ { "ulonglong**" [ [ marshall-ulonglong** ] ] }
+ { "float**" [ [ marshall-float** ] ] }
+ { "double**" [ [ marshall-double** ] ] }
+ { "void**" [ [ marshall-void** ] ] }
+ [ drop f ]
+ } case ;
+
+: marshall-non-pointer ( alien-wrapper/byte-array -- byte-array )
+ {
+ { [ dup byte-array? ] [ ] }
+ { [ dup alien-wrapper? ]
+ [ [ underlying>> ] [ class name>> heap-size ] bi
+ memory>byte-array ] }
+ } cond ;
+
+
+: marshaller ( type -- quot )
+ factorize-type dup primitive-marshaller [ nip ] [
+ pointer?
+ [ [ marshall-pointer ] ]
+ [ [ marshall-non-pointer ] ] if
+ ] if* ;
+
+
+: unmarshall-char*-to-string ( alien -- string )
+ utf8 alien>string ;
+
+: unmarshall-char*-to-string-free ( alien -- string )
+ [ unmarshall-char*-to-string ] keep add-malloc free ;
+
+: primitive-unmarshaller ( type -- quot/f )
+ {
+ { "bool" [ [ ] ] }
+ { "boolean" [ [ unmarshall-bool ] ] }
+ { "char" [ [ ] ] }
+ { "uchar" [ [ ] ] }
+ { "short" [ [ ] ] }
+ { "ushort" [ [ ] ] }
+ { "int" [ [ ] ] }
+ { "uint" [ [ ] ] }
+ { "long" [ [ ] ] }
+ { "ulong" [ [ ] ] }
+ { "longlong" [ [ ] ] }
+ { "ulonglong" [ [ ] ] }
+ { "float" [ [ ] ] }
+ { "double" [ [ ] ] }
+ { "bool*" [ [ unmarshall-bool*-free ] ] }
+ { "boolean*" [ [ unmarshall-bool*-free ] ] }
+ { "char*" [ [ ] ] }
+ { "uchar*" [ [ unmarshall-uchar*-free ] ] }
+ { "short*" [ [ unmarshall-short*-free ] ] }
+ { "ushort*" [ [ unmarshall-ushort*-free ] ] }
+ { "int*" [ [ unmarshall-int*-free ] ] }
+ { "uint*" [ [ unmarshall-uint*-free ] ] }
+ { "long*" [ [ unmarshall-long*-free ] ] }
+ { "ulong*" [ [ unmarshall-ulong*-free ] ] }
+ { "longlong*" [ [ unmarshall-long*-free ] ] }
+ { "ulonglong*" [ [ unmarshall-ulong*-free ] ] }
+ { "float*" [ [ unmarshall-float*-free ] ] }
+ { "double*" [ [ unmarshall-double*-free ] ] }
+ { "bool&" [ [ unmarshall-bool*-free ] ] }
+ { "boolean&" [ [ unmarshall-bool*-free ] ] }
+ { "char&" [ [ ] ] }
+ { "uchar&" [ [ unmarshall-uchar*-free ] ] }
+ { "short&" [ [ unmarshall-short*-free ] ] }
+ { "ushort&" [ [ unmarshall-ushort*-free ] ] }
+ { "int&" [ [ unmarshall-int*-free ] ] }
+ { "uint&" [ [ unmarshall-uint*-free ] ] }
+ { "long&" [ [ unmarshall-long*-free ] ] }
+ { "ulong&" [ [ unmarshall-ulong*-free ] ] }
+ { "longlong&" [ [ unmarshall-longlong*-free ] ] }
+ { "ulonglong&" [ [ unmarshall-ulonglong*-free ] ] }
+ { "float&" [ [ unmarshall-float*-free ] ] }
+ { "double&" [ [ unmarshall-double*-free ] ] }
+ [ drop f ]
+ } case ;
+
+: struct-primitive-unmarshaller ( type -- quot/f )
+ {
+ { "bool" [ [ unmarshall-bool ] ] }
+ { "boolean" [ [ unmarshall-bool ] ] }
+ { "char" [ [ ] ] }
+ { "uchar" [ [ ] ] }
+ { "short" [ [ ] ] }
+ { "ushort" [ [ ] ] }
+ { "int" [ [ ] ] }
+ { "uint" [ [ ] ] }
+ { "long" [ [ ] ] }
+ { "ulong" [ [ ] ] }
+ { "longlong" [ [ ] ] }
+ { "ulonglong" [ [ ] ] }
+ { "float" [ [ ] ] }
+ { "double" [ [ ] ] }
+ { "bool*" [ [ unmarshall-bool* ] ] }
+ { "boolean*" [ [ unmarshall-bool* ] ] }
+ { "char*" [ [ ] ] }
+ { "uchar*" [ [ unmarshall-uchar* ] ] }
+ { "short*" [ [ unmarshall-short* ] ] }
+ { "ushort*" [ [ unmarshall-ushort* ] ] }
+ { "int*" [ [ unmarshall-int* ] ] }
+ { "uint*" [ [ unmarshall-uint* ] ] }
+ { "long*" [ [ unmarshall-long* ] ] }
+ { "ulong*" [ [ unmarshall-ulong* ] ] }
+ { "longlong*" [ [ unmarshall-long* ] ] }
+ { "ulonglong*" [ [ unmarshall-ulong* ] ] }
+ { "float*" [ [ unmarshall-float* ] ] }
+ { "double*" [ [ unmarshall-double* ] ] }
+ { "bool&" [ [ unmarshall-bool* ] ] }
+ { "boolean&" [ [ unmarshall-bool* ] ] }
+ { "char&" [ [ unmarshall-char* ] ] }
+ { "uchar&" [ [ unmarshall-uchar* ] ] }
+ { "short&" [ [ unmarshall-short* ] ] }
+ { "ushort&" [ [ unmarshall-ushort* ] ] }
+ { "int&" [ [ unmarshall-int* ] ] }
+ { "uint&" [ [ unmarshall-uint* ] ] }
+ { "long&" [ [ unmarshall-long* ] ] }
+ { "ulong&" [ [ unmarshall-ulong* ] ] }
+ { "longlong&" [ [ unmarshall-longlong* ] ] }
+ { "ulonglong&" [ [ unmarshall-ulonglong* ] ] }
+ { "float&" [ [ unmarshall-float* ] ] }
+ { "double&" [ [ unmarshall-double* ] ] }
+ [ drop f ]
+ } case ;
+
+
+: ?malloc-byte-array ( c-type -- alien )
+ dup alien? [ malloc-byte-array ] unless ;
+
+:: x-unmarshaller ( type type-quot superclass def clean -- quot/f )
+ type type-quot call current-vocab lookup [
+ dup superclasses superclass swap member?
+ [ def call ] [ drop clean call f ] if
+ ] [ clean call f ] if* ; inline
+
+: struct-unmarshaller ( type -- quot/f )
+ [ ] \ struct-wrapper
+ [ '[ ?malloc-byte-array _ new swap >>underlying ] ]
+ [ ]
+ x-unmarshaller ;
+
+: class-unmarshaller ( type -- quot/f )
+ [ type-sans-pointer "#" append ] \ class-wrapper
+ [ '[ _ new swap >>underlying ] ]
+ [ ]
+ x-unmarshaller ;
+
+: non-primitive-unmarshaller ( type -- quot/f )
+ {
+ { [ dup pointer? ] [ class-unmarshaller ] }
+ [ struct-unmarshaller ]
+ } cond ;
+
+: unmarshaller ( type -- quot )
+ factorize-type {
+ [ primitive-unmarshaller ]
+ [ non-primitive-unmarshaller ]
+ [ drop [ ] ]
+ } 1|| ;
+
+: struct-field-unmarshaller ( type -- quot )
+ factorize-type {
+ [ struct-primitive-unmarshaller ]
+ [ non-primitive-unmarshaller ]
+ [ drop [ ] ]
+ } 1|| ;
+
+: out-arg-unmarshaller ( type -- quot )
+ dup pointer-to-non-const-primitive?
+ [ factorize-type primitive-unmarshaller ]
+ [ drop [ drop ] ] if ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types alien.inline arrays
+combinators fry functors kernel lexer libc macros math
+sequences specialized-arrays libc.private
+combinators.short-circuit alien.data ;
+SPECIALIZED-ARRAY: void*
+IN: alien.marshall.private
+
+: bool>arg ( ? -- 1/0/obj )
+ {
+ { t [ 1 ] }
+ { f [ 0 ] }
+ [ ]
+ } case ;
+
+MACRO: marshall-x* ( num-quot seq-quot -- alien )
+ '[ bool>arg dup number? _ _ if ] ;
+
+: ptr-pass-through ( obj quot -- alien )
+ over { [ c-ptr? ] [ ] } 1&& [ drop ] [ call ] if ; inline
+
+: malloc-underlying ( obj -- alien )
+ underlying>> malloc-byte-array ;
+
+FUNCTOR: define-primitive-marshallers ( TYPE -- )
+<TYPE> IS <${TYPE}>
+*TYPE IS *${TYPE}
+>TYPE-array IS >${TYPE}-array
+marshall-TYPE DEFINES marshall-${TYPE}
+(marshall-TYPE*) DEFINES (marshall-${TYPE}*)
+(marshall-TYPE**) DEFINES (marshall-${TYPE}**)
+marshall-TYPE* DEFINES marshall-${TYPE}*
+marshall-TYPE** DEFINES marshall-${TYPE}**
+marshall-TYPE*-free DEFINES marshall-${TYPE}*-free
+marshall-TYPE**-free DEFINES marshall-${TYPE}**-free
+unmarshall-TYPE* DEFINES unmarshall-${TYPE}*
+unmarshall-TYPE*-free DEFINES unmarshall-${TYPE}*-free
+WHERE
+<PRIVATE
+: (marshall-TYPE*) ( n/seq -- alien )
+ [ <TYPE> malloc-byte-array ]
+ [ >TYPE-array malloc-underlying ]
+ marshall-x* ;
+PRIVATE>
+: marshall-TYPE* ( n/seq -- alien )
+ [ (marshall-TYPE*) ] ptr-pass-through ;
+<PRIVATE
+: (marshall-TYPE**) ( seq -- alien )
+ [ marshall-TYPE* ] void*-array{ } map-as malloc-underlying ;
+PRIVATE>
+: marshall-TYPE** ( seq -- alien )
+ [ (marshall-TYPE**) ] ptr-pass-through ;
+: unmarshall-TYPE* ( alien -- n )
+ *TYPE ; inline
+: unmarshall-TYPE*-free ( alien -- n )
+ [ unmarshall-TYPE* ] keep add-malloc free ;
+;FUNCTOR
+
+SYNTAX: PRIMITIVE-MARSHALLERS:
+";" parse-tokens [ define-primitive-marshallers ] each ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes help.markup help.syntax kernel quotations words
+alien.marshall.structs strings alien.structs alien.marshall ;
+IN: alien.marshall.structs
+
+HELP: define-marshalled-struct
+{ $values
+ { "name" string } { "vocab" "a vocabulary specifier" } { "fields" "an alist" }
+}
+{ $description "Calls " { $link define-struct } " and " { $link define-struct-tuple } "." } ;
+
+HELP: define-struct-tuple
+{ $values
+ { "name" string }
+}
+{ $description "Defines a subclass of " { $link struct-wrapper } ", a constructor, "
+ "and accessor words."
+} ;
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.marshall arrays assocs
+classes.tuple combinators destructors generalizations generic
+kernel libc locals parser quotations sequences slots words
+alien.structs lexer vocabs.parser fry effects alien.data ;
+IN: alien.marshall.structs
+
+<PRIVATE
+: define-struct-accessor ( class name quot -- )
+ [ "accessors" create create-method dup make-inline ] dip define ;
+
+: define-struct-getter ( class name word type -- )
+ [ ">>" append \ underlying>> ] 2dip
+ struct-field-unmarshaller \ call 4array >quotation
+ define-struct-accessor ;
+
+: define-struct-setter ( class name word type -- )
+ [ "(>>" prepend ")" append ] 2dip
+ marshaller [ underlying>> ] \ bi* roll 4array >quotation
+ define-struct-accessor ;
+
+: define-struct-accessors ( class name type reader writer -- )
+ [ dup define-protocol-slot ] 3dip
+ [ drop swap define-struct-getter ]
+ [ nip swap define-struct-setter ] 5 nbi ;
+
+: define-struct-constructor ( class -- )
+ {
+ [ name>> "<" prepend ">" append create-in ]
+ [ '[ _ new ] ]
+ [ name>> '[ _ malloc-object >>underlying ] append ]
+ [ name>> 1array ]
+ } cleave { } swap <effect> define-declared ;
+PRIVATE>
+
+:: define-struct-tuple ( name -- )
+ name create-in :> class
+ class struct-wrapper { } define-tuple-class
+ class define-struct-constructor
+ name c-type fields>> [
+ class swap
+ {
+ [ name>> { { CHAR: space CHAR: - } } substitute ]
+ [ type>> ] [ reader>> ] [ writer>> ]
+ } cleave define-struct-accessors
+ ] each ;
+
+: define-marshalled-struct ( name vocab fields -- )
+ [ define-struct ] [ 2drop define-struct-tuple ] 3bi ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations words
+alien.inline alien.syntax effects alien.marshall
+alien.marshall.structs strings sequences alien.inline.syntax ;
+IN: alien.marshall.syntax
+
+HELP: CM-FUNCTION:
+{ $syntax "CM-FUNCTION: return name args\n body\n;" }
+{ $description "Like " { $link POSTPONE: C-FUNCTION: } " but with marshalling "
+ "of arguments and return values."
+}
+{ $examples
+ { $example
+ "USING: alien.inline.syntax alien.marshall.syntax prettyprint ;"
+ "IN: example"
+ ""
+ "C-LIBRARY: exlib"
+ ""
+ "C-INCLUDE: <stdio.h>"
+ "C-INCLUDE: <stdlib.h>"
+ "CM-FUNCTION: char* sum_diff ( const-int a, const-int b, int* x, int* y )"
+ " *x = a + b;"
+ " *y = a - b;"
+ " char* s = (char*) malloc(sizeof(char) * 64);"
+ " sprintf(s, \"sum %i, diff %i\", *x, *y);"
+ " return s;"
+ ";"
+ ""
+ ";C-LIBRARY"
+ ""
+ "8 5 0 0 sum_diff . . ."
+ "3\n13\n\"sum 13, diff 3\""
+ }
+}
+{ $see-also define-c-marshalled POSTPONE: C-FUNCTION: POSTPONE: M-FUNCTION: } ;
+
+HELP: CM-STRUCTURE:
+{ $syntax "CM-STRUCTURE: name fields ... ;" }
+{ $description "Like " { $link POSTPONE: C-STRUCTURE: } " but with marshalling of fields. "
+ "Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words."
+}
+{ $see-also POSTPONE: C-STRUCTURE: POSTPONE: M-STRUCTURE: } ;
+
+HELP: M-FUNCTION:
+{ $syntax "M-FUNCTION: return name args ;" }
+{ $description "Like " { $link POSTPONE: FUNCTION: } " but with marshalling "
+ "of arguments and return values."
+}
+{ $see-also marshalled-function POSTPONE: C-FUNCTION: POSTPONE: CM-FUNCTION: } ;
+
+HELP: M-STRUCTURE:
+{ $syntax "M-STRUCTURE: name fields ... ;" }
+{ $description "Like " { $link POSTPONE: C-STRUCT: } " but with marshalling of fields. "
+ "Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words."
+}
+{ $see-also define-marshalled-struct POSTPONE: C-STRUCTURE: POSTPONE: CM-STRUCTURE: } ;
+
+HELP: define-c-marshalled
+{ $values
+ { "name" string } { "types" sequence } { "effect" effect } { "body" string }
+}
+{ $description "Defines a C function and a factor word which calls it with marshalling of "
+ "args and return values."
+}
+{ $see-also define-c-marshalled' } ;
+
+HELP: define-c-marshalled'
+{ $values
+ { "name" string } { "effect" effect } { "body" string }
+}
+{ $description "Like " { $link define-c-marshalled } ". "
+ "The effect elements must be C type strings."
+} ;
+
+HELP: marshalled-function
+{ $values
+ { "name" string } { "types" sequence } { "effect" effect }
+ { "word" word } { "quot" quotation } { "effect" effect }
+}
+{ $description "Defines a word which calls the named C function. Arguments, "
+ "return value, and output parameters are marshalled and unmarshalled."
+} ;
+
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.inline.syntax alien.marshall.syntax destructors
+tools.test accessors kernel ;
+IN: alien.marshall.syntax.tests
+
+DELETE-C-LIBRARY: test
+C-LIBRARY: test
+
+C-INCLUDE: <stdlib.h>
+C-INCLUDE: <string.h>
+C-INCLUDE: <stdbool.h>
+
+CM-FUNCTION: void outarg1 ( int* a )
+ *a += 2;
+;
+
+CM-FUNCTION: unsigned-long* outarg2 ( unsigned-long a, unsigned-long* b )
+ unsigned long* x = malloc(sizeof(unsigned long*));
+ *b = 10 + *b;
+ *x = a + *b;
+ return x;
+;
+
+CM-STRUCTURE: wedge
+ { "double" "degrees" } ;
+
+CM-STRUCTURE: sundial
+ { "double" "radius" }
+ { "wedge" "wedge" } ;
+
+CM-FUNCTION: double hours ( sundial* d )
+ return d->wedge.degrees / 30;
+;
+
+CM-FUNCTION: void change_time ( double hours, sundial* d )
+ d->wedge.degrees = hours * 30;
+;
+
+CM-FUNCTION: bool c_not ( bool p )
+ return !p;
+;
+
+CM-FUNCTION: char* upcase ( const-char* s )
+ int len = strlen(s);
+ char* t = malloc(sizeof(char) * len);
+ int i;
+ for (i = 0; i < len; i++)
+ t[i] = toupper(s[i]);
+ t[i] = '\0';
+ return t;
+;
+
+;C-LIBRARY
+
+{ 1 1 } [ outarg1 ] must-infer-as
+[ 3 ] [ 1 outarg1 ] unit-test
+[ 3 ] [ t outarg1 ] unit-test
+[ 2 ] [ f outarg1 ] unit-test
+
+{ 2 2 } [ outarg2 ] must-infer-as
+[ 18 15 ] [ 3 5 outarg2 ] unit-test
+
+{ 1 1 } [ hours ] must-infer-as
+[ 5.0 ] [ <sundial> <wedge> 150 >>degrees >>wedge hours ] unit-test
+
+{ 2 0 } [ change_time ] must-infer-as
+[ 150.0 ] [ 5 <sundial> <wedge> 11 >>degrees >>wedge [ change_time ] keep wedge>> degrees>> ] unit-test
+
+{ 1 1 } [ c_not ] must-infer-as
+[ f ] [ "x" c_not ] unit-test
+[ f ] [ 0 c_not ] unit-test
+
+{ 1 1 } [ upcase ] must-infer-as
+[ "ABC" ] [ "abc" upcase ] unit-test
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.inline alien.inline.types alien.marshall
+combinators effects generalizations kernel locals make namespaces
+quotations sequences words alien.marshall.structs lexer parser
+vocabs.parser multiline ;
+IN: alien.marshall.syntax
+
+:: marshalled-function ( name types effect -- word quot effect )
+ name types effect factor-function
+ [ in>> ]
+ [ out>> types [ pointer-to-non-const-primitive? ] filter append ]
+ bi <effect>
+ [
+ [
+ types [ marshaller ] map , \ spread , ,
+ types length , \ nkeep ,
+ types [ out-arg-unmarshaller ] map
+ effect out>> dup empty?
+ [ drop ] [ first unmarshaller prefix ] if
+ , \ spread ,
+ ] [ ] make
+ ] dip ;
+
+: define-c-marshalled ( name types effect body -- )
+ [
+ [ marshalled-function define-declared ]
+ [ prototype-string ] 3bi
+ ] dip append-function-body c-strings get push ;
+
+: define-c-marshalled' ( name effect body -- )
+ [
+ [ in>> ] keep
+ [ marshalled-function define-declared ]
+ [ out>> prototype-string' ] 3bi
+ ] dip append-function-body c-strings get push ;
+
+SYNTAX: CM-FUNCTION:
+ function-types-effect parse-here define-c-marshalled ;
+
+SYNTAX: M-FUNCTION:
+ function-types-effect marshalled-function define-declared ;
+
+SYNTAX: M-STRUCTURE:
+ scan current-vocab parse-definition
+ define-marshalled-struct ;
+
+SYNTAX: CM-STRUCTURE:
+ scan current-vocab parse-definition
+ [ define-marshalled-struct ] [ nip define-c-struct ] 3bi ;
projects / factor.git / commitdiff