+++ /dev/null
-USING: help.syntax help.markup byte-arrays alien.c-types alien.data ;\r
-IN: alien.arrays\r
-\r
-ARTICLE: "c-arrays" "C arrays"\r
-"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."\r
-$nl\r
-"C type specifiers for array types are documented in " { $link "c-types-specs" } "."\r
-$nl\r
-"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " vocabulary set. They can also be loaded and constructed through their primitive C types:"\r
-{ $subsection require-c-array }\r
-{ $subsection <c-array> }\r
-{ $subsection <c-direct-array> } ;\r
{ $contract "Outputs the size of the byte array, struct, or specialized array data in bytes." } ;
HELP: heap-size
-{ $values { "type" string } { "size" math:integer } }
+{ $values { "name" "a C type name" } { "size" math:integer } }
{ $description "Outputs the number of bytes needed for a heap-allocated value of this C type." }
{ $examples
{ $example "USING: alien alien.c-types prettyprint ;\nint heap-size ." "4" }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: stack-size
-{ $values { "type" string } { "size" math:integer } }
+{ $values { "name" "a C type name" } { "size" math:integer } }
{ $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: <c-type>
-{ $values { "type" hashtable } }
+{ $values { "c-type" c-type } }
{ $description "Creates a prototypical C type. User code should use higher-level facilities to define C types; see " { $link "c-data" } "." } ;
HELP: no-c-type
-{ $values { "type" string } }
+{ $values { "name" "a C type name" } }
{ $description "Throws a " { $link no-c-type } " error." }
{ $error-description "Thrown by " { $link c-type } " if a given string does not name a C type. When thrown during compile time, indicates a typo in an " { $link alien-invoke } " or " { $link alien-callback } " form." } ;
{ $var-description "Global variable holding a hashtable mapping C type names to C types. Use the " { $link c-type } " word to look up C types." } ;
HELP: c-type
-{ $values { "name" string } { "type" hashtable } }
+{ $values { "name" "a C type" } { "c-type" c-type } }
{ $description "Looks up a C type by name." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: c-getter
-{ $values { "name" string } { "quot" { $quotation "( c-ptr n -- obj )" } } }
+{ $values { "name" "a C type" } { "quot" { $quotation "( c-ptr n -- obj )" } } }
{ $description "Outputs a quotation which reads values of this C type from a C structure." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: c-setter
-{ $values { "name" string } { "quot" { $quotation "( obj c-ptr n -- )" } } }
+{ $values { "name" "a C type" } { "quot" { $quotation "( obj c-ptr n -- )" } } }
{ $description "Outputs a quotation which writes values of this C type to a C structure." }
{ $errors "Throws an error if the type does not exist." } ;
HELP: box-parameter
-{ $values { "n" math:integer } { "ctype" string } }
+{ $values { "n" math:integer } { "c-type" "a C type" } }
{ $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." }
{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
HELP: box-return
-{ $values { "ctype" string } }
+{ $values { "c-type" "a C type" } }
{ $description "Generates code for converting a C value stored in return registers into a Factor object to be pushed on the data stack." }
{ $notes "This is an internal word used by the compiler when compiling alien calls." } ;
HELP: unbox-return
-{ $values { "ctype" string } }
+{ $values { "c-type" "a C type" } }
{ $description "Generates code for converting a Factor value on the data stack into a C value to be stored in the return registers." }
{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
{ rep initial: int-rep }
stack-align? ;
-: <c-type> ( -- type )
- \ c-type new ;
+: <c-type> ( -- c-type )
+ \ c-type new ; inline
SYMBOL: c-types
UNION: c-type-name string word ;
! C type protocol
-GENERIC: c-type ( name -- type ) foldable
+GENERIC: c-type ( name -- c-type ) foldable
GENERIC: resolve-pointer-type ( name -- c-type )
M: word resolve-pointer-type
dup "pointer-c-type" word-prop
[ ] [ drop void* ] ?if ;
+
M: string resolve-pointer-type
dup "*" append dup c-types get at
[ nip ] [
[ resolve-pointer-type ] [ drop void* ] if
] if ;
-: resolve-typedef ( name -- type )
+: resolve-typedef ( name -- c-type )
dup c-type-name? [ c-type ] when ;
-: parse-array-type ( name -- dims type )
+: parse-array-type ( name -- dims c-type )
"[" split unclip
[ [ "]" ?tail drop string>number ] map ] dip ;
-M: string c-type ( name -- type )
+M: string c-type ( name -- c-type )
CHAR: ] over member? [
parse-array-type prefix
] [
: void? ( c-type -- ? )
{ void "void" } member? ;
-GENERIC: c-struct? ( type -- ? )
+GENERIC: c-struct? ( c-type -- ? )
M: object c-struct?
drop f ;
M: c-type-name c-type-stack-align? c-type c-type-stack-align? ;
-: c-type-box ( n type -- )
+: c-type-box ( n c-type -- )
[ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
%box ;
-: c-type-unbox ( n ctype -- )
+: c-type-unbox ( n c-type -- )
[ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi
%unbox ;
-GENERIC: box-parameter ( n ctype -- )
+GENERIC: box-parameter ( n c-type -- )
M: c-type box-parameter c-type-box ;
M: c-type-name box-parameter c-type box-parameter ;
-GENERIC: box-return ( ctype -- )
+GENERIC: box-return ( c-type -- )
M: c-type box-return f swap c-type-box ;
M: c-type-name box-return c-type box-return ;
-GENERIC: unbox-parameter ( n ctype -- )
+GENERIC: unbox-parameter ( n c-type -- )
M: c-type unbox-parameter c-type-unbox ;
M: c-type-name unbox-parameter c-type unbox-parameter ;
-GENERIC: unbox-return ( ctype -- )
+GENERIC: unbox-return ( c-type -- )
M: c-type unbox-return f swap c-type-unbox ;
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
-GENERIC: heap-size ( type -- size ) foldable
+GENERIC: heap-size ( name -- size ) foldable
M: c-type-name heap-size c-type heap-size ;
M: abstract-c-type heap-size size>> ;
-GENERIC: stack-size ( type -- size ) foldable
+GENERIC: stack-size ( name -- size ) foldable
M: c-type-name stack-size c-type stack-size ;
[ "Cannot write struct fields with this type" throw ]
] unless* ;
-: array-accessor ( type quot -- def )
+: array-accessor ( c-type quot -- def )
[
\ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
] [ ] make ;
TUPLE: long-long-type < c-type ;
-: <long-long-type> ( -- type )
+: <long-long-type> ( -- c-type )
long-long-type new ;
-M: long-long-type unbox-parameter ( n type -- )
+M: long-long-type unbox-parameter ( n c-type -- )
c-type-unboxer %unbox-long-long ;
-M: long-long-type unbox-return ( type -- )
+M: long-long-type unbox-return ( c-type -- )
f swap unbox-parameter ;
-M: long-long-type box-parameter ( n type -- )
+M: long-long-type box-parameter ( n c-type -- )
c-type-boxer %box-long-long ;
-M: long-long-type box-return ( type -- )
+M: long-long-type box-return ( c-type -- )
f swap box-parameter ;
: define-deref ( name -- )
[ dup c-setter '[ _ heap-size <byte-array> [ 0 @ ] keep ] ] bi
(( value -- c-ptr )) define-inline ;
-: define-primitive-type ( type name -- )
+: define-primitive-type ( c-type name -- )
[ typedef ]
[ name>> define-deref ]
[ name>> define-out ]
tri ;
-: if-void ( type true false -- )
+: if-void ( c-type true false -- )
pick void? [ drop nip call ] [ nip call ] if ; inline
CONSTANT: primitive-types
-USING: alien alien.c-types help.syntax help.markup libc kernel.private
-byte-arrays math strings hashtables alien.syntax alien.strings sequences
-io.encodings.string debugger destructors vocabs.loader ;
+USING: alien alien.c-types help.syntax help.markup libc
+kernel.private byte-arrays math strings hashtables alien.syntax
+alien.strings sequences io.encodings.string debugger destructors
+vocabs.loader classes.struct ;
IN: alien.data
HELP: <c-array>
{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
HELP: malloc-array
-{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } }
+{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" "a specialized array" } }
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-direct-array> } "." }
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
$nl
"Allocating a C datum with a fixed address:"
{ $subsection malloc-object }
-{ $subsection malloc-array }
{ $subsection malloc-byte-array }
+{ $subsection malloc-file-contents }
"There is a set of words in the " { $vocab-link "libc" } " vocabulary which directly call C standard library memory management functions:"
{ $subsection malloc }
{ $subsection calloc }
"You can copy a byte array to memory unsafely:"
{ $subsection byte-array>memory } ;
-
-ARTICLE: "c-byte-arrays" "Passing data in byte arrays"
-"Instances of the " { $link byte-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array."
-$nl
-"Byte arrays can be allocated directly with a byte count using the " { $link <byte-array> } " word. However in most cases, instead of computing a size in bytes directly, it is easier to use a higher-level word which expects C type and outputs a byte array large enough to hold that type:"
-{ $subsection <c-object> }
-{ $subsection <c-array> }
+ARTICLE: "c-pointers" "Passing pointers to C functions"
+"The following Factor objects may be passed to C function parameters with pointer types:"
+{ $list
+ { "Instances of " { $link alien } "." }
+ { "Instances of " { $link f } "; this is interpreted as a null pointer." }
+ { "Instances of " { $link byte-array } "; the C function receives a pointer to the first element of the array." }
+ { "Any data type which defines a method on " { $link >c-ptr } " that returns an instance of one of the above. This includes " { $link "classes.struct" } " and " { $link "specialized-arrays" } "." }
+}
+"The class of primitive C pointer types:"
+{ $subsection c-ptr }
+"A generic word for converting any object to a C pointer; user-defined types may add methods to this generic word:"
+{ $subsection >c-ptr }
+"More about the " { $link alien } " type:"
+{ $subsection "aliens" }
{ $warning
-"The Factor garbage collector can move byte arrays around, and code passing byte arrays to C must obey important guidelines. See " { $link "byte-arrays-gc" } "." }
-{ $see-also "c-arrays" } ;
+"The Factor garbage collector can move byte arrays around, and code passing byte arrays, or objects backed by byte arrays, must obey important guidelines. See " { $link "byte-arrays-gc" } "." } ;
ARTICLE: "c-data" "Passing data between Factor and C"
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."
$nl
"Furthermore, Factor's garbage collector can move objects in memory; for a discussion of the consequences, see " { $link "byte-arrays-gc" } "."
{ $subsection "c-types-specs" }
-{ $subsection "c-byte-arrays" }
+{ $subsection "c-pointers" }
{ $subsection "malloc" }
{ $subsection "c-strings" }
-{ $subsection "c-arrays" }
{ $subsection "c-out-params" }
"Important guidelines for passing data in byte arrays:"
{ $subsection "byte-arrays-gc" }
{ $subsection POSTPONE: C-ENUM: }
"C types can be aliased for convenience and consitency with native library documentation:"
{ $subsection POSTPONE: TYPEDEF: }
-"New C types can be defined:"
-{ $subsection "c-structs" }
-{ $subsection "c-unions" }
"A utility for defining " { $link "destructors" } " for deallocating memory:"
{ $subsection "alien.destructors" }
-{ $see-also "aliens" } ;
+"C struct and union types can be defined with " { $link POSTPONE: STRUCT: } " and " { $link POSTPONE: UNION: } ". See " { $link "classes.struct" } " for details. For passing arrays to and from C, use the " { $link "specialized-arrays" } " vocabulary." ;
+
HELP: malloc-string
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
M: c-type-name <c-direct-array>
c-direct-array-constructor execute( alien len -- array ) ; inline
-: malloc-array ( n type -- alien )
+: malloc-array ( n type -- array )
[ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
: (malloc-array) ( n type -- alien )
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2005, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel kernel.private math namespaces
-make sequences strings words effects combinators alien.c-types ;
-IN: alien.structs.fields
-
-TUPLE: field-spec name offset type reader writer ;
-
-: reader-word ( class name vocab -- word )
- [ "-" glue ] dip create dup make-deprecated ;
-
-: writer-word ( class name vocab -- word )
- [ [ swap "set-" % % "-" % % ] "" make ] dip create dup make-deprecated ;
-
-: <field-spec> ( struct-name vocab type field-name -- spec )
- field-spec new
- 0 >>offset
- swap >>name
- swap >>type
- 3dup name>> swap reader-word >>reader
- 3dup name>> swap writer-word >>writer
- 2nip ;
-
-: align-offset ( offset type -- offset )
- c-type-align align ;
-
-: struct-offsets ( specs -- size )
- 0 [
- [ type>> align-offset ] keep
- [ (>>offset) ] [ type>> heap-size + ] 2bi
- ] reduce ;
-
-: define-struct-slot-word ( word quot spec effect -- )
- [ offset>> prefix ] dip define-inline ;
-
-: define-getter ( spec -- )
- [ reader>> ] [ type>> c-type-getter-boxer ] [ ] tri
- (( c-ptr -- value )) define-struct-slot-word ;
-
-: define-setter ( spec -- )
- [ writer>> ] [ type>> c-setter ] [ ] tri
- (( value c-ptr -- )) define-struct-slot-word ;
-
-: define-field ( spec -- )
- [ define-getter ] [ define-setter ] bi ;
+++ /dev/null
-Struct field implementation and reflection support
+++ /dev/null
-USING: alien.c-types alien.data strings help.markup help.syntax alien.syntax
-sequences io arrays kernel words assocs namespaces ;
-IN: alien.structs
-
-ARTICLE: "c-structs" "C structure types"
-"A " { $snippet "struct" } " in C is essentially a block of memory with the value of each structure field stored at a fixed offset from the start of the block. The C library interface provides some utilities to define words which read and write structure fields given a base address."
-{ $subsection POSTPONE: C-STRUCT: }
-"Great care must be taken when working with C structures since no type or bounds checking is possible."
-$nl
-"An example:"
-{ $code
- "C-STRUCT: XVisualInfo"
- " { \"Visual*\" \"visual\" }"
- " { \"VisualID\" \"visualid\" }"
- " { \"int\" \"screen\" }"
- " { \"uint\" \"depth\" }"
- " { \"int\" \"class\" }"
- " { \"ulong\" \"red_mask\" }"
- " { \"ulong\" \"green_mask\" }"
- " { \"ulong\" \"blue_mask\" }"
- " { \"int\" \"colormap_size\" }"
- " { \"int\" \"bits_per_rgb\" } ;"
-}
-"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
-$nl
-"Arrays of C structures can be created with the " { $vocab-link "specialized-arrays" } " vocabulary." ;
-
-ARTICLE: "c-unions" "C unions"
-"A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
-{ $subsection POSTPONE: C-UNION: }
-"C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
-$nl
-"Arrays of C unions can be created with the " { $vocab-link "specialized-arrays" } " vocabulary." ;
+++ /dev/null
-USING: alien alien.syntax alien.c-types alien.data kernel tools.test
-sequences system libc words vocabs namespaces layouts ;
-IN: alien.structs.tests
-
-C-STRUCT: bar
- { "int" "x" }
- { { "int" 8 } "y" } ;
-
-[ 36 ] [ "bar" heap-size ] unit-test
-[ t ] [ \ <displaced-alien> "bar" c-type-getter memq? ] unit-test
-
-C-STRUCT: align-test
- { "int" "x" }
- { "double" "y" } ;
-
-os winnt? cpu x86? and [
- [ 16 ] [ "align-test" heap-size ] unit-test
-
- cell 4 = [
- C-STRUCT: one
- { "long" "a" } { "double" "b" } { "int" "c" } ;
-
- [ 24 ] [ "one" heap-size ] unit-test
- ] when
-] when
-
-CONSTANT: MAX_FOOS 30
-
-C-STRUCT: foox
- { { "int" MAX_FOOS } "x" } ;
-
-[ 120 ] [ "foox" heap-size ] unit-test
-
-C-UNION: barx
- { "int" MAX_FOOS }
- "float" ;
-
-[ 120 ] [ "barx" heap-size ] unit-test
-
-"help" vocab [
- "print-topic" "help" lookup "help" set
- [ ] [ \ foox-x "help" get execute ] unit-test
- [ ] [ \ set-foox-x "help" get execute ] unit-test
-] when
-
-C-STRUCT: nested
- { "int" "x" } ;
-
-C-STRUCT: nested-2
- { "nested" "y" } ;
-
-[ 4 ] [
- "nested-2" <c-object>
- "nested" <c-object>
- 4 over set-nested-x
- over set-nested-2-y
- nested-2-y
- nested-x
-] unit-test
+++ /dev/null
-! Copyright (C) 2004, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs generic hashtables kernel kernel.private
-math namespaces parser sequences strings words libc fry
-alien.c-types alien.structs.fields cpu.architecture math.order
-quotations byte-arrays ;
-IN: alien.structs
-
-TUPLE: struct-type < abstract-c-type fields return-in-registers? ;
-
-INSTANCE: struct-type value-type
-
-M: struct-type c-type ;
-
-M: struct-type c-type-stack-align? drop f ;
-
-: if-value-struct ( ctype true false -- )
- [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
-
-M: struct-type unbox-parameter
- [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
-
-M: struct-type box-parameter
- [ %box-large-struct ] [ box-parameter ] if-value-struct ;
-
-: if-small-struct ( c-type true false -- ? )
- [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
-
-M: struct-type unbox-return
- [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
-
-M: struct-type box-return
- [ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
-
-M: struct-type stack-size
- [ heap-size ] [ stack-size ] if-value-struct ;
-
-M: struct-type c-struct? drop t ;
-
-: (define-struct) ( name size align fields class -- )
- [ [ align ] keep ] 2dip new
- byte-array >>class
- byte-array >>boxed-class
- swap >>fields
- swap >>align
- swap >>size
- swap typedef ;
-
-: make-fields ( name vocab fields -- fields )
- [ first2 <field-spec> ] with with map ;
-
-: compute-struct-align ( types -- n )
- [ c-type-align ] [ max ] map-reduce ;
-
-: define-struct ( name vocab fields -- )
- [ 2drop ] [ make-fields ] 3bi
- [ struct-offsets ] keep
- [ [ type>> ] map compute-struct-align ] keep
- [ struct-type (define-struct) ] keep
- [ define-field ] each ; deprecated
-
-: define-union ( name members -- )
- [ [ heap-size ] [ max ] map-reduce ] keep
- compute-struct-align f struct-type (define-struct) ; deprecated
-
-: offset-of ( field struct -- offset )
- c-types get at fields>>
- [ name>> = ] with find nip offset>> ;
-
-USE: vocabs.loader
-"specialized-arrays" require
+++ /dev/null
-C structure support
IN: alien.syntax
-USING: alien alien.c-types alien.parser alien.structs
-classes.struct help.markup help.syntax ;
+USING: alien alien.c-types alien.parser classes.struct help.markup help.syntax ;
HELP: DLL"
{ $syntax "DLL\" path\"" }
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." }
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
-HELP: C-STRUCT:
-{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: STRUCT: } " word." }
-{ $syntax "C-STRUCT: name pairs... ;" }
-{ $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } }
-{ $description "Defines a C struct layout and accessor words." }
-{ $notes "C type names are documented in " { $link "c-types-specs" } "." } ;
-
-HELP: C-UNION:
-{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: UNION-STRUCT: } " word." }
-{ $syntax "C-UNION: name members... ;" }
-{ $values { "name" "a new C type name" } { "members" "a sequence of C types" } }
-{ $description "Defines a new C type sized to fit its largest member." }
-{ $notes "C type names are documented in " { $link "c-types-specs" } "." }
-{ $examples { $code "C-UNION: event \"active-event\" \"keyboard-event\" \"mouse-event\" ;" } } ;
-
HELP: C-ENUM:
{ $syntax "C-ENUM: words... ;" }
{ $values { "words" "a sequence of word names" } }
{ POSTPONE: TYPEDEF: typedef } related-words
HELP: c-struct?
-{ $values { "type" "a string" } { "?" "a boolean" } }
-{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: C-STRUCT: } "." } ;
+{ $values { "c-type" "a C type name" } { "?" "a boolean" } }
+{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: STRUCT: } "." } ;
HELP: define-function
{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
! Copyright (C) 2005, 2009 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays alien alien.c-types alien.structs
+USING: accessors arrays alien alien.c-types
alien.arrays alien.strings kernel math namespaces parser
sequences words quotations math.parser splitting grouping
effects assocs combinators lexer strings.parser alien.parser
SYNTAX: TYPEDEF:
scan-c-type CREATE-C-TYPE typedef ;
-SYNTAX: C-STRUCT:
- scan current-vocab parse-definition define-struct ; deprecated
-
-SYNTAX: C-UNION:
- scan parse-definition define-union ; deprecated
-
SYNTAX: C-ENUM:
";" parse-tokens
[ [ create-in ] dip define-constant ] each-index ;
$nl
"Bit array words are in the " { $vocab-link "bit-arrays" } " vocabulary."
$nl
-"Bit arrays play a special role in the C library interface; they can be used to pass binary data back and forth between Factor and C. See " { $link "c-byte-arrays" } "."
+"Bit arrays play a special role in the C library interface; they can be used to pass binary data back and forth between Factor and C. See " { $link "c-pointers" } "."
$nl
"Bit arrays form a class of objects:"
{ $subsection bit-array }
HELP: struct-class
{ $class-description "The metaclass of all " { $link struct } " classes." } ;
-ARTICLE: "classes.struct" "Struct classes"
-{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI. Struct types are defined using a syntax similar to tuple syntax:"
+ARTICLE: "classes.struct.examples" "Struct class examples"
+"A struct with a variety of fields:"
+{ $code
+ "USING: alien.c-types classes.struct ;"
+ ""
+ "STRUCT: test-struct"
+ " { i int }"
+ " { chicken char[16] }"
+ " { data void* } ;"
+}
+"Creating a new instance of this struct, and printing out:"
+{ $code "test-struct <struct> ." }
+"Creating a new instance with slots initialized from the stack:"
+{ $code
+ "USING: libc specialized-arrays ;"
+ "SPECIALIZED-ARRAY: char"
+ ""
+ "42"
+ "\"Hello, chicken.\" >char-array"
+ "1024 malloc"
+ "test-struct <struct-boa> ."
+} ;
+
+ARTICLE: "classes.struct.define" "Defining struct classes"
+"Struct classes are defined using a syntax similar to the " { $link POSTPONE: TUPLE: } " syntax for defining tuple classes:"
{ $subsection POSTPONE: STRUCT: }
+"Union structs are also supported, which behave like structs but share the same memory for all the slots."
+{ $subsection POSTPONE: UNION-STRUCT: } ;
+
+ARTICLE: "classes.struct.create" "Creating instances of structs"
"Structs can be allocated with " { $link new } "- and " { $link boa } "-like constructor words. Additional words are provided for building structs from C memory and from existing buffers:"
{ $subsection <struct> }
{ $subsection <struct-boa> }
"When the contents of a struct will be immediately reset, faster primitive words are available that will create a struct without initializing its contents:"
{ $subsection (struct) }
{ $subsection (malloc-struct) }
-"Structs have literal syntax like tuples:"
-{ $subsection POSTPONE: S{ }
-"Union structs are also supported, which behave like structs but share the same memory for all the type's slots."
-{ $subsection POSTPONE: UNION-STRUCT: }
-;
+"Structs have literal syntax, similar to " { $link POSTPONE: T{ } " for tuples:"
+{ $subsection POSTPONE: S{ } ;
+
+ARTICLE: "classes.struct.c" "Passing structs to C functions"
+"Structs can be passed and returned by value, or by reference."
+$nl
+"If a parameter is declared with a struct type, the parameter is passed by value. To pass a struct by reference, declare a parameter with a pointer to struct type."
+$nl
+"If a C function is declared as returning a struct type, the struct is returned by value, and wrapped in an instance of the correct struct class automatically. If a C function is declared as returning a pointer to a struct, it will return an " { $link alien } " instance. This is because there is no way to distinguish between a pointer to a single struct and a pointer to an array of zero or more structs. It is up to the caller to wrap it in a struct, or a specialized array of structs, respectively."
+$nl
+"An example of a struct declaration:"
+{ $code
+ "USING: alien.c-types classes.struct ;"
+ ""
+ "STRUCT: Point"
+ " { x int }"
+ " { y int }"
+ " { z int } ;"
+}
+"A C function which returns a struct by value:"
+{ $code
+ "USING: alien.syntax ;"
+ "FUNCTION: Point give_me_a_point ( char* description ) ;"
+}
+"A C function which takes a struct parameter by reference:"
+{ $code
+ "FUNCTION: void print_point ( Point* p ) ;"
+} ;
+
+ARTICLE: "classes.struct" "Struct classes"
+{ $link struct } " classes are similar to " { $link tuple } "s, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for structured access to C memory or Factor byte arrays and for passing struct values in and out of the FFI."
+{ $subsection "classes.struct.examples" }
+{ $subsection "classes.struct.define" }
+{ $subsection "classes.struct.create" }
+{ $subsection "classes.struct.c" } ;
ABOUT: "classes.struct"
kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types
alien.strings alien.arrays alien.complex alien.libraries sets libc
-continuations.private fry cpu.architecture classes locals
+continuations.private fry cpu.architecture classes classes.struct locals
source-files.errors slots parser generic.parser
compiler.errors
compiler.alien
compiler.cfg.builder
compiler.codegen.fixup
compiler.utilities ;
-QUALIFIED: classes.struct
-QUALIFIED: alien.structs
IN: compiler.codegen
SYMBOL: insn-counts
M: object flatten-value-type 1array ;
-M: alien.structs:struct-type flatten-value-type ( type -- types )
- stack-size cell align (flatten-int-type) ;
-
-M: classes.struct:struct-c-type flatten-value-type ( type -- types )
+M: struct-c-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
M: long-long-type flatten-value-type ( type -- types )
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays sequences math splitting make assocs kernel
-layouts system alien.c-types cpu.architecture
+layouts system alien.c-types classes.struct cpu.architecture
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 compiler.codegen
compiler.cfg.registers ;
-QUALIFIED: alien.structs
-QUALIFIED: classes.struct
IN: cpu.x86.64.unix
M: int-regs param-regs
flatten-small-struct
] if ;
-M: alien.structs:struct-type flatten-value-type ( type -- seq )
- flatten-struct ;
-M: classes.struct:struct-c-type flatten-value-type ( type -- seq )
+M: struct-c-type flatten-value-type ( type -- seq )
flatten-struct ;
M: x86.64 return-struct-in-registers? ( c-type -- ? )
{ $values { "seq" "a sequence" } { "quot" { $quotation "( elt -- )" } } }
{ $description "Applies the quotation to each element of the sequence, printing a comma between each pair of elements." }
{ $examples
- { $example "USING: help.markup io ;" "{ \"fish\" \"chips\" \"salt\" } [ write ] textual-list" "fish, chips, salt" }
+ { $example "USING: help.markup io namespaces ;" "last-element off" "{ \"fish\" \"chips\" \"salt\" } [ write ] textual-list" "fish, chips, salt" }
} ;
HELP: $links
"Behind the scenes, these words are placed in a vocabulary named " { $snippet "specialized-arrays.instances.T" } ", however this vocabulary should not be placed in a " { $link POSTPONE: USING: } " form directly. Instead, always use " { $link POSTPONE: SPECIALIZED-ARRAY: } ". This ensures that the vocabulary can get generated the first time it is needed." ;
ARTICLE: "specialized-array-c" "Passing specialized arrays to C functions"
+"If a C function is declared as taking a parameter with a pointer or an array type (for example, " { $snippet "float*" } " or " { $snippet "int[3]" } "), instances of the relevant specialized array can be passed in."
+$nl
+"C type specifiers for array types are documented in " { $link "c-types-specs" } "."
+$nl
+"Here is an example; as is common with C functions, the array length is passed in separately, since C does not offer a runtime facility to determine the array length of a base pointer:"
+{ $code
+ "USING: alien.syntax specialized-arrays ;"
+ "SPECIALIZED-ARRAY: int"
+ "FUNCTION: void process_data ( int* data, int len ) ;"
+ "int-array{ 10 20 30 } dup length process_data"
+}
+"Literal specialized arrays, as well as specialized arrays created with " { $snippet "<T-array>" } " and " { $snippet ">T-array" } " are backed by a " { $link byte-array } " in the Factor heap, and can move as a result of garbage collection. If this is unsuitable, the array can be allocated in unmanaged memory instead."
+$nl
+"In the following example, it is presumed that the C library holds on to a pointer to the array's data after the " { $snippet "init_with_data()" } " call returns; this is one situation where unmanaged memory has to be used instead. Note the use of destructors to ensure the memory is deallocated after the block ends:"
+{ $code
+ "USING: alien.syntax specialized-arrays ;"
+ "SPECIALIZED-ARRAY: float"
+ "FUNCTION: void init_with_data ( float* data, int len ) ;"
+ "FUNCTION: float compute_result ( ) ;"
+ "["
+ " 100 malloc-float-array &free"
+ " dup length init_with_data"
+ " compute_result"
+ "] with-destructors"
+}
+"Finally, sometimes a C library returns a pointer to an array in unmanaged memory, together with a length. In this case, a specialized array can be constructed to view this memory using " { $snippet "<direct-T-array>" } ":"
+{ $code
+ "USING: alien.c-types classes.struct ;"
+ ""
+ "STRUCT: device_info"
+ " { id int }"
+ " { name char* } ;"
+ ""
+ "FUNCTION: void get_device_info ( int* length ) ;"
+ ""
+ "0 <int> [ get_device_info ] keep <direct-int-array> ."
+}
+"For a full discussion of Factor heap allocation versus unmanaged memory allocation, see " { $link "byte-arrays-gc" } "."
+$nl
"Each specialized array has a " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. Passing a specialized array as a parameter to a C function call will automatically extract the underlying data. To get at the underlying data directly, call the " { $link >c-ptr } " word on a specialized array." ;
ARTICLE: "specialized-array-math" "Vector arithmetic with specialized arrays"
$nl
"A specialized array type needs to be generated for each element type. This is done with a parsing word:"
{ $subsection POSTPONE: SPECIALIZED-ARRAY: }
-"This parsing word adds new words to the search path:"
+"This parsing word adds new words to the search path, documented in the next section."
{ $subsection "specialized-array-words" }
{ $subsection "specialized-array-c" }
{ $subsection "specialized-array-math" }
"C library interface words are found in the " { $vocab-link "alien" } " vocabulary."
{ $warning "C does not perform runtime type checking, automatic memory management or array bounds checks. Incorrect usage of C library functions can lead to crashes, data corruption, and security exploits." }
{ $subsection "loading-libs" }
-{ $subsection "aliens" }
{ $subsection "alien-invoke" }
{ $subsection "alien-callback" }
{ $subsection "c-data" }
$nl
"Byte array words are in the " { $vocab-link "byte-arrays" } " vocabulary."
$nl
-"Byte arrays play a special role in the C library interface; they can be used to pass binary data back and forth between Factor and C. See " { $link "c-byte-arrays" } "."
+"Byte arrays play a special role in the C library interface; they can be used to pass binary data back and forth between Factor and C. See " { $link "c-pointers" } "."
$nl
"Byte arrays form a class of objects."
{ $subsection byte-array }
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.cxx.parser alien.marshall
-alien.inline.types classes.mixin classes.tuple kernel namespaces
-assocs sequences parser classes.parser alien.marshall.syntax
-interpolate locals effects io strings make vocabs.parser words
-generic fry quotations ;
-IN: alien.cxx
-
-<PRIVATE
-: class-mixin ( str -- word )
- create-class-in [ define-mixin-class ] keep ;
-
-: class-tuple-word ( word -- word' )
- "#" append create-in ;
-
-: define-class-tuple ( word mixin -- )
- [ drop class-wrapper { } define-tuple-class ]
- [ add-mixin-instance ] 2bi ;
-PRIVATE>
-
-: define-c++-class ( name superclass-mixin -- )
- [ [ class-tuple-word ] [ class-mixin ] bi dup ] dip
- add-mixin-instance define-class-tuple ;
-
-:: define-c++-method ( class-name generic name types effect virtual -- )
- [ name % "_" % class-name { { CHAR: : CHAR: _ } } substitute % ] "" make :> name'
- effect [ in>> "self" suffix ] [ out>> ] bi <effect> :> effect'
- types class-name "*" append suffix :> types'
- effect in>> "," join :> args
- class-name virtual [ "#" append ] unless current-vocab lookup :> class
- SBUF" " clone dup [ I[ return self->${name}(${args});]I ] with-output-stream >string :> body
- name' types' effect' body define-c-marshalled
- class generic create-method name' current-vocab lookup 1quotation define ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: parser lexer alien.inline ;
-IN: alien.cxx.parser
-
-: parse-c++-class-definition ( -- class superclass-mixin )
- scan scan-word ;
-
-: parse-c++-method-definition ( -- class-name generic name types effect )
- scan scan-word function-types-effect ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.cxx.syntax alien.inline.syntax
-alien.marshall.syntax alien.marshall accessors kernel ;
-IN: alien.cxx.syntax.tests
-
-DELETE-C-LIBRARY: test
-C-LIBRARY: test
-
-COMPILE-AS-C++
-
-C-INCLUDE: <string>
-
-C-TYPEDEF: std::string string
-
-C++-CLASS: std::string c++-root
-
-GENERIC: to-string ( obj -- str )
-
-C++-METHOD: std::string to-string const-char* c_str ( )
-
-CM-FUNCTION: std::string* new_string ( const-char* s )
- return new std::string(s);
-;
-
-;C-LIBRARY
-
-ALIAS: <std::string> new_string
-
-{ 1 1 } [ new_string ] must-infer-as
-{ 1 1 } [ c_str_std__string ] must-infer-as
-[ t ] [ "abc" <std::string> std::string? ] unit-test
-[ "abc" ] [ "abc" <std::string> to-string ] unit-test
-
-
-DELETE-C-LIBRARY: inheritance
-C-LIBRARY: inheritance
-
-COMPILE-AS-C++
-
-C-INCLUDE: <cstring>
-
-<RAW-C
-class alpha {
- public:
- alpha(const char* s) {
- str = s;
- };
- const char* render() {
- return str;
- };
- virtual const char* chop() {
- return str;
- };
- virtual int length() {
- return strlen(str);
- };
- const char* str;
-};
-
-class beta : alpha {
- public:
- beta(const char* s) : alpha(s + 1) { };
- const char* render() {
- return str + 1;
- };
- virtual const char* chop() {
- return str + 2;
- };
-};
-RAW-C>
-
-C++-CLASS: alpha c++-root
-C++-CLASS: beta alpha
-
-CM-FUNCTION: alpha* new_alpha ( const-char* s )
- return new alpha(s);
-;
-
-CM-FUNCTION: beta* new_beta ( const-char* s )
- return new beta(s);
-;
-
-ALIAS: <alpha> new_alpha
-ALIAS: <beta> new_beta
-
-GENERIC: render ( obj -- obj )
-GENERIC: chop ( obj -- obj )
-GENERIC: length ( obj -- n )
-
-C++-METHOD: alpha render const-char* render ( )
-C++-METHOD: beta render const-char* render ( )
-C++-VIRTUAL: alpha chop const-char* chop ( )
-C++-VIRTUAL: beta chop const-char* chop ( )
-C++-VIRTUAL: alpha length int length ( )
-
-;C-LIBRARY
-
-{ 1 1 } [ render_alpha ] must-infer-as
-{ 1 1 } [ chop_beta ] must-infer-as
-{ 1 1 } [ length_alpha ] must-infer-as
-[ t ] [ "x" <alpha> alpha#? ] unit-test
-[ t ] [ "x" <alpha> alpha? ] unit-test
-[ t ] [ "x" <beta> alpha? ] unit-test
-[ f ] [ "x" <beta> alpha#? ] unit-test
-[ 5 ] [ "hello" <alpha> length ] unit-test
-[ 4 ] [ "hello" <beta> length ] unit-test
-[ "hello" ] [ "hello" <alpha> render ] unit-test
-[ "llo" ] [ "hello" <beta> render ] unit-test
-[ "ello" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying render ] unit-test
-[ "hello" ] [ "hello" <alpha> chop ] unit-test
-[ "lo" ] [ "hello" <beta> chop ] unit-test
-[ "lo" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying chop ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.cxx alien.cxx.parser ;
-IN: alien.cxx.syntax
-
-SYNTAX: C++-CLASS:
- parse-c++-class-definition define-c++-class ;
-
-SYNTAX: C++-METHOD:
- parse-c++-method-definition f define-c++-method ;
-
-SYNTAX: C++-VIRTUAL:
- parse-c++-method-definition t define-c++-method ;
+++ /dev/null
-Jeremy Hughes
+++ /dev/null
-Jeremy Hughes
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel strings words.symbol sequences ;
-IN: alien.inline.compiler
-
-HELP: C
-{ $var-description "A symbol representing C source." } ;
-
-HELP: C++
-{ $var-description "A symbol representing C++ source." } ;
-
-HELP: compile-to-library
-{ $values
- { "lang" symbol } { "args" sequence } { "contents" string } { "name" string }
-}
-{ $description "Compiles and links " { $snippet "contents" } " into a shared library called " { $snippet "libname.suffix" }
- "in " { $snippet "resource:alien-inline-libs" } ". " { $snippet "suffix" } " is OS specific. "
- { $snippet "args" } " is a sequence of arguments for the linking stage." }
-{ $notes
- { $list
- "C and C++ are the only supported languages."
- { "Source and object files are placed in " { $snippet "resource:temp" } "." } }
-} ;
-
-HELP: compiler
-{ $values
- { "lang" symbol }
- { "str" string }
-}
-{ $description "Returns a compiler name based on OS and source language." }
-{ $see-also compiler-descr } ;
-
-HELP: compiler-descr
-{ $values
- { "lang" symbol }
- { "descr" "a process description" }
-}
-{ $description "Returns a compiler process description based on OS and source language." }
-{ $see-also compiler } ;
-
-HELP: inline-library-file
-{ $values
- { "name" string }
- { "path" "a pathname string" }
-}
-{ $description "Appends " { $snippet "name" } " to the " { $link inline-libs-directory } "." } ;
-
-HELP: inline-libs-directory
-{ $values
- { "path" "a pathname string" }
-}
-{ $description "The directory where libraries created using " { $snippet "alien.inline" } " are stored." } ;
-
-HELP: library-path
-{ $values
- { "str" string }
- { "path" "a pathname string" }
-}
-{ $description "Converts " { $snippet "name" } " into a full path to the corresponding inline library." } ;
-
-HELP: library-suffix
-{ $values
- { "str" string }
-}
-{ $description "The appropriate shared library suffix for the current OS." } ;
-
-HELP: link-descr
-{ $values
- { "lang" "a language" }
- { "descr" sequence }
-}
-{ $description "Returns part of a process description. OS dependent." } ;
-
-ARTICLE: "alien.inline.compiler" "Inline C compiler"
-{ $vocab-link "alien.inline.compiler" }
-;
-
-ABOUT: "alien.inline.compiler"
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators fry generalizations
-io.encodings.ascii io.files io.files.temp io.launcher kernel
-locals make sequences system vocabs.parser words io.directories
-io.pathnames ;
-IN: alien.inline.compiler
-
-SYMBOL: C
-SYMBOL: C++
-
-: inline-libs-directory ( -- path )
- "alien-inline-libs" resource-path dup make-directories ;
-
-: inline-library-file ( name -- path )
- inline-libs-directory prepend-path ;
-
-: library-suffix ( -- str )
- os {
- { [ dup macosx? ] [ drop ".dylib" ] }
- { [ dup unix? ] [ drop ".so" ] }
- { [ dup windows? ] [ drop ".dll" ] }
- } cond ;
-
-: library-path ( str -- path )
- '[ "lib" % _ % library-suffix % ] "" make inline-library-file ;
-
-HOOK: compiler os ( lang -- str )
-
-M: word compiler
- {
- { C [ "gcc" ] }
- { C++ [ "g++" ] }
- } case ;
-
-M: openbsd compiler
- {
- { C [ "gcc" ] }
- { C++ [ "eg++" ] }
- } case ;
-
-M: windows compiler
- {
- { C [ "gcc" ] }
- { C++ [ "g++" ] }
- } case ;
-
-HOOK: compiler-descr os ( lang -- descr )
-
-M: word compiler-descr compiler 1array ;
-M: macosx compiler-descr
- call-next-method cpu x86.64?
- [ { "-arch" "x86_64" } append ] when ;
-
-HOOK: link-descr os ( lang -- descr )
-
-M: word link-descr drop { "-shared" "-o" } ;
-M: macosx link-descr
- drop { "-g" "-prebind" "-dynamiclib" "-o" }
- cpu x86.64? [ { "-arch" "x86_64" } prepend ] when ;
-M: windows link-descr
- {
- { C [ { "-mno-cygwin" "-shared" "-o" } ] }
- { C++ [ { "-lstdc++" "-mno-cygwin" "-shared" "-o" } ] }
- } case ;
-
-<PRIVATE
-: src-suffix ( lang -- str )
- {
- { C [ ".c" ] }
- { C++ [ ".cpp" ] }
- } case ;
-
-: link-command ( args in out lang -- descr )
- [ 2array ] dip [ compiler 1array ] [ link-descr ] bi
- append prepend prepend ;
-
-:: compile-to-object ( lang contents name -- )
- name ".o" append temp-file
- contents name lang src-suffix append temp-file
- [ ascii set-file-contents ] keep 2array
- lang compiler-descr { "-fPIC" "-c" "-o" } append prepend
- try-process ;
-
-:: link-object ( lang args name -- )
- args name [ library-path ]
- [ ".o" append temp-file ] bi
- lang link-command try-process ;
-PRIVATE>
-
-:: compile-to-library ( lang args contents name -- )
- lang contents name compile-to-object
- lang args name link-object ;
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel strings effects quotations ;
-IN: alien.inline
-
-<PRIVATE
-: $binding-note ( x -- )
- drop
- { "This word requires that certain variables are correctly bound. "
- "Call " { $link POSTPONE: define-c-library } " to set them up." } print-element ;
-PRIVATE>
-
-HELP: compile-c-library
-{ $description "Writes, compiles, and links code generated since last invocation of " { $link POSTPONE: define-c-library } ". "
- "Also calls " { $snippet "add-library" } ". "
- "This word does nothing if the shared library is younger than the factor source file." }
-{ $notes $binding-note } ;
-
-HELP: c-use-framework
-{ $values
- { "str" string }
-}
-{ $description "OS X only. Adds " { $snippet "-framework name" } " to linker command." }
-{ $notes $binding-note }
-{ $see-also c-link-to c-link-to/use-framework } ;
-
-HELP: define-c-function
-{ $values
- { "function" "function name" } { "types" "a sequence of C types" } { "effect" effect } { "body" string }
-}
-{ $description "Defines a C function and a factor word which calls it." }
-{ $notes
- { $list
- { "The number of " { $snippet "types" } " must match the " { $snippet "in" } " count of the " { $snippet "effect" } "." }
- { "There must be only one " { $snippet "out" } " element. It must be a legal C return type with dashes (-) instead of spaces." }
- $binding-note
- }
-}
-{ $see-also POSTPONE: define-c-function' } ;
-
-HELP: define-c-function'
-{ $values
- { "function" "function name" } { "effect" effect } { "body" string }
-}
-{ $description "Defines a C function and a factor word which calls it. See " { $link define-c-function } " for more information." }
-{ $notes
- { $list
- { "Each effect element must be a legal C type with dashes (-) instead of spaces. "
- "C argument names will be generated alphabetically, starting with " { $snippet "a" } "." }
- $binding-note
- }
-}
-{ $see-also define-c-function } ;
-
-HELP: c-include
-{ $values
- { "str" string }
-}
-{ $description "Appends an include line to the C library in scope." }
-{ $notes $binding-note } ;
-
-HELP: define-c-library
-{ $values
- { "name" string }
-}
-{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " words can be used after this one." } ;
-
-HELP: c-link-to
-{ $values
- { "str" string }
-}
-{ $description "Adds " { $snippet "-lname" } " to linker command." }
-{ $notes $binding-note }
-{ $see-also c-use-framework c-link-to/use-framework } ;
-
-HELP: c-link-to/use-framework
-{ $values
- { "str" string }
-}
-{ $description "Equivalent to " { $link c-use-framework } " on OS X and " { $link c-link-to } " everywhere else." }
-{ $notes $binding-note }
-{ $see-also c-link-to c-use-framework } ;
-
-HELP: define-c-struct
-{ $values
- { "name" string } { "fields" "type/name pairs" }
-}
-{ $description "Defines a C struct and factor words which operate on it." }
-{ $notes $binding-note } ;
-
-HELP: define-c-typedef
-{ $values
- { "old" "C type" } { "new" "C type" }
-}
-{ $description "Define C and factor typedefs." }
-{ $notes $binding-note } ;
-
-HELP: delete-inline-library
-{ $values
- { "name" string }
-}
-{ $description "Delete the shared library file corresponding to " { $snippet "name" } "." }
-{ $notes "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " } ;
-
-HELP: with-c-library
-{ $values
- { "name" string } { "quot" quotation }
-}
-{ $description "Calls " { $link define-c-library } ", then the quotation, then " { $link compile-c-library } ", then sets all variables bound by " { $snippet "define-c-library" } " to " { $snippet "f" } "." } ;
-
-HELP: raw-c
-{ $values { "str" string } }
-{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.inline.compiler alien.inline.types
-alien.libraries alien.parser arrays assocs effects fry
-generalizations grouping io.directories io.files
-io.files.info io.files.temp kernel lexer math math.order
-math.ranges multiline namespaces sequences source-files
-splitting strings system vocabs.loader vocabs.parser words
-alien.c-types alien.structs make parser continuations ;
-IN: alien.inline
-
-SYMBOL: c-library
-SYMBOL: library-is-c++
-SYMBOL: linker-args
-SYMBOL: c-strings
-
-<PRIVATE
-: cleanup-variables ( -- )
- { c-library library-is-c++ linker-args c-strings }
- [ off ] each ;
-
-: arg-list ( types -- params )
- CHAR: a swap length CHAR: a + [a,b]
- [ 1string ] map ;
-
-: compile-library? ( -- ? )
- c-library get library-path dup exists? [
- file get [
- path>>
- [ file-info modified>> ] bi@ <=> +lt+ =
- ] [ drop t ] if*
- ] [ drop t ] if ;
-
-: compile-library ( -- )
- library-is-c++ get [ C++ ] [ C ] if
- linker-args get
- c-strings get "\n" join
- c-library get compile-to-library ;
-
-: c-library-name ( name -- name' )
- [ current-vocab name>> % "_" % % ] "" make ;
-PRIVATE>
-
-: parse-arglist ( parameters return -- types effect )
- [ 2 group unzip [ "," ?tail drop ] map ]
- [ [ { } ] [ 1array ] if-void ]
- bi* <effect> ;
-
-: append-function-body ( prototype-str body -- str )
- [ swap % " {\n" % % "\n}\n" % ] "" make ;
-
-: function-types-effect ( -- function types effect )
- scan scan swap ")" parse-tokens
- [ "(" subseq? not ] filter swap parse-arglist ;
-
-: prototype-string ( function types effect -- str )
- [ [ cify-type ] map ] dip
- types-effect>params-return cify-type -rot
- [ " " join ] map ", " join
- "(" prepend ")" append 3array " " join
- library-is-c++ get [ "extern \"C\" " prepend ] when ;
-
-: prototype-string' ( function types return -- str )
- [ dup arg-list ] <effect> prototype-string ;
-
-: factor-function ( function types effect -- word quot effect )
- annotate-effect [ c-library get ] 3dip
- [ [ factorize-type ] map ] dip
- types-effect>params-return factorize-type -roll
- concat make-function ;
-
-: define-c-library ( name -- )
- c-library-name [ c-library set ] [ "c-library" set ] bi
- V{ } clone c-strings set
- V{ } clone linker-args set ;
-
-: compile-c-library ( -- )
- compile-library? [ compile-library ] when
- c-library get dup library-path "cdecl" add-library ;
-
-: define-c-function ( function types effect body -- )
- [
- [ factor-function define-declared ]
- [ prototype-string ] 3bi
- ] dip append-function-body c-strings get push ;
-
-: define-c-function' ( function effect body -- )
- [
- [ in>> ] keep
- [ factor-function define-declared ]
- [ out>> prototype-string' ] 3bi
- ] dip append-function-body c-strings get push ;
-
-: c-link-to ( str -- )
- "-l" prepend linker-args get push ;
-
-: c-use-framework ( str -- )
- "-framework" swap linker-args get '[ _ push ] bi@ ;
-
-: c-link-to/use-framework ( str -- )
- os macosx? [ c-use-framework ] [ c-link-to ] if ;
-
-: c-include ( str -- )
- "#include " prepend c-strings get push ;
-
-: define-c-typedef ( old new -- )
- [ typedef ] [
- [ swap "typedef " % % " " % % ";" % ]
- "" make c-strings get push
- ] 2bi ;
-
-: define-c-struct ( name fields -- )
- [ current-vocab swap define-struct ] [
- over
- [
- "typedef struct " % "_" % % " {\n" %
- [ first2 swap % " " % % ";\n" % ] each
- "} " % % ";\n" %
- ] "" make c-strings get push
- ] 2bi ;
-
-: delete-inline-library ( name -- )
- c-library-name [ remove-library ]
- [ library-path dup exists? [ delete-file ] [ drop ] if ] bi ;
-
-: with-c-library ( name quot -- )
- [ [ define-c-library ] dip call compile-c-library ]
- [ cleanup-variables ] [ ] cleanup ; inline
-
-: raw-c ( str -- )
- [ "\n" % % "\n" % ] "" make c-strings get push ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax alien.inline ;
-IN: alien.inline.syntax
-
-HELP: ;C-LIBRARY
-{ $syntax ";C-LIBRARY" }
-{ $description "Writes, compiles, and links code generated since previous invocation of " { $link POSTPONE: C-LIBRARY: } "." }
-{ $see-also POSTPONE: compile-c-library } ;
-
-HELP: C-FRAMEWORK:
-{ $syntax "C-FRAMEWORK: name" }
-{ $description "OS X only. Link to named framework. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
-{ $see-also POSTPONE: c-use-framework } ;
-
-HELP: C-FUNCTION:
-{ $syntax "C-FUNCTION: return name ( args ... )\nbody\n;" }
-{ $description "Appends a function to the C library in scope and defines an FFI word that calls it." }
-{ $examples
- { $example
- "USING: alien.inline.syntax prettyprint ;"
- "IN: cmath.ffi"
- ""
- "C-LIBRARY: cmathlib"
- ""
- "C-FUNCTION: int add ( int a, int b )"
- " return a + b;"
- ";"
- ""
- ";C-LIBRARY"
- ""
- "1 2 add ."
- "3" }
-}
-{ $see-also POSTPONE: define-c-function } ;
-
-HELP: C-INCLUDE:
-{ $syntax "C-INCLUDE: name" }
-{ $description "Appends an include line to the C library in scope." }
-{ $see-also POSTPONE: c-include } ;
-
-HELP: C-LIBRARY:
-{ $syntax "C-LIBRARY: name" }
-{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " syntax can be used after this word." }
-{ $examples
- { $example
- "USING: alien.inline.syntax ;"
- "IN: rectangle.ffi"
- ""
- "C-LIBRARY: rectlib"
- ""
- "C-STRUCTURE: rectangle { \"int\" \"width\" } { \"int\" \"height\" } ;"
- ""
- "C-FUNCTION: int area ( rectangle c )"
- " return c.width * c.height;"
- ";"
- ""
- ";C-LIBRARY"
- "" }
-}
-{ $see-also POSTPONE: define-c-library } ;
-
-HELP: C-LINK/FRAMEWORK:
-{ $syntax "C-LINK/FRAMEWORK: name" }
-{ $description "Equivalent to " { $link POSTPONE: C-FRAMEWORK: } " on OS X and " { $link POSTPONE: C-LINK: } " everywhere else." }
-{ $see-also POSTPONE: c-link-to/use-framework } ;
-
-HELP: C-LINK:
-{ $syntax "C-LINK: name" }
-{ $description "Link to named library. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
-{ $see-also POSTPONE: c-link-to } ;
-
-HELP: C-STRUCTURE:
-{ $syntax "C-STRUCTURE: name pairs ... ;" }
-{ $description "Like " { $snippet "C-STRUCT:" } " but also generates equivalent C code."}
-{ $see-also POSTPONE: define-c-struct } ;
-
-HELP: C-TYPEDEF:
-{ $syntax "C-TYPEDEF: old new" }
-{ $description "Like " { $snippet "TYPEDEF:" } " but generates a C typedef statement too." }
-{ $see-also POSTPONE: define-c-typedef } ;
-
-HELP: COMPILE-AS-C++
-{ $syntax "COMPILE-AS-C++" }
-{ $description "Insert this word anywhere between " { $link POSTPONE: C-LIBRARY: } " and " { $link POSTPONE: ;C-LIBRARY } " and the generated code will be treated as C++ with " { $snippet "extern \"C\"" } " prepended to each function prototype." } ;
-
-HELP: DELETE-C-LIBRARY:
-{ $syntax "DELETE-C-LIBRARY: name" }
-{ $description "Deletes the shared library file corresponding to " { $snippet "name" } " . " }
-{ $notes
- { $list
- { "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " }
- "This word is mainly useful for unit tests."
- }
-}
-{ $see-also POSTPONE: delete-inline-library } ;
-
-HELP: <RAW-C
-{ $syntax "<RAW-C code RAW-C>" }
-{ $description "Insert a (multiline) string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.inline alien.inline.syntax io.directories io.files
-kernel namespaces tools.test alien.c-types alien.data alien.structs ;
-IN: alien.inline.syntax.tests
-
-DELETE-C-LIBRARY: test
-C-LIBRARY: test
-
-C-FUNCTION: const-int add ( int a, int b )
- return a + b;
-;
-
-C-TYPEDEF: double bigfloat
-
-C-FUNCTION: bigfloat smaller ( bigfloat a )
- return a / 10;
-;
-
-C-STRUCTURE: rectangle
- { "int" "width" }
- { "int" "height" } ;
-
-C-FUNCTION: int area ( rectangle c )
- return c.width * c.height;
-;
-
-;C-LIBRARY
-
-{ 2 1 } [ add ] must-infer-as
-[ 5 ] [ 2 3 add ] unit-test
-
-[ t ] [ "double" "bigfloat" [ resolve-typedef ] bi@ = ] unit-test
-{ 1 1 } [ smaller ] must-infer-as
-[ 1.0 ] [ 10 smaller ] unit-test
-
-[ t ] [ "rectangle" resolve-typedef struct-type? ] unit-test
-{ 1 1 } [ area ] must-infer-as
-[ 20 ] [
- "rectangle" <c-object>
- 4 over set-rectangle-width
- 5 over set-rectangle-height
- area
-] unit-test
-
-
-DELETE-C-LIBRARY: cpplib
-C-LIBRARY: cpplib
-
-COMPILE-AS-C++
-
-C-INCLUDE: <string>
-
-C-FUNCTION: const-char* hello ( )
- std::string s("hello world");
- return s.c_str();
-;
-
-;C-LIBRARY
-
-{ 0 1 } [ hello ] must-infer-as
-[ "hello world" ] [ hello ] unit-test
-
-
-DELETE-C-LIBRARY: compile-error
-C-LIBRARY: compile-error
-
-C-FUNCTION: char* breakme ( )
- return not a string;
-;
-
-<< [ compile-c-library ] must-fail >>
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.inline lexer multiline namespaces parser ;
-IN: alien.inline.syntax
-
-
-SYNTAX: C-LIBRARY: scan define-c-library ;
-
-SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
-
-SYNTAX: C-LINK: scan c-link-to ;
-
-SYNTAX: C-FRAMEWORK: scan c-use-framework ;
-
-SYNTAX: C-LINK/FRAMEWORK: scan c-link-to/use-framework ;
-
-SYNTAX: C-INCLUDE: scan c-include ;
-
-SYNTAX: C-FUNCTION:
- function-types-effect parse-here define-c-function ;
-
-SYNTAX: C-TYPEDEF: scan scan define-c-typedef ;
-
-SYNTAX: C-STRUCTURE:
- scan parse-definition define-c-struct ;
-
-SYNTAX: ;C-LIBRARY compile-c-library ;
-
-SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ;
-
-SYNTAX: <RAW-C "RAW-C>" parse-multiline-string raw-c ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types assocs combinators.short-circuit
-continuations effects fry kernel math memoize sequences
-splitting strings peg.ebnf make words ;
-IN: alien.inline.types
-
-: cify-type ( str -- str' )
- dup word? [ name>> ] when
- { { CHAR: - CHAR: space } } substitute ;
-
-: factorize-type ( str -- str' )
- cify-type
- "const " ?head drop
- "unsigned " ?head [ "u" prepend ] when
- "long " ?head [ "long" prepend ] when
- " const" ?tail drop ;
-
-: const-pointer? ( str -- ? )
- cify-type { [ " const" tail? ] [ "&" tail? ] } 1|| ;
-
-: pointer-to-const? ( str -- ? )
- cify-type "const " head? ;
-
-: template-class? ( str -- ? )
- [ CHAR: < = ] any? ;
-
-MEMO: resolved-primitives ( -- seq )
- primitive-types [ resolve-typedef ] map ;
-
-: primitive-type? ( type -- ? )
- [
- factorize-type resolve-typedef [ resolved-primitives ] dip
- '[ _ = ] any?
- ] [ 2drop f ] recover ;
-
-: pointer? ( type -- ? )
- factorize-type [ "*" tail? ] [ "&" tail? ] bi or ;
-
-: type-sans-pointer ( type -- type' )
- factorize-type [ '[ _ = ] "*&" swap any? ] trim-tail ;
-
-: pointer-to-primitive? ( type -- ? )
- factorize-type
- { [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ;
-
-: pointer-to-non-const-primitive? ( str -- ? )
- {
- [ pointer-to-const? not ]
- [ factorize-type pointer-to-primitive? ]
- } 1&& ;
-
-: types-effect>params-return ( types effect -- params return )
- [ in>> zip ]
- [ nip out>> dup length 0 > [ first ] [ drop "void" ] if ]
- 2bi ;
-
-: annotate-effect ( types effect -- types effect' )
- [ in>> ] [ out>> ] bi [
- zip
- [ over pointer-to-primitive? [ ">" prepend ] when ]
- assoc-map unzip
- ] dip <effect> ;
-
-TUPLE: c++-type name params ptr ;
-C: <c++-type> c++-type
-
-EBNF: (parse-c++-type)
-dig = [0-9]
-alpha = [a-zA-Z]
-alphanum = [1-9a-zA-Z]
-name = [_a-zA-Z] [_a-zA-Z1-9:]* => [[ first2 swap prefix >string ]]
-ptr = [*&] => [[ empty? not ]]
-
-param = "," " "* type " "* => [[ third ]]
-
-params = "<" " "* type " "* param* ">" => [[ [ 4 swap nth ] [ third ] bi prefix ]]
-
-type = name " "* params? " "* ptr? => [[ { 0 2 4 } [ swap nth ] with map first3 <c++-type> ]]
-;EBNF
-
-: parse-c++-type ( str -- c++-type )
- factorize-type (parse-c++-type) ;
-
-DEFER: c++-type>string
-
-: params>string ( params -- str )
- [ "<" % [ c++-type>string ] map "," join % ">" % ] "" make ;
-
-: c++-type>string ( c++-type -- str )
- [
- [ name>> % ]
- [ params>> [ params>string % ] when* ]
- [ ptr>> [ "*" % ] when ]
- tri
- ] "" make ;
-
-GENERIC: c++-type ( obj -- c++-type/f )
-
-M: object c++-type drop f ;
-
-M: c++-type c-type ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations sequences
-strings alien alien.c-types alien.data math byte-arrays ;
-IN: alien.marshall
-
-<PRIVATE
-: $memory-note ( arg -- )
- drop "This word returns a pointer to unmanaged memory."
- print-element ;
-
-: $c-ptr-note ( arg -- )
- drop "Does nothing if its argument is a non false c-ptr."
- print-element ;
-
-: $see-article ( arg -- )
- drop { "See " { $vocab-link "alien.inline" } "." }
- print-element ;
-PRIVATE>
-
-HELP: ?malloc-byte-array
-{ $values
- { "c-type" c-type }
- { "alien" alien }
-}
-{ $description "Does nothing if input is an alien, otherwise assumes it is a byte array and calls "
- { $snippet "malloc-byte-array" } "."
-}
-{ $notes $memory-note } ;
-
-HELP: alien-wrapper
-{ $var-description "For wrapping C pointers in a structure factor can dispatch on." } ;
-
-HELP: unmarshall-cast
-{ $values
- { "alien-wrapper" alien-wrapper }
- { "alien-wrapper'" alien-wrapper }
-}
-{ $description "Called immediately after unmarshalling. Useful for automatically casting to subtypes." } ;
-
-HELP: marshall-bool
-{ $values
- { "?" "a generalized boolean" }
- { "n" "0 or 1" }
-}
-{ $description "Marshalls objects to bool." }
-{ $notes "Will treat " { $snippet "0" } " as " { $snippet "t" } "." } ;
-
-HELP: marshall-bool*
-{ $values
- { "?/seq" "t/f or sequence" }
- { "alien" alien }
-}
-{ $description "When the argument is a sequence, returns a pointer to an array of bool, "
- "otherwise returns a pointer to a single bool value."
-}
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-bool**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description "Takes a one or two dimensional array of generalized booleans "
- "and returns a pointer to the equivalent C structure."
-}
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-primitive
-{ $values
- { "n" number }
- { "n" number }
-}
-{ $description "Marshall numbers to C primitives."
- $nl
- "Factor marshalls numbers to primitives for FFI calls, so all "
- "this word does is convert " { $snippet "t" } " to " { $snippet "1" }
- ", " { $snippet "f" } " to " { $snippet "0" } ", and lets anything else "
- "pass through untouched."
-} ;
-
-HELP: marshall-char*
-{ $values
- { "n/seq" "number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-char**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-char**-or-strings
-{ $values
- { "seq" "a sequence of strings" }
- { "alien" alien }
-}
-{ $description "Marshalls an array of strings or characters to an array of C strings." }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-char*-or-string
-{ $values
- { "n/string" "a number or string" }
- { "alien" alien }
-}
-{ $description "Marshalls a string to a C string or a number to a pointer to " { $snippet "char" } "." }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-double*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-double**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-float*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-float**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-int*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-int**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-long*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-long**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-longlong*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-longlong**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-non-pointer
-{ $values
- { "alien-wrapper/byte-array" "an alien-wrapper or byte-array" }
- { "byte-array" byte-array }
-}
-{ $description "Converts argument to a byte array." }
-{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
-
-HELP: marshall-pointer
-{ $values
- { "obj" object }
- { "alien" alien }
-}
-{ $description "Converts argument to a C pointer." }
-{ $notes "Can marshall the following types: " { $snippet "alien, f, byte-array, alien-wrapper, struct-array" } "." } ;
-
-HELP: marshall-short*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-short**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-uchar*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-uchar**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-uint*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-uint**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-ulong*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-ulong**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-ulonglong*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-ulonglong**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-ushort*
-{ $values
- { "n/seq" "a number or sequence" }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-ushort**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description $see-article }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshall-void**
-{ $values
- { "seq" sequence }
- { "alien" alien }
-}
-{ $description "Marshalls a sequence of objects to an array of pointers to void." }
-{ $notes { $list $c-ptr-note $memory-note } } ;
-
-HELP: marshaller
-{ $values
- { "type" "a C type string" }
- { "quot" quotation }
-}
-{ $description "Given a C type, returns a quotation that will marshall its argument to that type." } ;
-
-HELP: out-arg-unmarshaller
-{ $values
- { "type" "a C type string" }
- { "quot" quotation }
-}
-{ $description "Like " { $link unmarshaller } " but returns an empty quotation "
- "for all types except pointers to non-const primitives."
-} ;
-
-HELP: class-unmarshaller
-{ $values
- { "type" " a C type string" }
- { "quot/f" quotation }
-}
-{ $description "If in the vocab in which this word is called, there is a subclass of " { $link alien-wrapper }
- " named after the type argument, " { $snippet "pointer-unmarshaller" } " will return a quotation which "
- "wraps its argument in an instance of that subclass. In any other case it returns an empty quotation."
-}
-{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
-
-HELP: primitive-marshaller
-{ $values
- { "type" "a C type string" }
- { "quot/f" "a quotation or f" }
-}
-{ $description "Returns a quotation to marshall objects to the argument type." }
-{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
-
-HELP: primitive-unmarshaller
-{ $values
- { "type" "a C type string" }
- { "quot/f" "a quotation or f" }
-}
-{ $description "Returns a quotation to unmarshall objects from the argument type." }
-{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
-
-HELP: struct-field-unmarshaller
-{ $values
- { "type" "a C type string" }
- { "quot" quotation }
-}
-{ $description "Like " { $link unmarshaller } " but returns a quotation that "
- "does not call " { $snippet "free" } " on its argument."
-}
-{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
-
-HELP: struct-primitive-unmarshaller
-{ $values
- { "type" "a C type string" }
- { "quot/f" "a quotation or f" }
-}
-{ $description "Like " { $link primitive-unmarshaller } " but returns a quotation that "
- "does not call " { $snippet "free" } " on its argument." }
-{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
-
-HELP: struct-unmarshaller
-{ $values
- { "type" "a C type string" }
- { "quot/f" quotation }
-}
-{ $description "Returns a quotation which wraps its argument in the subclass of "
- { $link struct-wrapper } " which matches the " { $snippet "type" } " arg."
-}
-{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
-
-HELP: struct-wrapper
-{ $var-description "For wrapping C structs in a structure factor can dispatch on." } ;
-
-HELP: unmarshall-bool
-{ $values
- { "n" number }
- { "?" "a boolean" }
-}
-{ $description "Unmarshalls a number to a boolean." } ;
-
-HELP: unmarshall-bool*
-{ $values
- { "alien" alien }
- { "?" "a boolean" }
-}
-{ $description "Unmarshalls a C pointer to a boolean." } ;
-
-HELP: unmarshall-bool*-free
-{ $values
- { "alien" alien }
- { "?" "a boolean" }
-}
-{ $description "Unmarshalls a C pointer to a boolean and frees the pointer." } ;
-
-HELP: unmarshall-char*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-char*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-char*-to-string
-{ $values
- { "alien" alien }
- { "string" string }
-}
-{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string." } ;
-
-HELP: unmarshall-char*-to-string-free
-{ $values
- { "alien" alien }
- { "string" string }
-}
-{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string and frees the pointer." } ;
-
-HELP: unmarshall-double*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-double*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-float*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-float*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-int*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-int*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-long*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-long*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-longlong*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-longlong*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-short*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-short*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-uchar*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-uchar*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-uint*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-uint*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-ulong*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-ulong*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-ulonglong*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-ulonglong*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-ushort*
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshall-ushort*-free
-{ $values
- { "alien" alien }
- { "n" number }
-}
-{ $description $see-article } ;
-
-HELP: unmarshaller
-{ $values
- { "type" "a C type string" }
- { "quot" quotation }
-}
-{ $description "Given a C type, returns a quotation that will unmarshall values of that type." } ;
-
-ARTICLE: "alien.marshall" "C marshalling"
-{ $vocab-link "alien.marshall" } " provides alien wrappers and marshalling words for the "
-"automatic marshalling and unmarshalling of C function arguments, return values, and output parameters."
-
-{ $subheading "Important words" }
-"Wrap an alien:" { $subsection alien-wrapper }
-"Wrap a struct:" { $subsection struct-wrapper }
-"Get the marshaller for a C type:" { $subsection marshaller }
-"Get the unmarshaller for a C type:" { $subsection unmarshaller }
-"Get the unmarshaller for an output parameter:" { $subsection out-arg-unmarshaller }
-"Get the unmarshaller for a struct field:" { $subsection struct-field-unmarshaller }
-$nl
-"Other marshalling and unmarshalling words in this vocabulary are not intended to be "
-"invoked directly."
-$nl
-"Most marshalling words allow non false c-ptrs to pass through unchanged."
-
-{ $subheading "Primitive marshallers" }
-{ $subsection marshall-primitive } "for marshalling primitive values."
-{ $subsection marshall-int* }
- "marshalls a number or sequence of numbers. If argument is a sequence, returns a pointer "
- "to a C array, otherwise returns a pointer to a single value."
-{ $subsection marshall-int** }
-"marshalls a 1D or 2D array of numbers. Returns an array of pointers to arrays."
-
-{ $subheading "Primitive unmarshallers" }
-{ $snippet "unmarshall-<prim>*" } " and " { $snippet "unmarshall-<prim>*-free" }
-" for all values of " { $snippet "<prim>" } " in " { $link primitive-types } "."
-{ $subsection unmarshall-int* }
-"unmarshalls a pointer to primitive. Returns a number. "
-"Assumes the pointer is not an array (if it is, only the first value is returned). "
-"C functions that return arrays are not handled correctly by " { $snippet "alien.marshall" }
-" and must be unmarshalled by hand."
-{ $subsection unmarshall-int*-free }
-"unmarshalls a pointer to primitive, and then frees the pointer."
-$nl
-"Primitive values require no unmarshalling. The factor FFI already does this."
-;
-
-ABOUT: "alien.marshall"
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.inline.types
-alien.marshall.private alien.strings byte-arrays classes
-combinators combinators.short-circuit destructors fry
-io.encodings.utf8 kernel libc sequences alien.data
-specialized-arrays strings unix.utilities vocabs.parser
-words libc.private locals generalizations math ;
-FROM: alien.c-types => float short ;
-SPECIALIZED-ARRAY: bool
-SPECIALIZED-ARRAY: char
-SPECIALIZED-ARRAY: double
-SPECIALIZED-ARRAY: float
-SPECIALIZED-ARRAY: int
-SPECIALIZED-ARRAY: long
-SPECIALIZED-ARRAY: longlong
-SPECIALIZED-ARRAY: short
-SPECIALIZED-ARRAY: uchar
-SPECIALIZED-ARRAY: uint
-SPECIALIZED-ARRAY: ulong
-SPECIALIZED-ARRAY: ulonglong
-SPECIALIZED-ARRAY: ushort
-SPECIALIZED-ARRAY: void*
-IN: alien.marshall
-
-<< primitive-types [ [ void* = ] [ bool = ] bi or not ]
-filter [ define-primitive-marshallers ] each >>
-
-TUPLE: alien-wrapper { underlying alien } ;
-TUPLE: struct-wrapper < alien-wrapper disposed ;
-TUPLE: class-wrapper < alien-wrapper disposed ;
-
-MIXIN: c++-root
-
-GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
-
-M: alien-wrapper unmarshall-cast ;
-M: struct-wrapper unmarshall-cast ;
-
-M: struct-wrapper dispose* underlying>> free ;
-
-M: class-wrapper c++-type class name>> parse-c++-type ;
-
-: marshall-pointer ( obj -- alien )
- {
- { [ dup alien? ] [ ] }
- { [ dup not ] [ ] }
- { [ dup byte-array? ] [ malloc-byte-array ] }
- { [ dup alien-wrapper? ] [ underlying>> ] }
- } cond ;
-
-: marshall-primitive ( n -- n )
- [ bool>arg ] ptr-pass-through ;
-
-ALIAS: marshall-void* marshall-pointer
-
-: marshall-void** ( seq -- alien )
- [ marshall-void* ] void*-array{ } map-as malloc-underlying ;
-
-: (marshall-char*-or-string) ( n/string -- alien )
- dup string?
- [ utf8 string>alien malloc-byte-array ]
- [ (marshall-char*) ] if ;
-
-: marshall-char*-or-string ( n/string -- alien )
- [ (marshall-char*-or-string) ] ptr-pass-through ;
-
-: (marshall-char**-or-strings) ( seq -- alien )
- [ marshall-char*-or-string ] void*-array{ } map-as
- malloc-underlying ;
-
-: marshall-char**-or-strings ( seq -- alien )
- [ (marshall-char**-or-strings) ] ptr-pass-through ;
-
-: marshall-bool ( ? -- n )
- >boolean [ 1 ] [ 0 ] if ;
-
-: (marshall-bool*) ( ?/seq -- alien )
- [ marshall-bool <bool> malloc-byte-array ]
- [ >bool-array malloc-underlying ]
- marshall-x* ;
-
-: marshall-bool* ( ?/seq -- alien )
- [ (marshall-bool*) ] ptr-pass-through ;
-
-: (marshall-bool**) ( seq -- alien )
- [ marshall-bool* ] map >void*-array malloc-underlying ;
-
-: marshall-bool** ( seq -- alien )
- [ (marshall-bool**) ] ptr-pass-through ;
-
-: unmarshall-bool ( n -- ? )
- 0 = not ;
-
-: unmarshall-bool* ( alien -- ? )
- *bool unmarshall-bool ;
-
-: unmarshall-bool*-free ( alien -- ? )
- [ *bool unmarshall-bool ] keep add-malloc free ;
-
-: primitive-marshaller ( type -- quot/f )
- {
- { "bool" [ [ ] ] }
- { "boolean" [ [ marshall-bool ] ] }
- { "char" [ [ marshall-primitive ] ] }
- { "uchar" [ [ marshall-primitive ] ] }
- { "short" [ [ marshall-primitive ] ] }
- { "ushort" [ [ marshall-primitive ] ] }
- { "int" [ [ marshall-primitive ] ] }
- { "uint" [ [ marshall-primitive ] ] }
- { "long" [ [ marshall-primitive ] ] }
- { "ulong" [ [ marshall-primitive ] ] }
- { "long" [ [ marshall-primitive ] ] }
- { "ulong" [ [ marshall-primitive ] ] }
- { "float" [ [ marshall-primitive ] ] }
- { "double" [ [ marshall-primitive ] ] }
- { "bool*" [ [ marshall-bool* ] ] }
- { "boolean*" [ [ marshall-bool* ] ] }
- { "char*" [ [ marshall-char*-or-string ] ] }
- { "uchar*" [ [ marshall-uchar* ] ] }
- { "short*" [ [ marshall-short* ] ] }
- { "ushort*" [ [ marshall-ushort* ] ] }
- { "int*" [ [ marshall-int* ] ] }
- { "uint*" [ [ marshall-uint* ] ] }
- { "long*" [ [ marshall-long* ] ] }
- { "ulong*" [ [ marshall-ulong* ] ] }
- { "longlong*" [ [ marshall-longlong* ] ] }
- { "ulonglong*" [ [ marshall-ulonglong* ] ] }
- { "float*" [ [ marshall-float* ] ] }
- { "double*" [ [ marshall-double* ] ] }
- { "bool&" [ [ marshall-bool* ] ] }
- { "boolean&" [ [ marshall-bool* ] ] }
- { "char&" [ [ marshall-char* ] ] }
- { "uchar&" [ [ marshall-uchar* ] ] }
- { "short&" [ [ marshall-short* ] ] }
- { "ushort&" [ [ marshall-ushort* ] ] }
- { "int&" [ [ marshall-int* ] ] }
- { "uint&" [ [ marshall-uint* ] ] }
- { "long&" [ [ marshall-long* ] ] }
- { "ulong&" [ [ marshall-ulong* ] ] }
- { "longlong&" [ [ marshall-longlong* ] ] }
- { "ulonglong&" [ [ marshall-ulonglong* ] ] }
- { "float&" [ [ marshall-float* ] ] }
- { "double&" [ [ marshall-double* ] ] }
- { "void*" [ [ marshall-void* ] ] }
- { "bool**" [ [ marshall-bool** ] ] }
- { "boolean**" [ [ marshall-bool** ] ] }
- { "char**" [ [ marshall-char**-or-strings ] ] }
- { "uchar**" [ [ marshall-uchar** ] ] }
- { "short**" [ [ marshall-short** ] ] }
- { "ushort**" [ [ marshall-ushort** ] ] }
- { "int**" [ [ marshall-int** ] ] }
- { "uint**" [ [ marshall-uint** ] ] }
- { "long**" [ [ marshall-long** ] ] }
- { "ulong**" [ [ marshall-ulong** ] ] }
- { "longlong**" [ [ marshall-longlong** ] ] }
- { "ulonglong**" [ [ marshall-ulonglong** ] ] }
- { "float**" [ [ marshall-float** ] ] }
- { "double**" [ [ marshall-double** ] ] }
- { "void**" [ [ marshall-void** ] ] }
- [ drop f ]
- } case ;
-
-: marshall-non-pointer ( alien-wrapper/byte-array -- byte-array )
- {
- { [ dup byte-array? ] [ ] }
- { [ dup alien-wrapper? ]
- [ [ underlying>> ] [ class name>> heap-size ] bi
- memory>byte-array ] }
- } cond ;
-
-
-: marshaller ( type -- quot )
- factorize-type dup primitive-marshaller [ nip ] [
- pointer?
- [ [ marshall-pointer ] ]
- [ [ marshall-non-pointer ] ] if
- ] if* ;
-
-
-: unmarshall-char*-to-string ( alien -- string )
- utf8 alien>string ;
-
-: unmarshall-char*-to-string-free ( alien -- string )
- [ unmarshall-char*-to-string ] keep add-malloc free ;
-
-: primitive-unmarshaller ( type -- quot/f )
- {
- { "bool" [ [ ] ] }
- { "boolean" [ [ unmarshall-bool ] ] }
- { "char" [ [ ] ] }
- { "uchar" [ [ ] ] }
- { "short" [ [ ] ] }
- { "ushort" [ [ ] ] }
- { "int" [ [ ] ] }
- { "uint" [ [ ] ] }
- { "long" [ [ ] ] }
- { "ulong" [ [ ] ] }
- { "longlong" [ [ ] ] }
- { "ulonglong" [ [ ] ] }
- { "float" [ [ ] ] }
- { "double" [ [ ] ] }
- { "bool*" [ [ unmarshall-bool*-free ] ] }
- { "boolean*" [ [ unmarshall-bool*-free ] ] }
- { "char*" [ [ ] ] }
- { "uchar*" [ [ unmarshall-uchar*-free ] ] }
- { "short*" [ [ unmarshall-short*-free ] ] }
- { "ushort*" [ [ unmarshall-ushort*-free ] ] }
- { "int*" [ [ unmarshall-int*-free ] ] }
- { "uint*" [ [ unmarshall-uint*-free ] ] }
- { "long*" [ [ unmarshall-long*-free ] ] }
- { "ulong*" [ [ unmarshall-ulong*-free ] ] }
- { "longlong*" [ [ unmarshall-long*-free ] ] }
- { "ulonglong*" [ [ unmarshall-ulong*-free ] ] }
- { "float*" [ [ unmarshall-float*-free ] ] }
- { "double*" [ [ unmarshall-double*-free ] ] }
- { "bool&" [ [ unmarshall-bool*-free ] ] }
- { "boolean&" [ [ unmarshall-bool*-free ] ] }
- { "char&" [ [ ] ] }
- { "uchar&" [ [ unmarshall-uchar*-free ] ] }
- { "short&" [ [ unmarshall-short*-free ] ] }
- { "ushort&" [ [ unmarshall-ushort*-free ] ] }
- { "int&" [ [ unmarshall-int*-free ] ] }
- { "uint&" [ [ unmarshall-uint*-free ] ] }
- { "long&" [ [ unmarshall-long*-free ] ] }
- { "ulong&" [ [ unmarshall-ulong*-free ] ] }
- { "longlong&" [ [ unmarshall-longlong*-free ] ] }
- { "ulonglong&" [ [ unmarshall-ulonglong*-free ] ] }
- { "float&" [ [ unmarshall-float*-free ] ] }
- { "double&" [ [ unmarshall-double*-free ] ] }
- [ drop f ]
- } case ;
-
-: struct-primitive-unmarshaller ( type -- quot/f )
- {
- { "bool" [ [ unmarshall-bool ] ] }
- { "boolean" [ [ unmarshall-bool ] ] }
- { "char" [ [ ] ] }
- { "uchar" [ [ ] ] }
- { "short" [ [ ] ] }
- { "ushort" [ [ ] ] }
- { "int" [ [ ] ] }
- { "uint" [ [ ] ] }
- { "long" [ [ ] ] }
- { "ulong" [ [ ] ] }
- { "longlong" [ [ ] ] }
- { "ulonglong" [ [ ] ] }
- { "float" [ [ ] ] }
- { "double" [ [ ] ] }
- { "bool*" [ [ unmarshall-bool* ] ] }
- { "boolean*" [ [ unmarshall-bool* ] ] }
- { "char*" [ [ ] ] }
- { "uchar*" [ [ unmarshall-uchar* ] ] }
- { "short*" [ [ unmarshall-short* ] ] }
- { "ushort*" [ [ unmarshall-ushort* ] ] }
- { "int*" [ [ unmarshall-int* ] ] }
- { "uint*" [ [ unmarshall-uint* ] ] }
- { "long*" [ [ unmarshall-long* ] ] }
- { "ulong*" [ [ unmarshall-ulong* ] ] }
- { "longlong*" [ [ unmarshall-long* ] ] }
- { "ulonglong*" [ [ unmarshall-ulong* ] ] }
- { "float*" [ [ unmarshall-float* ] ] }
- { "double*" [ [ unmarshall-double* ] ] }
- { "bool&" [ [ unmarshall-bool* ] ] }
- { "boolean&" [ [ unmarshall-bool* ] ] }
- { "char&" [ [ unmarshall-char* ] ] }
- { "uchar&" [ [ unmarshall-uchar* ] ] }
- { "short&" [ [ unmarshall-short* ] ] }
- { "ushort&" [ [ unmarshall-ushort* ] ] }
- { "int&" [ [ unmarshall-int* ] ] }
- { "uint&" [ [ unmarshall-uint* ] ] }
- { "long&" [ [ unmarshall-long* ] ] }
- { "ulong&" [ [ unmarshall-ulong* ] ] }
- { "longlong&" [ [ unmarshall-longlong* ] ] }
- { "ulonglong&" [ [ unmarshall-ulonglong* ] ] }
- { "float&" [ [ unmarshall-float* ] ] }
- { "double&" [ [ unmarshall-double* ] ] }
- [ drop f ]
- } case ;
-
-
-: ?malloc-byte-array ( c-type -- alien )
- dup alien? [ malloc-byte-array ] unless ;
-
-:: x-unmarshaller ( type type-quot superclass def clean -- quot/f )
- type type-quot call current-vocab lookup [
- dup superclasses superclass swap member?
- [ def call ] [ drop clean call f ] if
- ] [ clean call f ] if* ; inline
-
-: struct-unmarshaller ( type -- quot/f )
- [ ] \ struct-wrapper
- [ '[ ?malloc-byte-array _ new swap >>underlying ] ]
- [ ]
- x-unmarshaller ;
-
-: class-unmarshaller ( type -- quot/f )
- [ type-sans-pointer "#" append ] \ class-wrapper
- [ '[ _ new swap >>underlying ] ]
- [ ]
- x-unmarshaller ;
-
-: non-primitive-unmarshaller ( type -- quot/f )
- {
- { [ dup pointer? ] [ class-unmarshaller ] }
- [ struct-unmarshaller ]
- } cond ;
-
-: unmarshaller ( type -- quot )
- factorize-type {
- [ primitive-unmarshaller ]
- [ non-primitive-unmarshaller ]
- [ drop [ ] ]
- } 1|| ;
-
-: struct-field-unmarshaller ( type -- quot )
- factorize-type {
- [ struct-primitive-unmarshaller ]
- [ non-primitive-unmarshaller ]
- [ drop [ ] ]
- } 1|| ;
-
-: out-arg-unmarshaller ( type -- quot )
- dup pointer-to-non-const-primitive?
- [ factorize-type primitive-unmarshaller ]
- [ drop [ drop ] ] if ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.inline arrays
-combinators fry functors kernel lexer libc macros math
-sequences specialized-arrays libc.private
-combinators.short-circuit alien.data ;
-SPECIALIZED-ARRAY: void*
-IN: alien.marshall.private
-
-: bool>arg ( ? -- 1/0/obj )
- {
- { t [ 1 ] }
- { f [ 0 ] }
- [ ]
- } case ;
-
-MACRO: marshall-x* ( num-quot seq-quot -- alien )
- '[ bool>arg dup number? _ _ if ] ;
-
-: ptr-pass-through ( obj quot -- alien )
- over { [ c-ptr? ] [ ] } 1&& [ drop ] [ call ] if ; inline
-
-: malloc-underlying ( obj -- alien )
- underlying>> malloc-byte-array ;
-
-FUNCTOR: define-primitive-marshallers ( TYPE -- )
-<TYPE> IS <${TYPE}>
-*TYPE IS *${TYPE}
->TYPE-array IS >${TYPE}-array
-marshall-TYPE DEFINES marshall-${TYPE}
-(marshall-TYPE*) DEFINES (marshall-${TYPE}*)
-(marshall-TYPE**) DEFINES (marshall-${TYPE}**)
-marshall-TYPE* DEFINES marshall-${TYPE}*
-marshall-TYPE** DEFINES marshall-${TYPE}**
-marshall-TYPE*-free DEFINES marshall-${TYPE}*-free
-marshall-TYPE**-free DEFINES marshall-${TYPE}**-free
-unmarshall-TYPE* DEFINES unmarshall-${TYPE}*
-unmarshall-TYPE*-free DEFINES unmarshall-${TYPE}*-free
-WHERE
-<PRIVATE
-: (marshall-TYPE*) ( n/seq -- alien )
- [ <TYPE> malloc-byte-array ]
- [ >TYPE-array malloc-underlying ]
- marshall-x* ;
-PRIVATE>
-: marshall-TYPE* ( n/seq -- alien )
- [ (marshall-TYPE*) ] ptr-pass-through ;
-<PRIVATE
-: (marshall-TYPE**) ( seq -- alien )
- [ marshall-TYPE* ] void*-array{ } map-as malloc-underlying ;
-PRIVATE>
-: marshall-TYPE** ( seq -- alien )
- [ (marshall-TYPE**) ] ptr-pass-through ;
-: unmarshall-TYPE* ( alien -- n )
- *TYPE ; inline
-: unmarshall-TYPE*-free ( alien -- n )
- [ unmarshall-TYPE* ] keep add-malloc free ;
-;FUNCTOR
-
-SYNTAX: PRIMITIVE-MARSHALLERS:
-";" parse-tokens [ define-primitive-marshallers ] each ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: classes help.markup help.syntax kernel quotations words
-alien.marshall.structs strings alien.structs alien.marshall ;
-IN: alien.marshall.structs
-
-HELP: define-marshalled-struct
-{ $values
- { "name" string } { "vocab" "a vocabulary specifier" } { "fields" "an alist" }
-}
-{ $description "Calls " { $link define-struct } " and " { $link define-struct-tuple } "." } ;
-
-HELP: define-struct-tuple
-{ $values
- { "name" string }
-}
-{ $description "Defines a subclass of " { $link struct-wrapper } ", a constructor, "
- "and accessor words."
-} ;
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.marshall arrays assocs
-classes.tuple combinators destructors generalizations generic
-kernel libc locals parser quotations sequences slots words
-alien.structs lexer vocabs.parser fry effects alien.data ;
-IN: alien.marshall.structs
-
-<PRIVATE
-: define-struct-accessor ( class name quot -- )
- [ "accessors" create create-method dup make-inline ] dip define ;
-
-: define-struct-getter ( class name word type -- )
- [ ">>" append \ underlying>> ] 2dip
- struct-field-unmarshaller \ call 4array >quotation
- define-struct-accessor ;
-
-: define-struct-setter ( class name word type -- )
- [ "(>>" prepend ")" append ] 2dip
- marshaller [ underlying>> ] \ bi* roll 4array >quotation
- define-struct-accessor ;
-
-: define-struct-accessors ( class name type reader writer -- )
- [ dup define-protocol-slot ] 3dip
- [ drop swap define-struct-getter ]
- [ nip swap define-struct-setter ] 5 nbi ;
-
-: define-struct-constructor ( class -- )
- {
- [ name>> "<" prepend ">" append create-in ]
- [ '[ _ new ] ]
- [ name>> '[ _ malloc-object >>underlying ] append ]
- [ name>> 1array ]
- } cleave { } swap <effect> define-declared ;
-PRIVATE>
-
-:: define-struct-tuple ( name -- )
- name create-in :> class
- class struct-wrapper { } define-tuple-class
- class define-struct-constructor
- name c-type fields>> [
- class swap
- {
- [ name>> { { CHAR: space CHAR: - } } substitute ]
- [ type>> ] [ reader>> ] [ writer>> ]
- } cleave define-struct-accessors
- ] each ;
-
-: define-marshalled-struct ( name vocab fields -- )
- [ define-struct ] [ 2drop define-struct-tuple ] 3bi ;
+++ /dev/null
-Jeremy Hughes
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations words
-alien.inline alien.syntax effects alien.marshall
-alien.marshall.structs strings sequences alien.inline.syntax ;
-IN: alien.marshall.syntax
-
-HELP: CM-FUNCTION:
-{ $syntax "CM-FUNCTION: return name args\n body\n;" }
-{ $description "Like " { $link POSTPONE: C-FUNCTION: } " but with marshalling "
- "of arguments and return values."
-}
-{ $examples
- { $example
- "USING: alien.inline.syntax alien.marshall.syntax prettyprint ;"
- "IN: example"
- ""
- "C-LIBRARY: exlib"
- ""
- "C-INCLUDE: <stdio.h>"
- "C-INCLUDE: <stdlib.h>"
- "CM-FUNCTION: char* sum_diff ( const-int a, const-int b, int* x, int* y )"
- " *x = a + b;"
- " *y = a - b;"
- " char* s = (char*) malloc(sizeof(char) * 64);"
- " sprintf(s, \"sum %i, diff %i\", *x, *y);"
- " return s;"
- ";"
- ""
- ";C-LIBRARY"
- ""
- "8 5 0 0 sum_diff . . ."
- "3\n13\n\"sum 13, diff 3\""
- }
-}
-{ $see-also define-c-marshalled POSTPONE: C-FUNCTION: POSTPONE: M-FUNCTION: } ;
-
-HELP: CM-STRUCTURE:
-{ $syntax "CM-STRUCTURE: name fields ... ;" }
-{ $description "Like " { $link POSTPONE: C-STRUCTURE: } " but with marshalling of fields. "
- "Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words."
-}
-{ $see-also POSTPONE: C-STRUCTURE: POSTPONE: M-STRUCTURE: } ;
-
-HELP: M-FUNCTION:
-{ $syntax "M-FUNCTION: return name args ;" }
-{ $description "Like " { $link POSTPONE: FUNCTION: } " but with marshalling "
- "of arguments and return values."
-}
-{ $see-also marshalled-function POSTPONE: C-FUNCTION: POSTPONE: CM-FUNCTION: } ;
-
-HELP: M-STRUCTURE:
-{ $syntax "M-STRUCTURE: name fields ... ;" }
-{ $description "Like " { $link POSTPONE: C-STRUCT: } " but with marshalling of fields. "
- "Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words."
-}
-{ $see-also define-marshalled-struct POSTPONE: C-STRUCTURE: POSTPONE: CM-STRUCTURE: } ;
-
-HELP: define-c-marshalled
-{ $values
- { "name" string } { "types" sequence } { "effect" effect } { "body" string }
-}
-{ $description "Defines a C function and a factor word which calls it with marshalling of "
- "args and return values."
-}
-{ $see-also define-c-marshalled' } ;
-
-HELP: define-c-marshalled'
-{ $values
- { "name" string } { "effect" effect } { "body" string }
-}
-{ $description "Like " { $link define-c-marshalled } ". "
- "The effect elements must be C type strings."
-} ;
-
-HELP: marshalled-function
-{ $values
- { "name" string } { "types" sequence } { "effect" effect }
- { "word" word } { "quot" quotation } { "effect" effect }
-}
-{ $description "Defines a word which calls the named C function. Arguments, "
- "return value, and output parameters are marshalled and unmarshalled."
-} ;
-
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.inline.syntax alien.marshall.syntax destructors
-tools.test accessors kernel ;
-IN: alien.marshall.syntax.tests
-
-DELETE-C-LIBRARY: test
-C-LIBRARY: test
-
-C-INCLUDE: <stdlib.h>
-C-INCLUDE: <string.h>
-C-INCLUDE: <stdbool.h>
-
-CM-FUNCTION: void outarg1 ( int* a )
- *a += 2;
-;
-
-CM-FUNCTION: unsigned-long* outarg2 ( unsigned-long a, unsigned-long* b )
- unsigned long* x = malloc(sizeof(unsigned long*));
- *b = 10 + *b;
- *x = a + *b;
- return x;
-;
-
-CM-STRUCTURE: wedge
- { "double" "degrees" } ;
-
-CM-STRUCTURE: sundial
- { "double" "radius" }
- { "wedge" "wedge" } ;
-
-CM-FUNCTION: double hours ( sundial* d )
- return d->wedge.degrees / 30;
-;
-
-CM-FUNCTION: void change_time ( double hours, sundial* d )
- d->wedge.degrees = hours * 30;
-;
-
-CM-FUNCTION: bool c_not ( bool p )
- return !p;
-;
-
-CM-FUNCTION: char* upcase ( const-char* s )
- int len = strlen(s);
- char* t = malloc(sizeof(char) * len);
- int i;
- for (i = 0; i < len; i++)
- t[i] = toupper(s[i]);
- t[i] = '\0';
- return t;
-;
-
-;C-LIBRARY
-
-{ 1 1 } [ outarg1 ] must-infer-as
-[ 3 ] [ 1 outarg1 ] unit-test
-[ 3 ] [ t outarg1 ] unit-test
-[ 2 ] [ f outarg1 ] unit-test
-
-{ 2 2 } [ outarg2 ] must-infer-as
-[ 18 15 ] [ 3 5 outarg2 ] unit-test
-
-{ 1 1 } [ hours ] must-infer-as
-[ 5.0 ] [ <sundial> <wedge> 150 >>degrees >>wedge hours ] unit-test
-
-{ 2 0 } [ change_time ] must-infer-as
-[ 150.0 ] [ 5 <sundial> <wedge> 11 >>degrees >>wedge [ change_time ] keep wedge>> degrees>> ] unit-test
-
-{ 1 1 } [ c_not ] must-infer-as
-[ f ] [ "x" c_not ] unit-test
-[ f ] [ 0 c_not ] unit-test
-
-{ 1 1 } [ upcase ] must-infer-as
-[ "ABC" ] [ "abc" upcase ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Jeremy Hughes.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.inline alien.inline.types alien.marshall
-combinators effects generalizations kernel locals make namespaces
-quotations sequences words alien.marshall.structs lexer parser
-vocabs.parser multiline ;
-IN: alien.marshall.syntax
-
-:: marshalled-function ( name types effect -- word quot effect )
- name types effect factor-function
- [ in>> ]
- [ out>> types [ pointer-to-non-const-primitive? ] filter append ]
- bi <effect>
- [
- [
- types [ marshaller ] map , \ spread , ,
- types length , \ nkeep ,
- types [ out-arg-unmarshaller ] map
- effect out>> dup empty?
- [ drop ] [ first unmarshaller prefix ] if
- , \ spread ,
- ] [ ] make
- ] dip ;
-
-: define-c-marshalled ( name types effect body -- )
- [
- [ marshalled-function define-declared ]
- [ prototype-string ] 3bi
- ] dip append-function-body c-strings get push ;
-
-: define-c-marshalled' ( name effect body -- )
- [
- [ in>> ] keep
- [ marshalled-function define-declared ]
- [ out>> prototype-string' ] 3bi
- ] dip append-function-body c-strings get push ;
-
-SYNTAX: CM-FUNCTION:
- function-types-effect parse-here define-c-marshalled ;
-
-SYNTAX: M-FUNCTION:
- function-types-effect marshalled-function define-declared ;
-
-SYNTAX: M-STRUCTURE:
- scan current-vocab parse-definition
- define-marshalled-struct ;
-
-SYNTAX: CM-STRUCTURE:
- scan current-vocab parse-definition
- [ define-marshalled-struct ] [ nip define-c-struct ] 3bi ;
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING:
+ alien
+ alien.c-types
+ alien.libraries
+ alien.syntax
+ classes.struct
+ combinators
+ kernel
+ system
+;
+IN: ogg
+
+<<
+"ogg" {
+ { [ os winnt? ] [ "ogg.dll" ] }
+ { [ os macosx? ] [ "libogg.0.dylib" ] }
+ { [ os unix? ] [ "libogg.so" ] }
+} cond "cdecl" add-library
+>>
+
+LIBRARY: ogg
+
+STRUCT: oggpack-buffer
+ { endbyte long }
+ { endbit int }
+ { buffer uchar* }
+ { ptr uchar* }
+ { storage long } ;
+
+STRUCT: ogg-page
+ { header uchar* }
+ { header_len long }
+ { body uchar* }
+ { body_len long } ;
+
+STRUCT: ogg-stream-state
+ { body_data uchar* }
+ { body_storage long }
+ { body_fill long }
+ { body_returned long }
+ { lacing_vals int* }
+ { granule_vals longlong* }
+ { lacing_storage long }
+ { lacing_fill long }
+ { lacing_packet long }
+ { lacing_returned long }
+ { header { uchar 282 } }
+ { header_fill int }
+ { e_o_s int }
+ { b_o_s int }
+ { serialno long }
+ { pageno long }
+ { packetno longlong }
+ { granulepos longlong } ;
+
+STRUCT: ogg-packet
+ { packet uchar* }
+ { bytes long }
+ { b_o_s long }
+ { e_o_s long }
+ { granulepos longlong }
+ { packetno longlong } ;
+
+STRUCT: ogg-sync-state
+ { data uchar* }
+ { storage int }
+ { fill int }
+ { returned int }
+ { unsynced int }
+ { headerbytes int }
+ { bodybytes int } ;
+
+FUNCTION: void oggpack_writeinit ( oggpack-buffer* b ) ;
+FUNCTION: void oggpack_writetrunc ( oggpack-buffer* b, long bits ) ;
+FUNCTION: void oggpack_writealign ( oggpack-buffer* b) ;
+FUNCTION: void oggpack_writecopy ( oggpack-buffer* b, void* source, long bits ) ;
+FUNCTION: void oggpack_reset ( oggpack-buffer* b ) ;
+FUNCTION: void oggpack_writeclear ( oggpack-buffer* b ) ;
+FUNCTION: void oggpack_readinit ( oggpack-buffer* b, uchar* buf, int bytes ) ;
+FUNCTION: void oggpack_write ( oggpack-buffer* b, ulong value, int bits ) ;
+FUNCTION: long oggpack_look ( oggpack-buffer* b, int bits ) ;
+FUNCTION: long oggpack_look1 ( oggpack-buffer* b ) ;
+FUNCTION: void oggpack_adv ( oggpack-buffer* b, int bits ) ;
+FUNCTION: void oggpack_adv1 ( oggpack-buffer* b ) ;
+FUNCTION: long oggpack_read ( oggpack-buffer* b, int bits ) ;
+FUNCTION: long oggpack_read1 ( oggpack-buffer* b ) ;
+FUNCTION: long oggpack_bytes ( oggpack-buffer* b ) ;
+FUNCTION: long oggpack_bits ( oggpack-buffer* b ) ;
+FUNCTION: uchar* oggpack_get_buffer ( oggpack-buffer* b ) ;
+FUNCTION: void oggpackB_writeinit ( oggpack-buffer* b ) ;
+FUNCTION: void oggpackB_writetrunc ( oggpack-buffer* b, long bits ) ;
+FUNCTION: void oggpackB_writealign ( oggpack-buffer* b ) ;
+FUNCTION: void oggpackB_writecopy ( oggpack-buffer* b, void* source, long bits ) ;
+FUNCTION: void oggpackB_reset ( oggpack-buffer* b ) ;
+FUNCTION: void oggpackB_writeclear ( oggpack-buffer* b ) ;
+FUNCTION: void oggpackB_readinit ( oggpack-buffer* b, uchar* buf, int bytes ) ;
+FUNCTION: void oggpackB_write ( oggpack-buffer* b, ulong value, int bits ) ;
+FUNCTION: long oggpackB_look ( oggpack-buffer* b, int bits ) ;
+FUNCTION: long oggpackB_look1 ( oggpack-buffer* b ) ;
+FUNCTION: void oggpackB_adv ( oggpack-buffer* b, int bits ) ;
+FUNCTION: void oggpackB_adv1 ( oggpack-buffer* b ) ;
+FUNCTION: long oggpackB_read ( oggpack-buffer* b, int bits ) ;
+FUNCTION: long oggpackB_read1 ( oggpack-buffer* b ) ;
+FUNCTION: long oggpackB_bytes ( oggpack-buffer* b ) ;
+FUNCTION: long oggpackB_bits ( oggpack-buffer* b ) ;
+FUNCTION: uchar* oggpackB_get_buffer ( oggpack-buffer* b ) ;
+FUNCTION: int ogg_stream_packetin ( ogg-stream-state* os, ogg-packet* op ) ;
+FUNCTION: int ogg_stream_pageout ( ogg-stream-state* os, ogg-page* og ) ;
+FUNCTION: int ogg_stream_flush ( ogg-stream-state* os, ogg-page* og ) ;
+FUNCTION: int ogg_sync_init ( ogg-sync-state* oy ) ;
+FUNCTION: int ogg_sync_clear ( ogg-sync-state* oy ) ;
+FUNCTION: int ogg_sync_reset ( ogg-sync-state* oy ) ;
+FUNCTION: int ogg_sync_destroy ( ogg-sync-state* oy ) ;
+
+FUNCTION: void* ogg_sync_buffer ( ogg-sync-state* oy, long size ) ;
+FUNCTION: int ogg_sync_wrote ( ogg-sync-state* oy, long bytes ) ;
+FUNCTION: long ogg_sync_pageseek ( ogg-sync-state* oy, ogg-page* og ) ;
+FUNCTION: int ogg_sync_pageout ( ogg-sync-state* oy, ogg-page* og ) ;
+FUNCTION: int ogg_stream_pagein ( ogg-stream-state* os, ogg-page* og ) ;
+FUNCTION: int ogg_stream_packetout ( ogg-stream-state* os, ogg-packet* op ) ;
+FUNCTION: int ogg_stream_packetpeek ( ogg-stream-state* os, ogg-packet* op ) ;
+FUNCTION: int ogg_stream_init (ogg-stream-state* os, int serialno ) ;
+FUNCTION: int ogg_stream_clear ( ogg-stream-state* os ) ;
+FUNCTION: int ogg_stream_reset ( ogg-stream-state* os ) ;
+FUNCTION: int ogg_stream_reset_serialno ( ogg-stream-state* os, int serialno ) ;
+FUNCTION: int ogg_stream_destroy ( ogg-stream-state* os ) ;
+FUNCTION: int ogg_stream_eos ( ogg-stream-state* os ) ;
+FUNCTION: void ogg_page_checksum_set ( ogg-page* og ) ;
+FUNCTION: int ogg_page_version ( ogg-page* og ) ;
+FUNCTION: int ogg_page_continued ( ogg-page* og ) ;
+FUNCTION: int ogg_page_bos ( ogg-page* og ) ;
+FUNCTION: int ogg_page_eos ( ogg-page* og ) ;
+FUNCTION: longlong ogg_page_granulepos ( ogg-page* og ) ;
+FUNCTION: int ogg_page_serialno ( ogg-page* og ) ;
+FUNCTION: long ogg_page_pageno ( ogg-page* og ) ;
+FUNCTION: int ogg_page_packets ( ogg-page* og ) ;
+FUNCTION: void ogg_packet_clear ( ogg-packet* op ) ;
+
--- /dev/null
+Ogg media library binding
--- /dev/null
+bindings
+audio
+video
--- /dev/null
+Chris Double
--- /dev/null
+Ogg Theora video library binding
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING:
+ alien
+ alien.c-types
+ alien.libraries
+ alien.syntax
+ classes.struct
+ combinators
+ kernel
+ ogg
+ system
+;
+IN: ogg.theora
+
+<<
+"theoradec" {
+ { [ os winnt? ] [ "theoradec.dll" ] }
+ { [ os macosx? ] [ "libtheoradec.0.dylib" ] }
+ { [ os unix? ] [ "libtheoradec.so" ] }
+} cond "cdecl" add-library
+
+"theoraenc" {
+ { [ os winnt? ] [ "theoraenc.dll" ] }
+ { [ os macosx? ] [ "libtheoraenc.0.dylib" ] }
+ { [ os unix? ] [ "libtheoraenc.so" ] }
+} cond "cdecl" add-library
+>>
+
+CONSTANT: TH-EFAULT -1
+CONSTANT: TH-EINVAL -10
+CONSTANT: TH-EBADHEADER -20
+CONSTANT: TH-ENOTFORMAT -21
+CONSTANT: TH-EVERSION -22
+CONSTANT: TH-EIMPL -23
+CONSTANT: TH-EBADPACKET -24
+CONSTANT: TH-DUPFRAME 1
+
+TYPEDEF: int th-colorspace
+CONSTANT: TH-CS-UNSPECIFIED 0
+CONSTANT: TH-CS-ITU-REC-470M 1
+CONSTANT: TH-CS-ITU-REC-470BG 2
+CONSTANT: TH-CS-NSPACES 3
+
+TYPEDEF: int th-pixelformat
+CONSTANT: TH-PF-RSVD 0
+CONSTANT: TH-PF-422 1
+CONSTANT: TH-PF-444 2
+CONSTANT: TH-PF-NFORMATS 3
+
+STRUCT: th-img-plane
+ { width int }
+ { height int }
+ { stride int }
+ { data uchar* }
+;
+
+TYPEDEF: th-img-plane[3] th-ycbcr-buffer
+
+STRUCT: th-info
+ { version-major uchar }
+ { version-minor uchar }
+ { version-subminor uchar }
+ { frame-width uint }
+ { frame-height uint }
+ { pic-width uint }
+ { pic-height uint }
+ { pic-x uint }
+ { pic-y uint }
+ { fps-numerator uint }
+ { fps-denominator uint }
+ { aspect-numerator uint }
+ { aspect-denominator uint }
+ { colorspace th-colorspace }
+ { pixel-fmt th-pixelformat }
+ { target-bitrate int }
+ { quality int }
+ { keyframe-granule-shift int }
+;
+
+STRUCT: th-comment
+ { user-comments char** }
+ { comment-lengths int* }
+ { comments int }
+ { vendor char* }
+;
+
+TYPEDEF: uchar[64] th-quant-base
+
+STRUCT: th-quant-ranges
+ { nranges int }
+ { sizes int* }
+ { base-matrices th-quant-base* }
+;
+
+STRUCT: th-quant-info
+ { dc-scale { short 64 } }
+ { ac-scale { short 64 } }
+ { loop-filter-limits { uchar 64 } }
+ { qi-ranges { th-quant-ranges 2 3 } }
+;
+
+CONSTANT: TH-NHUFFMANE-TABLES 80
+CONSTANT: TH-NDCT-TOKENS 32
+
+STRUCT: th-huff-code
+ { pattern int }
+ { nbits int }
+;
+
+LIBRARY: theoradec
+FUNCTION: char* th_version_string ( ) ;
+FUNCTION: uint th_version_number ( ) ;
+FUNCTION: longlong th_granule_frame ( void* encdec, longlong granpos) ;
+FUNCTION: int th_packet_isheader ( ogg-packet* op ) ;
+FUNCTION: int th_packet_iskeyframe ( ogg-packet* op ) ;
+FUNCTION: void th_info_init ( th-info* info ) ;
+FUNCTION: void th_info_clear ( th-info* info ) ;
+FUNCTION: void th_comment_init ( th-comment* tc ) ;
+FUNCTION: void th_comment_add ( th-comment* tc, char* comment ) ;
+FUNCTION: void th_comment_add_tag ( th-comment* tc, char* tag, char* value ) ;
+FUNCTION: char* th_comment_query ( th-comment* tc, char* tag, int count ) ;
+FUNCTION: int th_comment_query_count ( th-comment* tc, char* tag ) ;
+FUNCTION: void th_comment_clear ( th-comment* tc ) ;
+
+CONSTANT: TH-ENCCTL-SET-HUFFMAN-CODES 0
+CONSTANT: TH-ENCCTL-SET-QUANT-PARAMS 2
+CONSTANT: TH-ENCCTL-SET-KEYFRAME-FREQUENCY-FORCE 4
+CONSTANT: TH-ENCCTL-SET-VP3-COMPATIBLE 10
+CONSTANT: TH-ENCCTL-GET-SPLEVEL-MAX 12
+CONSTANT: TH-ENCCTL-SET-SPLEVEL 14
+CONSTANT: TH-ENCCTL-SET-DUP-COUNT 18
+CONSTANT: TH-ENCCTL-SET-RATE-FLAGS 20
+CONSTANT: TH-ENCCTL-SET-RATE-BUFFER 22
+CONSTANT: TH-ENCCTL-2PASS-OUT 24
+CONSTANT: TH-ENCCTL-2PASS-IN 26
+CONSTANT: TH-ENCCTL-SET-QUALITY 28
+CONSTANT: TH-ENCCTL-SET-BITRATE 30
+
+CONSTANT: TH-RATECTL-DROP-FRAMES 1
+CONSTANT: TH-RATECTL-CAP-OVERFLOW 2
+CONSTANT: TH-RATECTL-CAP-UNDERFOW 4
+
+TYPEDEF: void* th-enc-ctx
+
+LIBRARY: theoraenc
+FUNCTION: th-enc-ctx* th_encode_alloc ( th-info* info ) ;
+FUNCTION: int th_encode_ctl ( th-enc-ctx* enc, int req, void* buf, int buf_sz ) ;
+FUNCTION: int th_encode_flushheader ( th-enc-ctx* enc, th-comment* comments, ogg-packet* op ) ;
+FUNCTION: int th_encode_ycbcr_in ( th-enc-ctx* enc, th-ycbcr-buffer ycbcr ) ;
+FUNCTION: int th_encode_packetout ( th-enc-ctx* enc, int last, ogg-packet* op ) ;
+FUNCTION: void th_encode_free ( th-enc-ctx* enc ) ;
+
+CONSTANT: TH-DECCTL-GET-PPLEVEL-MAX 1
+CONSTANT: TH-DECCTL-SET-PPLEVEL 3
+CONSTANT: TH-DECCTL-SET-GRANPOS 5
+CONSTANT: TH-DECCTL-SET-STRIPE-CB 7
+CONSTANT: TH-DECCTL-SET-TELEMETRY-MBMODE 9
+CONSTANT: TH-DECCTL-SET-TELEMETRY-MV 11
+CONSTANT: TH-DECCTL-SET-TELEMETRY-QI 13
+CONSTANT: TH-DECCTL-SET-TELEMETRY-BITS 15
+
+TYPEDEF: void* th-stripe-decoded-func
+
+STRUCT: th-stripe-callback
+ { ctx void* }
+ { stripe-decoded th-stripe-decoded-func }
+;
+
+TYPEDEF: void* th-dec-ctx
+TYPEDEF: void* th-setup-info
+
+LIBRARY: theoradec
+FUNCTION: int th_decode_headerin ( th-info* info, th-comment* tc, th-setup-info** setup, ogg-packet* op ) ;
+FUNCTION: th-dec-ctx* th_decode_alloc ( th-info* info, th-setup-info* setup ) ;
+FUNCTION: void th_setup_free ( th-setup-info* setup ) ;
+FUNCTION: int th_decode_ctl ( th-dec-ctx* dec, int req, void* buf, int buf_sz ) ;
+FUNCTION: int th_decode_packetin ( th-dec-ctx* dec, ogg-packet* op, longlong granpos ) ;
+FUNCTION: int th_decode_ycbcr_out ( th-dec-ctx* dec, th-ycbcr-buffer ycbcr ) ;
+FUNCTION: void th_decode_free ( th-dec-ctx* dec ) ;
--- /dev/null
+Chris Double
--- /dev/null
+Ogg Vorbis audio library binding
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING:
+ alien
+ alien.c-types
+ alien.libraries
+ alien.syntax
+ classes.struct
+ combinators
+ kernel
+ ogg
+ system
+;
+IN: ogg.vorbis
+
+<<
+"vorbis" {
+ { [ os winnt? ] [ "vorbis.dll" ] }
+ { [ os macosx? ] [ "libvorbis.0.dylib" ] }
+ { [ os unix? ] [ "libvorbis.so" ] }
+} cond "cdecl" add-library
+>>
+
+LIBRARY: vorbis
+
+STRUCT: vorbis-info
+ { version int }
+ { channels int }
+ { rate long }
+ { bitrate_upper long }
+ { bitrate_nominal long }
+ { bitrate_lower long }
+ { bitrate_window long }
+ { codec_setup void* }
+ ;
+
+STRUCT: vorbis-dsp-state
+ { analysisp int }
+ { vi vorbis-info* }
+ { pcm float** }
+ { pcmret float** }
+ { pcm_storage int }
+ { pcm_current int }
+ { pcm_returned int }
+ { preextrapolate int }
+ { eofflag int }
+ { lW long }
+ { W long }
+ { nW long }
+ { centerW long }
+ { granulepos longlong }
+ { sequence longlong }
+ { glue_bits longlong }
+ { time_bits longlong }
+ { floor_bits longlong }
+ { res_bits longlong }
+ { backend_state void* }
+ ;
+
+STRUCT: alloc-chain
+ { ptr void* }
+ { next void* }
+ ;
+
+STRUCT: vorbis-block
+ { pcm float** }
+ { opb oggpack-buffer }
+ { lW long }
+ { W long }
+ { nW long }
+ { pcmend int }
+ { mode int }
+ { eofflag int }
+ { granulepos longlong }
+ { sequence longlong }
+ { vd vorbis-dsp-state* }
+ { localstore void* }
+ { localtop long }
+ { localalloc long }
+ { totaluse long }
+ { reap alloc-chain* }
+ { glue_bits long }
+ { time_bits long }
+ { floor_bits long }
+ { res_bits long }
+ { internal void* }
+ ;
+
+STRUCT: vorbis-comment
+ { usercomments char** }
+ { comment_lengths int* }
+ { comments int }
+ { vendor char* }
+ ;
+
+FUNCTION: void vorbis_info_init ( vorbis-info* vi ) ;
+FUNCTION: void vorbis_info_clear ( vorbis-info* vi ) ;
+FUNCTION: int vorbis_info_blocksize ( vorbis-info* vi, int zo ) ;
+FUNCTION: void vorbis_comment_init ( vorbis-comment* vc ) ;
+FUNCTION: void vorbis_comment_add ( vorbis-comment* vc, char* comment ) ;
+FUNCTION: void vorbis_comment_add_tag ( vorbis-comment* vc, char* tag, char* contents ) ;
+FUNCTION: char* vorbis_comment_query ( vorbis-comment* vc, char* tag, int count ) ;
+FUNCTION: int vorbis_comment_query_count ( vorbis-comment* vc, char* tag ) ;
+FUNCTION: void vorbis_comment_clear ( vorbis-comment* vc ) ;
+FUNCTION: int vorbis_block_init ( vorbis-dsp-state* v, vorbis-block* vb ) ;
+FUNCTION: int vorbis_block_clear ( vorbis-block* vb ) ;
+FUNCTION: void vorbis_dsp_clear ( vorbis-dsp-state* v ) ;
+FUNCTION: double vorbis_granule_time ( vorbis-dsp-state* v, longlong granulepos ) ;
+FUNCTION: int vorbis_analysis_init ( vorbis-dsp-state* v, vorbis-info* vi ) ;
+FUNCTION: int vorbis_commentheader_out ( vorbis-comment* vc, ogg-packet* op ) ;
+FUNCTION: int vorbis_analysis_headerout ( vorbis-dsp-state* v,
+ vorbis-comment* vc,
+ ogg-packet* op,
+ ogg-packet* op_comm,
+ ogg-packet* op_code ) ;
+FUNCTION: float** vorbis_analysis_buffer ( vorbis-dsp-state* v, int vals ) ;
+FUNCTION: int vorbis_analysis_wrote ( vorbis-dsp-state* v, int vals ) ;
+FUNCTION: int vorbis_analysis_blockout ( vorbis-dsp-state* v, vorbis-block* vb ) ;
+FUNCTION: int vorbis_analysis ( vorbis-block* vb, ogg-packet* op ) ;
+FUNCTION: int vorbis_bitrate_addblock ( vorbis-block* vb ) ;
+FUNCTION: int vorbis_bitrate_flushpacket ( vorbis-dsp-state* vd,
+ ogg-packet* op ) ;
+FUNCTION: int vorbis_synthesis_headerin ( vorbis-info* vi, vorbis-comment* vc,
+ ogg-packet* op ) ;
+FUNCTION: int vorbis_synthesis_init ( vorbis-dsp-state* v, vorbis-info* vi ) ;
+FUNCTION: int vorbis_synthesis_restart ( vorbis-dsp-state* v ) ;
+FUNCTION: int vorbis_synthesis ( vorbis-block* vb, ogg-packet* op ) ;
+FUNCTION: int vorbis_synthesis_trackonly ( vorbis-block* vb, ogg-packet* op ) ;
+FUNCTION: int vorbis_synthesis_blockin ( vorbis-dsp-state* v, vorbis-block* vb ) ;
+FUNCTION: int vorbis_synthesis_pcmout ( vorbis-dsp-state* v, float*** pcm ) ;
+FUNCTION: int vorbis_synthesis_lapout ( vorbis-dsp-state* v, float*** pcm ) ;
+FUNCTION: int vorbis_synthesis_read ( vorbis-dsp-state* v, int samples ) ;
+FUNCTION: long vorbis_packet_blocksize ( vorbis-info* vi, ogg-packet* op ) ;
+FUNCTION: int vorbis_synthesis_halfrate ( vorbis-info* v, int flag ) ;
+FUNCTION: int vorbis_synthesis_halfrate_p ( vorbis-info* v ) ;
+
+CONSTANT: OV_FALSE -1
+CONSTANT: OV_EOF -2
+CONSTANT: OV_HOLE -3
+CONSTANT: OV_EREAD -128
+CONSTANT: OV_EFAULT -129
+CONSTANT: OV_EIMPL -130
+CONSTANT: OV_EINVAL -131
+CONSTANT: OV_ENOTVORBIS -132
+CONSTANT: OV_EBADHEADER -133
+CONSTANT: OV_EVERSION -134
+CONSTANT: OV_ENOTAUDIO -135
+CONSTANT: OV_EBADPACKET -136
+CONSTANT: OV_EBADLINK -137
+CONSTANT: OV_ENOSEEK -138
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.cxx.parser alien.marshall
+alien.inline.types classes.mixin classes.tuple kernel namespaces
+assocs sequences parser classes.parser alien.marshall.syntax
+interpolate locals effects io strings make vocabs.parser words
+generic fry quotations ;
+IN: alien.cxx
+
+<PRIVATE
+: class-mixin ( str -- word )
+ create-class-in [ define-mixin-class ] keep ;
+
+: class-tuple-word ( word -- word' )
+ "#" append create-in ;
+
+: define-class-tuple ( word mixin -- )
+ [ drop class-wrapper { } define-tuple-class ]
+ [ add-mixin-instance ] 2bi ;
+PRIVATE>
+
+: define-c++-class ( name superclass-mixin -- )
+ [ [ class-tuple-word ] [ class-mixin ] bi dup ] dip
+ add-mixin-instance define-class-tuple ;
+
+:: define-c++-method ( class-name generic name types effect virtual -- )
+ [ name % "_" % class-name { { CHAR: : CHAR: _ } } substitute % ] "" make :> name'
+ effect [ in>> "self" suffix ] [ out>> ] bi <effect> :> effect'
+ types class-name "*" append suffix :> types'
+ effect in>> "," join :> args
+ class-name virtual [ "#" append ] unless current-vocab lookup :> class
+ SBUF" " clone dup [ I[ return self->${name}(${args});]I ] with-output-stream >string :> body
+ name' types' effect' body define-c-marshalled
+ class generic create-method name' current-vocab lookup 1quotation define ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser lexer alien.inline ;
+IN: alien.cxx.parser
+
+: parse-c++-class-definition ( -- class superclass-mixin )
+ scan scan-word ;
+
+: parse-c++-method-definition ( -- class-name generic name types effect )
+ scan scan-word function-types-effect ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test alien.cxx.syntax alien.inline.syntax
+alien.marshall.syntax alien.marshall accessors kernel ;
+IN: alien.cxx.syntax.tests
+
+DELETE-C-LIBRARY: test
+C-LIBRARY: test
+
+COMPILE-AS-C++
+
+C-INCLUDE: <string>
+
+C-TYPEDEF: std::string string
+
+C++-CLASS: std::string c++-root
+
+GENERIC: to-string ( obj -- str )
+
+C++-METHOD: std::string to-string const-char* c_str ( )
+
+CM-FUNCTION: std::string* new_string ( const-char* s )
+ return new std::string(s);
+;
+
+;C-LIBRARY
+
+ALIAS: <std::string> new_string
+
+{ 1 1 } [ new_string ] must-infer-as
+{ 1 1 } [ c_str_std__string ] must-infer-as
+[ t ] [ "abc" <std::string> std::string? ] unit-test
+[ "abc" ] [ "abc" <std::string> to-string ] unit-test
+
+
+DELETE-C-LIBRARY: inheritance
+C-LIBRARY: inheritance
+
+COMPILE-AS-C++
+
+C-INCLUDE: <cstring>
+
+<RAW-C
+class alpha {
+ public:
+ alpha(const char* s) {
+ str = s;
+ };
+ const char* render() {
+ return str;
+ };
+ virtual const char* chop() {
+ return str;
+ };
+ virtual int length() {
+ return strlen(str);
+ };
+ const char* str;
+};
+
+class beta : alpha {
+ public:
+ beta(const char* s) : alpha(s + 1) { };
+ const char* render() {
+ return str + 1;
+ };
+ virtual const char* chop() {
+ return str + 2;
+ };
+};
+RAW-C>
+
+C++-CLASS: alpha c++-root
+C++-CLASS: beta alpha
+
+CM-FUNCTION: alpha* new_alpha ( const-char* s )
+ return new alpha(s);
+;
+
+CM-FUNCTION: beta* new_beta ( const-char* s )
+ return new beta(s);
+;
+
+ALIAS: <alpha> new_alpha
+ALIAS: <beta> new_beta
+
+GENERIC: render ( obj -- obj )
+GENERIC: chop ( obj -- obj )
+GENERIC: length ( obj -- n )
+
+C++-METHOD: alpha render const-char* render ( )
+C++-METHOD: beta render const-char* render ( )
+C++-VIRTUAL: alpha chop const-char* chop ( )
+C++-VIRTUAL: beta chop const-char* chop ( )
+C++-VIRTUAL: alpha length int length ( )
+
+;C-LIBRARY
+
+{ 1 1 } [ render_alpha ] must-infer-as
+{ 1 1 } [ chop_beta ] must-infer-as
+{ 1 1 } [ length_alpha ] must-infer-as
+[ t ] [ "x" <alpha> alpha#? ] unit-test
+[ t ] [ "x" <alpha> alpha? ] unit-test
+[ t ] [ "x" <beta> alpha? ] unit-test
+[ f ] [ "x" <beta> alpha#? ] unit-test
+[ 5 ] [ "hello" <alpha> length ] unit-test
+[ 4 ] [ "hello" <beta> length ] unit-test
+[ "hello" ] [ "hello" <alpha> render ] unit-test
+[ "llo" ] [ "hello" <beta> render ] unit-test
+[ "ello" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying render ] unit-test
+[ "hello" ] [ "hello" <alpha> chop ] unit-test
+[ "lo" ] [ "hello" <beta> chop ] unit-test
+[ "lo" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying chop ] unit-test
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.cxx alien.cxx.parser ;
+IN: alien.cxx.syntax
+
+SYNTAX: C++-CLASS:
+ parse-c++-class-definition define-c++-class ;
+
+SYNTAX: C++-METHOD:
+ parse-c++-method-definition f define-c++-method ;
+
+SYNTAX: C++-VIRTUAL:
+ parse-c++-method-definition t define-c++-method ;
--- /dev/null
+Jeremy Hughes
--- /dev/null
+Jeremy Hughes
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel strings words.symbol sequences ;
+IN: alien.inline.compiler
+
+HELP: C
+{ $var-description "A symbol representing C source." } ;
+
+HELP: C++
+{ $var-description "A symbol representing C++ source." } ;
+
+HELP: compile-to-library
+{ $values
+ { "lang" symbol } { "args" sequence } { "contents" string } { "name" string }
+}
+{ $description "Compiles and links " { $snippet "contents" } " into a shared library called " { $snippet "libname.suffix" }
+ "in " { $snippet "resource:alien-inline-libs" } ". " { $snippet "suffix" } " is OS specific. "
+ { $snippet "args" } " is a sequence of arguments for the linking stage." }
+{ $notes
+ { $list
+ "C and C++ are the only supported languages."
+ { "Source and object files are placed in " { $snippet "resource:temp" } "." } }
+} ;
+
+HELP: compiler
+{ $values
+ { "lang" symbol }
+ { "str" string }
+}
+{ $description "Returns a compiler name based on OS and source language." }
+{ $see-also compiler-descr } ;
+
+HELP: compiler-descr
+{ $values
+ { "lang" symbol }
+ { "descr" "a process description" }
+}
+{ $description "Returns a compiler process description based on OS and source language." }
+{ $see-also compiler } ;
+
+HELP: inline-library-file
+{ $values
+ { "name" string }
+ { "path" "a pathname string" }
+}
+{ $description "Appends " { $snippet "name" } " to the " { $link inline-libs-directory } "." } ;
+
+HELP: inline-libs-directory
+{ $values
+ { "path" "a pathname string" }
+}
+{ $description "The directory where libraries created using " { $snippet "alien.inline" } " are stored." } ;
+
+HELP: library-path
+{ $values
+ { "str" string }
+ { "path" "a pathname string" }
+}
+{ $description "Converts " { $snippet "name" } " into a full path to the corresponding inline library." } ;
+
+HELP: library-suffix
+{ $values
+ { "str" string }
+}
+{ $description "The appropriate shared library suffix for the current OS." } ;
+
+HELP: link-descr
+{ $values
+ { "lang" "a language" }
+ { "descr" sequence }
+}
+{ $description "Returns part of a process description. OS dependent." } ;
+
+ARTICLE: "alien.inline.compiler" "Inline C compiler"
+{ $vocab-link "alien.inline.compiler" }
+;
+
+ABOUT: "alien.inline.compiler"
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators fry generalizations
+io.encodings.ascii io.files io.files.temp io.launcher kernel
+locals make sequences system vocabs.parser words io.directories
+io.pathnames ;
+IN: alien.inline.compiler
+
+SYMBOL: C
+SYMBOL: C++
+
+: inline-libs-directory ( -- path )
+ "alien-inline-libs" resource-path dup make-directories ;
+
+: inline-library-file ( name -- path )
+ inline-libs-directory prepend-path ;
+
+: library-suffix ( -- str )
+ os {
+ { [ dup macosx? ] [ drop ".dylib" ] }
+ { [ dup unix? ] [ drop ".so" ] }
+ { [ dup windows? ] [ drop ".dll" ] }
+ } cond ;
+
+: library-path ( str -- path )
+ '[ "lib" % _ % library-suffix % ] "" make inline-library-file ;
+
+HOOK: compiler os ( lang -- str )
+
+M: word compiler
+ {
+ { C [ "gcc" ] }
+ { C++ [ "g++" ] }
+ } case ;
+
+M: openbsd compiler
+ {
+ { C [ "gcc" ] }
+ { C++ [ "eg++" ] }
+ } case ;
+
+M: windows compiler
+ {
+ { C [ "gcc" ] }
+ { C++ [ "g++" ] }
+ } case ;
+
+HOOK: compiler-descr os ( lang -- descr )
+
+M: word compiler-descr compiler 1array ;
+M: macosx compiler-descr
+ call-next-method cpu x86.64?
+ [ { "-arch" "x86_64" } append ] when ;
+
+HOOK: link-descr os ( lang -- descr )
+
+M: word link-descr drop { "-shared" "-o" } ;
+M: macosx link-descr
+ drop { "-g" "-prebind" "-dynamiclib" "-o" }
+ cpu x86.64? [ { "-arch" "x86_64" } prepend ] when ;
+M: windows link-descr
+ {
+ { C [ { "-mno-cygwin" "-shared" "-o" } ] }
+ { C++ [ { "-lstdc++" "-mno-cygwin" "-shared" "-o" } ] }
+ } case ;
+
+<PRIVATE
+: src-suffix ( lang -- str )
+ {
+ { C [ ".c" ] }
+ { C++ [ ".cpp" ] }
+ } case ;
+
+: link-command ( args in out lang -- descr )
+ [ 2array ] dip [ compiler 1array ] [ link-descr ] bi
+ append prepend prepend ;
+
+:: compile-to-object ( lang contents name -- )
+ name ".o" append temp-file
+ contents name lang src-suffix append temp-file
+ [ ascii set-file-contents ] keep 2array
+ lang compiler-descr { "-fPIC" "-c" "-o" } append prepend
+ try-process ;
+
+:: link-object ( lang args name -- )
+ args name [ library-path ]
+ [ ".o" append temp-file ] bi
+ lang link-command try-process ;
+PRIVATE>
+
+:: compile-to-library ( lang args contents name -- )
+ lang contents name compile-to-object
+ lang args name link-object ;
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel strings effects quotations ;
+IN: alien.inline
+
+<PRIVATE
+: $binding-note ( x -- )
+ drop
+ { "This word requires that certain variables are correctly bound. "
+ "Call " { $link POSTPONE: define-c-library } " to set them up." } print-element ;
+PRIVATE>
+
+HELP: compile-c-library
+{ $description "Writes, compiles, and links code generated since last invocation of " { $link POSTPONE: define-c-library } ". "
+ "Also calls " { $snippet "add-library" } ". "
+ "This word does nothing if the shared library is younger than the factor source file." }
+{ $notes $binding-note } ;
+
+HELP: c-use-framework
+{ $values
+ { "str" string }
+}
+{ $description "OS X only. Adds " { $snippet "-framework name" } " to linker command." }
+{ $notes $binding-note }
+{ $see-also c-link-to c-link-to/use-framework } ;
+
+HELP: define-c-function
+{ $values
+ { "function" "function name" } { "types" "a sequence of C types" } { "effect" effect } { "body" string }
+}
+{ $description "Defines a C function and a factor word which calls it." }
+{ $notes
+ { $list
+ { "The number of " { $snippet "types" } " must match the " { $snippet "in" } " count of the " { $snippet "effect" } "." }
+ { "There must be only one " { $snippet "out" } " element. It must be a legal C return type with dashes (-) instead of spaces." }
+ $binding-note
+ }
+}
+{ $see-also POSTPONE: define-c-function' } ;
+
+HELP: define-c-function'
+{ $values
+ { "function" "function name" } { "effect" effect } { "body" string }
+}
+{ $description "Defines a C function and a factor word which calls it. See " { $link define-c-function } " for more information." }
+{ $notes
+ { $list
+ { "Each effect element must be a legal C type with dashes (-) instead of spaces. "
+ "C argument names will be generated alphabetically, starting with " { $snippet "a" } "." }
+ $binding-note
+ }
+}
+{ $see-also define-c-function } ;
+
+HELP: c-include
+{ $values
+ { "str" string }
+}
+{ $description "Appends an include line to the C library in scope." }
+{ $notes $binding-note } ;
+
+HELP: define-c-library
+{ $values
+ { "name" string }
+}
+{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " words can be used after this one." } ;
+
+HELP: c-link-to
+{ $values
+ { "str" string }
+}
+{ $description "Adds " { $snippet "-lname" } " to linker command." }
+{ $notes $binding-note }
+{ $see-also c-use-framework c-link-to/use-framework } ;
+
+HELP: c-link-to/use-framework
+{ $values
+ { "str" string }
+}
+{ $description "Equivalent to " { $link c-use-framework } " on OS X and " { $link c-link-to } " everywhere else." }
+{ $notes $binding-note }
+{ $see-also c-link-to c-use-framework } ;
+
+HELP: define-c-struct
+{ $values
+ { "name" string } { "fields" "type/name pairs" }
+}
+{ $description "Defines a C struct and factor words which operate on it." }
+{ $notes $binding-note } ;
+
+HELP: define-c-typedef
+{ $values
+ { "old" "C type" } { "new" "C type" }
+}
+{ $description "Define C and factor typedefs." }
+{ $notes $binding-note } ;
+
+HELP: delete-inline-library
+{ $values
+ { "name" string }
+}
+{ $description "Delete the shared library file corresponding to " { $snippet "name" } "." }
+{ $notes "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " } ;
+
+HELP: with-c-library
+{ $values
+ { "name" string } { "quot" quotation }
+}
+{ $description "Calls " { $link define-c-library } ", then the quotation, then " { $link compile-c-library } ", then sets all variables bound by " { $snippet "define-c-library" } " to " { $snippet "f" } "." } ;
+
+HELP: raw-c
+{ $values { "str" string } }
+{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.inline.compiler alien.inline.types
+alien.libraries alien.parser arrays assocs effects fry
+generalizations grouping io.directories io.files
+io.files.info io.files.temp kernel lexer math math.order
+math.ranges multiline namespaces sequences source-files
+splitting strings system vocabs.loader vocabs.parser words
+alien.c-types alien.structs make parser continuations ;
+IN: alien.inline
+
+SYMBOL: c-library
+SYMBOL: library-is-c++
+SYMBOL: linker-args
+SYMBOL: c-strings
+
+<PRIVATE
+: cleanup-variables ( -- )
+ { c-library library-is-c++ linker-args c-strings }
+ [ off ] each ;
+
+: arg-list ( types -- params )
+ CHAR: a swap length CHAR: a + [a,b]
+ [ 1string ] map ;
+
+: compile-library? ( -- ? )
+ c-library get library-path dup exists? [
+ file get [
+ path>>
+ [ file-info modified>> ] bi@ <=> +lt+ =
+ ] [ drop t ] if*
+ ] [ drop t ] if ;
+
+: compile-library ( -- )
+ library-is-c++ get [ C++ ] [ C ] if
+ linker-args get
+ c-strings get "\n" join
+ c-library get compile-to-library ;
+
+: c-library-name ( name -- name' )
+ [ current-vocab name>> % "_" % % ] "" make ;
+PRIVATE>
+
+: parse-arglist ( parameters return -- types effect )
+ [ 2 group unzip [ "," ?tail drop ] map ]
+ [ [ { } ] [ 1array ] if-void ]
+ bi* <effect> ;
+
+: append-function-body ( prototype-str body -- str )
+ [ swap % " {\n" % % "\n}\n" % ] "" make ;
+
+: function-types-effect ( -- function types effect )
+ scan scan swap ")" parse-tokens
+ [ "(" subseq? not ] filter swap parse-arglist ;
+
+: prototype-string ( function types effect -- str )
+ [ [ cify-type ] map ] dip
+ types-effect>params-return cify-type -rot
+ [ " " join ] map ", " join
+ "(" prepend ")" append 3array " " join
+ library-is-c++ get [ "extern \"C\" " prepend ] when ;
+
+: prototype-string' ( function types return -- str )
+ [ dup arg-list ] <effect> prototype-string ;
+
+: factor-function ( function types effect -- word quot effect )
+ annotate-effect [ c-library get ] 3dip
+ [ [ factorize-type ] map ] dip
+ types-effect>params-return factorize-type -roll
+ concat make-function ;
+
+: define-c-library ( name -- )
+ c-library-name [ c-library set ] [ "c-library" set ] bi
+ V{ } clone c-strings set
+ V{ } clone linker-args set ;
+
+: compile-c-library ( -- )
+ compile-library? [ compile-library ] when
+ c-library get dup library-path "cdecl" add-library ;
+
+: define-c-function ( function types effect body -- )
+ [
+ [ factor-function define-declared ]
+ [ prototype-string ] 3bi
+ ] dip append-function-body c-strings get push ;
+
+: define-c-function' ( function effect body -- )
+ [
+ [ in>> ] keep
+ [ factor-function define-declared ]
+ [ out>> prototype-string' ] 3bi
+ ] dip append-function-body c-strings get push ;
+
+: c-link-to ( str -- )
+ "-l" prepend linker-args get push ;
+
+: c-use-framework ( str -- )
+ "-framework" swap linker-args get '[ _ push ] bi@ ;
+
+: c-link-to/use-framework ( str -- )
+ os macosx? [ c-use-framework ] [ c-link-to ] if ;
+
+: c-include ( str -- )
+ "#include " prepend c-strings get push ;
+
+: define-c-typedef ( old new -- )
+ [ typedef ] [
+ [ swap "typedef " % % " " % % ";" % ]
+ "" make c-strings get push
+ ] 2bi ;
+
+: define-c-struct ( name fields -- )
+ [ current-vocab swap define-struct ] [
+ over
+ [
+ "typedef struct " % "_" % % " {\n" %
+ [ first2 swap % " " % % ";\n" % ] each
+ "} " % % ";\n" %
+ ] "" make c-strings get push
+ ] 2bi ;
+
+: delete-inline-library ( name -- )
+ c-library-name [ remove-library ]
+ [ library-path dup exists? [ delete-file ] [ drop ] if ] bi ;
+
+: with-c-library ( name quot -- )
+ [ [ define-c-library ] dip call compile-c-library ]
+ [ cleanup-variables ] [ ] cleanup ; inline
+
+: raw-c ( str -- )
+ [ "\n" % % "\n" % ] "" make c-strings get push ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax alien.inline ;
+IN: alien.inline.syntax
+
+HELP: ;C-LIBRARY
+{ $syntax ";C-LIBRARY" }
+{ $description "Writes, compiles, and links code generated since previous invocation of " { $link POSTPONE: C-LIBRARY: } "." }
+{ $see-also POSTPONE: compile-c-library } ;
+
+HELP: C-FRAMEWORK:
+{ $syntax "C-FRAMEWORK: name" }
+{ $description "OS X only. Link to named framework. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
+{ $see-also POSTPONE: c-use-framework } ;
+
+HELP: C-FUNCTION:
+{ $syntax "C-FUNCTION: return name ( args ... )\nbody\n;" }
+{ $description "Appends a function to the C library in scope and defines an FFI word that calls it." }
+{ $examples
+ { $example
+ "USING: alien.inline.syntax prettyprint ;"
+ "IN: cmath.ffi"
+ ""
+ "C-LIBRARY: cmathlib"
+ ""
+ "C-FUNCTION: int add ( int a, int b )"
+ " return a + b;"
+ ";"
+ ""
+ ";C-LIBRARY"
+ ""
+ "1 2 add ."
+ "3" }
+}
+{ $see-also POSTPONE: define-c-function } ;
+
+HELP: C-INCLUDE:
+{ $syntax "C-INCLUDE: name" }
+{ $description "Appends an include line to the C library in scope." }
+{ $see-also POSTPONE: c-include } ;
+
+HELP: C-LIBRARY:
+{ $syntax "C-LIBRARY: name" }
+{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " syntax can be used after this word." }
+{ $examples
+ { $example
+ "USING: alien.inline.syntax ;"
+ "IN: rectangle.ffi"
+ ""
+ "C-LIBRARY: rectlib"
+ ""
+ "C-STRUCTURE: rectangle { \"int\" \"width\" } { \"int\" \"height\" } ;"
+ ""
+ "C-FUNCTION: int area ( rectangle c )"
+ " return c.width * c.height;"
+ ";"
+ ""
+ ";C-LIBRARY"
+ "" }
+}
+{ $see-also POSTPONE: define-c-library } ;
+
+HELP: C-LINK/FRAMEWORK:
+{ $syntax "C-LINK/FRAMEWORK: name" }
+{ $description "Equivalent to " { $link POSTPONE: C-FRAMEWORK: } " on OS X and " { $link POSTPONE: C-LINK: } " everywhere else." }
+{ $see-also POSTPONE: c-link-to/use-framework } ;
+
+HELP: C-LINK:
+{ $syntax "C-LINK: name" }
+{ $description "Link to named library. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
+{ $see-also POSTPONE: c-link-to } ;
+
+HELP: C-STRUCTURE:
+{ $syntax "C-STRUCTURE: name pairs ... ;" }
+{ $description "Like " { $snippet "C-STRUCT:" } " but also generates equivalent C code."}
+{ $see-also POSTPONE: define-c-struct } ;
+
+HELP: C-TYPEDEF:
+{ $syntax "C-TYPEDEF: old new" }
+{ $description "Like " { $snippet "TYPEDEF:" } " but generates a C typedef statement too." }
+{ $see-also POSTPONE: define-c-typedef } ;
+
+HELP: COMPILE-AS-C++
+{ $syntax "COMPILE-AS-C++" }
+{ $description "Insert this word anywhere between " { $link POSTPONE: C-LIBRARY: } " and " { $link POSTPONE: ;C-LIBRARY } " and the generated code will be treated as C++ with " { $snippet "extern \"C\"" } " prepended to each function prototype." } ;
+
+HELP: DELETE-C-LIBRARY:
+{ $syntax "DELETE-C-LIBRARY: name" }
+{ $description "Deletes the shared library file corresponding to " { $snippet "name" } " . " }
+{ $notes
+ { $list
+ { "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " }
+ "This word is mainly useful for unit tests."
+ }
+}
+{ $see-also POSTPONE: delete-inline-library } ;
+
+HELP: <RAW-C
+{ $syntax "<RAW-C code RAW-C>" }
+{ $description "Insert a (multiline) string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.inline alien.inline.syntax io.directories io.files
+kernel namespaces tools.test alien.c-types alien.data alien.structs ;
+IN: alien.inline.syntax.tests
+
+DELETE-C-LIBRARY: test
+C-LIBRARY: test
+
+C-FUNCTION: const-int add ( int a, int b )
+ return a + b;
+;
+
+C-TYPEDEF: double bigfloat
+
+C-FUNCTION: bigfloat smaller ( bigfloat a )
+ return a / 10;
+;
+
+C-STRUCTURE: rectangle
+ { "int" "width" }
+ { "int" "height" } ;
+
+C-FUNCTION: int area ( rectangle c )
+ return c.width * c.height;
+;
+
+;C-LIBRARY
+
+{ 2 1 } [ add ] must-infer-as
+[ 5 ] [ 2 3 add ] unit-test
+
+[ t ] [ "double" "bigfloat" [ resolve-typedef ] bi@ = ] unit-test
+{ 1 1 } [ smaller ] must-infer-as
+[ 1.0 ] [ 10 smaller ] unit-test
+
+[ t ] [ "rectangle" resolve-typedef struct-type? ] unit-test
+{ 1 1 } [ area ] must-infer-as
+[ 20 ] [
+ "rectangle" <c-object>
+ 4 over set-rectangle-width
+ 5 over set-rectangle-height
+ area
+] unit-test
+
+
+DELETE-C-LIBRARY: cpplib
+C-LIBRARY: cpplib
+
+COMPILE-AS-C++
+
+C-INCLUDE: <string>
+
+C-FUNCTION: const-char* hello ( )
+ std::string s("hello world");
+ return s.c_str();
+;
+
+;C-LIBRARY
+
+{ 0 1 } [ hello ] must-infer-as
+[ "hello world" ] [ hello ] unit-test
+
+
+DELETE-C-LIBRARY: compile-error
+C-LIBRARY: compile-error
+
+C-FUNCTION: char* breakme ( )
+ return not a string;
+;
+
+<< [ compile-c-library ] must-fail >>
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.inline lexer multiline namespaces parser ;
+IN: alien.inline.syntax
+
+
+SYNTAX: C-LIBRARY: scan define-c-library ;
+
+SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
+
+SYNTAX: C-LINK: scan c-link-to ;
+
+SYNTAX: C-FRAMEWORK: scan c-use-framework ;
+
+SYNTAX: C-LINK/FRAMEWORK: scan c-link-to/use-framework ;
+
+SYNTAX: C-INCLUDE: scan c-include ;
+
+SYNTAX: C-FUNCTION:
+ function-types-effect parse-here define-c-function ;
+
+SYNTAX: C-TYPEDEF: scan scan define-c-typedef ;
+
+SYNTAX: C-STRUCTURE:
+ scan parse-definition define-c-struct ;
+
+SYNTAX: ;C-LIBRARY compile-c-library ;
+
+SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ;
+
+SYNTAX: <RAW-C "RAW-C>" parse-multiline-string raw-c ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types assocs combinators.short-circuit
+continuations effects fry kernel math memoize sequences
+splitting strings peg.ebnf make words ;
+IN: alien.inline.types
+
+: cify-type ( str -- str' )
+ dup word? [ name>> ] when
+ { { CHAR: - CHAR: space } } substitute ;
+
+: factorize-type ( str -- str' )
+ cify-type
+ "const " ?head drop
+ "unsigned " ?head [ "u" prepend ] when
+ "long " ?head [ "long" prepend ] when
+ " const" ?tail drop ;
+
+: const-pointer? ( str -- ? )
+ cify-type { [ " const" tail? ] [ "&" tail? ] } 1|| ;
+
+: pointer-to-const? ( str -- ? )
+ cify-type "const " head? ;
+
+: template-class? ( str -- ? )
+ [ CHAR: < = ] any? ;
+
+MEMO: resolved-primitives ( -- seq )
+ primitive-types [ resolve-typedef ] map ;
+
+: primitive-type? ( type -- ? )
+ [
+ factorize-type resolve-typedef [ resolved-primitives ] dip
+ '[ _ = ] any?
+ ] [ 2drop f ] recover ;
+
+: pointer? ( type -- ? )
+ factorize-type [ "*" tail? ] [ "&" tail? ] bi or ;
+
+: type-sans-pointer ( type -- type' )
+ factorize-type [ '[ _ = ] "*&" swap any? ] trim-tail ;
+
+: pointer-to-primitive? ( type -- ? )
+ factorize-type
+ { [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ;
+
+: pointer-to-non-const-primitive? ( str -- ? )
+ {
+ [ pointer-to-const? not ]
+ [ factorize-type pointer-to-primitive? ]
+ } 1&& ;
+
+: types-effect>params-return ( types effect -- params return )
+ [ in>> zip ]
+ [ nip out>> dup length 0 > [ first ] [ drop "void" ] if ]
+ 2bi ;
+
+: annotate-effect ( types effect -- types effect' )
+ [ in>> ] [ out>> ] bi [
+ zip
+ [ over pointer-to-primitive? [ ">" prepend ] when ]
+ assoc-map unzip
+ ] dip <effect> ;
+
+TUPLE: c++-type name params ptr ;
+C: <c++-type> c++-type
+
+EBNF: (parse-c++-type)
+dig = [0-9]
+alpha = [a-zA-Z]
+alphanum = [1-9a-zA-Z]
+name = [_a-zA-Z] [_a-zA-Z1-9:]* => [[ first2 swap prefix >string ]]
+ptr = [*&] => [[ empty? not ]]
+
+param = "," " "* type " "* => [[ third ]]
+
+params = "<" " "* type " "* param* ">" => [[ [ 4 swap nth ] [ third ] bi prefix ]]
+
+type = name " "* params? " "* ptr? => [[ { 0 2 4 } [ swap nth ] with map first3 <c++-type> ]]
+;EBNF
+
+: parse-c++-type ( str -- c++-type )
+ factorize-type (parse-c++-type) ;
+
+DEFER: c++-type>string
+
+: params>string ( params -- str )
+ [ "<" % [ c++-type>string ] map "," join % ">" % ] "" make ;
+
+: c++-type>string ( c++-type -- str )
+ [
+ [ name>> % ]
+ [ params>> [ params>string % ] when* ]
+ [ ptr>> [ "*" % ] when ]
+ tri
+ ] "" make ;
+
+GENERIC: c++-type ( obj -- c++-type/f )
+
+M: object c++-type drop f ;
+
+M: c++-type c-type ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations sequences
+strings alien alien.c-types alien.data math byte-arrays ;
+IN: alien.marshall
+
+<PRIVATE
+: $memory-note ( arg -- )
+ drop "This word returns a pointer to unmanaged memory."
+ print-element ;
+
+: $c-ptr-note ( arg -- )
+ drop "Does nothing if its argument is a non false c-ptr."
+ print-element ;
+
+: $see-article ( arg -- )
+ drop { "See " { $vocab-link "alien.inline" } "." }
+ print-element ;
+PRIVATE>
+
+HELP: ?malloc-byte-array
+{ $values
+ { "c-type" c-type }
+ { "alien" alien }
+}
+{ $description "Does nothing if input is an alien, otherwise assumes it is a byte array and calls "
+ { $snippet "malloc-byte-array" } "."
+}
+{ $notes $memory-note } ;
+
+HELP: alien-wrapper
+{ $var-description "For wrapping C pointers in a structure factor can dispatch on." } ;
+
+HELP: unmarshall-cast
+{ $values
+ { "alien-wrapper" alien-wrapper }
+ { "alien-wrapper'" alien-wrapper }
+}
+{ $description "Called immediately after unmarshalling. Useful for automatically casting to subtypes." } ;
+
+HELP: marshall-bool
+{ $values
+ { "?" "a generalized boolean" }
+ { "n" "0 or 1" }
+}
+{ $description "Marshalls objects to bool." }
+{ $notes "Will treat " { $snippet "0" } " as " { $snippet "t" } "." } ;
+
+HELP: marshall-bool*
+{ $values
+ { "?/seq" "t/f or sequence" }
+ { "alien" alien }
+}
+{ $description "When the argument is a sequence, returns a pointer to an array of bool, "
+ "otherwise returns a pointer to a single bool value."
+}
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-bool**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description "Takes a one or two dimensional array of generalized booleans "
+ "and returns a pointer to the equivalent C structure."
+}
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-primitive
+{ $values
+ { "n" number }
+ { "n" number }
+}
+{ $description "Marshall numbers to C primitives."
+ $nl
+ "Factor marshalls numbers to primitives for FFI calls, so all "
+ "this word does is convert " { $snippet "t" } " to " { $snippet "1" }
+ ", " { $snippet "f" } " to " { $snippet "0" } ", and lets anything else "
+ "pass through untouched."
+} ;
+
+HELP: marshall-char*
+{ $values
+ { "n/seq" "number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-char**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-char**-or-strings
+{ $values
+ { "seq" "a sequence of strings" }
+ { "alien" alien }
+}
+{ $description "Marshalls an array of strings or characters to an array of C strings." }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-char*-or-string
+{ $values
+ { "n/string" "a number or string" }
+ { "alien" alien }
+}
+{ $description "Marshalls a string to a C string or a number to a pointer to " { $snippet "char" } "." }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-double*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-double**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-float*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-float**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-int*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-int**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-long*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-long**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-longlong*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-longlong**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-non-pointer
+{ $values
+ { "alien-wrapper/byte-array" "an alien-wrapper or byte-array" }
+ { "byte-array" byte-array }
+}
+{ $description "Converts argument to a byte array." }
+{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
+
+HELP: marshall-pointer
+{ $values
+ { "obj" object }
+ { "alien" alien }
+}
+{ $description "Converts argument to a C pointer." }
+{ $notes "Can marshall the following types: " { $snippet "alien, f, byte-array, alien-wrapper, struct-array" } "." } ;
+
+HELP: marshall-short*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-short**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-uchar*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-uchar**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-uint*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-uint**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ulong*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ulong**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ulonglong*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ulonglong**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ushort*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ushort**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-void**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description "Marshalls a sequence of objects to an array of pointers to void." }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot" quotation }
+}
+{ $description "Given a C type, returns a quotation that will marshall its argument to that type." } ;
+
+HELP: out-arg-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot" quotation }
+}
+{ $description "Like " { $link unmarshaller } " but returns an empty quotation "
+ "for all types except pointers to non-const primitives."
+} ;
+
+HELP: class-unmarshaller
+{ $values
+ { "type" " a C type string" }
+ { "quot/f" quotation }
+}
+{ $description "If in the vocab in which this word is called, there is a subclass of " { $link alien-wrapper }
+ " named after the type argument, " { $snippet "pointer-unmarshaller" } " will return a quotation which "
+ "wraps its argument in an instance of that subclass. In any other case it returns an empty quotation."
+}
+{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
+
+HELP: primitive-marshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot/f" "a quotation or f" }
+}
+{ $description "Returns a quotation to marshall objects to the argument type." }
+{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
+
+HELP: primitive-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot/f" "a quotation or f" }
+}
+{ $description "Returns a quotation to unmarshall objects from the argument type." }
+{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
+
+HELP: struct-field-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot" quotation }
+}
+{ $description "Like " { $link unmarshaller } " but returns a quotation that "
+ "does not call " { $snippet "free" } " on its argument."
+}
+{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
+
+HELP: struct-primitive-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot/f" "a quotation or f" }
+}
+{ $description "Like " { $link primitive-unmarshaller } " but returns a quotation that "
+ "does not call " { $snippet "free" } " on its argument." }
+{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
+
+HELP: struct-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot/f" quotation }
+}
+{ $description "Returns a quotation which wraps its argument in the subclass of "
+ { $link struct-wrapper } " which matches the " { $snippet "type" } " arg."
+}
+{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
+
+HELP: struct-wrapper
+{ $var-description "For wrapping C structs in a structure factor can dispatch on." } ;
+
+HELP: unmarshall-bool
+{ $values
+ { "n" number }
+ { "?" "a boolean" }
+}
+{ $description "Unmarshalls a number to a boolean." } ;
+
+HELP: unmarshall-bool*
+{ $values
+ { "alien" alien }
+ { "?" "a boolean" }
+}
+{ $description "Unmarshalls a C pointer to a boolean." } ;
+
+HELP: unmarshall-bool*-free
+{ $values
+ { "alien" alien }
+ { "?" "a boolean" }
+}
+{ $description "Unmarshalls a C pointer to a boolean and frees the pointer." } ;
+
+HELP: unmarshall-char*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-char*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-char*-to-string
+{ $values
+ { "alien" alien }
+ { "string" string }
+}
+{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string." } ;
+
+HELP: unmarshall-char*-to-string-free
+{ $values
+ { "alien" alien }
+ { "string" string }
+}
+{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string and frees the pointer." } ;
+
+HELP: unmarshall-double*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-double*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-float*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-float*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-int*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-int*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-long*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-long*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-longlong*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-longlong*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-short*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-short*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-uchar*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-uchar*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-uint*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-uint*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ulong*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ulong*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ulonglong*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ulonglong*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ushort*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ushort*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot" quotation }
+}
+{ $description "Given a C type, returns a quotation that will unmarshall values of that type." } ;
+
+ARTICLE: "alien.marshall" "C marshalling"
+{ $vocab-link "alien.marshall" } " provides alien wrappers and marshalling words for the "
+"automatic marshalling and unmarshalling of C function arguments, return values, and output parameters."
+
+{ $subheading "Important words" }
+"Wrap an alien:" { $subsection alien-wrapper }
+"Wrap a struct:" { $subsection struct-wrapper }
+"Get the marshaller for a C type:" { $subsection marshaller }
+"Get the unmarshaller for a C type:" { $subsection unmarshaller }
+"Get the unmarshaller for an output parameter:" { $subsection out-arg-unmarshaller }
+"Get the unmarshaller for a struct field:" { $subsection struct-field-unmarshaller }
+$nl
+"Other marshalling and unmarshalling words in this vocabulary are not intended to be "
+"invoked directly."
+$nl
+"Most marshalling words allow non false c-ptrs to pass through unchanged."
+
+{ $subheading "Primitive marshallers" }
+{ $subsection marshall-primitive } "for marshalling primitive values."
+{ $subsection marshall-int* }
+ "marshalls a number or sequence of numbers. If argument is a sequence, returns a pointer "
+ "to a C array, otherwise returns a pointer to a single value."
+{ $subsection marshall-int** }
+"marshalls a 1D or 2D array of numbers. Returns an array of pointers to arrays."
+
+{ $subheading "Primitive unmarshallers" }
+{ $snippet "unmarshall-<prim>*" } " and " { $snippet "unmarshall-<prim>*-free" }
+" for all values of " { $snippet "<prim>" } " in " { $link primitive-types } "."
+{ $subsection unmarshall-int* }
+"unmarshalls a pointer to primitive. Returns a number. "
+"Assumes the pointer is not an array (if it is, only the first value is returned). "
+"C functions that return arrays are not handled correctly by " { $snippet "alien.marshall" }
+" and must be unmarshalled by hand."
+{ $subsection unmarshall-int*-free }
+"unmarshalls a pointer to primitive, and then frees the pointer."
+$nl
+"Primitive values require no unmarshalling. The factor FFI already does this."
+;
+
+ABOUT: "alien.marshall"
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types alien.inline.types
+alien.marshall.private alien.strings byte-arrays classes
+combinators combinators.short-circuit destructors fry
+io.encodings.utf8 kernel libc sequences alien.data
+specialized-arrays strings unix.utilities vocabs.parser
+words libc.private locals generalizations math ;
+FROM: alien.c-types => float short ;
+SPECIALIZED-ARRAY: bool
+SPECIALIZED-ARRAY: char
+SPECIALIZED-ARRAY: double
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: long
+SPECIALIZED-ARRAY: longlong
+SPECIALIZED-ARRAY: short
+SPECIALIZED-ARRAY: uchar
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: ulong
+SPECIALIZED-ARRAY: ulonglong
+SPECIALIZED-ARRAY: ushort
+SPECIALIZED-ARRAY: void*
+IN: alien.marshall
+
+<< primitive-types [ [ void* = ] [ bool = ] bi or not ]
+filter [ define-primitive-marshallers ] each >>
+
+TUPLE: alien-wrapper { underlying alien } ;
+TUPLE: struct-wrapper < alien-wrapper disposed ;
+TUPLE: class-wrapper < alien-wrapper disposed ;
+
+MIXIN: c++-root
+
+GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
+
+M: alien-wrapper unmarshall-cast ;
+M: struct-wrapper unmarshall-cast ;
+
+M: struct-wrapper dispose* underlying>> free ;
+
+M: class-wrapper c++-type class name>> parse-c++-type ;
+
+: marshall-pointer ( obj -- alien )
+ {
+ { [ dup alien? ] [ ] }
+ { [ dup not ] [ ] }
+ { [ dup byte-array? ] [ malloc-byte-array ] }
+ { [ dup alien-wrapper? ] [ underlying>> ] }
+ } cond ;
+
+: marshall-primitive ( n -- n )
+ [ bool>arg ] ptr-pass-through ;
+
+ALIAS: marshall-void* marshall-pointer
+
+: marshall-void** ( seq -- alien )
+ [ marshall-void* ] void*-array{ } map-as malloc-underlying ;
+
+: (marshall-char*-or-string) ( n/string -- alien )
+ dup string?
+ [ utf8 string>alien malloc-byte-array ]
+ [ (marshall-char*) ] if ;
+
+: marshall-char*-or-string ( n/string -- alien )
+ [ (marshall-char*-or-string) ] ptr-pass-through ;
+
+: (marshall-char**-or-strings) ( seq -- alien )
+ [ marshall-char*-or-string ] void*-array{ } map-as
+ malloc-underlying ;
+
+: marshall-char**-or-strings ( seq -- alien )
+ [ (marshall-char**-or-strings) ] ptr-pass-through ;
+
+: marshall-bool ( ? -- n )
+ >boolean [ 1 ] [ 0 ] if ;
+
+: (marshall-bool*) ( ?/seq -- alien )
+ [ marshall-bool <bool> malloc-byte-array ]
+ [ >bool-array malloc-underlying ]
+ marshall-x* ;
+
+: marshall-bool* ( ?/seq -- alien )
+ [ (marshall-bool*) ] ptr-pass-through ;
+
+: (marshall-bool**) ( seq -- alien )
+ [ marshall-bool* ] map >void*-array malloc-underlying ;
+
+: marshall-bool** ( seq -- alien )
+ [ (marshall-bool**) ] ptr-pass-through ;
+
+: unmarshall-bool ( n -- ? )
+ 0 = not ;
+
+: unmarshall-bool* ( alien -- ? )
+ *bool unmarshall-bool ;
+
+: unmarshall-bool*-free ( alien -- ? )
+ [ *bool unmarshall-bool ] keep add-malloc free ;
+
+: primitive-marshaller ( type -- quot/f )
+ {
+ { "bool" [ [ ] ] }
+ { "boolean" [ [ marshall-bool ] ] }
+ { "char" [ [ marshall-primitive ] ] }
+ { "uchar" [ [ marshall-primitive ] ] }
+ { "short" [ [ marshall-primitive ] ] }
+ { "ushort" [ [ marshall-primitive ] ] }
+ { "int" [ [ marshall-primitive ] ] }
+ { "uint" [ [ marshall-primitive ] ] }
+ { "long" [ [ marshall-primitive ] ] }
+ { "ulong" [ [ marshall-primitive ] ] }
+ { "long" [ [ marshall-primitive ] ] }
+ { "ulong" [ [ marshall-primitive ] ] }
+ { "float" [ [ marshall-primitive ] ] }
+ { "double" [ [ marshall-primitive ] ] }
+ { "bool*" [ [ marshall-bool* ] ] }
+ { "boolean*" [ [ marshall-bool* ] ] }
+ { "char*" [ [ marshall-char*-or-string ] ] }
+ { "uchar*" [ [ marshall-uchar* ] ] }
+ { "short*" [ [ marshall-short* ] ] }
+ { "ushort*" [ [ marshall-ushort* ] ] }
+ { "int*" [ [ marshall-int* ] ] }
+ { "uint*" [ [ marshall-uint* ] ] }
+ { "long*" [ [ marshall-long* ] ] }
+ { "ulong*" [ [ marshall-ulong* ] ] }
+ { "longlong*" [ [ marshall-longlong* ] ] }
+ { "ulonglong*" [ [ marshall-ulonglong* ] ] }
+ { "float*" [ [ marshall-float* ] ] }
+ { "double*" [ [ marshall-double* ] ] }
+ { "bool&" [ [ marshall-bool* ] ] }
+ { "boolean&" [ [ marshall-bool* ] ] }
+ { "char&" [ [ marshall-char* ] ] }
+ { "uchar&" [ [ marshall-uchar* ] ] }
+ { "short&" [ [ marshall-short* ] ] }
+ { "ushort&" [ [ marshall-ushort* ] ] }
+ { "int&" [ [ marshall-int* ] ] }
+ { "uint&" [ [ marshall-uint* ] ] }
+ { "long&" [ [ marshall-long* ] ] }
+ { "ulong&" [ [ marshall-ulong* ] ] }
+ { "longlong&" [ [ marshall-longlong* ] ] }
+ { "ulonglong&" [ [ marshall-ulonglong* ] ] }
+ { "float&" [ [ marshall-float* ] ] }
+ { "double&" [ [ marshall-double* ] ] }
+ { "void*" [ [ marshall-void* ] ] }
+ { "bool**" [ [ marshall-bool** ] ] }
+ { "boolean**" [ [ marshall-bool** ] ] }
+ { "char**" [ [ marshall-char**-or-strings ] ] }
+ { "uchar**" [ [ marshall-uchar** ] ] }
+ { "short**" [ [ marshall-short** ] ] }
+ { "ushort**" [ [ marshall-ushort** ] ] }
+ { "int**" [ [ marshall-int** ] ] }
+ { "uint**" [ [ marshall-uint** ] ] }
+ { "long**" [ [ marshall-long** ] ] }
+ { "ulong**" [ [ marshall-ulong** ] ] }
+ { "longlong**" [ [ marshall-longlong** ] ] }
+ { "ulonglong**" [ [ marshall-ulonglong** ] ] }
+ { "float**" [ [ marshall-float** ] ] }
+ { "double**" [ [ marshall-double** ] ] }
+ { "void**" [ [ marshall-void** ] ] }
+ [ drop f ]
+ } case ;
+
+: marshall-non-pointer ( alien-wrapper/byte-array -- byte-array )
+ {
+ { [ dup byte-array? ] [ ] }
+ { [ dup alien-wrapper? ]
+ [ [ underlying>> ] [ class name>> heap-size ] bi
+ memory>byte-array ] }
+ } cond ;
+
+
+: marshaller ( type -- quot )
+ factorize-type dup primitive-marshaller [ nip ] [
+ pointer?
+ [ [ marshall-pointer ] ]
+ [ [ marshall-non-pointer ] ] if
+ ] if* ;
+
+
+: unmarshall-char*-to-string ( alien -- string )
+ utf8 alien>string ;
+
+: unmarshall-char*-to-string-free ( alien -- string )
+ [ unmarshall-char*-to-string ] keep add-malloc free ;
+
+: primitive-unmarshaller ( type -- quot/f )
+ {
+ { "bool" [ [ ] ] }
+ { "boolean" [ [ unmarshall-bool ] ] }
+ { "char" [ [ ] ] }
+ { "uchar" [ [ ] ] }
+ { "short" [ [ ] ] }
+ { "ushort" [ [ ] ] }
+ { "int" [ [ ] ] }
+ { "uint" [ [ ] ] }
+ { "long" [ [ ] ] }
+ { "ulong" [ [ ] ] }
+ { "longlong" [ [ ] ] }
+ { "ulonglong" [ [ ] ] }
+ { "float" [ [ ] ] }
+ { "double" [ [ ] ] }
+ { "bool*" [ [ unmarshall-bool*-free ] ] }
+ { "boolean*" [ [ unmarshall-bool*-free ] ] }
+ { "char*" [ [ ] ] }
+ { "uchar*" [ [ unmarshall-uchar*-free ] ] }
+ { "short*" [ [ unmarshall-short*-free ] ] }
+ { "ushort*" [ [ unmarshall-ushort*-free ] ] }
+ { "int*" [ [ unmarshall-int*-free ] ] }
+ { "uint*" [ [ unmarshall-uint*-free ] ] }
+ { "long*" [ [ unmarshall-long*-free ] ] }
+ { "ulong*" [ [ unmarshall-ulong*-free ] ] }
+ { "longlong*" [ [ unmarshall-long*-free ] ] }
+ { "ulonglong*" [ [ unmarshall-ulong*-free ] ] }
+ { "float*" [ [ unmarshall-float*-free ] ] }
+ { "double*" [ [ unmarshall-double*-free ] ] }
+ { "bool&" [ [ unmarshall-bool*-free ] ] }
+ { "boolean&" [ [ unmarshall-bool*-free ] ] }
+ { "char&" [ [ ] ] }
+ { "uchar&" [ [ unmarshall-uchar*-free ] ] }
+ { "short&" [ [ unmarshall-short*-free ] ] }
+ { "ushort&" [ [ unmarshall-ushort*-free ] ] }
+ { "int&" [ [ unmarshall-int*-free ] ] }
+ { "uint&" [ [ unmarshall-uint*-free ] ] }
+ { "long&" [ [ unmarshall-long*-free ] ] }
+ { "ulong&" [ [ unmarshall-ulong*-free ] ] }
+ { "longlong&" [ [ unmarshall-longlong*-free ] ] }
+ { "ulonglong&" [ [ unmarshall-ulonglong*-free ] ] }
+ { "float&" [ [ unmarshall-float*-free ] ] }
+ { "double&" [ [ unmarshall-double*-free ] ] }
+ [ drop f ]
+ } case ;
+
+: struct-primitive-unmarshaller ( type -- quot/f )
+ {
+ { "bool" [ [ unmarshall-bool ] ] }
+ { "boolean" [ [ unmarshall-bool ] ] }
+ { "char" [ [ ] ] }
+ { "uchar" [ [ ] ] }
+ { "short" [ [ ] ] }
+ { "ushort" [ [ ] ] }
+ { "int" [ [ ] ] }
+ { "uint" [ [ ] ] }
+ { "long" [ [ ] ] }
+ { "ulong" [ [ ] ] }
+ { "longlong" [ [ ] ] }
+ { "ulonglong" [ [ ] ] }
+ { "float" [ [ ] ] }
+ { "double" [ [ ] ] }
+ { "bool*" [ [ unmarshall-bool* ] ] }
+ { "boolean*" [ [ unmarshall-bool* ] ] }
+ { "char*" [ [ ] ] }
+ { "uchar*" [ [ unmarshall-uchar* ] ] }
+ { "short*" [ [ unmarshall-short* ] ] }
+ { "ushort*" [ [ unmarshall-ushort* ] ] }
+ { "int*" [ [ unmarshall-int* ] ] }
+ { "uint*" [ [ unmarshall-uint* ] ] }
+ { "long*" [ [ unmarshall-long* ] ] }
+ { "ulong*" [ [ unmarshall-ulong* ] ] }
+ { "longlong*" [ [ unmarshall-long* ] ] }
+ { "ulonglong*" [ [ unmarshall-ulong* ] ] }
+ { "float*" [ [ unmarshall-float* ] ] }
+ { "double*" [ [ unmarshall-double* ] ] }
+ { "bool&" [ [ unmarshall-bool* ] ] }
+ { "boolean&" [ [ unmarshall-bool* ] ] }
+ { "char&" [ [ unmarshall-char* ] ] }
+ { "uchar&" [ [ unmarshall-uchar* ] ] }
+ { "short&" [ [ unmarshall-short* ] ] }
+ { "ushort&" [ [ unmarshall-ushort* ] ] }
+ { "int&" [ [ unmarshall-int* ] ] }
+ { "uint&" [ [ unmarshall-uint* ] ] }
+ { "long&" [ [ unmarshall-long* ] ] }
+ { "ulong&" [ [ unmarshall-ulong* ] ] }
+ { "longlong&" [ [ unmarshall-longlong* ] ] }
+ { "ulonglong&" [ [ unmarshall-ulonglong* ] ] }
+ { "float&" [ [ unmarshall-float* ] ] }
+ { "double&" [ [ unmarshall-double* ] ] }
+ [ drop f ]
+ } case ;
+
+
+: ?malloc-byte-array ( c-type -- alien )
+ dup alien? [ malloc-byte-array ] unless ;
+
+:: x-unmarshaller ( type type-quot superclass def clean -- quot/f )
+ type type-quot call current-vocab lookup [
+ dup superclasses superclass swap member?
+ [ def call ] [ drop clean call f ] if
+ ] [ clean call f ] if* ; inline
+
+: struct-unmarshaller ( type -- quot/f )
+ [ ] \ struct-wrapper
+ [ '[ ?malloc-byte-array _ new swap >>underlying ] ]
+ [ ]
+ x-unmarshaller ;
+
+: class-unmarshaller ( type -- quot/f )
+ [ type-sans-pointer "#" append ] \ class-wrapper
+ [ '[ _ new swap >>underlying ] ]
+ [ ]
+ x-unmarshaller ;
+
+: non-primitive-unmarshaller ( type -- quot/f )
+ {
+ { [ dup pointer? ] [ class-unmarshaller ] }
+ [ struct-unmarshaller ]
+ } cond ;
+
+: unmarshaller ( type -- quot )
+ factorize-type {
+ [ primitive-unmarshaller ]
+ [ non-primitive-unmarshaller ]
+ [ drop [ ] ]
+ } 1|| ;
+
+: struct-field-unmarshaller ( type -- quot )
+ factorize-type {
+ [ struct-primitive-unmarshaller ]
+ [ non-primitive-unmarshaller ]
+ [ drop [ ] ]
+ } 1|| ;
+
+: out-arg-unmarshaller ( type -- quot )
+ dup pointer-to-non-const-primitive?
+ [ factorize-type primitive-unmarshaller ]
+ [ drop [ drop ] ] if ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types alien.inline arrays
+combinators fry functors kernel lexer libc macros math
+sequences specialized-arrays libc.private
+combinators.short-circuit alien.data ;
+SPECIALIZED-ARRAY: void*
+IN: alien.marshall.private
+
+: bool>arg ( ? -- 1/0/obj )
+ {
+ { t [ 1 ] }
+ { f [ 0 ] }
+ [ ]
+ } case ;
+
+MACRO: marshall-x* ( num-quot seq-quot -- alien )
+ '[ bool>arg dup number? _ _ if ] ;
+
+: ptr-pass-through ( obj quot -- alien )
+ over { [ c-ptr? ] [ ] } 1&& [ drop ] [ call ] if ; inline
+
+: malloc-underlying ( obj -- alien )
+ underlying>> malloc-byte-array ;
+
+FUNCTOR: define-primitive-marshallers ( TYPE -- )
+<TYPE> IS <${TYPE}>
+*TYPE IS *${TYPE}
+>TYPE-array IS >${TYPE}-array
+marshall-TYPE DEFINES marshall-${TYPE}
+(marshall-TYPE*) DEFINES (marshall-${TYPE}*)
+(marshall-TYPE**) DEFINES (marshall-${TYPE}**)
+marshall-TYPE* DEFINES marshall-${TYPE}*
+marshall-TYPE** DEFINES marshall-${TYPE}**
+marshall-TYPE*-free DEFINES marshall-${TYPE}*-free
+marshall-TYPE**-free DEFINES marshall-${TYPE}**-free
+unmarshall-TYPE* DEFINES unmarshall-${TYPE}*
+unmarshall-TYPE*-free DEFINES unmarshall-${TYPE}*-free
+WHERE
+<PRIVATE
+: (marshall-TYPE*) ( n/seq -- alien )
+ [ <TYPE> malloc-byte-array ]
+ [ >TYPE-array malloc-underlying ]
+ marshall-x* ;
+PRIVATE>
+: marshall-TYPE* ( n/seq -- alien )
+ [ (marshall-TYPE*) ] ptr-pass-through ;
+<PRIVATE
+: (marshall-TYPE**) ( seq -- alien )
+ [ marshall-TYPE* ] void*-array{ } map-as malloc-underlying ;
+PRIVATE>
+: marshall-TYPE** ( seq -- alien )
+ [ (marshall-TYPE**) ] ptr-pass-through ;
+: unmarshall-TYPE* ( alien -- n )
+ *TYPE ; inline
+: unmarshall-TYPE*-free ( alien -- n )
+ [ unmarshall-TYPE* ] keep add-malloc free ;
+;FUNCTOR
+
+SYNTAX: PRIMITIVE-MARSHALLERS:
+";" parse-tokens [ define-primitive-marshallers ] each ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes help.markup help.syntax kernel quotations words
+alien.marshall.structs strings alien.structs alien.marshall ;
+IN: alien.marshall.structs
+
+HELP: define-marshalled-struct
+{ $values
+ { "name" string } { "vocab" "a vocabulary specifier" } { "fields" "an alist" }
+}
+{ $description "Calls " { $link define-struct } " and " { $link define-struct-tuple } "." } ;
+
+HELP: define-struct-tuple
+{ $values
+ { "name" string }
+}
+{ $description "Defines a subclass of " { $link struct-wrapper } ", a constructor, "
+ "and accessor words."
+} ;
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.marshall arrays assocs
+classes.tuple combinators destructors generalizations generic
+kernel libc locals parser quotations sequences slots words
+alien.structs lexer vocabs.parser fry effects alien.data ;
+IN: alien.marshall.structs
+
+<PRIVATE
+: define-struct-accessor ( class name quot -- )
+ [ "accessors" create create-method dup make-inline ] dip define ;
+
+: define-struct-getter ( class name word type -- )
+ [ ">>" append \ underlying>> ] 2dip
+ struct-field-unmarshaller \ call 4array >quotation
+ define-struct-accessor ;
+
+: define-struct-setter ( class name word type -- )
+ [ "(>>" prepend ")" append ] 2dip
+ marshaller [ underlying>> ] \ bi* roll 4array >quotation
+ define-struct-accessor ;
+
+: define-struct-accessors ( class name type reader writer -- )
+ [ dup define-protocol-slot ] 3dip
+ [ drop swap define-struct-getter ]
+ [ nip swap define-struct-setter ] 5 nbi ;
+
+: define-struct-constructor ( class -- )
+ {
+ [ name>> "<" prepend ">" append create-in ]
+ [ '[ _ new ] ]
+ [ name>> '[ _ malloc-object >>underlying ] append ]
+ [ name>> 1array ]
+ } cleave { } swap <effect> define-declared ;
+PRIVATE>
+
+:: define-struct-tuple ( name -- )
+ name create-in :> class
+ class struct-wrapper { } define-tuple-class
+ class define-struct-constructor
+ name c-type fields>> [
+ class swap
+ {
+ [ name>> { { CHAR: space CHAR: - } } substitute ]
+ [ type>> ] [ reader>> ] [ writer>> ]
+ } cleave define-struct-accessors
+ ] each ;
+
+: define-marshalled-struct ( name vocab fields -- )
+ [ define-struct ] [ 2drop define-struct-tuple ] 3bi ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations words
+alien.inline alien.syntax effects alien.marshall
+alien.marshall.structs strings sequences alien.inline.syntax ;
+IN: alien.marshall.syntax
+
+HELP: CM-FUNCTION:
+{ $syntax "CM-FUNCTION: return name args\n body\n;" }
+{ $description "Like " { $link POSTPONE: C-FUNCTION: } " but with marshalling "
+ "of arguments and return values."
+}
+{ $examples
+ { $example
+ "USING: alien.inline.syntax alien.marshall.syntax prettyprint ;"
+ "IN: example"
+ ""
+ "C-LIBRARY: exlib"
+ ""
+ "C-INCLUDE: <stdio.h>"
+ "C-INCLUDE: <stdlib.h>"
+ "CM-FUNCTION: char* sum_diff ( const-int a, const-int b, int* x, int* y )"
+ " *x = a + b;"
+ " *y = a - b;"
+ " char* s = (char*) malloc(sizeof(char) * 64);"
+ " sprintf(s, \"sum %i, diff %i\", *x, *y);"
+ " return s;"
+ ";"
+ ""
+ ";C-LIBRARY"
+ ""
+ "8 5 0 0 sum_diff . . ."
+ "3\n13\n\"sum 13, diff 3\""
+ }
+}
+{ $see-also define-c-marshalled POSTPONE: C-FUNCTION: POSTPONE: M-FUNCTION: } ;
+
+HELP: CM-STRUCTURE:
+{ $syntax "CM-STRUCTURE: name fields ... ;" }
+{ $description "Like " { $link POSTPONE: C-STRUCTURE: } " but with marshalling of fields. "
+ "Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words."
+}
+{ $see-also POSTPONE: C-STRUCTURE: POSTPONE: M-STRUCTURE: } ;
+
+HELP: M-FUNCTION:
+{ $syntax "M-FUNCTION: return name args ;" }
+{ $description "Like " { $link POSTPONE: FUNCTION: } " but with marshalling "
+ "of arguments and return values."
+}
+{ $see-also marshalled-function POSTPONE: C-FUNCTION: POSTPONE: CM-FUNCTION: } ;
+
+HELP: M-STRUCTURE:
+{ $syntax "M-STRUCTURE: name fields ... ;" }
+{ $description "Like " { $link POSTPONE: C-STRUCT: } " but with marshalling of fields. "
+ "Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words."
+}
+{ $see-also define-marshalled-struct POSTPONE: C-STRUCTURE: POSTPONE: CM-STRUCTURE: } ;
+
+HELP: define-c-marshalled
+{ $values
+ { "name" string } { "types" sequence } { "effect" effect } { "body" string }
+}
+{ $description "Defines a C function and a factor word which calls it with marshalling of "
+ "args and return values."
+}
+{ $see-also define-c-marshalled' } ;
+
+HELP: define-c-marshalled'
+{ $values
+ { "name" string } { "effect" effect } { "body" string }
+}
+{ $description "Like " { $link define-c-marshalled } ". "
+ "The effect elements must be C type strings."
+} ;
+
+HELP: marshalled-function
+{ $values
+ { "name" string } { "types" sequence } { "effect" effect }
+ { "word" word } { "quot" quotation } { "effect" effect }
+}
+{ $description "Defines a word which calls the named C function. Arguments, "
+ "return value, and output parameters are marshalled and unmarshalled."
+} ;
+
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.inline.syntax alien.marshall.syntax destructors
+tools.test accessors kernel ;
+IN: alien.marshall.syntax.tests
+
+DELETE-C-LIBRARY: test
+C-LIBRARY: test
+
+C-INCLUDE: <stdlib.h>
+C-INCLUDE: <string.h>
+C-INCLUDE: <stdbool.h>
+
+CM-FUNCTION: void outarg1 ( int* a )
+ *a += 2;
+;
+
+CM-FUNCTION: unsigned-long* outarg2 ( unsigned-long a, unsigned-long* b )
+ unsigned long* x = malloc(sizeof(unsigned long*));
+ *b = 10 + *b;
+ *x = a + *b;
+ return x;
+;
+
+CM-STRUCTURE: wedge
+ { "double" "degrees" } ;
+
+CM-STRUCTURE: sundial
+ { "double" "radius" }
+ { "wedge" "wedge" } ;
+
+CM-FUNCTION: double hours ( sundial* d )
+ return d->wedge.degrees / 30;
+;
+
+CM-FUNCTION: void change_time ( double hours, sundial* d )
+ d->wedge.degrees = hours * 30;
+;
+
+CM-FUNCTION: bool c_not ( bool p )
+ return !p;
+;
+
+CM-FUNCTION: char* upcase ( const-char* s )
+ int len = strlen(s);
+ char* t = malloc(sizeof(char) * len);
+ int i;
+ for (i = 0; i < len; i++)
+ t[i] = toupper(s[i]);
+ t[i] = '\0';
+ return t;
+;
+
+;C-LIBRARY
+
+{ 1 1 } [ outarg1 ] must-infer-as
+[ 3 ] [ 1 outarg1 ] unit-test
+[ 3 ] [ t outarg1 ] unit-test
+[ 2 ] [ f outarg1 ] unit-test
+
+{ 2 2 } [ outarg2 ] must-infer-as
+[ 18 15 ] [ 3 5 outarg2 ] unit-test
+
+{ 1 1 } [ hours ] must-infer-as
+[ 5.0 ] [ <sundial> <wedge> 150 >>degrees >>wedge hours ] unit-test
+
+{ 2 0 } [ change_time ] must-infer-as
+[ 150.0 ] [ 5 <sundial> <wedge> 11 >>degrees >>wedge [ change_time ] keep wedge>> degrees>> ] unit-test
+
+{ 1 1 } [ c_not ] must-infer-as
+[ f ] [ "x" c_not ] unit-test
+[ f ] [ 0 c_not ] unit-test
+
+{ 1 1 } [ upcase ] must-infer-as
+[ "ABC" ] [ "abc" upcase ] unit-test
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.inline alien.inline.types alien.marshall
+combinators effects generalizations kernel locals make namespaces
+quotations sequences words alien.marshall.structs lexer parser
+vocabs.parser multiline ;
+IN: alien.marshall.syntax
+
+:: marshalled-function ( name types effect -- word quot effect )
+ name types effect factor-function
+ [ in>> ]
+ [ out>> types [ pointer-to-non-const-primitive? ] filter append ]
+ bi <effect>
+ [
+ [
+ types [ marshaller ] map , \ spread , ,
+ types length , \ nkeep ,
+ types [ out-arg-unmarshaller ] map
+ effect out>> dup empty?
+ [ drop ] [ first unmarshaller prefix ] if
+ , \ spread ,
+ ] [ ] make
+ ] dip ;
+
+: define-c-marshalled ( name types effect body -- )
+ [
+ [ marshalled-function define-declared ]
+ [ prototype-string ] 3bi
+ ] dip append-function-body c-strings get push ;
+
+: define-c-marshalled' ( name effect body -- )
+ [
+ [ in>> ] keep
+ [ marshalled-function define-declared ]
+ [ out>> prototype-string' ] 3bi
+ ] dip append-function-body c-strings get push ;
+
+SYNTAX: CM-FUNCTION:
+ function-types-effect parse-here define-c-marshalled ;
+
+SYNTAX: M-FUNCTION:
+ function-types-effect marshalled-function define-declared ;
+
+SYNTAX: M-STRUCTURE:
+ scan current-vocab parse-definition
+ define-marshalled-struct ;
+
+SYNTAX: CM-STRUCTURE:
+ scan current-vocab parse-definition
+ [ define-marshalled-struct ] [ nip define-c-struct ] 3bi ;
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-USING: kernel system combinators alien alien.syntax ;
-IN: ogg
-
-<<
-"ogg" {
- { [ os winnt? ] [ "ogg.dll" ] }
- { [ os macosx? ] [ "libogg.0.dylib" ] }
- { [ os unix? ] [ "libogg.so" ] }
-} cond "cdecl" add-library
->>
-
-LIBRARY: ogg
-
-C-STRUCT: oggpack_buffer
- { "long" "endbyte" }
- { "int" "endbit" }
- { "uchar*" "buffer" }
- { "uchar*" "ptr" }
- { "long" "storage" } ;
-
-C-STRUCT: ogg_page
- { "uchar*" "header" }
- { "long" "header_len" }
- { "uchar*" "body" }
- { "long" "body_len" } ;
-
-C-STRUCT: ogg_stream_state
- { "uchar*" "body_data" }
- { "long" "body_storage" }
- { "long" "body_fill" }
- { "long" "body_returned" }
- { "int*" "lacing_vals" }
- { "longlong*" "granule_vals" }
- { "long" "lacing_storage" }
- { "long" "lacing_fill" }
- { "long" "lacing_packet" }
- { "long" "lacing_returned" }
- { { "uchar" 282 } "header" }
- { "int" "header_fill" }
- { "int" "e_o_s" }
- { "int" "b_o_s" }
- { "long" "serialno" }
- { "long" "pageno" }
- { "longlong" "packetno" }
- { "longlong" "granulepos" } ;
-
-C-STRUCT: ogg_packet
- { "uchar*" "packet" }
- { "long" "bytes" }
- { "long" "b_o_s" }
- { "long" "e_o_s" }
- { "longlong" "granulepos" }
- { "longlong" "packetno" } ;
-
-C-STRUCT: ogg_sync_state
- { "uchar*" "data" }
- { "int" "storage" }
- { "int" "fill" }
- { "int" "returned" }
- { "int" "unsynced" }
- { "int" "headerbytes" }
- { "int" "bodybytes" } ;
-
-FUNCTION: void oggpack_writeinit ( oggpack_buffer* b ) ;
-FUNCTION: void oggpack_writetrunc ( oggpack_buffer* b, long bits ) ;
-FUNCTION: void oggpack_writealign ( oggpack_buffer* b) ;
-FUNCTION: void oggpack_writecopy ( oggpack_buffer* b, void* source, long bits ) ;
-FUNCTION: void oggpack_reset ( oggpack_buffer* b ) ;
-FUNCTION: void oggpack_writeclear ( oggpack_buffer* b ) ;
-FUNCTION: void oggpack_readinit ( oggpack_buffer* b, uchar* buf, int bytes ) ;
-FUNCTION: void oggpack_write ( oggpack_buffer* b, ulong value, int bits ) ;
-FUNCTION: long oggpack_look ( oggpack_buffer* b, int bits ) ;
-FUNCTION: long oggpack_look1 ( oggpack_buffer* b ) ;
-FUNCTION: void oggpack_adv ( oggpack_buffer* b, int bits ) ;
-FUNCTION: void oggpack_adv1 ( oggpack_buffer* b ) ;
-FUNCTION: long oggpack_read ( oggpack_buffer* b, int bits ) ;
-FUNCTION: long oggpack_read1 ( oggpack_buffer* b ) ;
-FUNCTION: long oggpack_bytes ( oggpack_buffer* b ) ;
-FUNCTION: long oggpack_bits ( oggpack_buffer* b ) ;
-FUNCTION: uchar* oggpack_get_buffer ( oggpack_buffer* b ) ;
-FUNCTION: void oggpackB_writeinit ( oggpack_buffer* b ) ;
-FUNCTION: void oggpackB_writetrunc ( oggpack_buffer* b, long bits ) ;
-FUNCTION: void oggpackB_writealign ( oggpack_buffer* b ) ;
-FUNCTION: void oggpackB_writecopy ( oggpack_buffer* b, void* source, long bits ) ;
-FUNCTION: void oggpackB_reset ( oggpack_buffer* b ) ;
-FUNCTION: void oggpackB_writeclear ( oggpack_buffer* b ) ;
-FUNCTION: void oggpackB_readinit ( oggpack_buffer* b, uchar* buf, int bytes ) ;
-FUNCTION: void oggpackB_write ( oggpack_buffer* b, ulong value, int bits ) ;
-FUNCTION: long oggpackB_look ( oggpack_buffer* b, int bits ) ;
-FUNCTION: long oggpackB_look1 ( oggpack_buffer* b ) ;
-FUNCTION: void oggpackB_adv ( oggpack_buffer* b, int bits ) ;
-FUNCTION: void oggpackB_adv1 ( oggpack_buffer* b ) ;
-FUNCTION: long oggpackB_read ( oggpack_buffer* b, int bits ) ;
-FUNCTION: long oggpackB_read1 ( oggpack_buffer* b ) ;
-FUNCTION: long oggpackB_bytes ( oggpack_buffer* b ) ;
-FUNCTION: long oggpackB_bits ( oggpack_buffer* b ) ;
-FUNCTION: uchar* oggpackB_get_buffer ( oggpack_buffer* b ) ;
-FUNCTION: int ogg_stream_packetin ( ogg_stream_state* os, ogg_packet* op ) ;
-FUNCTION: int ogg_stream_pageout ( ogg_stream_state* os, ogg_page* og ) ;
-FUNCTION: int ogg_stream_flush ( ogg_stream_state* os, ogg_page* og ) ;
-FUNCTION: int ogg_sync_init ( ogg_sync_state* oy ) ;
-FUNCTION: int ogg_sync_clear ( ogg_sync_state* oy ) ;
-FUNCTION: int ogg_sync_reset ( ogg_sync_state* oy ) ;
-FUNCTION: int ogg_sync_destroy ( ogg_sync_state* oy ) ;
-
-FUNCTION: void* ogg_sync_buffer ( ogg_sync_state* oy, long size ) ;
-FUNCTION: int ogg_sync_wrote ( ogg_sync_state* oy, long bytes ) ;
-FUNCTION: long ogg_sync_pageseek ( ogg_sync_state* oy, ogg_page* og ) ;
-FUNCTION: int ogg_sync_pageout ( ogg_sync_state* oy, ogg_page* og ) ;
-FUNCTION: int ogg_stream_pagein ( ogg_stream_state* os, ogg_page* og ) ;
-FUNCTION: int ogg_stream_packetout ( ogg_stream_state* os, ogg_packet* op ) ;
-FUNCTION: int ogg_stream_packetpeek ( ogg_stream_state* os, ogg_packet* op ) ;
-FUNCTION: int ogg_stream_init (ogg_stream_state* os, int serialno ) ;
-FUNCTION: int ogg_stream_clear ( ogg_stream_state* os ) ;
-FUNCTION: int ogg_stream_reset ( ogg_stream_state* os ) ;
-FUNCTION: int ogg_stream_reset_serialno ( ogg_stream_state* os, int serialno ) ;
-FUNCTION: int ogg_stream_destroy ( ogg_stream_state* os ) ;
-FUNCTION: int ogg_stream_eos ( ogg_stream_state* os ) ;
-FUNCTION: void ogg_page_checksum_set ( ogg_page* og ) ;
-FUNCTION: int ogg_page_version ( ogg_page* og ) ;
-FUNCTION: int ogg_page_continued ( ogg_page* og ) ;
-FUNCTION: int ogg_page_bos ( ogg_page* og ) ;
-FUNCTION: int ogg_page_eos ( ogg_page* og ) ;
-FUNCTION: longlong ogg_page_granulepos ( ogg_page* og ) ;
-FUNCTION: int ogg_page_serialno ( ogg_page* og ) ;
-FUNCTION: long ogg_page_pageno ( ogg_page* og ) ;
-FUNCTION: int ogg_page_packets ( ogg_page* og ) ;
-FUNCTION: void ogg_packet_clear ( ogg_packet* op ) ;
-
+++ /dev/null
-Ogg media library binding
+++ /dev/null
-bindings
-audio
-video
+++ /dev/null
-Chris Double
+++ /dev/null
-Ogg Theora video library binding
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-USING: kernel system combinators alien alien.syntax ;
-IN: ogg.theora
-
-<<
-"theora" {
- { [ os winnt? ] [ "theora.dll" ] }
- { [ os macosx? ] [ "libtheora.0.dylib" ] }
- { [ os unix? ] [ "libtheora.so" ] }
-} cond "cdecl" add-library
->>
-
-LIBRARY: theora
-
-C-STRUCT: yuv_buffer
- { "int" "y_width" }
- { "int" "y_height" }
- { "int" "y_stride" }
- { "int" "uv_width" }
- { "int" "uv_height" }
- { "int" "uv_stride" }
- { "void*" "y" }
- { "void*" "u" }
- { "void*" "v" } ;
-
-: OC_CS_UNSPECIFIED ( -- number ) 0 ; inline
-: OC_CS_ITU_REC_470M ( -- number ) 1 ; inline
-: OC_CS_ITU_REC_470BG ( -- number ) 2 ; inline
-: OC_CS_NSPACES ( -- number ) 3 ; inline
-
-TYPEDEF: int theora_colorspace
-
-: OC_PF_420 ( -- number ) 0 ; inline
-: OC_PF_RSVD ( -- number ) 1 ; inline
-: OC_PF_422 ( -- number ) 2 ; inline
-: OC_PF_444 ( -- number ) 3 ; inline
-
-TYPEDEF: int theora_pixelformat
-
-C-STRUCT: theora_info
- { "uint" "width" }
- { "uint" "height" }
- { "uint" "frame_width" }
- { "uint" "frame_height" }
- { "uint" "offset_x" }
- { "uint" "offset_y" }
- { "uint" "fps_numerator" }
- { "uint" "fps_denominator" }
- { "uint" "aspect_numerator" }
- { "uint" "aspect_denominator" }
- { "theora_colorspace" "colorspace" }
- { "int" "target_bitrate" }
- { "int" "quality" }
- { "int" "quick_p" }
- { "uchar" "version_major" }
- { "uchar" "version_minor" }
- { "uchar" "version_subminor" }
- { "void*" "codec_setup" }
- { "int" "dropframes_p" }
- { "int" "keyframe_auto_p" }
- { "uint" "keyframe_frequency" }
- { "uint" "keyframe_frequency_force" }
- { "uint" "keyframe_data_target_bitrate" }
- { "int" "keyframe_auto_threshold" }
- { "uint" "keyframe_mindistance" }
- { "int" "noise_sensitivity" }
- { "int" "sharpness" }
- { "theora_pixelformat" "pixelformat" } ;
-
-C-STRUCT: theora_state
- { "theora_info*" "i" }
- { "longlong" "granulepos" }
- { "void*" "internal_encode" }
- { "void*" "internal_decode" } ;
-
-C-STRUCT: theora_comment
- { "char**" "user_comments" }
- { "int*" "comment_lengths" }
- { "int" "comments" }
- { "char*" "vendor" } ;
-
-: OC_FAULT ( -- number ) -1 ; inline
-: OC_EINVAL ( -- number ) -10 ; inline
-: OC_DISABLED ( -- number ) -11 ; inline
-: OC_BADHEADER ( -- number ) -20 ; inline
-: OC_NOTFORMAT ( -- number ) -21 ; inline
-: OC_VERSION ( -- number ) -22 ; inline
-: OC_IMPL ( -- number ) -23 ; inline
-: OC_BADPACKET ( -- number ) -24 ; inline
-: OC_NEWPACKET ( -- number ) -25 ; inline
-: OC_DUPFRAME ( -- number ) 1 ; inline
-
-FUNCTION: char* theora_version_string ( ) ;
-FUNCTION: uint theora_version_number ( ) ;
-FUNCTION: int theora_encode_init ( theora_state* th, theora_info* ti ) ;
-FUNCTION: int theora_encode_YUVin ( theora_state* t, yuv_buffer* yuv ) ;
-FUNCTION: int theora_encode_packetout ( theora_state* t, int last_p, ogg_packet* op ) ;
-FUNCTION: int theora_encode_header ( theora_state* t, ogg_packet* op ) ;
-FUNCTION: int theora_encode_comment ( theora_comment* tc, ogg_packet* op ) ;
-FUNCTION: int theora_encode_tables ( theora_state* t, ogg_packet* op ) ;
-FUNCTION: int theora_decode_header ( theora_info* ci, theora_comment* cc, ogg_packet* op ) ;
-FUNCTION: int theora_decode_init ( theora_state* th, theora_info* c ) ;
-FUNCTION: int theora_decode_packetin ( theora_state* th, ogg_packet* op ) ;
-FUNCTION: int theora_decode_YUVout ( theora_state* th, yuv_buffer* yuv ) ;
-FUNCTION: int theora_packet_isheader ( ogg_packet* op ) ;
-FUNCTION: int theora_packet_iskeyframe ( ogg_packet* op ) ;
-FUNCTION: int theora_granule_shift ( theora_info* ti ) ;
-FUNCTION: longlong theora_granule_frame ( theora_state* th, longlong granulepos ) ;
-FUNCTION: double theora_granule_time ( theora_state* th, longlong granulepos ) ;
-FUNCTION: void theora_info_init ( theora_info* c ) ;
-FUNCTION: void theora_info_clear ( theora_info* c ) ;
-FUNCTION: void theora_clear ( theora_state* t ) ;
-FUNCTION: void theora_comment_init ( theora_comment* tc ) ;
-FUNCTION: void theora_comment_add ( theora_comment* tc, char* comment ) ;
-FUNCTION: void theora_comment_add_tag ( theora_comment* tc, char* tag, char* value ) ;
-FUNCTION: char* theora_comment_query ( theora_comment* tc, char* tag, int count ) ;
-FUNCTION: int theora_comment_query_count ( theora_comment* tc, char* tag ) ;
-FUNCTION: void theora_comment_clear ( theora_comment* tc ) ;
+++ /dev/null
-Chris Double
+++ /dev/null
-Ogg Vorbis audio library binding
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-USING: kernel system combinators alien alien.syntax ogg ;
-IN: ogg.vorbis
-
-<<
-"vorbis" {
- { [ os winnt? ] [ "vorbis.dll" ] }
- { [ os macosx? ] [ "libvorbis.0.dylib" ] }
- { [ os unix? ] [ "libvorbis.so" ] }
-} cond "cdecl" add-library
->>
-
-LIBRARY: vorbis
-
-C-STRUCT: vorbis_info
- { "int" "version" }
- { "int" "channels" }
- { "long" "rate" }
- { "long" "bitrate_upper" }
- { "long" "bitrate_nominal" }
- { "long" "bitrate_lower" }
- { "long" "bitrate_window" }
- { "void*" "codec_setup"}
- ;
-
-C-STRUCT: vorbis_dsp_state
- { "int" "analysisp" }
- { "vorbis_info*" "vi" }
- { "float**" "pcm" }
- { "float**" "pcmret" }
- { "int" "pcm_storage" }
- { "int" "pcm_current" }
- { "int" "pcm_returned" }
- { "int" "preextrapolate" }
- { "int" "eofflag" }
- { "long" "lW" }
- { "long" "W" }
- { "long" "nW" }
- { "long" "centerW" }
- { "longlong" "granulepos" }
- { "longlong" "sequence" }
- { "longlong" "glue_bits" }
- { "longlong" "time_bits" }
- { "longlong" "floor_bits" }
- { "longlong" "res_bits" }
- { "void*" "backend_state" }
- ;
-
-C-STRUCT: alloc_chain
- { "void*" "ptr" }
- { "void*" "next" }
- ;
-
-C-STRUCT: vorbis_block
- { "float**" "pcm" }
- { "oggpack_buffer" "opb" }
- { "long" "lW" }
- { "long" "W" }
- { "long" "nW" }
- { "int" "pcmend" }
- { "int" "mode" }
- { "int" "eofflag" }
- { "longlong" "granulepos" }
- { "longlong" "sequence" }
- { "vorbis_dsp_state*" "vd" }
- { "void*" "localstore" }
- { "long" "localtop" }
- { "long" "localalloc" }
- { "long" "totaluse" }
- { "alloc_chain*" "reap" }
- { "long" "glue_bits" }
- { "long" "time_bits" }
- { "long" "floor_bits" }
- { "long" "res_bits" }
- { "void*" "internal" }
- ;
-
-C-STRUCT: vorbis_comment
- { "char**" "usercomments" }
- { "int*" "comment_lengths" }
- { "int" "comments" }
- { "char*" "vendor" }
- ;
-
-FUNCTION: void vorbis_info_init ( vorbis_info* vi ) ;
-FUNCTION: void vorbis_info_clear ( vorbis_info* vi ) ;
-FUNCTION: int vorbis_info_blocksize ( vorbis_info* vi, int zo ) ;
-FUNCTION: void vorbis_comment_init ( vorbis_comment* vc ) ;
-FUNCTION: void vorbis_comment_add ( vorbis_comment* vc, char* comment ) ;
-FUNCTION: void vorbis_comment_add_tag ( vorbis_comment* vc, char* tag, char* contents ) ;
-FUNCTION: char* vorbis_comment_query ( vorbis_comment* vc, char* tag, int count ) ;
-FUNCTION: int vorbis_comment_query_count ( vorbis_comment* vc, char* tag ) ;
-FUNCTION: void vorbis_comment_clear ( vorbis_comment* vc ) ;
-FUNCTION: int vorbis_block_init ( vorbis_dsp_state* v, vorbis_block* vb ) ;
-FUNCTION: int vorbis_block_clear ( vorbis_block* vb ) ;
-FUNCTION: void vorbis_dsp_clear ( vorbis_dsp_state* v ) ;
-FUNCTION: double vorbis_granule_time ( vorbis_dsp_state* v, longlong granulepos ) ;
-FUNCTION: int vorbis_analysis_init ( vorbis_dsp_state* v, vorbis_info* vi ) ;
-FUNCTION: int vorbis_commentheader_out ( vorbis_comment* vc, ogg_packet* op ) ;
-FUNCTION: int vorbis_analysis_headerout ( vorbis_dsp_state* v,
- vorbis_comment* vc,
- ogg_packet* op,
- ogg_packet* op_comm,
- ogg_packet* op_code ) ;
-FUNCTION: float** vorbis_analysis_buffer ( vorbis_dsp_state* v, int vals ) ;
-FUNCTION: int vorbis_analysis_wrote ( vorbis_dsp_state* v, int vals ) ;
-FUNCTION: int vorbis_analysis_blockout ( vorbis_dsp_state* v, vorbis_block* vb ) ;
-FUNCTION: int vorbis_analysis ( vorbis_block* vb, ogg_packet* op ) ;
-FUNCTION: int vorbis_bitrate_addblock ( vorbis_block* vb ) ;
-FUNCTION: int vorbis_bitrate_flushpacket ( vorbis_dsp_state* vd,
- ogg_packet* op ) ;
-FUNCTION: int vorbis_synthesis_headerin ( vorbis_info* vi, vorbis_comment* vc,
- ogg_packet* op ) ;
-FUNCTION: int vorbis_synthesis_init ( vorbis_dsp_state* v, vorbis_info* vi ) ;
-FUNCTION: int vorbis_synthesis_restart ( vorbis_dsp_state* v ) ;
-FUNCTION: int vorbis_synthesis ( vorbis_block* vb, ogg_packet* op ) ;
-FUNCTION: int vorbis_synthesis_trackonly ( vorbis_block* vb, ogg_packet* op ) ;
-FUNCTION: int vorbis_synthesis_blockin ( vorbis_dsp_state* v, vorbis_block* vb ) ;
-FUNCTION: int vorbis_synthesis_pcmout ( vorbis_dsp_state* v, float*** pcm ) ;
-FUNCTION: int vorbis_synthesis_lapout ( vorbis_dsp_state* v, float*** pcm ) ;
-FUNCTION: int vorbis_synthesis_read ( vorbis_dsp_state* v, int samples ) ;
-FUNCTION: long vorbis_packet_blocksize ( vorbis_info* vi, ogg_packet* op ) ;
-FUNCTION: int vorbis_synthesis_halfrate ( vorbis_info* v, int flag ) ;
-FUNCTION: int vorbis_synthesis_halfrate_p ( vorbis_info* v ) ;
-
-: OV_FALSE ( -- number ) -1 ; inline
-: OV_EOF ( -- number ) -2 ; inline
-: OV_HOLE ( -- number ) -3 ; inline
-: OV_EREAD ( -- number ) -128 ; inline
-: OV_EFAULT ( -- number ) -129 ; inline
-: OV_EIMPL ( -- number ) -130 ; inline
-: OV_EINVAL ( -- number ) -131 ; inline
-: OV_ENOTVORBIS ( -- number ) -132 ; inline
-: OV_EBADHEADER ( -- number ) -133 ; inline
-: OV_EVERSION ( -- number ) -134 ; inline
-: OV_ENOTAUDIO ( -- number ) -135 ; inline
-: OV_EBADPACKET ( -- number ) -136 ; inline
-: OV_EBADLINK ( -- number ) -137 ; inline
-: OV_ENOSEEK ( -- number ) -138 ; inline
projects / factor.git / commitdiff