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

db4
Slava Pestov 2009-07-15 19:25:41 -05:00
commit b4c522f045
24 changed files with 1471 additions and 164 deletions

View File

@ -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" } "." } ;

View File

@ -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 ;

View File

@ -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" } "." } ;

View File

@ -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

View File

@ -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 ;

View File

@ -0,0 +1 @@
Jeremy Hughes

View File

@ -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 ]

View File

@ -0,0 +1 @@
Jeremy Hughes

View File

@ -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"

View File

@ -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 ;

View File

@ -0,0 +1 @@
Jeremy Hughes

View File

@ -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 ;

View File

@ -0,0 +1 @@
Jeremy Hughes

View File

@ -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."
} ;

View File

@ -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 ;

View File

@ -0,0 +1 @@
Jeremy Hughes

View File

@ -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."
} ;

View File

@ -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

View File

@ -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 ;