Merge branch 'marshall' of git://github.com/jedahu/factor
Slava Pestov
commit
b4c522f045
|
|
@ -3,108 +3,12 @@
|
|||
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 ;
|
||||
|
||||
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 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 ;"
|
||||
"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:" "body" ";" }
|
||||
{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
|
||||
|
||||
CONSTANT: foo "abc"
|
||||
PRIVATE>
|
||||
|
||||
HELP: compile-c-library
|
||||
{ $description "Writes, compiles, and links code generated since last invocation of " { $link POSTPONE: define-c-library } ". "
|
||||
|
|
@ -204,8 +108,6 @@ HELP: with-c-library
|
|||
}
|
||||
{ $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" } "." } ;
|
||||
|
||||
ARTICLE: "alien.inline" "Inline C"
|
||||
{ $vocab-link "alien.inline" }
|
||||
;
|
||||
|
||||
ABOUT: "alien.inline"
|
||||
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" } "." } ;
|
||||
|
|
@ -9,43 +9,20 @@ splitting strings system vocabs.loader vocabs.parser words
|
|||
alien.c-types alien.structs make parser continuations ;
|
||||
IN: alien.inline
|
||||
|
||||
<PRIVATE
|
||||
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 ;
|
||||
|
||||
: function-types-effect ( -- function types effect )
|
||||
scan scan swap ")" parse-tokens
|
||||
[ "(" subseq? not ] filter swap parse-arglist ;
|
||||
|
||||
: arg-list ( types -- params )
|
||||
CHAR: a swap length CHAR: a + [a,b]
|
||||
[ 1string ] map ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
: append-function-body ( prototype-str body -- str )
|
||||
[ swap % " {\n" % % "\n}\n" % ] "" make ;
|
||||
|
||||
: compile-library? ( -- ? )
|
||||
c-library get library-path dup exists? [
|
||||
file get [
|
||||
|
|
@ -64,6 +41,29 @@ SYMBOL: c-strings
|
|||
[ current-vocab name>> % "_" % % ] "" make ;
|
||||
PRIVATE>
|
||||
|
||||
: 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
|
||||
V{ } clone c-strings set
|
||||
|
|
@ -122,29 +122,5 @@ PRIVATE>
|
|||
[ [ define-c-library ] dip call compile-c-library ]
|
||||
[ cleanup-variables ] [ ] cleanup ; inline
|
||||
|
||||
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:
|
||||
[ "\n" % parse-here % "\n" % c-strings get push ] "" make ;
|
||||
: raw-c ( str -- )
|
||||
[ "\n" % % "\n" % ] "" make c-strings get push ;
|
||||
|
|
@ -0,0 +1,100 @@
|
|||
! 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 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 ;"
|
||||
"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:" "body" ";" }
|
||||
{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2009 Jeremy Hughes.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.inline alien.inline.private io.directories io.files
|
||||
USING: alien.inline alien.inline.syntax io.directories io.files
|
||||
kernel namespaces tools.test alien.c-types alien.structs ;
|
||||
IN: alien.inline.tests
|
||||
IN: alien.inline.syntax.tests
|
||||
|
||||
DELETE-C-LIBRARY: test
|
||||
C-LIBRARY: test
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
! 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: parse-here raw-c ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jeremy Hughes
|
||||
|
|
@ -5,16 +5,21 @@ continuations effects fry kernel math memoize sequences
|
|||
splitting ;
|
||||
IN: alien.inline.types
|
||||
|
||||
: factorize-type ( str -- str' )
|
||||
"const-" ?head drop
|
||||
"unsigned-" ?head [ "u" prepend ] when
|
||||
"long-" ?head [ "long" prepend ] when ;
|
||||
|
||||
: cify-type ( str -- str' )
|
||||
{ { CHAR: - CHAR: space } } substitute ;
|
||||
|
||||
: const-type? ( str -- ? )
|
||||
"const-" head? ;
|
||||
: 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? ;
|
||||
|
||||
MEMO: resolved-primitives ( -- seq )
|
||||
primitive-types [ resolve-typedef ] map ;
|
||||
|
|
@ -26,14 +31,21 @@ MEMO: resolved-primitives ( -- seq )
|
|||
] [ 2drop f ] recover ;
|
||||
|
||||
: pointer? ( type -- ? )
|
||||
[ "*" tail? ] [ "&" tail? ] bi or ;
|
||||
factorize-type [ "*" tail? ] [ "&" tail? ] bi or ;
|
||||
|
||||
: type-sans-pointer ( type -- type' )
|
||||
[ '[ _ = ] "*&" swap any? ] trim-tail ;
|
||||
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 ]
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jeremy Hughes
|
||||
|
|
@ -0,0 +1,638 @@
|
|||
! 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 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: pointer-unmarshaller
|
||||
{ $values
|
||||
{ "type" " a C type string" }
|
||||
{ "quot" 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" 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 marshaller }
|
||||
"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"
|
||||
|
|
@ -0,0 +1,303 @@
|
|||
! 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
|
||||
specialized-arrays.alien specialized-arrays.bool
|
||||
specialized-arrays.char specialized-arrays.double
|
||||
specialized-arrays.float specialized-arrays.int
|
||||
specialized-arrays.long specialized-arrays.longlong
|
||||
specialized-arrays.short specialized-arrays.uchar
|
||||
specialized-arrays.uint specialized-arrays.ulong
|
||||
specialized-arrays.ulonglong specialized-arrays.ushort strings
|
||||
unix.utilities vocabs.parser words libc.private struct-arrays ;
|
||||
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 ;
|
||||
|
||||
GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
|
||||
|
||||
M: alien-wrapper unmarshall-cast ;
|
||||
M: struct-wrapper unmarshall-cast ;
|
||||
|
||||
M: struct-wrapper dispose* underlying>> free ;
|
||||
|
||||
: marshall-pointer ( obj -- alien )
|
||||
{
|
||||
{ [ dup alien? ] [ ] }
|
||||
{ [ dup not ] [ ] }
|
||||
{ [ dup byte-array? ] [ malloc-byte-array ] }
|
||||
{ [ dup alien-wrapper? ] [ underlying>> ] }
|
||||
{ [ dup struct-array? ] [ 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" [ [ marshall-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" [ [ unmarshall-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 ;
|
||||
|
||||
: struct-unmarshaller ( type -- quot )
|
||||
current-vocab lookup [
|
||||
dup superclasses [ \ struct-wrapper = ] any? [
|
||||
'[ ?malloc-byte-array _ new swap >>underlying ]
|
||||
] [ drop [ ] ] if
|
||||
] [ [ ] ] if* ;
|
||||
|
||||
: pointer-unmarshaller ( type -- quot )
|
||||
type-sans-pointer current-vocab lookup [
|
||||
dup superclasses [ \ alien-wrapper = ] any? [
|
||||
'[ _ new swap >>underlying unmarshall-cast ]
|
||||
] [ drop [ ] ] if
|
||||
] [ [ ] ] if* ;
|
||||
|
||||
: unmarshaller ( type -- quot )
|
||||
factorize-type dup primitive-unmarshaller [ nip ] [
|
||||
dup pointer?
|
||||
[ pointer-unmarshaller ]
|
||||
[ struct-unmarshaller ] if
|
||||
] if* ;
|
||||
|
||||
: struct-field-unmarshaller ( type -- quot )
|
||||
factorize-type dup struct-primitive-unmarshaller [ nip ] [
|
||||
dup pointer?
|
||||
[ pointer-unmarshaller ]
|
||||
[ struct-unmarshaller ] if
|
||||
] if* ;
|
||||
|
||||
: out-arg-unmarshaller ( type -- quot )
|
||||
dup pointer-to-non-const-primitive?
|
||||
[ factorize-type primitive-unmarshaller ]
|
||||
[ drop [ drop ] ] if ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jeremy Hughes
|
||||
|
|
@ -0,0 +1,60 @@
|
|||
! 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.alien libc.private
|
||||
combinators.short-circuit ;
|
||||
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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jeremy Hughes
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
! 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."
|
||||
} ;
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
! 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 ;
|
||||
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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jeremy Hughes
|
||||
|
|
@ -0,0 +1,85 @@
|
|||
! 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 ;
|
||||
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 alien.marshall.syntax prettyprint ;"
|
||||
"IN: example"
|
||||
""
|
||||
"C-LIBRARY: exlib"
|
||||
""
|
||||
"C-INCLUDE: <stdio.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 .s"
|
||||
"\"sum 13, diff 3\""
|
||||
"13"
|
||||
"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."
|
||||
} ;
|
||||
|
||||
|
|
@ -0,0 +1,76 @@
|
|||
! Copyright (C) 2009 Jeremy Hughes.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.inline 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-TYPEDEF: char bool
|
||||
|
||||
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
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
! 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 ;
|
||||
Loading…
Reference in New Issue