+++ /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
io.encodings.string debugger destructors vocabs.loader
classes.struct ;
QUALIFIED: math
+QUALIFIED: sequences
IN: alien.c-types
HELP: byte-length
{ $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." } ;
{ $description "This C type represents a four-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 32 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: long
{ $description "This C type represents a four- or eight-byte signed integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
+HELP: intptr_t
+{ $description "This C type represents a signed integer type large enough to hold any pointer value; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: ulong
{ $description "This C type represents a four- or eight-byte unsigned integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
+HELP: uintptr_t
+{ $description "This C type represents an unsigned integer type large enough to hold any pointer value; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
+HELP: ptrdiff_t
+{ $description "This C type represents a signed integer type large enough to hold the distance between two pointer values; that is, on 32-bit platforms, it will be four bytes, and on 64-bit platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
+HELP: size_t
+{ $description "This C type represents unsigned size values of the size expected by the platform's standard C library (usually four bytes on a 32-bit platform, and eight on a 64-bit platform). Input values will be converted to " { $link math:integer } "s and truncated to the appropriate size; output values will be returned as " { $link math:integer } "s." } ;
HELP: longlong
{ $description "This C type represents an eight-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: ulonglong
{ $description "This C type represents an eight-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: void
-{ $description "This symbol is not a valid C type, but it can be used as the return type for a " { $link POSTPONE: FUNCTION: } " or " { $link POSTPONE: CALLBACK: } " definition, or an " { $link alien-invoke } " or " { $link alien-callback } " call." } ;
+{ $description "This symbol is not a valid C type, but it can be used as the return type for a " { $link POSTPONE: FUNCTION: } " or " { $link POSTPONE: CALLBACK: } " definition or for an " { $link alien-invoke } " or " { $link alien-callback } " call." } ;
HELP: void*
-{ $description "This C type represents a pointer to C memory. " { $link byte-array } " and " { $link alien } " values can be passed as inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. Output values are returned as " { $link alien } "s." } ;
+{ $description "This C type represents a pointer to C memory. " { $link byte-array } " and " { $link alien } " values can be passed as " { $snippet "void*" } " function inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. " { $snippet "void*" } " output values are returned as " { $link alien } "s." } ;
HELP: char*
{ $description "This C type represents a pointer to a C string. See " { $link "c-strings" } " for details about using strings with the FFI." } ;
HELP: float
{ $subsection *void* }
"Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link <void*> } " and " { $link *void* } " may be used." ;
-ARTICLE: "c-types-specs" "C type specifiers"
-"C types are identified by special words, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words. New C types can be defined by the words " { $link POSTPONE: STRUCT: } ", " { $link POSTPONE: UNION-STRUCT: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: TYPEDEF: } "."
-$nl
-"The following numerical types are available; a " { $snippet "u" } " prefix denotes an unsigned type:"
+ARTICLE: "c-types.primitives" "Primitive C types"
+"The following numerical types are defined in the " { $vocab-link "alien.c-types" } " vocabulary; a " { $snippet "u" } " prefix denotes an unsigned type:"
{ $table
{ "C type" "Notes" }
{ { $link char } "always 1 byte" }
{ { $link ulonglong } { } }
{ { $link float } { "single-precision float (not the same as Factor's " { $link math:float } " class!)" } }
{ { $link double } { "double-precision float (the same format as Factor's " { $link math:float } " objects)" } }
+}
+"The following C99 complex number types are defined in the " { $vocab-link "alien.complex" } " vocabulary:"
+{ $table
{ { $link complex-float } { "C99 or Fortran " { $snippet "complex float" } " type, converted to and from Factor " { $link math:complex } " values" } }
{ { $link complex-double } { "C99 or Fortran " { $snippet "complex double" } " type, converted to and from Factor " { $link math:complex } " values" } }
}
-"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision."
-$nl
+"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision." ;
+
+ARTICLE: "c-types.pointers" "Pointer and array types"
"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $link void* } ", which denotes a generic pointer; " { $link void } " by itself is not a valid C type specifier. With the exception of strings (see " { $link "c-strings" } "), all pointer types are identical to " { $snippet "void*" } " as far as the C library interface is concerned."
$nl
"Fixed-size array types are supported; the syntax consists of a C type name followed by dimension sizes in brackets; the following denotes a 3 by 4 array of integers:"
{ $code "int[3][4]" }
-"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however when used as function parameters they behave exactly like pointers and thus the dimensions only serve as documentation."
-$nl
-"Structure and union types are specified by the name of the structure or union." ;
+"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however when used as function parameters they behave exactly like pointers and thus the dimensions only serve as documentation." ;
+
+ARTICLE: "c-types.ambiguity" "Word name clashes with C types"
+"Note that some of the C type word names clash with commonly-used Factor words:"
+{ $list
+ { { $link short } " clashes with the " { $link sequences:short } " word in the " { $vocab-link "sequences" } " vocabulary" }
+ { { $link float } " clashes with the " { $link math:float } " word in the " { $vocab-link "math" } " vocabulary" }
+}
+"If you use the wrong vocabulary, you will see a " { $link no-c-type } " error. For example, the following is " { $strong "not" } " valid, and will raise an error because the " { $link math:float } " word from the " { $vocab-link "math" } " vocabulary is not a C type:"
+{ $code
+ "USING: alien.syntax math prettyprint ;"
+ "FUNCTION: float magic_number ( ) ;"
+ "magic_number 3.0 + ."
+}
+"The following won't work either; now the problem is that there are two vocabularies in the search path that define a word named " { $snippet "float" } ":"
+{ $code
+ "USING: alien.c-types alien.syntax math prettyprint ;"
+ "FUNCTION: float magic_number ( ) ;"
+ "magic_number 3.0 + ."
+}
+"The correct solution is to use one of " { $link POSTPONE: FROM: } ", " { $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: QUALIFIED-WITH: } " to disambiguate word lookup:"
+{ $code
+ "USING: alien.syntax math prettyprint ;"
+ "QUALIFIED-WITH: alien.c-types c"
+ "FUNCTION: c:float magic_number ( ) ;"
+ "magic_number 3.0 + ."
+}
+"See " { $link "word-search-semantics" } " for details." ;
+
+ARTICLE: "c-types.structs" "Struct and union types"
+"Struct and union types are identified by their class word. See " { $link "classes.struct" } "." ;
+
+ARTICLE: "c-types-specs" "C type specifiers"
+"C types are identified by special words, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words. New C types can be defined by the words " { $link POSTPONE: STRUCT: } ", " { $link POSTPONE: UNION-STRUCT: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: TYPEDEF: } "."
+{ $subsection "c-types.primitives" }
+{ $subsection "c-types.pointers" }
+{ $subsection "c-types.ambiguity" }
+{ $subsection "c-types.structs" }
+;
+
+ABOUT: "c-types-specs"
-USING: alien alien.syntax alien.c-types kernel tools.test
-sequences system libc alien.strings io.encodings.utf8
-math.constants ;
+USING: alien alien.syntax alien.c-types alien.parser
+eval kernel tools.test sequences system libc alien.strings
+io.encodings.utf8 math.constants classes.struct classes ;
IN: alien.c-types.tests
CONSTANT: xyz 123
-[ 492 ] [ { "int" xyz } heap-size ] unit-test
+[ 492 ] [ { int xyz } heap-size ] unit-test
[ -1 ] [ -1 <char> *char ] unit-test
[ -1 ] [ -1 <short> *short ] unit-test
[ -1 ] [ -1 <int> *int ] unit-test
-C-UNION: foo
- "int"
- "int" ;
+UNION-STRUCT: foo
+ { a int }
+ { b int } ;
-[ f ] [ "char*" c-type "void*" c-type eq? ] unit-test
-[ t ] [ "char**" c-type "void*" c-type eq? ] unit-test
+[ f ] [ char resolve-pointer-type c-type void* c-type eq? ] unit-test
+[ t ] [ char* resolve-pointer-type c-type void* c-type eq? ] unit-test
-[ t ] [ "foo" heap-size "int" heap-size = ] unit-test
+[ t ] [ foo heap-size int heap-size = ] unit-test
TYPEDEF: int MyInt
-[ t ] [ "int" c-type "MyInt" c-type eq? ] unit-test
-[ t ] [ "void*" c-type "MyInt*" c-type eq? ] unit-test
+[ t ] [ int c-type MyInt c-type eq? ] unit-test
+[ t ] [ void* c-type MyInt resolve-pointer-type c-type eq? ] unit-test
TYPEDEF: char MyChar
-[ t ] [ "char" c-type "MyChar" c-type eq? ] unit-test
-[ f ] [ "void*" c-type "MyChar*" c-type eq? ] unit-test
-[ t ] [ "char*" c-type "MyChar*" c-type eq? ] unit-test
+[ t ] [ char c-type MyChar c-type eq? ] unit-test
+[ f ] [ void* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
+[ t ] [ char* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
-[ 32 ] [ { "int" 8 } heap-size ] unit-test
+[ 32 ] [ { int 8 } heap-size ] unit-test
TYPEDEF: char* MyString
-[ t ] [ "char*" c-type "MyString" c-type eq? ] unit-test
-[ t ] [ "void*" c-type "MyString*" c-type eq? ] unit-test
+[ t ] [ char* c-type MyString c-type eq? ] unit-test
+[ t ] [ void* c-type MyString resolve-pointer-type c-type eq? ] unit-test
TYPEDEF: int* MyIntArray
-[ t ] [ "void*" c-type "MyIntArray" c-type eq? ] unit-test
+[ t ] [ void* c-type MyIntArray c-type eq? ] unit-test
TYPEDEF: uchar* MyLPBYTE
-[ t ] [ { char* utf8 } c-type "MyLPBYTE" c-type = ] unit-test
+[ t ] [ { char* utf8 } c-type MyLPBYTE c-type = ] unit-test
[
0 B{ 1 2 3 4 } <displaced-alien> <void*>
[ -10 ] [ -10 char c-type-clamp ] unit-test
[ 127 ] [ 230 char c-type-clamp ] unit-test
[ t ] [ pi dup float c-type-clamp = ] unit-test
+
+C-TYPE: opaque
+
+[ t ] [ void* c-type opaque resolve-pointer-type c-type eq? ] unit-test
+[ opaque c-type ] [ no-c-type? ] must-fail-with
+
+[ """
+ USING: alien.syntax ;
+ IN: alien.c-types.tests
+ FUNCTION: opaque return_opaque ( ) ;
+""" eval( -- ) ] [ no-c-type? ] must-fail-with
+
+C-TYPE: forward
+STRUCT: backward { x forward* } ;
+STRUCT: forward { x backward* } ;
+
+[ t ] [ forward c-type struct-c-type? ] unit-test
+[ t ] [ backward c-type struct-c-type? ] unit-test
+
+DEFER: struct-redefined
+
+[ f ]
+[
+
+ """
+ USING: alien.c-types classes.struct ;
+ IN: alien.c-types.tests
+
+ STRUCT: struct-redefined { x int } ;
+ """ eval( -- )
+
+ """
+ USING: alien.syntax ;
+ IN: alien.c-types.tests
+
+ C-TYPE: struct-redefined
+ """ eval( -- )
+
+ \ struct-redefined class?
+] unit-test
+
{ rep initial: int-rep }
stack-align? ;
-: <c-type> ( -- type )
- \ c-type new ;
+: <c-type> ( -- c-type )
+ \ c-type new ; inline
SYMBOL: c-types
PREDICATE: c-type-word < word
"c-type" word-prop ;
-UNION: c-type-name string word ;
+UNION: c-type-name string c-type-word ;
! C type protocol
-GENERIC: c-type ( name -- type ) foldable
+GENERIC: c-type ( name -- c-type ) foldable
GENERIC: resolve-pointer-type ( name -- c-type )
+<< \ void \ void* "pointer-c-type" set-word-prop >>
+
+: void? ( c-type -- ? )
+ { void "void" } member? ;
+
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 void? [ no-c-type ] when
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
] [
] if ;
M: word c-type
- "c-type" word-prop resolve-typedef ;
-
-: void? ( c-type -- ? )
- { void "void" } member? ;
+ dup "c-type" word-prop resolve-typedef
+ [ ] [ no-c-type ] ?if ;
-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
}
SYMBOLS:
- ptrdiff_t intptr_t size_t
+ ptrdiff_t intptr_t uintptr_t size_t
char* uchar* ;
[
[ >float ] >>unboxer-quot
\ double define-primitive-type
- \ long \ ptrdiff_t typedef
- \ long \ intptr_t typedef
- \ ulong \ size_t typedef
+ \ long c-type \ ptrdiff_t typedef
+ \ long c-type \ intptr_t typedef
+ \ ulong c-type \ uintptr_t typedef
+ \ ulong c-type \ size_t typedef
] with-compilation-unit
M: char-16-rep rep-component-type drop char ;
-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." }
! (c)2009 Slava Pestov, Joe Groff bsd license
USING: accessors alien alien.c-types alien.strings arrays
byte-arrays cpu.architecture fry io io.encodings.binary
-io.files io.streams.memory kernel libc math sequences ;
+io.files io.streams.memory kernel libc math sequences words ;
IN: alien.data
GENERIC: require-c-array ( c-type -- )
M: array require-c-array first require-c-array ;
-GENERIC: c-array-constructor ( c-type -- word )
+GENERIC: c-array-constructor ( c-type -- word ) foldable
-GENERIC: c-(array)-constructor ( c-type -- word )
+GENERIC: c-(array)-constructor ( c-type -- word ) foldable
-GENERIC: c-direct-array-constructor ( c-type -- word )
+GENERIC: c-direct-array-constructor ( c-type -- word ) foldable
GENERIC: <c-array> ( len c-type -- array )
-M: c-type-name <c-array>
+M: word <c-array>
c-array-constructor execute( len -- array ) ; inline
GENERIC: (c-array) ( len c-type -- array )
-M: c-type-name (c-array)
+M: word (c-array)
c-(array)-constructor execute( len -- array ) ; inline
GENERIC: <c-direct-array> ( alien len c-type -- array )
-M: c-type-name <c-direct-array>
+M: word <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
+! (c)2009 Joe Groff bsd license
+USING: accessors alien.c-types alien.parser alien.syntax
+tools.test vocabs.parser parser ;
+IN: alien.parser.tests
+
+TYPEDEF: char char2
+
+SYMBOL: not-c-type
+
+[
+ "alien.parser.tests" use-vocab
+ "alien.c-types" use-vocab
+
+ [ int ] [ "int" parse-c-type ] unit-test
+ [ { int 5 } ] [ "int[5]" parse-c-type ] unit-test
+ [ { int 5 10 11 } ] [ "int[5][10][11]" parse-c-type ] unit-test
+ [ void* ] [ "int*" parse-c-type ] unit-test
+ [ void* ] [ "int**" parse-c-type ] unit-test
+ [ void* ] [ "int***" parse-c-type ] unit-test
+ [ void* ] [ "int****" parse-c-type ] unit-test
+ [ char* ] [ "char*" parse-c-type ] unit-test
+ [ void* ] [ "char**" parse-c-type ] unit-test
+ [ void* ] [ "char***" parse-c-type ] unit-test
+ [ void* ] [ "char****" parse-c-type ] unit-test
+ [ char2 ] [ "char2" parse-c-type ] unit-test
+ [ char* ] [ "char2*" parse-c-type ] unit-test
+
+ [ "not-c-type" parse-c-type ] [ no-c-type? ] must-fail-with
+ [ "not-word" parse-c-type ] [ error>> no-word-error? ] must-fail-with
+
+] with-file-vocabs
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays assocs
-combinators combinators.short-circuit effects grouping
+USING: accessors alien alien.c-types alien.parser
+alien.libraries arrays assocs classes combinators
+combinators.short-circuit compiler.units effects grouping
kernel parser sequences splitting words fry locals lexer
namespaces summary math vocabs.parser ;
IN: alien.parser
-: parse-c-type-name ( name -- word/string )
- [ search ] keep or ;
+: parse-c-type-name ( name -- word )
+ dup search [ nip ] [ no-word ] if* ;
: parse-c-type ( string -- array )
{
{ [ dup "void" = ] [ drop void ] }
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
{ [ dup search c-type-word? ] [ parse-c-type-name ] }
- { [ dup c-types get at ] [ ] }
+ { [ "**" ?tail ] [ drop void* ] }
{ [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] }
- [ no-c-type ]
+ [ parse-c-type-name no-c-type ]
} cond ;
: scan-c-type ( -- c-type )
[ parse-c-type ] if ;
: reset-c-type ( word -- )
- { "c-type" "pointer-c-type" "callback-effect" "callback-abi" } reset-props ;
+ dup "struct-size" word-prop
+ [ dup [ forget-class ] [ { "struct-size" } reset-props ] bi ] when
+ {
+ "c-type"
+ "pointer-c-type"
+ "callback-effect"
+ "callback-library"
+ } reset-props ;
: CREATE-C-TYPE ( -- word )
- scan current-vocab create dup reset-c-type ;
+ scan current-vocab create {
+ [ fake-definition ]
+ [ set-word ]
+ [ reset-c-type ]
+ [ ]
+ } cleave ;
: normalize-c-arg ( type name -- type' name' )
[ length ]
: callback-quot ( return types abi -- quot )
[ [ ] 3curry dip alien-callback ] 3curry ;
-:: make-callback-type ( abi return! type-name! parameters -- word quot effect )
+: library-abi ( lib -- abi )
+ library [ abi>> ] [ "cdecl" ] if* ;
+
+:: make-callback-type ( lib return! type-name! parameters -- word quot effect )
return type-name normalize-c-arg type-name! return!
type-name current-vocab create :> type-word
type-word [ reset-generic ] [ reset-c-type ] bi
void* type-word typedef
parameters return parse-arglist :> callback-effect :> types
type-word callback-effect "callback-effect" set-word-prop
- type-word abi "callback-abi" set-word-prop
- type-word return types abi callback-quot (( quot -- alien )) ;
+ type-word lib "callback-library" set-word-prop
+ type-word return types lib library-abi callback-quot (( quot -- alien )) ;
-: (CALLBACK:) ( abi -- word quot effect )
+: (CALLBACK:) ( -- word quot effect )
+ "c-library" get
scan scan parse-arg-tokens make-callback-type ;
PREDICATE: alien-function-word < word
first2 pprint-function-arg
] if-empty ;
+: pprint-library ( library -- )
+ [ \ LIBRARY: [ text ] pprint-prefix ] when* ;
+
M: alien-function-word definer
drop \ FUNCTION: \ ; ;
M: alien-function-word definition drop f ;
M: alien-function-word synopsis*
{
[ seeing-word ]
- [ def>> second [ \ LIBRARY: [ text ] pprint-prefix ] when* ]
+ [ def>> second pprint-library ]
[ definer. ]
[ def>> first pprint-c-type ]
[ pprint-word ]
} cleave ;
M: alien-callback-type-word definer
- "callback-abi" word-prop "stdcall" =
- \ STDCALL-CALLBACK: \ CALLBACK: ?
- f ;
+ drop \ CALLBACK: \ ; ;
M: alien-callback-type-word definition drop f ;
M: alien-callback-type-word synopsis*
{
[ seeing-word ]
+ [ "callback-library" word-prop pprint-library ]
[ definer. ]
[ def>> first pprint-c-type ]
[ pprint-word ]
+++ /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 see ;
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" } }
{ $code "CONSTANT: red 0" "CONSTANT: green 1" "CONSTANT: blue 2" }
} ;
+HELP: C-TYPE:
+{ $syntax "C-TYPE: type" }
+{ $values { "type" "a new C type" } }
+{ $description "Defines a new, opaque C type. Since it is opaque, " { $snippet "type" } " will not be directly usable as a parameter or return type of a " { $link POSTPONE: FUNCTION: } " or as a slot of a " { $link POSTPONE: STRUCT: } ". However, it can be used as the type of a pointer (that is, as " { $snippet "type*" } ")." $nl
+{ $snippet "C-TYPE:" } " can also be used to forward-declare C types to enable circular dependencies. For example:"
+{ $code """C-TYPE: forward
+STRUCT: backward { x forward* } ;
+STRUCT: forward { x backward* } ; """ } }
+{ $notes "Primitive C types are also displayed using " { $snippet "C-TYPE:" } " syntax when they are displayed by " { $link see } "." } ;
+
HELP: CALLBACK:
{ $syntax "CALLBACK: return type ( parameters ) ;" }
{ $values { "return" "a C return type" } { "type" "a type name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
-{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters with the " { $snippet "\"cdecl\"" } " ABI." }
+{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters. The ABI of the callback is decided from the ABI of the active " { $link POSTPONE: LIBRARY: } " declaration." }
{ $examples
{ $code
"CALLBACK: bool FakeCallback ( int message, void* payload ) ;"
}
} ;
-HELP: STDCALL-CALLBACK:
-{ $syntax "STDCALL-CALLBACK: return type ( parameters ) ;" }
-{ $values { "return" "a C return type" } { "type" "a type name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
-{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters with the " { $snippet "\"stdcall\"" } " ABI." }
-{ $examples
- { $code
- "STDCALL-CALLBACK: bool FakeCallback ( int message, void* payload ) ;"
- ": MyFakeCallback ( -- alien )"
- " [| message payload |"
- " \"message #\" write"
- " message number>string write"
- " \" received\" write nl"
- " t"
- " ] FakeCallback ;"
- }
-} ;
-
-{ POSTPONE: CALLBACK: POSTPONE: STDCALL-CALLBACK: } related-words
-
HELP: &:
{ $syntax "&: symbol" }
{ $values { "symbol" "A C library symbol name" } }
{ 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
(FUNCTION:) define-declared ;
SYNTAX: CALLBACK:
- "cdecl" (CALLBACK:) define-inline ;
-
-SYNTAX: STDCALL-CALLBACK:
- "stdcall" (CALLBACK:) define-inline ;
+ (CALLBACK:) define-inline ;
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 ;
SYNTAX: C-TYPE:
- "Primitive C type definition not supported" throw ;
+ void CREATE-C-TYPE typedef ;
ERROR: no-such-symbol name library ;
$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"
+"The " { $vocab-link "classes.struct" } " vocabulary implements " { $link struct } " classes. They are similar to " { $link tuple } " classes, but their slots exhibit value semantics, and they are backed by a contiguous structured block of memory. Structs can be used for space-efficient storage of data in the Factor heap, as well as for passing data to and from C libraries using the " { $link "alien" } "."
+{ $subsection "classes.struct.examples" }
+{ $subsection "classes.struct.define" }
+{ $subsection "classes.struct.create" }
+{ $subsection "classes.struct.c" } ;
ABOUT: "classes.struct"
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct ;
IN: cocoa.runtime
TYPEDEF: void* SEL
! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax combinators kernel layouts
-classes.struct core-graphics.types ;
+classes.struct cocoa.runtime core-graphics.types ;
IN: cocoa.types
TYPEDEF: long NSInteger
compiler.tree.optimizer cpu.architecture compiler.cfg.builder
compiler.cfg.linearization compiler.cfg.registers
compiler.cfg.stack-frame compiler.cfg.linear-scan
-compiler.cfg.two-operand compiler.cfg.optimizer
-compiler.cfg.instructions compiler.cfg.utilities
-compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.mr
-compiler.cfg.representations.preferred compiler.cfg ;
+compiler.cfg.optimizer compiler.cfg.instructions
+compiler.cfg.utilities compiler.cfg.def-use compiler.cfg.rpo
+compiler.cfg.mr compiler.cfg.representations.preferred
+compiler.cfg ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
[ next-vreg dup ] dip {
{ [ dup not ] [ drop \ f tag-number ##load-immediate ] }
{ [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
+ { [ dup float? ] [ ##load-constant ] }
[ ##load-reference ]
} cond ;
: ^^unbox-c-ptr ( src class -- dst )
[ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ;
-: ^^neg ( src -- dst )
- [ 0 ^^load-literal ] dip ^^sub ;
-
: ^^allot-tuple ( n -- dst )
2 + cells tuple ^^allot ;
def: dst/int-rep
constant: obj ;
+INSN: ##load-constant
+def: dst/int-rep
+constant: obj ;
+
INSN: ##peek
def: dst/int-rep
literal: loc ;
def: dst/int-rep
use: src/int-rep ;
-PURE-INSN: ##log2
+PURE-INSN: ##neg
def: dst/int-rep
use: src/int-rep ;
-! Bignum/integer conversion
-PURE-INSN: ##integer>bignum
-def: dst/int-rep
-use: src/int-rep
-temp: temp/int-rep ;
-
-PURE-INSN: ##bignum>integer
+PURE-INSN: ##log2
def: dst/int-rep
-use: src/int-rep
-temp: temp/int-rep ;
+use: src/int-rep ;
! Float arithmetic
PURE-INSN: ##unbox-float
use: src/int-rep
literal: rep ;
-PURE-INSN: ##broadcast-vector
+PURE-INSN: ##zero-vector
def: dst
-use: src/scalar-rep
literal: rep ;
PURE-INSN: ##gather-vector-2
use: src1/scalar-rep src2/scalar-rep src3/scalar-rep src4/scalar-rep
literal: rep ;
+PURE-INSN: ##shuffle-vector
+def: dst
+use: src
+literal: shuffle rep ;
+
PURE-INSN: ##add-vector
def: dst
use: src1 src2
use: src1 src2
literal: rep ;
+PURE-INSN: ##dot-vector
+def: dst/scalar-rep
+use: src1 src2
+literal: rep ;
+
PURE-INSN: ##horizontal-add-vector
def: dst/scalar-rep
use: src
literal: rep ;
+PURE-INSN: ##horizontal-sub-vector
+def: dst/scalar-rep
+use: src
+literal: rep ;
+
+PURE-INSN: ##horizontal-shl-vector
+def: dst
+use: src1
+literal: src2 rep ;
+
+PURE-INSN: ##horizontal-shr-vector
+def: dst
+use: src1
+literal: src2 rep ;
+
PURE-INSN: ##abs-vector
def: dst
use: src
use: src1 src2
literal: rep ;
+PURE-INSN: ##andn-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
PURE-INSN: ##or-vector
def: dst
use: src1 src2
use: src1 src2/scalar-rep
literal: rep ;
-! Scalar/integer conversion
+! Scalar/vector conversion
PURE-INSN: ##scalar>integer
def: dst/int-rep
use: src
use: src/int-rep
literal: rep ;
+PURE-INSN: ##vector>scalar
+def: dst/scalar-rep
+use: src
+literal: rep ;
+
+PURE-INSN: ##scalar>vector
+def: dst
+use: src/scalar-rep
+literal: rep ;
+
! Boxing and unboxing aliens
PURE-INSN: ##box-alien
def: dst/int-rep
! Alien accessors
INSN: ##alien-unsigned-1
def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
INSN: ##alien-unsigned-2
def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
INSN: ##alien-unsigned-4
def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
INSN: ##alien-signed-1
def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
INSN: ##alien-signed-2
def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
INSN: ##alien-signed-4
def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
INSN: ##alien-cell
def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
INSN: ##alien-float
def: dst/float-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
INSN: ##alien-double
def: dst/double-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
INSN: ##alien-vector
def: dst
use: src/int-rep
-literal: rep ;
+literal: offset rep ;
INSN: ##set-alien-integer-1
-use: src/int-rep value/int-rep ;
+use: src/int-rep
+literal: offset
+use: value/int-rep ;
INSN: ##set-alien-integer-2
-use: src/int-rep value/int-rep ;
+use: src/int-rep
+literal: offset
+use: value/int-rep ;
INSN: ##set-alien-integer-4
-use: src/int-rep value/int-rep ;
+use: src/int-rep
+literal: offset
+use: value/int-rep ;
INSN: ##set-alien-cell
-use: src/int-rep value/int-rep ;
+use: src/int-rep
+literal: offset
+use: value/int-rep ;
INSN: ##set-alien-float
-use: src/int-rep value/float-rep ;
+use: src/int-rep
+literal: offset
+use: value/float-rep ;
INSN: ##set-alien-double
-use: src/int-rep value/double-rep ;
+use: src/int-rep
+literal: offset
+use: value/double-rep ;
INSN: ##set-alien-vector
-use: src/int-rep value
+use: src/int-rep
+literal: offset
+use: value
literal: rep ;
! Memory allocation
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-TUPLE: spill-slot n ; C: <spill-slot> spill-slot
+TUPLE: spill-slot { n integer } ;
+C: <spill-slot> spill-slot
INSN: _gc
temp: temp1 temp2
! virtual registers
INSN: _spill
use: src
-literal: rep n ;
+literal: rep dst ;
INSN: _reload
def: dst
-literal: rep n ;
+literal: rep src ;
INSN: _spill-area-size
literal: n ;
##box-float
##box-vector
##box-alien
-##box-displaced-alien
-##integer>bignum ;
+##box-displaced-alien ;
! For alias analysis
UNION: ##read ##slot ##slot-imm ;
! Instructions that have complex expansions and require that the
! output registers are not equal to any of the input registers
UNION: def-is-use-insn
-##integer>bignum
-##bignum>integer
+##box-alien
+##box-displaced-alien
+##string-nth
##unbox-any-c-ptr ;
SYMBOL: vreg-insn
[ second class>> fixnum class<= ]
bi and ;
-: prepare-alien-accessor ( info -- offset-vreg )
- class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
+: prepare-alien-accessor ( info -- ptr-vreg offset )
+ class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ;
-: prepare-alien-getter ( infos -- offset-vreg )
+: prepare-alien-getter ( infos -- ptr-vreg offset )
first prepare-alien-accessor ;
: inline-alien-getter ( node quot -- )
[ third class>> fixnum class<= ]
tri and and ;
-: prepare-alien-setter ( infos -- offset-vreg )
+: prepare-alien-setter ( infos -- ptr-vreg offset )
second prepare-alien-accessor ;
: inline-alien-integer-setter ( node quot -- )
: emit-fixnum-comparison ( cc -- )
'[ _ ^^compare ] emit-fixnum-op ;
-: emit-bignum>fixnum ( -- )
- ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
-
-: emit-fixnum>bignum ( -- )
- ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
-
: emit-no-overflow-case ( dst -- final-bb )
[ ds-drop ds-drop ds-push ] with-branch ;
{ math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vmin) [ [ ^^min-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vmax) [ [ ^^max-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-v.) [ [ ^^dot-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vabs) [ [ ^^abs-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vbitand) [ [ ^^and-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vbitandn) [ [ ^^andn-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vbitor) [ [ ^^or-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vbitxor) [ [ ^^xor-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vlshift) [ [ ^^shl-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-broadcast) [ [ ^^broadcast-vector ] emit-unary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-hlshift) [ [ ^^horizontal-shl-vector ] emit-horizontal-shift ] }
+ { math.vectors.simd.intrinsics:(simd-hrshift) [ [ ^^horizontal-shr-vector ] emit-horizontal-shift ] }
+ { math.vectors.simd.intrinsics:(simd-with) [ [ ^^with-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] }
{ math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] }
+ { math.vectors.simd.intrinsics:(simd-vshuffle) [ emit-shuffle-vector ] }
+ { math.vectors.simd.intrinsics:(simd-select) [ emit-select-vector ] }
{ math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:alien-vector [ emit-alien-vector ] }
{ math.vectors.simd.intrinsics:set-alien-vector [ emit-set-alien-vector ] }
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors byte-arrays fry cpu.architecture kernel
-sequences compiler.tree.propagation.info
-compiler.cfg.builder.blocks compiler.cfg.stacks
-compiler.cfg.stacks.local compiler.cfg.hats
+USING: accessors byte-arrays fry cpu.architecture kernel math
+sequences math.vectors.simd.intrinsics macros generalizations
+combinators combinators.short-circuit arrays
+compiler.tree.propagation.info compiler.cfg.builder.blocks
+compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.intrinsics.alien ;
IN: compiler.cfg.intrinsics.simd
+MACRO: check-elements ( quots -- )
+ [ length '[ _ firstn ] ]
+ [ '[ _ spread ] ]
+ [ length 1 - \ and <repetition> [ ] like ]
+ tri 3append ;
+
+MACRO: if-literals-match ( quots -- )
+ [ length ] [ ] [ length ] tri
+ ! n quots n n
+ '[
+ ! node quot
+ [
+ dup node-input-infos
+ _ tail-slice* [ literal>> ] map
+ dup _ check-elements
+ ] dip
+ swap [
+ ! node literals quot
+ [ _ firstn ] dip call
+ drop
+ ] [ 2drop emit-primitive ] if
+ ] ;
+
: emit-vector-op ( node quot: ( rep -- ) -- )
- [ dup node-input-infos last literal>> ] dip over representation?
- [ [ drop ] 2dip call ] [ 2drop emit-primitive ] if ; inline
+ { [ representation? ] } if-literals-match ; inline
+
+: [binary] ( quot -- quot' )
+ '[ [ ds-drop 2inputs ] dip @ ds-push ] ; inline
: emit-binary-vector-op ( node quot -- )
- '[ [ ds-drop 2inputs ] dip @ ds-push ] emit-vector-op ; inline
+ [binary] emit-vector-op ; inline
+
+: [unary] ( quot -- quot' )
+ '[ [ ds-drop ds-pop ] dip @ ds-push ] ; inline
: emit-unary-vector-op ( node quot -- )
- '[ [ ds-drop ds-pop ] dip @ ds-push ] emit-vector-op ; inline
+ [unary] emit-vector-op ; inline
+
+: [unary/param] ( quot -- quot' )
+ '[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] ; inline
+
+: emit-horizontal-shift ( node quot -- )
+ [unary/param]
+ { [ integer? ] [ representation? ] } if-literals-match ; inline
: emit-gather-vector-2 ( node -- )
[ ^^gather-vector-2 ] emit-binary-vector-op ;
ds-push
] emit-vector-op ;
+: shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ;
+
+: emit-shuffle-vector ( node -- )
+ [ ^^shuffle-vector ] [unary/param]
+ { [ shuffle? ] [ representation? ] } if-literals-match ;
+
+: ^^broadcast-vector ( src n rep -- dst )
+ [ rep-components swap <array> ] keep
+ ^^shuffle-vector ;
+
+: emit-broadcast-vector ( node -- )
+ [ ^^broadcast-vector ] [unary/param]
+ { [ integer? ] [ representation? ] } if-literals-match ;
+
+: ^^with-vector ( src rep -- dst )
+ [ ^^scalar>vector ] keep [ 0 ] dip ^^broadcast-vector ;
+
+: ^^select-vector ( src n rep -- dst )
+ [ ^^broadcast-vector ] keep ^^vector>scalar ;
+
+: emit-select-vector ( node -- )
+ [ ^^select-vector ] [unary/param]
+ { [ integer? ] [ representation? ] } if-literals-match ; inline
+
: emit-alien-vector ( node -- )
dup [
'[
[ drop assign-blocked-register ]
} cond ;
+: spill-at-sync-point ( live-interval n -- ? )
+ ! If the live interval has a usage at 'n', don't spill it,
+ ! since this means its being defined by the sync point
+ ! instruction. Output t if this is the case.
+ 2dup [ uses>> ] dip swap member? [ 2drop t ] [ spill f ] if ;
+
: handle-sync-point ( n -- )
[ active-intervals get values ] dip
- [ '[ [ _ spill ] each ] each ]
- [ drop [ delete-all ] each ]
- 2bi ;
+ '[ [ _ spill-at-sync-point ] filter-here ] each ;
:: handle-progress ( n sync? -- )
n {
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals
-math sequences sets sorting splitting namespaces
+math sequences sets sorting splitting namespaces linked-assocs
combinators.short-circuit compiler.utilities
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.allocation.splitting
find-use-positions ;
: spill-status ( new -- use-pos )
- H{ } clone
+ H{ } <linked-assoc>
[ inactive-positions ] [ active-positions ] [ nip ] 2tri
>alist alist-max ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators cpu.architecture fry heaps
kernel math math.order namespaces sequences vectors
-compiler.cfg compiler.cfg.registers
-compiler.cfg.linear-scan.live-intervals ;
+linked-assocs compiler.cfg compiler.cfg.registers
+compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.state
! Start index of current live interval. We ensure that all
: next-spill-slot ( rep -- n )
rep-size cfg get
- [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop ;
+ [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop
+ <spill-slot> ;
! Minheap of sync points which still need to be processed
SYMBOL: unhandled-sync-points
! Mapping from vregs to spill slots
SYMBOL: spill-slots
-: vreg-spill-slot ( vreg -- n )
+: vreg-spill-slot ( vreg -- spill-slot )
spill-slots get [ rep-of next-spill-slot ] cache ;
: init-allocator ( registers -- )
! A utility used by register-status and spill-status words
: free-positions ( new -- assoc )
- vreg>> rep-of reg-class-of registers get at [ 1/0. ] H{ } map>assoc ;
+ vreg>> rep-of reg-class-of registers get at
+ [ 1/0. ] H{ } <linked-assoc> map>assoc ;
: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
: (vreg>reg) ( vreg pending -- reg )
! If a live vreg is not in the pending set, then it must
! have been spilled.
- ?at [ spill-slots get ?at [ <spill-slot> ] [ bad-vreg ] if ] unless ;
+ ?at [ spill-slots get ?at [ ] [ bad-vreg ] if ] unless ;
: vreg>reg ( vreg -- reg )
pending-interval-assoc get (vreg>reg) ;
{ end 2 }
{ uses V{ 0 1 } }
{ ranges V{ T{ live-range f 0 2 } } }
- { spill-to 0 }
+ { spill-to T{ spill-slot f 0 } }
}
T{ live-interval
{ vreg 1 }
{ end 5 }
{ uses V{ 5 } }
{ ranges V{ T{ live-range f 5 5 } } }
- { reload-from 0 }
+ { reload-from T{ spill-slot f 0 } }
}
] [
T{ live-interval
{ end 1 }
{ uses V{ 0 } }
{ ranges V{ T{ live-range f 0 1 } } }
- { spill-to 4 }
+ { spill-to T{ spill-slot f 4 } }
}
T{ live-interval
{ vreg 2 }
{ end 5 }
{ uses V{ 1 5 } }
{ ranges V{ T{ live-range f 1 5 } } }
- { reload-from 4 }
+ { reload-from T{ spill-slot f 4 } }
}
] [
T{ live-interval
{ end 1 }
{ uses V{ 0 } }
{ ranges V{ T{ live-range f 0 1 } } }
- { spill-to 8 }
+ { spill-to T{ spill-slot f 8 } }
}
T{ live-interval
{ vreg 3 }
{ end 30 }
{ uses V{ 20 30 } }
{ ranges V{ T{ live-range f 20 30 } } }
- { reload-from 8 }
+ { reload-from T{ spill-slot f 8 } }
}
] [
T{ live-interval
[ _spill ] [ 1 get instructions>> second class ] unit-test
[ _reload ] [ 4 get instructions>> 4 swap nth class ] unit-test
-[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ n>> cell / ] map ] unit-test
-[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> cell / ] map ] unit-test
+[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ dst>> n>> cell / ] map ] unit-test
+[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ src>> n>> cell / ] map ] unit-test
! Resolve pass should insert this
[ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test
[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
-[ { 3 } ] [ 1 get instructions>> first tagged-values>> ] unit-test
+[ { 1 } ] [ 1 get instructions>> first tagged-values>> ] unit-test
V{
T{ ##peek f 0 D 0 }
[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
-[ { 3 } ] [ 1 get instructions>> first tagged-values>> ] unit-test
+[ { 1 } ] [ 1 get instructions>> first tagged-values>> ] unit-test
[
{
- T{ _reload { dst 1 } { rep int-rep } { n 0 } }
+ T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 0 } } }
}
] [
[
[
{
- T{ _spill { src 1 } { rep int-rep } { n 0 } }
+ T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 0 } } }
}
] [
[
{ { { 0 int-rep } { 1 int-rep } } { { 1 int-rep } { 0 int-rep } } }
mapping-instructions {
{
- T{ _spill { src 0 } { rep int-rep } { n 8 } }
+ T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } }
T{ ##copy { dst 0 } { src 1 } { rep int-rep } }
- T{ _reload { dst 1 } { rep int-rep } { n 8 } }
+ T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 8 } } }
}
{
- T{ _spill { src 1 } { rep int-rep } { n 8 } }
+ T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 8 } } }
T{ ##copy { dst 1 } { src 0 } { rep int-rep } }
- T{ _reload { dst 0 } { rep int-rep } { n 8 } }
+ T{ _reload { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } }
}
} member?
] unit-test
] if ;
: memory->register ( from to -- )
- swap [ first2 ] [ first n>> ] bi* _reload ;
+ swap [ first2 ] [ first ] bi* _reload ;
: register->memory ( from to -- )
- [ first2 ] [ first n>> ] bi* _spill ;
+ [ first2 ] [ first ] bi* _spill ;
: temp->register ( from to -- )
nip [ first ] [ second ] [ second spill-temp ] tri _reload ;
compiler.cfg.dce
compiler.cfg.write-barrier
compiler.cfg.representations
-compiler.cfg.two-operand
compiler.cfg.ssa.destruction
compiler.cfg.empty-blocks
compiler.cfg.checker ;
eliminate-dead-code
eliminate-write-barriers
select-representations
- convert-two-operand
destruct-ssa
delete-empty-blocks
?check ;
! Copyright (C) 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel fry accessors sequences assocs sets namespaces
-arrays combinators make locals deques dlists layouts
-cpu.architecture compiler.utilities
+arrays combinators combinators.short-circuit make locals deques
+dlists layouts cpu.architecture compiler.utilities
compiler.cfg
compiler.cfg.rpo
compiler.cfg.hats
H{ } clone [
'[
[
- dup ##load-reference? [ drop ] [
- [ _ (compute-always-boxed) ] each-def-rep
- ] if
+ dup [ ##load-reference? ] [ ##load-constant? ] bi or
+ [ drop ] [ [ _ (compute-always-boxed) ] each-def-rep ] if
] each-non-phi
] each-basic-block
] keep ;
M: ##phi conversions-for-insn
[ , ] [ [ inputs>> values ] [ dst>> ] bi phi-mappings get set-at ] bi ;
+! When a literal zero vector is unboxed, we replace the ##load-reference
+! with a ##zero-vector instruction since this is more efficient.
+: convert-to-zero-vector? ( insn -- ? )
+ {
+ [ dst>> rep-of vector-rep? ]
+ [ obj>> B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } = ]
+ } 1&& ;
+
+: convert-to-zero-vector ( insn -- )
+ dst>> dup rep-of ##zero-vector ;
+
+M: ##load-reference conversions-for-insn
+ dup convert-to-zero-vector?
+ [ convert-to-zero-vector ] [ call-next-method ] if ;
+
+M: ##load-constant conversions-for-insn
+ dup convert-to-zero-vector?
+ [ convert-to-zero-vector ] [ call-next-method ] if ;
+
M: vreg-insn conversions-for-insn
[ compute-renaming-set ] [ perform-renaming ] bi ;
compiler.cfg.rpo
compiler.cfg.def-use
compiler.cfg.renaming
+compiler.cfg.registers
compiler.cfg.dominance
compiler.cfg.instructions
compiler.cfg.liveness.ssa
GENERIC: prepare-insn ( insn -- )
+: try-to-coalesce ( dst src -- ) 2array copies get push ;
+
+M: insn prepare-insn
+ [ defs-vreg ] [ uses-vregs ] bi
+ 2dup empty? not and [
+ first
+ 2dup [ rep-of ] bi@ eq?
+ [ try-to-coalesce ] [ 2drop ] if
+ ] [ 2drop ] if ;
+
M: ##copy prepare-insn
- [ dst>> ] [ src>> ] bi 2array copies get push ;
+ [ dst>> ] [ src>> ] bi try-to-coalesce ;
M: ##phi prepare-insn
[ dst>> ] [ inputs>> values ] bi
[ eliminate-copy ] with each ;
-M: insn prepare-insn drop ;
-
: prepare-block ( bb -- )
instructions>> [ prepare-insn ] each ;
SYMBOLS: local-def-indices local-kill-indices ;
-: record-def ( n vreg -- )
+: record-def ( n insn -- )
! We allow multiple defs of a vreg as long as they're
! all in the same basic block
- dup [
+ defs-vreg dup [
local-def-indices get 2dup key?
[ 3drop ] [ set-at ] if
] [ 2drop ] if ;
-: record-uses ( n vregs -- )
- local-kill-indices get '[ _ set-at ] with each ;
+: record-uses ( n insn -- )
+ ! Record live intervals so that all but the first input interfere
+ ! with the output. This lets us coalesce the output with the
+ ! first input.
+ [ uses-vregs ] [ def-is-use-insn? ] bi over empty? [ 3drop ] [
+ [ [ first local-kill-indices get set-at ] [ rest-slice ] 2bi ] unless
+ [ 1 + ] dip [ local-kill-indices get set-at ] with each
+ ] if ;
: visit-insn ( insn n -- )
- ! Instructions are numbered 2 apart. If the instruction requires
- ! that outputs are in different registers than the inputs, then
- ! a use will be registered for every output immediately after
- ! this instruction and before the next one, ensuring that outputs
- ! interfere with inputs.
- 2 *
- [ swap defs-vreg record-def ]
- [ swap uses-vregs record-uses ]
- [ over def-is-use-insn? [ 1 + swap defs-vreg 1array record-uses ] [ 2drop ] if ]
- 2tri ;
+ 2 * swap [ record-def ] [ record-uses ] 2bi ;
SYMBOLS: def-indices kill-indices ;
+++ /dev/null
-Converting three-operand instructions into two-operand form
+++ /dev/null
-USING: kernel compiler.cfg.two-operand compiler.cfg.instructions
-compiler.cfg.registers cpu.architecture namespaces tools.test ;
-IN: compiler.cfg.two-operand.tests
-
-3 vreg-counter set-global
-
-[
- V{
- T{ ##copy f 1 2 int-rep }
- T{ ##sub f 1 1 3 }
- }
-] [
- H{
- { 1 int-rep }
- { 2 int-rep }
- { 3 int-rep }
- } clone representations set
- {
- T{ ##sub f 1 2 3 }
- } (convert-two-operand)
-] unit-test
-
-[
- V{
- T{ ##copy f 1 2 double-rep }
- T{ ##sub-float f 1 1 3 }
- }
-] [
- H{
- { 1 double-rep }
- { 2 double-rep }
- { 3 double-rep }
- } clone representations set
- {
- T{ ##sub-float f 1 2 3 }
- } (convert-two-operand)
-] unit-test
-
-[
- V{
- T{ ##copy f 1 2 double-rep }
- T{ ##mul-float f 1 1 1 }
- }
-] [
- H{
- { 1 double-rep }
- { 2 double-rep }
- } clone representations set
- {
- T{ ##mul-float f 1 2 2 }
- } (convert-two-operand)
-] unit-test
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences make combinators
-compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.rpo cpu.architecture ;
-IN: compiler.cfg.two-operand
-
-! This pass runs before SSA coalescing and normalizes instructions
-! to fit the x86 two-address scheme. Since the input is in SSA,
-! it suffices to convert
-!
-! x = y op z
-!
-! to
-!
-! x = y
-! x = x op z
-!
-! We don't bother with ##add, ##add-imm, ##sub-imm or ##mul-imm
-! since x86 has LEA and IMUL instructions which are effectively
-! three-operand addition and multiplication, respectively.
-
-UNION: two-operand-insn
- ##sub
- ##mul
- ##and
- ##and-imm
- ##or
- ##or-imm
- ##xor
- ##xor-imm
- ##shl
- ##shl-imm
- ##shr
- ##shr-imm
- ##sar
- ##sar-imm
- ##min
- ##max
- ##fixnum-add
- ##fixnum-sub
- ##fixnum-mul
- ##add-float
- ##sub-float
- ##mul-float
- ##div-float
- ##min-float
- ##max-float
- ##add-vector
- ##saturated-add-vector
- ##add-sub-vector
- ##sub-vector
- ##saturated-sub-vector
- ##mul-vector
- ##saturated-mul-vector
- ##div-vector
- ##min-vector
- ##max-vector
- ##and-vector
- ##or-vector
- ##xor-vector
- ##shl-vector
- ##shr-vector ;
-
-GENERIC: convert-two-operand* ( insn -- )
-
-: emit-copy ( dst src -- )
- dup rep-of ##copy ; inline
-
-M: two-operand-insn convert-two-operand*
- [ [ dst>> ] [ src1>> ] bi emit-copy ]
- [
- dup [ src1>> ] [ src2>> ] bi = [ dup dst>> >>src2 ] when
- dup dst>> >>src1 ,
- ] bi ;
-
-M: ##not convert-two-operand*
- [ [ dst>> ] [ src>> ] bi emit-copy ]
- [ dup dst>> >>src , ]
- bi ;
-
-M: insn convert-two-operand* , ;
-
-: (convert-two-operand) ( insns -- insns' )
- dup first kill-vreg-insn? [
- [ [ convert-two-operand* ] each ] V{ } make
- ] unless ;
-
-: convert-two-operand ( cfg -- cfg' )
- two-operand? [ [ (convert-two-operand) ] local-optimization ] when ;
\ No newline at end of file
M: constant-expr equal?
over constant-expr? [
- {
- [ [ value>> class ] bi@ = ]
- [ [ value>> ] bi@ = ]
- } 2&&
+ [ value>> ] bi@
+ 2dup [ float? ] both? [ fp-bitwise= ] [
+ { [ [ class ] bi@ = ] [ = ] } 2&&
+ ] if
] [ 2drop f ] if ;
TUPLE: reference-expr < expr value ;
C: <reference> reference-expr
M: reference-expr equal?
- over reference-expr? [
- [ value>> ] bi@ {
- { [ 2dup eq? ] [ 2drop t ] }
- { [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
- [ 2drop f ]
- } cond
- ] [ 2drop f ] if ;
+ over reference-expr? [ [ value>> ] bi@ eq? ] [ 2drop f ] if ;
: constant>vn ( constant -- vn ) <constant> expr>vn ; inline
M: ##load-reference >expr obj>> <reference> ;
+M: ##load-constant >expr obj>> <constant> ;
+
<<
: input-values ( slot-specs -- slot-specs' )
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit arrays
fry kernel layouts math namespaces sequences cpu.architecture
-math.bitwise math.order classes vectors locals make
+math.bitwise math.order math.vectors.simd.intrinsics classes
+vectors locals make alien.c-types io.binary grouping
compiler.cfg
compiler.cfg.registers
compiler.cfg.comparisons
: vreg-small-constant? ( vreg -- ? )
vreg>expr {
[ constant-expr? ]
+ [ value>> fixnum? ]
[ value>> small-enough? ]
} 1&& ;
: >boolean-insn ( insn ? -- insn' )
[ dst>> ] dip
{
- { t [ t \ ##load-reference new-insn ] }
+ { t [ t \ ##load-constant new-insn ] }
{ f [ \ f tag-number \ ##load-immediate new-insn ] }
} case ;
[ sub-imm>add-imm ]
} cond ;
-: strength-reduce-mul ( insn -- insn' )
- [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
+: mul-to-neg? ( insn -- ? )
+ src2>> -1 = ;
+
+: mul-to-neg ( insn -- insn' )
+ [ dst>> ] [ src1>> ] bi \ ##neg new-insn ;
-: strength-reduce-mul? ( insn -- ? )
+: mul-to-shl? ( insn -- ? )
src2>> power-of-2? ;
+: mul-to-shl ( insn -- insn' )
+ [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
+
M: ##mul-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
- { [ dup strength-reduce-mul? ] [ strength-reduce-mul ] }
+ { [ dup mul-to-neg? ] [ mul-to-neg ] }
+ { [ dup mul-to-shl? ] [ mul-to-shl ] }
{ [ dup src1>> vreg>expr mul-imm-expr? ] [ \ ##mul-imm reassociate ] }
[ drop f ]
} cond ;
: rewrite-subtraction-identity ( insn -- insn' )
dst>> 0 \ ##load-immediate new-insn ;
+: sub-to-neg? ( ##sub -- ? )
+ src1>> vn>expr expr-zero? ;
+
+: sub-to-neg ( ##sub -- insn )
+ [ dst>> ] [ src2>> ] bi \ ##neg new-insn ;
+
M: ##sub rewrite
{
+ { [ dup sub-to-neg? ] [ sub-to-neg ] }
{ [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] }
[ \ ##sub-imm rewrite-arithmetic ]
} cond ;
M: ##unbox-any-c-ptr rewrite
dup src>> vreg>expr dup box-displaced-alien-expr?
[ rewrite-unbox-displaced-alien ] [ 2drop f ] if ;
+
+! More efficient addressing for alien intrinsics
+: rewrite-alien-addressing ( insn -- insn' )
+ dup src>> vreg>expr dup add-imm-expr? [
+ [ src1>> vn>vreg ] [ src2>> vn>constant ] bi
+ [ >>src ] [ '[ _ + ] change-offset ] bi*
+ ] [ 2drop f ] if ;
+
+M: ##alien-unsigned-1 rewrite rewrite-alien-addressing ;
+M: ##alien-unsigned-2 rewrite rewrite-alien-addressing ;
+M: ##alien-unsigned-4 rewrite rewrite-alien-addressing ;
+M: ##alien-signed-1 rewrite rewrite-alien-addressing ;
+M: ##alien-signed-2 rewrite rewrite-alien-addressing ;
+M: ##alien-signed-4 rewrite rewrite-alien-addressing ;
+M: ##alien-float rewrite rewrite-alien-addressing ;
+M: ##alien-double rewrite rewrite-alien-addressing ;
+M: ##alien-vector rewrite rewrite-alien-addressing ;
+M: ##set-alien-integer-1 rewrite rewrite-alien-addressing ;
+M: ##set-alien-integer-2 rewrite rewrite-alien-addressing ;
+M: ##set-alien-integer-4 rewrite rewrite-alien-addressing ;
+M: ##set-alien-float rewrite rewrite-alien-addressing ;
+M: ##set-alien-double rewrite rewrite-alien-addressing ;
+M: ##set-alien-vector rewrite rewrite-alien-addressing ;
+
+! Some lame constant folding for SIMD intrinsics. Eventually this
+! should be redone completely.
+
+: rewrite-shuffle-vector ( insn expr -- insn' )
+ 2dup [ rep>> ] bi@ eq? [
+ [ [ dst>> ] [ src>> vn>vreg ] bi* ]
+ [ [ shuffle>> ] bi@ nths ]
+ [ drop rep>> ]
+ 2tri \ ##shuffle-vector new-insn
+ ] [ 2drop f ] if ;
+
+: (fold-shuffle-vector) ( shuffle bytes -- bytes' )
+ 2dup length swap length /i group nths concat ;
+
+: fold-shuffle-vector ( insn expr -- insn' )
+ [ [ dst>> ] [ shuffle>> ] bi ] dip value>>
+ (fold-shuffle-vector) \ ##load-constant new-insn ;
+
+M: ##shuffle-vector rewrite
+ dup src>> vreg>expr {
+ { [ dup shuffle-vector-expr? ] [ rewrite-shuffle-vector ] }
+ { [ dup reference-expr? ] [ fold-shuffle-vector ] }
+ { [ dup constant-expr? ] [ fold-shuffle-vector ] }
+ [ 2drop f ]
+ } cond ;
+
+: (fold-scalar>vector) ( insn bytes -- insn' )
+ [ [ dst>> ] [ rep>> rep-components ] bi ] dip <repetition> concat
+ \ ##load-constant new-insn ;
+
+: fold-scalar>vector ( insn expr -- insn' )
+ value>> over rep>> {
+ { float-4-rep [ float>bits 4 >le (fold-scalar>vector) ] }
+ { double-2-rep [ double>bits 8 >le (fold-scalar>vector) ] }
+ [ rep-component-type heap-size >le (fold-scalar>vector) ]
+ } case ;
+
+M: ##scalar>vector rewrite
+ dup src>> vreg>expr dup constant-expr?
+ [ fold-scalar>vector ] [ 2drop f ] if ;
+
+M: ##xor-vector rewrite
+ dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
+ [ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators classes math layouts
+sequences math.vectors.simd.intrinsics
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions ;
: expr-one? ( expr -- ? ) T{ constant-expr f 1 } = ; inline
+: expr-neg-one? ( expr -- ? ) T{ constant-expr f -1 } = ; inline
+
+: >unary-expr< ( expr -- in ) src>> vn>expr ; inline
+
+M: neg-expr simplify*
+ >unary-expr< {
+ { [ dup neg-expr? ] [ src>> ] }
+ [ drop f ]
+ } cond ;
+
+M: not-expr simplify*
+ >unary-expr< {
+ { [ dup not-expr? ] [ src>> ] }
+ [ drop f ]
+ } cond ;
+
: >binary-expr< ( expr -- in1 in2 )
[ src1>> vn>expr ] [ src2>> vn>expr ] bi ; inline
[ 2drop f ]
} cond ;
+M: scalar>vector-expr simplify*
+ src>> vn>expr {
+ { [ dup vector>scalar-expr? ] [ src>> ] }
+ [ drop f ]
+ } cond ;
+
+M: shuffle-vector-expr simplify*
+ [ src>> ] [ shuffle>> ] [ rep>> rep-components iota ] tri
+ sequence= [ drop f ] unless ;
+
M: expr simplify* drop f ;
: simplify ( expr -- vn )
! Folding constants together
[
{
- T{ ##load-reference f 0 0.0 }
- T{ ##load-reference f 1 -0.0 }
+ T{ ##load-constant f 0 0.0 }
+ T{ ##load-constant f 1 -0.0 }
T{ ##replace f 0 D 0 }
T{ ##replace f 1 D 1 }
}
] [
{
- T{ ##load-reference f 0 0.0 }
- T{ ##load-reference f 1 -0.0 }
+ T{ ##load-constant f 0 0.0 }
+ T{ ##load-constant f 1 -0.0 }
T{ ##replace f 0 D 0 }
T{ ##replace f 1 D 1 }
} value-numbering-step
[
{
- T{ ##load-reference f 0 0.0 }
+ T{ ##load-constant f 0 0.0 }
T{ ##copy f 1 0 any-rep }
T{ ##replace f 0 D 0 }
T{ ##replace f 1 D 1 }
}
] [
{
- T{ ##load-reference f 0 0.0 }
- T{ ##load-reference f 1 0.0 }
+ T{ ##load-constant f 0 0.0 }
+ T{ ##load-constant f 1 0.0 }
T{ ##replace f 0 D 0 }
T{ ##replace f 1 D 1 }
} value-numbering-step
[
{
- T{ ##load-reference f 0 t }
+ T{ ##load-constant f 0 t }
T{ ##copy f 1 0 any-rep }
T{ ##replace f 0 D 0 }
T{ ##replace f 1 D 1 }
}
] [
{
- T{ ##load-reference f 0 t }
- T{ ##load-reference f 1 t }
+ T{ ##load-constant f 0 t }
+ T{ ##load-constant f 1 t }
T{ ##replace f 0 D 0 }
T{ ##replace f 1 D 1 }
} value-numbering-step
} value-numbering-step
] unit-test
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 -1 }
+ T{ ##neg f 2 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 -1 }
+ T{ ##mul f 2 0 1 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 -1 }
+ T{ ##neg f 2 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 -1 }
+ T{ ##mul f 2 1 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 0 }
+ T{ ##neg f 2 0 }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 0 }
+ T{ ##sub f 2 1 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 0 }
+ T{ ##neg f 2 0 }
+ T{ ##copy f 3 0 any-rep }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-immediate f 1 0 }
+ T{ ##sub f 2 1 0 }
+ T{ ##sub f 3 1 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##not f 1 0 }
+ T{ ##copy f 2 0 any-rep }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##not f 1 0 }
+ T{ ##not f 2 1 }
+ } value-numbering-step
+] unit-test
+
[
{
T{ ##peek f 0 D 0 }
} value-numbering-step trim-temps
] unit-test
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-constant f 1 3.5 }
+ T{ ##compare f 2 0 1 cc= }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-constant f 1 3.5 }
+ T{ ##compare f 2 0 1 cc= }
+ } value-numbering-step trim-temps
+] unit-test
+
[
{
T{ ##peek f 0 D 0 }
} value-numbering-step
] unit-test
+[
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-constant f 1 3.5 }
+ T{ ##compare-branch f 0 1 cc= }
+ }
+] [
+ {
+ T{ ##peek f 0 D 0 }
+ T{ ##load-constant f 1 3.5 }
+ T{ ##compare-branch f 0 1 cc= }
+ } value-numbering-step trim-temps
+] unit-test
+
[
{
T{ ##peek f 0 D 0 }
{
T{ ##load-immediate f 1 1 }
T{ ##load-immediate f 2 2 }
- T{ ##load-reference f 3 t }
+ T{ ##load-constant f 3 t }
}
] [
{
{
T{ ##load-immediate f 1 1 }
T{ ##load-immediate f 2 2 }
- T{ ##load-reference f 3 t }
+ T{ ##load-constant f 3 t }
}
] [
{
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-reference f 1 t }
+ T{ ##load-constant f 1 t }
}
] [
{
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-reference f 1 t }
+ T{ ##load-constant f 1 t }
}
] [
{
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-reference f 1 t }
+ T{ ##load-constant f 1 t }
}
] [
{
} value-numbering-step
] unit-test
+[
+ {
+ T{ ##vector>scalar f 1 0 float-4-rep }
+ T{ ##copy f 2 0 any-rep }
+ }
+] [
+ {
+ T{ ##vector>scalar f 1 0 float-4-rep }
+ T{ ##scalar>vector f 2 1 float-4-rep }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##copy f 1 0 any-rep }
+ }
+] [
+ {
+ T{ ##shuffle-vector f 1 0 { 0 1 2 3 } float-4-rep }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##shuffle-vector f 1 0 { 1 2 3 0 } float-4-rep }
+ T{ ##shuffle-vector f 2 0 { 0 2 3 1 } float-4-rep }
+ }
+] [
+ {
+ T{ ##shuffle-vector f 1 0 { 1 2 3 0 } float-4-rep }
+ T{ ##shuffle-vector f 2 1 { 3 1 2 0 } float-4-rep }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##shuffle-vector f 1 0 { 1 2 3 0 } float-4-rep }
+ T{ ##shuffle-vector f 2 1 { 1 0 } double-2-rep }
+ }
+] [
+ {
+ T{ ##shuffle-vector f 1 0 { 1 2 3 0 } float-4-rep }
+ T{ ##shuffle-vector f 2 1 { 1 0 } double-2-rep }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##load-constant f 0 1.25 }
+ T{ ##load-constant f 1 B{ 0 0 160 63 0 0 160 63 0 0 160 63 0 0 160 63 } }
+ T{ ##copy f 2 1 any-rep }
+ }
+] [
+ {
+ T{ ##load-constant f 0 1.25 }
+ T{ ##scalar>vector f 1 0 float-4-rep }
+ T{ ##shuffle-vector f 2 1 { 0 0 0 0 } float-4-rep }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##zero-vector f 2 float-4-rep }
+ }
+] [
+ {
+ T{ ##xor-vector f 2 1 1 float-4-rep }
+ } value-numbering-step
+] unit-test
+
: test-branch-folding ( insns -- insns' n )
<basic-block>
[ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-reference f 1 t }
+ T{ ##load-constant f 1 t }
T{ ##branch }
}
0
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
CODEGEN: ##load-immediate %load-immediate
CODEGEN: ##load-reference %load-reference
+CODEGEN: ##load-constant %load-reference
CODEGEN: ##peek %peek
CODEGEN: ##replace %replace
CODEGEN: ##inc-d %inc-d
CODEGEN: ##min %min
CODEGEN: ##max %max
CODEGEN: ##not %not
+CODEGEN: ##neg %neg
CODEGEN: ##log2 %log2
CODEGEN: ##copy %copy
-CODEGEN: ##integer>bignum %integer>bignum
-CODEGEN: ##bignum>integer %bignum>integer
CODEGEN: ##unbox-float %unbox-float
CODEGEN: ##box-float %box-float
CODEGEN: ##add-float %add-float
CODEGEN: ##integer>float %integer>float
CODEGEN: ##float>integer %float>integer
CODEGEN: ##unbox-vector %unbox-vector
-CODEGEN: ##broadcast-vector %broadcast-vector
+CODEGEN: ##zero-vector %zero-vector
CODEGEN: ##gather-vector-2 %gather-vector-2
CODEGEN: ##gather-vector-4 %gather-vector-4
+CODEGEN: ##shuffle-vector %shuffle-vector
CODEGEN: ##box-vector %box-vector
CODEGEN: ##add-vector %add-vector
CODEGEN: ##saturated-add-vector %saturated-add-vector
CODEGEN: ##div-vector %div-vector
CODEGEN: ##min-vector %min-vector
CODEGEN: ##max-vector %max-vector
+CODEGEN: ##dot-vector %dot-vector
CODEGEN: ##sqrt-vector %sqrt-vector
CODEGEN: ##horizontal-add-vector %horizontal-add-vector
+CODEGEN: ##horizontal-sub-vector %horizontal-sub-vector
+CODEGEN: ##horizontal-shl-vector %horizontal-shl-vector
+CODEGEN: ##horizontal-shr-vector %horizontal-shr-vector
CODEGEN: ##abs-vector %abs-vector
CODEGEN: ##and-vector %and-vector
+CODEGEN: ##andn-vector %andn-vector
CODEGEN: ##or-vector %or-vector
CODEGEN: ##xor-vector %xor-vector
CODEGEN: ##shl-vector %shl-vector
CODEGEN: ##shr-vector %shr-vector
CODEGEN: ##integer>scalar %integer>scalar
CODEGEN: ##scalar>integer %scalar>integer
+CODEGEN: ##vector>scalar %vector>scalar
+CODEGEN: ##scalar>vector %scalar>vector
CODEGEN: ##box-alien %box-alien
CODEGEN: ##box-displaced-alien %box-displaced-alien
CODEGEN: ##unbox-alien %unbox-alien
GENERIC# save-gc-root 1 ( gc-root operand temp -- )
M:: spill-slot save-gc-root ( gc-root operand temp -- )
- temp int-rep operand n>> %reload
+ temp int-rep operand %reload
gc-root temp %save-gc-root ;
M: object save-gc-root drop %save-gc-root ;
M:: spill-slot load-gc-root ( gc-root operand temp -- )
gc-root temp %load-gc-root
- temp int-rep operand n>> %spill ;
+ temp int-rep operand %spill ;
M: object load-gc-root drop %load-gc-root ;
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 )
dup recompile-callers?
[ compiled-usage keys [ queue-compile ] each ] [ drop ] if ;
+: compiler-message ( string -- )
+ "trace-compilation" get [ global [ print flush ] bind ] [ drop ] if ;
+
: start ( word -- )
- "trace-compilation" get [ dup name>> print flush ] when
+ dup name>> compiler-message
H{ } clone dependencies set
H{ } clone generic-dependencies set
clear-compiler-error ;
compile-queue get compile-loop
compiled get >alist
] with-scope
- "trace-compilation" get [ "--- compile done" print flush ] when ;
+ "--- compile done" compiler-message ;
: with-optimizer ( quot -- )
[ optimizing-compiler compiler-impl ] dip with-variable ; inline
io.streams.string kernel math memory namespaces
namespaces.private parser quotations sequences
specialized-arrays stack-checker stack-checker.errors
-system threads tools.test words ;
+system threads tools.test words alien.complex ;
FROM: alien.c-types => float short ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: char
-USING: generalizations accessors arrays compiler kernel kernel.private
-math hashtables.private math.private namespaces sequences tools.test
-namespaces.private slots.private sequences.private byte-arrays alien
-alien.accessors layouts words definitions compiler.units io
-combinators vectors grouping make alien.c-types combinators.short-circuit
-math.order math.libm math.parser alien.c-types ;
+USING: generalizations accessors arrays compiler kernel
+kernel.private math hashtables.private math.private namespaces
+sequences tools.test namespaces.private slots.private
+sequences.private byte-arrays alien alien.accessors layouts
+words definitions compiler.units io combinators vectors grouping
+make alien.c-types combinators.short-circuit math.order
+math.libm math.parser math.functions alien.syntax ;
FROM: math => float ;
QUALIFIED: namespaces.private
IN: compiler.tests.codegen
] compile-call
] unit-test
+! Bug in CSSA construction
TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-only } ;
[ 2 ] [
] 2curry each-integer
] compile-call
] unit-test
+
+! Bug in linear scan's partial sync point logic
+[ t ] [
+ [ 1.0 100 [ fsin ] times 1.0 float+ ] compile-call
+ 1.168852488727981 1.e-9 ~
+] unit-test
+
+[ 65537.0 ] [
+ [ 2.0 4 [ 2.0 fpow ] times 1.0 float+ ] compile-call
+] unit-test
+
+! ##box-displaced-alien is a def-is-use instruction
+[ ALIEN: 3e9 ] [
+ [
+ f
+ 100 [ 10 swap <displaced-alien> ] times
+ 1 swap <displaced-alien>
+ ] compile-call
+] unit-test
+
+! Forgot to two-operand shifts
+[ 2 0 ] [
+ 1 1
+ [ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call
+] unit-test
\ No newline at end of file
T{ ##add-imm f 0 0 -8 }
} compile-test-bb
] unit-test
-
-! These are def-is-use-insns
-USE: multiline
-
-/*
-
-[ 100 ] [
- V{
- T{ ##load-immediate f 0 100 }
- T{ ##integer>bignum f 0 0 1 }
- } compile-test-bb
-] unit-test
-
-[ 1 ] [
- V{
- T{ ##load-reference f 0 ALIEN: 8 }
- T{ ##unbox-any-c-ptr f 0 0 1 }
- } compile-test-bb
-] unit-test
-
-*/
math.intervals quotations effects alien alien.data ;
FROM: math => float ;
SPECIALIZED-ARRAY: double
+SPECIALIZED-ARRAY: void*
IN: compiler.tree.propagation.tests
[ V{ } ] [ [ ] final-classes ] unit-test
! We want this to inline
[ t ] [ [ void* <c-direct-array> ] { <c-direct-array> } inlined? ] unit-test
+[ V{ void*-array } ] [ [ void* <c-direct-array> ] final-classes ] unit-test
(simd-vabs)
(simd-vsqrt)
(simd-vbitand)
+ (simd-vbitandn)
(simd-vbitor)
(simd-vbitxor)
(simd-vlshift)
(simd-vrshift)
- (simd-broadcast)
+ (simd-hlshift)
+ (simd-hrshift)
+ (simd-vshuffle)
+ (simd-with)
(simd-gather-2)
(simd-gather-4)
alien-vector
} [ { byte-array } "default-output-classes" set-word-prop ] each
-\ (simd-sum) [
- nip dup literal?>> [
+: scalar-output-class ( rep -- class )
+ dup literal?>> [
literal>> scalar-rep-of {
{ float-rep [ float ] }
{ double-rep [ float ] }
- [ integer ]
+ [ drop integer ]
} case
] [ drop real ] if
- <class-info>
-] "outputs" set-word-prop
+ <class-info> ;
+
+\ (simd-sum) [ nip scalar-output-class ] "outputs" set-word-prop
+
+\ (simd-v.) [ 2nip scalar-output-class ] "outputs" set-word-prop
+
+\ (simd-select) [ 2nip scalar-output-class ] "outputs" set-word-prop
\ assert-positive [
real [0,inf] <class/interval-info> value-info-intersect
: alist-most ( alist quot -- pair )
[ [ ] ] dip '[ [ [ second ] bi@ @ ] most ] map-reduce ; inline
-: alist-min ( alist -- pair ) [ before? ] alist-most ;
+: alist-min ( alist -- pair ) [ before=? ] alist-most ;
-: alist-max ( alist -- pair ) [ after? ] alist-most ;
+: alist-max ( alist -- pair ) [ after=? ] alist-most ;
: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs byte-arrays
-byte-vectors combinators fry grouping hashtables
-compression.huffman images io.binary kernel locals
-math math.bitwise math.order math.ranges multiline sequences
-sorting ;
+USING: accessors arrays assocs byte-vectors combinators
+compression.huffman fry hashtables io.binary kernel locals math
+math.bitwise math.order math.ranges sequences sorting ;
+QUALIFIED-WITH: bitstreams bs
IN: compression.inflate
QUALIFIED-WITH: bitstreams bs
case
]
[ produce ] keep call suffix concat ;
-
- ! [ produce ] keep dip swap suffix
-
-:: paeth ( a b c -- p )
- a b + c - { a b c } [ [ - abs ] keep 2array ] with map
- sort-keys first second ;
-
-:: png-unfilter-line ( prev curr filter -- curr' )
- prev :> c
- prev 3 tail-slice :> b
- curr :> a
- curr 3 tail-slice :> x
- x length [0,b)
- filter {
- { 0 [ drop ] }
- { 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
- { 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
- { 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
- { 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
- } case
- curr 3 tail ;
PRIVATE>
-: reverse-png-filter' ( lines -- byte-array )
- [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
- concat [ 128 + ] B{ } map-as ;
-
-: reverse-png-filter ( lines -- byte-array )
- dup first length 0 <array> prefix
- [ { 0 0 } prepend ] map
- 2 clump [
- first2 dup [ third ] [ [ 0 2 ] dip set-nth ] bi
- png-unfilter-line
- ] map B{ } concat-as ;
-
: zlib-inflate ( bytes -- bytes )
bs:<lsb0-bit-reader>
[ check-zlib-header ] [ inflate-loop ] bi
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax combinators system alien.libraries ;
+USING: alien alien.c-types alien.syntax combinators system
+alien.libraries ;
IN: compression.zlib.ffi
<< "zlib" {
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel sequences fry ;
+USING: alien.c-types alien.syntax core-foundation kernel
+sequences fry ;
IN: core-foundation.arrays
TYPEDEF: void* CFArrayRef
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel destructors core-foundation
+USING: alien.c-types alien.syntax kernel destructors
+core-foundation core-foundation.dictionaries
+core-foundation.strings
core-foundation.utilities ;
IN: core-foundation.attributed-strings
[
[ >cf &CFRelease ] bi@
[ kCFAllocatorDefault ] 2dip CFAttributedStringCreate
- ] with-destructors ;
\ No newline at end of file
+ ] with-destructors ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel sequences core-foundation
-core-foundation.urls ;
+USING: alien.c-types alien.syntax kernel sequences
+core-foundation core-foundation.urls ;
IN: core-foundation.bundles
TYPEDEF: void* CFBundleRef
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax kernel math sequences ;
+USING: alien.c-types alien.syntax core-foundation kernel math
+sequences ;
IN: core-foundation.data
TYPEDEF: void* CFDataRef
FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
: <CFData> ( byte-array -- alien )
- [ f ] dip dup length CFDataCreate ;
\ No newline at end of file
+ [ f ] dip dup length CFDataCreate ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax core-foundation kernel assocs
+USING: alien.c-types alien.syntax core-foundation kernel assocs
specialized-arrays math sequences accessors ;
IN: core-foundation.dictionaries
TYPEDEF: void* CFDictionaryRef
TYPEDEF: void* CFMutableDictionaryRef
-TYPEDEF: void* CFDictionaryKeyCallBacks*
-TYPEDEF: void* CFDictionaryValueCallBacks*
+C-TYPE: CFDictionaryKeyCallBacks
+C-TYPE: CFDictionaryValueCallBacks
FUNCTION: CFDictionaryRef CFDictionaryCreate (
CFAllocatorRef allocator,
[ [ underlying>> ] bi@ ] [ nip length ] 2bi
&: kCFTypeDictionaryKeyCallBacks
&: kCFTypeDictionaryValueCallBacks
- CFDictionaryCreate ;
\ No newline at end of file
+ CFDictionaryCreate ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel math.bitwise core-foundation ;
+USING: alien.c-types alien.syntax kernel math.bitwise core-foundation ;
IN: core-foundation.file-descriptors
TYPEDEF: void* CFFileDescriptorRef
TYPEDEF: int CFFileDescriptorNativeDescriptor
TYPEDEF: void* CFFileDescriptorCallBack
+C-TYPE: CFFileDescriptorContext
FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate (
CFAllocatorRef allocator,
math sequences namespaces make assocs init accessors
continuations combinators io.encodings.utf8 destructors locals
arrays specialized-arrays classes.struct core-foundation
-core-foundation.run-loop core-foundation.strings
-core-foundation.time ;
+core-foundation.arrays core-foundation.run-loop
+core-foundation.strings core-foundation.time unix.types ;
IN: core-foundation.fsevents
SPECIALIZED-ARRAY: void*
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.syntax kernel math namespaces
-sequences destructors combinators threads heaps deques calendar
-core-foundation core-foundation.strings
+USING: accessors alien alien.c-types alien.syntax kernel math
+namespaces sequences destructors combinators threads heaps
+deques calendar core-foundation core-foundation.strings
core-foundation.file-descriptors core-foundation.timers
core-foundation.time ;
IN: core-foundation.run-loop
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax alien.strings io.encodings.string kernel
-sequences byte-arrays io.encodings.utf8 math core-foundation
+USING: alien.c-types alien.syntax alien.strings io.encodings.string
+kernel sequences byte-arrays io.encodings.utf8 math core-foundation
core-foundation.arrays destructors parser fry alien words ;
IN: core-foundation.strings
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: calendar alien.syntax ;
+USING: calendar alien.c-types alien.syntax ;
IN: core-foundation.time
TYPEDEF: double CFTimeInterval
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax system math kernel calendar core-foundation
-core-foundation.time ;
+USING: alien.c-types alien.syntax system math kernel calendar
+core-foundation core-foundation.time ;
IN: core-foundation.timers
TYPEDEF: void* CFRunLoopTimerRef
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel core-foundation.strings
-core-foundation ;
+USING: alien.c-types alien.syntax kernel core-foundation.strings
+core-foundation core-foundation.urls ;
IN: core-foundation.urls
CONSTANT: kCFURLPOSIXPathStyle 0
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.destructors alien.syntax accessors
destructors fry kernel math math.bitwise sequences libc colors
-images images.memory core-graphics.types core-foundation.utilities ;
+images images.memory core-graphics.types core-foundation.utilities
+opengl.gl ;
IN: core-graphics
! CGImageAlphaInfo
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.syntax classes.struct kernel layouts
-math math.rectangles arrays ;
+math math.rectangles arrays literals ;
+FROM: alien.c-types => float ;
IN: core-graphics.types
-<< cell 4 = "float" "double" ? "CGFloat" typedef >>
+SYMBOL: CGFloat
+<< cell 4 = float double ? \ CGFloat typedef >>
: <CGFloat> ( x -- alien )
cell 4 = [ <float> ] [ <double> ] if ; inline
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.syntax assocs core-foundation
-core-foundation.strings core-text.utilities destructors init
-kernel math memoize fonts combinators ;
+USING: accessors alien.c-types alien.syntax assocs core-foundation
+core-foundation.dictionaries core-foundation.strings
+core-graphics.types core-text.utilities destructors init
+kernel math memoize fonts combinators unix.types ;
IN: core-text.fonts
TYPEDEF: void* CTFontRef
M: double-rep rep-size drop 8 ;
M: stack-params rep-size drop cell ;
M: vector-rep rep-size drop 16 ;
+M: char-scalar-rep rep-size drop 1 ;
+M: uchar-scalar-rep rep-size drop 1 ;
+M: short-scalar-rep rep-size drop 2 ;
+M: ushort-scalar-rep rep-size drop 2 ;
+M: int-scalar-rep rep-size drop 4 ;
+M: uint-scalar-rep rep-size drop 4 ;
+M: longlong-scalar-rep rep-size drop 8 ;
+M: ulonglong-scalar-rep rep-size drop 8 ;
GENERIC: rep-component-type ( rep -- n )
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
-HOOK: two-operand? cpu ( -- ? )
-
HOOK: %load-immediate cpu ( reg obj -- )
HOOK: %load-reference cpu ( reg obj -- )
HOOK: %min cpu ( dst src1 src2 -- )
HOOK: %max cpu ( dst src1 src2 -- )
HOOK: %not cpu ( dst src -- )
+HOOK: %neg cpu ( dst src -- )
HOOK: %log2 cpu ( dst src -- )
HOOK: %copy cpu ( dst src rep -- )
HOOK: %fixnum-sub cpu ( label dst src1 src2 -- )
HOOK: %fixnum-mul cpu ( label dst src1 src2 -- )
-HOOK: %integer>bignum cpu ( dst src temp -- )
-HOOK: %bignum>integer cpu ( dst src temp -- )
-
HOOK: %unbox-float cpu ( dst src -- )
HOOK: %box-float cpu ( dst src temp -- )
HOOK: %box-vector cpu ( dst src temp rep -- )
HOOK: %unbox-vector cpu ( dst src rep -- )
-HOOK: %broadcast-vector cpu ( dst src rep -- )
+HOOK: %zero-vector cpu ( dst rep -- )
HOOK: %gather-vector-2 cpu ( dst src1 src2 rep -- )
HOOK: %gather-vector-4 cpu ( dst src1 src2 src3 src4 rep -- )
+HOOK: %shuffle-vector cpu ( dst src shuffle rep -- )
HOOK: %add-vector cpu ( dst src1 src2 rep -- )
HOOK: %saturated-add-vector cpu ( dst src1 src2 rep -- )
HOOK: %add-sub-vector cpu ( dst src1 src2 rep -- )
HOOK: %div-vector cpu ( dst src1 src2 rep -- )
HOOK: %min-vector cpu ( dst src1 src2 rep -- )
HOOK: %max-vector cpu ( dst src1 src2 rep -- )
+HOOK: %dot-vector cpu ( dst src1 src2 rep -- )
HOOK: %sqrt-vector cpu ( dst src rep -- )
HOOK: %horizontal-add-vector cpu ( dst src rep -- )
+HOOK: %horizontal-sub-vector cpu ( dst src rep -- )
HOOK: %abs-vector cpu ( dst src rep -- )
HOOK: %and-vector cpu ( dst src1 src2 rep -- )
+HOOK: %andn-vector cpu ( dst src1 src2 rep -- )
HOOK: %or-vector cpu ( dst src1 src2 rep -- )
HOOK: %xor-vector cpu ( dst src1 src2 rep -- )
HOOK: %shl-vector cpu ( dst src1 src2 rep -- )
HOOK: %shr-vector cpu ( dst src1 src2 rep -- )
+HOOK: %horizontal-shl-vector cpu ( dst src1 src2 rep -- )
+HOOK: %horizontal-shr-vector cpu ( dst src1 src2 rep -- )
HOOK: %integer>scalar cpu ( dst src rep -- )
HOOK: %scalar>integer cpu ( dst src rep -- )
+HOOK: %vector>scalar cpu ( dst src rep -- )
+HOOK: %scalar>vector cpu ( dst src rep -- )
-HOOK: %broadcast-vector-reps cpu ( -- reps )
+HOOK: %zero-vector-reps cpu ( -- reps )
HOOK: %gather-vector-2-reps cpu ( -- reps )
HOOK: %gather-vector-4-reps cpu ( -- reps )
+HOOK: %shuffle-vector-reps cpu ( -- reps )
HOOK: %add-vector-reps cpu ( -- reps )
HOOK: %saturated-add-vector-reps cpu ( -- reps )
HOOK: %add-sub-vector-reps cpu ( -- reps )
HOOK: %div-vector-reps cpu ( -- reps )
HOOK: %min-vector-reps cpu ( -- reps )
HOOK: %max-vector-reps cpu ( -- reps )
+HOOK: %dot-vector-reps cpu ( -- reps )
HOOK: %sqrt-vector-reps cpu ( -- reps )
HOOK: %horizontal-add-vector-reps cpu ( -- reps )
+HOOK: %horizontal-sub-vector-reps cpu ( -- reps )
HOOK: %abs-vector-reps cpu ( -- reps )
HOOK: %and-vector-reps cpu ( -- reps )
+HOOK: %andn-vector-reps cpu ( -- reps )
HOOK: %or-vector-reps cpu ( -- reps )
HOOK: %xor-vector-reps cpu ( -- reps )
HOOK: %shl-vector-reps cpu ( -- reps )
HOOK: %shr-vector-reps cpu ( -- reps )
+HOOK: %horizontal-shl-vector-reps cpu ( -- reps )
+HOOK: %horizontal-shr-vector-reps cpu ( -- reps )
HOOK: %unbox-alien cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
HOOK: %box-alien cpu ( dst src temp -- )
HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 base-class -- )
-HOOK: %alien-unsigned-1 cpu ( dst src -- )
-HOOK: %alien-unsigned-2 cpu ( dst src -- )
-HOOK: %alien-unsigned-4 cpu ( dst src -- )
-HOOK: %alien-signed-1 cpu ( dst src -- )
-HOOK: %alien-signed-2 cpu ( dst src -- )
-HOOK: %alien-signed-4 cpu ( dst src -- )
-HOOK: %alien-cell cpu ( dst src -- )
-HOOK: %alien-float cpu ( dst src -- )
-HOOK: %alien-double cpu ( dst src -- )
-HOOK: %alien-vector cpu ( dst src rep -- )
-
-HOOK: %set-alien-integer-1 cpu ( ptr value -- )
-HOOK: %set-alien-integer-2 cpu ( ptr value -- )
-HOOK: %set-alien-integer-4 cpu ( ptr value -- )
-HOOK: %set-alien-cell cpu ( ptr value -- )
-HOOK: %set-alien-float cpu ( ptr value -- )
-HOOK: %set-alien-double cpu ( ptr value -- )
-HOOK: %set-alien-vector cpu ( ptr value rep -- )
+HOOK: %alien-unsigned-1 cpu ( dst src offset -- )
+HOOK: %alien-unsigned-2 cpu ( dst src offset -- )
+HOOK: %alien-unsigned-4 cpu ( dst src offset -- )
+HOOK: %alien-signed-1 cpu ( dst src offset -- )
+HOOK: %alien-signed-2 cpu ( dst src offset -- )
+HOOK: %alien-signed-4 cpu ( dst src offset -- )
+HOOK: %alien-cell cpu ( dst src offset -- )
+HOOK: %alien-float cpu ( dst src offset -- )
+HOOK: %alien-double cpu ( dst src offset -- )
+HOOK: %alien-vector cpu ( dst src offset rep -- )
+
+HOOK: %set-alien-integer-1 cpu ( ptr offset value -- )
+HOOK: %set-alien-integer-2 cpu ( ptr offset value -- )
+HOOK: %set-alien-integer-4 cpu ( ptr offset value -- )
+HOOK: %set-alien-cell cpu ( ptr offset value -- )
+HOOK: %set-alien-float cpu ( ptr offset value -- )
+HOOK: %set-alien-double cpu ( ptr offset value -- )
+HOOK: %set-alien-vector cpu ( ptr offset value rep -- )
HOOK: %alien-global cpu ( dst symbol library -- )
HOOK: %vm-field-ptr cpu ( dst fieldname -- )
HOOK: %compare-float-ordered-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-float-unordered-branch cpu ( label cc src1 src2 -- )
-HOOK: %spill cpu ( src rep n -- )
-HOOK: %reload cpu ( dst rep n -- )
+HOOK: %spill cpu ( src rep dst -- )
+HOOK: %reload cpu ( dst rep src -- )
HOOK: %loop-entry cpu ( -- )
CONSTANT: scratch-reg 30
CONSTANT: fp-scratch-reg 30
-M: ppc two-operand? f ;
-
M: ppc %load-immediate ( reg n -- ) swap LOAD ;
M: ppc %load-reference ( reg obj -- )
M: ppc %sar SRAW ;
M: ppc %sar-imm SRAWI ;
M: ppc %not NOT ;
+M: ppc %neg NEG ;
:: overflow-template ( label dst src1 src2 insn -- )
0 0 LI
M: ppc %fixnum-mul ( label dst src1 src2 -- )
[ MULLWO. ] overflow-template ;
-: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
-
-M:: ppc %integer>bignum ( dst src temp -- )
- [
- "end" define-label
- dst 0 >bignum %load-reference
- ! Is it zero? Then just go to the end and return this zero
- 0 src 0 CMPI
- "end" get BEQ
- ! Allocate a bignum
- dst 4 cells bignum temp %allot
- ! Write length
- 2 tag-fixnum temp LI
- temp dst 1 bignum@ STW
- ! Compute sign
- temp src MR
- temp temp cell-bits 1 - SRAWI
- temp temp 1 ANDI
- ! Store sign
- temp dst 2 bignum@ STW
- ! Make negative value positive
- temp temp temp ADD
- temp temp NEG
- temp temp 1 ADDI
- temp src temp MULLW
- ! Store the bignum
- temp dst 3 bignum@ STW
- "end" resolve-label
- ] with-scope ;
-
-M:: ppc %bignum>integer ( dst src temp -- )
- [
- "end" define-label
- temp src 1 bignum@ LWZ
- ! if the length is 1, its just the sign and nothing else,
- ! so output 0
- 0 dst LI
- 0 temp 1 tag-fixnum CMPI
- "end" get BEQ
- ! load the value
- dst src 3 bignum@ LWZ
- ! load the sign
- temp src 2 bignum@ LWZ
- ! branchless arithmetic: we want to turn 0 into 1,
- ! and 1 into -1
- temp temp temp ADD
- temp temp 1 SUBI
- temp temp NEG
- ! multiply value by sign
- dst dst temp MULLW
- "end" resolve-label
- ] with-scope ;
-
M: ppc %add-float FADD ;
M: ppc %sub-float FSUB ;
M: ppc %mul-float FMUL ;
dst 16 float temp %allot
src dst float-offset STFD ;
-: float-function-param ( i spill-slot -- )
- [ float-regs param-regs nth 1 ] [ n>> spill@ ] bi* LFD ;
+GENERIC: float-function-param* ( dst src -- )
+
+M: spill-slot float-function-param* [ 1 ] dip n>> spill@ LFD ;
+M: integer float-function-param* FMR ;
+
+: float-function-param ( i src -- )
+ [ float-regs param-regs nth ] dip float-function-param* ;
: float-function-return ( reg -- )
float-regs return-reg double-rep %copy ;
M: ppc %double>single-float double-rep %copy ;
! VMX/AltiVec not supported yet
-M: ppc %broadcast-vector-reps { } ;
+M: ppc %zero-vector-reps { } ;
M: ppc %gather-vector-2-reps { } ;
M: ppc %gather-vector-4-reps { } ;
+M: ppc %shuffle-vector-reps { } ;
M: ppc %add-vector-reps { } ;
M: ppc %saturated-add-vector-reps { } ;
M: ppc %add-sub-vector-reps { } ;
M: ppc %div-vector-reps { } ;
M: ppc %min-vector-reps { } ;
M: ppc %max-vector-reps { } ;
+M: ppc %dot-vector-reps { } ;
M: ppc %sqrt-vector-reps { } ;
M: ppc %horizontal-add-vector-reps { } ;
+M: ppc %horizontal-sub-vector-reps { } ;
M: ppc %abs-vector-reps { } ;
M: ppc %and-vector-reps { } ;
+M: ppc %andn-vector-reps { } ;
M: ppc %or-vector-reps { } ;
M: ppc %xor-vector-reps { } ;
M: ppc %shl-vector-reps { } ;
M: ppc %shr-vector-reps { } ;
+M: ppc %horizontal-shl-vector-reps { } ;
+M: ppc %horizontal-shr-vector-reps { } ;
M: ppc %unbox-alien ( dst src -- )
alien-offset LWZ ;
{ stack-params [ [ [ 0 1 ] dip next-param@ LWZ 0 1 ] dip STW ] }
} case ;
-M: ppc %spill ( src rep n -- )
- swap [ spill@ ] dip store-to-frame ;
+M: ppc %spill ( src rep dst -- )
+ swap [ n>> spill@ ] dip store-to-frame ;
-M: ppc %reload ( dst rep n -- )
- swap [ spill@ ] dip load-from-frame ;
+M: ppc %reload ( dst rep src -- )
+ swap [ n>> spill@ ] dip load-from-frame ;
M: ppc %loop-entry ;
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: locals alien.c-types alien.syntax arrays kernel fry math
-namespaces sequences system layouts io vocabs.loader accessors init
-combinators command-line make compiler compiler.units
-compiler.constants compiler.alien compiler.codegen
-compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder
-compiler.cfg.intrinsics compiler.cfg.stack-frame cpu.x86.assembler
-cpu.x86.assembler.operands cpu.x86 cpu.architecture ;
+USING: locals alien.c-types alien.libraries alien.syntax arrays
+kernel fry math namespaces sequences system layouts io
+vocabs.loader accessors init combinators command-line make
+compiler compiler.units compiler.constants compiler.alien
+compiler.codegen compiler.codegen.fixup
+compiler.cfg.instructions compiler.cfg.builder
+compiler.cfg.intrinsics compiler.cfg.stack-frame
+cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
+cpu.architecture ;
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
! Unbox EAX
unbox-return ;
+GENERIC: float-function-param ( stack-slot dst src -- )
+
+M:: spill-slot float-function-param ( stack-slot dst src -- )
+ ! We can clobber dst here since its going to contain the
+ ! final result
+ dst src double-rep %copy
+ stack-slot dst double-rep %copy ;
+
+M: register float-function-param
+ nip double-rep %copy ;
+
+: float-function-return ( reg -- )
+ ESP [] FSTPL
+ ESP [] MOVSD
+ ESP 16 ADD ;
+
+M:: x86.32 %unary-float-function ( dst src func -- )
+ ESP -16 [+] dst src float-function-param
+ ESP 16 SUB
+ func "libm" load-library %alien-invoke
+ dst float-function-return ;
+
+M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
+ ESP -16 [+] dst src1 float-function-param
+ ESP -8 [+] dst src2 float-function-param
+ ESP 16 SUB
+ func "libm" load-library %alien-invoke
+ dst float-function-return ;
M: x86.32 %cleanup ( params -- )
#! a) If we just called an stdcall function in Windows, it
! Unbox former top of data stack to return registers
unbox-return ;
-: float-function-param ( i spill-slot -- )
- [ float-regs param-regs nth ] [ n>> spill@ ] bi* MOVSD ;
+: float-function-param ( i src -- )
+ [ float-regs param-regs nth ] dip double-rep %copy ;
: float-function-return ( reg -- )
float-regs return-reg double-rep %copy ;
dst float-function-return ;
M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
+ ! src1 might equal dst; otherwise it will be a spill slot
+ ! src2 is always a spill slot
0 src1 float-function-param
1 src2 float-function-param
func f %alien-invoke
! x86-64.
enable-alien-4-intrinsics
-! Enable fast calling of libc math functions
-enable-float-functions
-
USE: vocabs.loader
{
! 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 -- ? )
! [ { HEX: f2 HEX: 41 HEX: 0f HEX: 11 HEX: 04 HEX: 24 } ] [ [ R12 [] XMM0 MOVSD ] { } make ] unit-test
! 3-operand r-rm-imm sse instructions
-[ { HEX: 66 HEX: 0f HEX: 70 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 2 PSHUFD ] { } make ] unit-test
-[ { HEX: 0f HEX: c6 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 2 SHUFPS ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: 70 HEX: c1 HEX: 02 } ]
+[ [ XMM0 XMM1 2 PSHUFD ] { } make ] unit-test
+
+[ { HEX: 0f HEX: c6 HEX: c1 HEX: 02 } ]
+[ [ XMM0 XMM1 2 SHUFPS ] { } make ] unit-test
+
+! shufflers with arrays of indexes
+[ { HEX: 66 HEX: 0f HEX: 70 HEX: c1 HEX: 02 } ]
+[ [ XMM0 XMM1 { 2 0 0 0 } PSHUFD ] { } make ] unit-test
+
+[ { HEX: 0f HEX: c6 HEX: c1 HEX: 63 } ]
+[ [ XMM0 XMM1 { 3 0 2 1 } SHUFPS ] { } make ] unit-test
+
+[ { HEX: 66 HEX: 0f HEX: c6 HEX: c1 HEX: 2 } ]
+[ [ XMM0 XMM1 { 0 1 } SHUFPD ] { } make ] unit-test
+
+[ { HEX: 66 HEX: 0f HEX: c6 HEX: c1 HEX: 1 } ]
+[ [ XMM0 XMM1 { 1 0 } SHUFPD ] { } make ] unit-test
! scalar register insert/extract sse instructions
[ { HEX: 66 HEX: 0f HEX: c4 HEX: c1 HEX: 02 } ] [ [ XMM0 ECX 2 PINSRW ] { } make ] unit-test
! Copyright (C) 2005, 2009 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io.binary kernel combinators kernel.private math locals
-namespaces make sequences words system layouts math.order accessors
-cpu.x86.assembler.operands cpu.x86.assembler.operands.private ;
+USING: arrays io.binary kernel combinators kernel.private math
+math.bitwise locals namespaces make sequences words system
+layouts math.order accessors cpu.x86.assembler.operands
+cpu.x86.assembler.operands.private ;
QUALIFIED: sequences
IN: cpu.x86.assembler
: MOVDQA ( dest src -- ) { HEX: 6f HEX: 7f } HEX: 66 2-operand-rm-mr-sse ;
: MOVDQU ( dest src -- ) { HEX: 6f HEX: 7f } HEX: f3 2-operand-rm-mr-sse ;
-: PSHUFD ( dest src imm -- ) HEX: 70 HEX: 66 3-operand-rm-sse ;
-: PSHUFLW ( dest src imm -- ) HEX: 70 HEX: f2 3-operand-rm-sse ;
-: PSHUFHW ( dest src imm -- ) HEX: 70 HEX: f3 3-operand-rm-sse ;
+<PRIVATE
+
+: 2shuffler ( indexes/mask -- mask )
+ dup integer? [ first2 { 1 0 } bitfield ] unless ;
+: 4shuffler ( indexes/mask -- mask )
+ dup integer? [ first4 { 6 4 2 0 } bitfield ] unless ;
+
+PRIVATE>
+
+: PSHUFD ( dest src imm -- ) 4shuffler HEX: 70 HEX: 66 3-operand-rm-sse ;
+: PSHUFLW ( dest src imm -- ) 4shuffler HEX: 70 HEX: f2 3-operand-rm-sse ;
+: PSHUFHW ( dest src imm -- ) 4shuffler HEX: 70 HEX: f3 3-operand-rm-sse ;
<PRIVATE
: MOVNTI ( dest src -- ) { HEX: 0f HEX: c3 } (2-operand) ;
: PINSRW ( dest src imm -- ) HEX: c4 HEX: 66 3-operand-rm-sse ;
-: SHUFPS ( dest src imm -- ) HEX: c6 f 3-operand-rm-sse ;
-: SHUFPD ( dest src imm -- ) HEX: c6 HEX: 66 3-operand-rm-sse ;
+: SHUFPS ( dest src imm -- ) 4shuffler HEX: c6 f 3-operand-rm-sse ;
+: SHUFPD ( dest src imm -- ) 2shuffler HEX: c6 HEX: 66 3-operand-rm-sse ;
: ADDSUBPD ( dest src -- ) HEX: d0 HEX: 66 2-operand-rm-sse ;
: ADDSUBPS ( dest src -- ) HEX: d0 HEX: f2 2-operand-rm-sse ;
M: label JMP 0 JMP rc-relative label-fixup ;
M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
-M: x86 two-operand? t ;
-
M: x86 vector-regs float-regs ;
HOOK: stack-reg cpu ( -- reg )
M: x86 %set-slot ( src obj slot -- ) [+] swap MOV ;
M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ;
+:: two-operand ( dst src1 src2 rep -- dst src )
+ dst src2 eq? dst src1 eq? not and [ "Cannot handle this case" throw ] when
+ dst src1 rep %copy
+ dst src2 ; inline
+
+:: one-operand ( dst src rep -- dst )
+ dst src rep %copy
+ dst ; inline
+
M: x86 %add 2over eq? [ nip ADD ] [ [+] LEA ] if ;
M: x86 %add-imm 2over eq? [ nip ADD ] [ [+] LEA ] if ;
-M: x86 %sub nip SUB ;
+M: x86 %sub int-rep two-operand SUB ;
M: x86 %sub-imm 2over eq? [ nip SUB ] [ neg [+] LEA ] if ;
-M: x86 %mul nip swap IMUL2 ;
+M: x86 %mul int-rep two-operand swap IMUL2 ;
M: x86 %mul-imm IMUL3 ;
-M: x86 %and nip AND ;
-M: x86 %and-imm nip AND ;
-M: x86 %or nip OR ;
-M: x86 %or-imm nip OR ;
-M: x86 %xor nip XOR ;
-M: x86 %xor-imm nip XOR ;
-M: x86 %shl-imm nip SHL ;
-M: x86 %shr-imm nip SHR ;
-M: x86 %sar-imm nip SAR ;
-
-M: x86 %min nip [ CMP ] [ CMOVG ] 2bi ;
-M: x86 %max nip [ CMP ] [ CMOVL ] 2bi ;
-
-M: x86 %not drop NOT ;
+M: x86 %and int-rep two-operand AND ;
+M: x86 %and-imm int-rep two-operand AND ;
+M: x86 %or int-rep two-operand OR ;
+M: x86 %or-imm int-rep two-operand OR ;
+M: x86 %xor int-rep two-operand XOR ;
+M: x86 %xor-imm int-rep two-operand XOR ;
+M: x86 %shl-imm int-rep two-operand SHL ;
+M: x86 %shr-imm int-rep two-operand SHR ;
+M: x86 %sar-imm int-rep two-operand SAR ;
+
+M: x86 %min int-rep two-operand [ CMP ] [ CMOVG ] 2bi ;
+M: x86 %max int-rep two-operand [ CMP ] [ CMOVL ] 2bi ;
+
+M: x86 %not int-rep one-operand NOT ;
+M: x86 %neg int-rep one-operand NEG ;
M: x86 %log2 BSR ;
GENERIC: copy-register* ( dst src rep -- )
M: vector-rep copy-register* drop MOVDQU ;
M: x86 %copy ( dst src rep -- )
- 2over eq? [ 3drop ] [ copy-register* ] if ;
-
-:: overflow-template ( label dst src1 src2 insn -- )
- src1 src2 insn call
- label JO ; inline
+ 2over eq? [ 3drop ] [
+ [ [ dup spill-slot? [ n>> spill@ ] when ] bi@ ] dip
+ copy-register*
+ ] if ;
M: x86 %fixnum-add ( label dst src1 src2 -- )
- [ ADD ] overflow-template ;
+ int-rep two-operand ADD JO ;
M: x86 %fixnum-sub ( label dst src1 src2 -- )
- [ SUB ] overflow-template ;
+ int-rep two-operand SUB JO ;
M: x86 %fixnum-mul ( label dst src1 src2 -- )
- [ swap IMUL2 ] overflow-template ;
+ int-rep two-operand swap IMUL2 JO ;
+
+M: x86 %unbox-alien ( dst src -- )
+ alien-offset [+] MOV ;
+
+M:: x86 %unbox-any-c-ptr ( dst src temp -- )
+ [
+ { "is-byte-array" "end" "start" } [ define-label ] each
+ dst 0 MOV
+ temp src MOV
+ ! We come back here with displaced aliens
+ "start" resolve-label
+ ! Is the object f?
+ temp \ f tag-number CMP
+ "end" get JE
+ ! Is the object an alien?
+ temp header-offset [+] alien type-number tag-fixnum CMP
+ "is-byte-array" get JNE
+ ! If so, load the offset and add it to the address
+ dst temp alien-offset [+] ADD
+ ! Now recurse on the underlying alien
+ temp temp underlying-alien-offset [+] MOV
+ "start" get JMP
+ "is-byte-array" resolve-label
+ ! Add byte array address to address being computed
+ dst temp ADD
+ ! Add an offset to start of byte array's data
+ dst byte-array-offset ADD
+ "end" resolve-label
+ ] with-scope ;
+
+: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
-: bignum@ ( reg n -- op )
- cells bignum tag-number - [+] ; inline
+:: %allot-alien ( dst displacement base temp -- )
+ dst 4 cells alien temp %allot
+ dst 1 alien@ base MOV ! alien
+ dst 2 alien@ \ f tag-number MOV ! expired
+ dst 3 alien@ displacement MOV ! displacement
+ ;
-M:: x86 %integer>bignum ( dst src temp -- )
- #! on entry, inreg is a signed 32-bit quantity
- #! exits with tagged ptr to bignum in outreg
- #! 1 cell header, 1 cell length, 1 cell sign, + digits
- #! length is the # of digits + sign
+M:: x86 %box-alien ( dst src temp -- )
[
"end" define-label
- ! Load cached zero value
- dst 0 >bignum %load-reference
+ dst \ f tag-number MOV
src 0 CMP
- ! Is it zero? Then just go to the end and return this zero
"end" get JE
- ! Allocate a bignum
- dst 4 cells bignum temp %allot
- ! Write length
- dst 1 bignum@ 2 tag-fixnum MOV
- ! Store value
- dst 3 bignum@ src MOV
- ! Compute sign
- temp src MOV
- temp cell-bits 1 - SAR
- temp 1 AND
- ! Store sign
- dst 2 bignum@ temp MOV
- ! Make negative value positive
- temp temp ADD
- temp NEG
- temp 1 ADD
- src temp IMUL2
- ! Store the bignum
- dst 3 bignum@ temp MOV
+ dst src \ f tag-number temp %allot-alien
"end" resolve-label
] with-scope ;
-M:: x86 %bignum>integer ( dst src temp -- )
+M:: x86 %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
[
"end" define-label
- ! load length
- temp src 1 bignum@ MOV
- ! if the length is 1, its just the sign and nothing else,
- ! so output 0
- dst 0 MOV
- temp 1 tag-fixnum CMP
+ "ok" define-label
+ ! If displacement is zero, return the base
+ dst base MOV
+ displacement 0 CMP
"end" get JE
- ! load the value
- dst src 3 bignum@ MOV
- ! load the sign
- temp src 2 bignum@ MOV
- ! convert it into -1 or 1
- temp temp ADD
- temp NEG
- temp 1 ADD
- ! make dst signed
- temp dst IMUL2
+ ! Quickly use displacement' before its needed for real, as allot temporary
+ dst 4 cells alien displacement' %allot
+ ! If base is already a displaced alien, unpack it
+ base' base MOV
+ displacement' displacement MOV
+ base \ f tag-number CMP
+ "ok" get JE
+ base header-offset [+] alien type-number tag-fixnum CMP
+ "ok" get JNE
+ ! displacement += base.displacement
+ displacement' base 3 alien@ ADD
+ ! base = base.base
+ base' base 1 alien@ MOV
+ "ok" resolve-label
+ dst 1 alien@ base' MOV ! alien
+ dst 2 alien@ \ f tag-number MOV ! expired
+ dst 3 alien@ displacement' MOV ! displacement
"end" resolve-label
] with-scope ;
-M: x86 %add-float nip ADDSD ;
-M: x86 %sub-float nip SUBSD ;
-M: x86 %mul-float nip MULSD ;
-M: x86 %div-float nip DIVSD ;
-M: x86 %min-float nip MINSD ;
-M: x86 %max-float nip MAXSD ;
-M: x86 %sqrt SQRTSD ;
-
-M: x86 %single>double-float CVTSS2SD ;
-M: x86 %double>single-float CVTSD2SS ;
+! The 'small-reg' mess is pretty crappy, but its only used on x86-32.
+! On x86-64, all registers have 8-bit versions. However, a similar
+! problem arises for shifts, where the shift count must be in CL, and
+! so one day I will fix this properly by adding precoloring to the
+! register allocator.
-M: x86 %integer>float CVTSI2SD ;
-M: x86 %float>integer CVTTSD2SI ;
+HOOK: has-small-reg? cpu ( reg size -- ? )
-M: x86 %unbox-float ( dst src -- )
- float-offset [+] MOVSD ;
+CONSTANT: have-byte-regs { EAX ECX EDX EBX }
-M:: x86 %box-float ( dst src temp -- )
- dst 16 float temp %allot
- dst float-offset [+] src MOVSD ;
+M: x86.32 has-small-reg?
+ {
+ { 8 [ have-byte-regs memq? ] }
+ { 16 [ drop t ] }
+ { 32 [ drop t ] }
+ } case ;
-M:: x86 %box-vector ( dst src rep temp -- )
- dst rep rep-size 2 cells + byte-array temp %allot
- 16 tag-fixnum dst 1 byte-array tag-number %set-slot-imm
- dst byte-array-offset [+]
- src rep %copy ;
+M: x86.64 has-small-reg? 2drop t ;
-M:: x86 %unbox-vector ( dst src rep -- )
- dst src byte-array-offset [+]
- rep %copy ;
+: small-reg-that-isn't ( exclude -- reg' )
+ [ have-byte-regs ] dip
+ [ native-version-of ] map
+ '[ _ memq? not ] find nip ;
-MACRO: available-reps ( alist -- )
- ! Each SSE version adds new representations and supports
- ! all old ones
- unzip { } [ append ] accumulate rest swap suffix
- [ [ 1quotation ] map ] bi@ zip
- reverse [ { } ] suffix
- '[ _ cond ] ;
+: with-save/restore ( reg quot -- )
+ [ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
-M: x86 %broadcast-vector ( dst src rep -- )
- {
- { float-4-rep [ [ float-4-rep %copy ] [ drop dup 0 SHUFPS ] 2bi ] }
- { double-2-rep [ [ double-2-rep %copy ] [ drop dup UNPCKLPD ] 2bi ] }
- } case ;
+:: with-small-register ( dst exclude size quot: ( new-dst -- ) -- )
+ ! If the destination register overlaps a small register with
+ ! 'size' bits, we call the quot with that. Otherwise, we find a
+ ! small register that is not in exclude, and call quot, saving and
+ ! restoring the small register.
+ dst size has-small-reg? [ dst quot call ] [
+ exclude small-reg-that-isn't
+ [ quot call ] with-save/restore
+ ] if ; inline
-M: x86 %broadcast-vector-reps
- {
- ! Can't do this with sse1 since it will want to unbox
- ! a double-precision float and convert to single precision
- { sse2? { float-4-rep double-2-rep } }
- } available-reps ;
+M:: x86 %string-nth ( dst src index temp -- )
+ ! We request a small-reg of size 8 since those of size 16 are
+ ! a superset.
+ "end" define-label
+ dst { src index temp } 8 [| new-dst |
+ ! Load the least significant 7 bits into new-dst.
+ ! 8th bit indicates whether we have to load from
+ ! the aux vector or not.
+ temp src index [+] LEA
+ new-dst 8-bit-version-of temp string-offset [+] MOV
+ new-dst new-dst 8-bit-version-of MOVZX
+ ! Do we have to look at the aux vector?
+ new-dst HEX: 80 CMP
+ "end" get JL
+ ! Yes, this is a non-ASCII character. Load aux vector
+ temp src string-aux-offset [+] MOV
+ new-dst temp XCHG
+ ! Compute index
+ new-dst index ADD
+ new-dst index ADD
+ ! Load high 16 bits
+ new-dst 16-bit-version-of new-dst byte-array-offset [+] MOV
+ new-dst new-dst 16-bit-version-of MOVZX
+ new-dst 7 SHL
+ ! Compute code point
+ new-dst temp XOR
+ "end" resolve-label
+ dst new-dst int-rep %copy
+ ] with-small-register ;
-M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- )
- rep {
- {
- float-4-rep
- [
- dst src1 float-4-rep %copy
- dst src2 UNPCKLPS
- src3 src4 UNPCKLPS
- dst src3 MOVLHPS
- ]
- }
- } case ;
+M:: x86 %set-string-nth-fast ( ch str index temp -- )
+ ch { index str temp } 8 [| new-ch |
+ new-ch ch int-rep %copy
+ temp str index [+] LEA
+ temp string-offset [+] new-ch 8-bit-version-of MOV
+ ] with-small-register ;
-M: x86 %gather-vector-4-reps
- {
- ! Can't do this with sse1 since it will want to unbox
- ! double-precision floats and convert to single precision
- { sse2? { float-4-rep } }
- } available-reps ;
+:: %alien-integer-getter ( dst src offset size quot -- )
+ dst { src } size [| new-dst |
+ new-dst dup size n-bit-version-of dup src offset [+] MOV
+ quot call
+ dst new-dst int-rep %copy
+ ] with-small-register ; inline
-M:: x86 %gather-vector-2 ( dst src1 src2 rep -- )
- rep {
- {
- double-2-rep
- [
- dst src1 double-2-rep %copy
- dst src2 UNPCKLPD
- ]
- }
- } case ;
+: %alien-unsigned-getter ( dst src offset size -- )
+ [ MOVZX ] %alien-integer-getter ; inline
-M: x86 %gather-vector-2-reps
- {
- { sse2? { double-2-rep } }
- } available-reps ;
+M: x86 %alien-unsigned-1 8 %alien-unsigned-getter ;
+M: x86 %alien-unsigned-2 16 %alien-unsigned-getter ;
+M: x86 %alien-unsigned-4 32 [ 2drop ] %alien-integer-getter ;
-M: x86 %add-vector ( dst src1 src2 rep -- )
- {
- { float-4-rep [ ADDPS ] }
- { double-2-rep [ ADDPD ] }
- { char-16-rep [ PADDB ] }
- { uchar-16-rep [ PADDB ] }
- { short-8-rep [ PADDW ] }
- { ushort-8-rep [ PADDW ] }
- { int-4-rep [ PADDD ] }
- { uint-4-rep [ PADDD ] }
- { longlong-2-rep [ PADDQ ] }
- { ulonglong-2-rep [ PADDQ ] }
- } case drop ;
+: %alien-signed-getter ( dst src offset size -- )
+ [ MOVSX ] %alien-integer-getter ; inline
-M: x86 %add-vector-reps
- {
- { sse? { float-4-rep } }
- { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
- } available-reps ;
+M: x86 %alien-signed-1 8 %alien-signed-getter ;
+M: x86 %alien-signed-2 16 %alien-signed-getter ;
+M: x86 %alien-signed-4 32 %alien-signed-getter ;
-M: x86 %saturated-add-vector ( dst src1 src2 rep -- )
- {
- { char-16-rep [ PADDSB ] }
- { uchar-16-rep [ PADDUSB ] }
- { short-8-rep [ PADDSW ] }
- { ushort-8-rep [ PADDUSW ] }
- } case drop ;
+M: x86 %alien-cell [+] MOV ;
+M: x86 %alien-float [+] MOVSS ;
+M: x86 %alien-double [+] MOVSD ;
+M: x86 %alien-vector [ [+] ] dip %copy ;
-M: x86 %saturated-add-vector-reps
- {
- { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } }
- } available-reps ;
+:: %alien-integer-setter ( ptr offset value size -- )
+ value { ptr } size [| new-value |
+ new-value value int-rep %copy
+ ptr offset [+] new-value size n-bit-version-of MOV
+ ] with-small-register ; inline
-M: x86 %add-sub-vector ( dst src1 src2 rep -- )
- {
- { float-4-rep [ ADDSUBPS ] }
- { double-2-rep [ ADDSUBPD ] }
- } case drop ;
+M: x86 %set-alien-integer-1 8 %alien-integer-setter ;
+M: x86 %set-alien-integer-2 16 %alien-integer-setter ;
+M: x86 %set-alien-integer-4 32 %alien-integer-setter ;
+M: x86 %set-alien-cell [ [+] ] dip MOV ;
+M: x86 %set-alien-float [ [+] ] dip MOVSS ;
+M: x86 %set-alien-double [ [+] ] dip MOVSD ;
+M: x86 %set-alien-vector [ [+] ] 2dip %copy ;
-M: x86 %add-sub-vector-reps
- {
- { sse3? { float-4-rep double-2-rep } }
- } available-reps ;
+: shift-count? ( reg -- ? ) { ECX RCX } memq? ;
-M: x86 %sub-vector ( dst src1 src2 rep -- )
- {
- { float-4-rep [ SUBPS ] }
- { double-2-rep [ SUBPD ] }
- { char-16-rep [ PSUBB ] }
- { uchar-16-rep [ PSUBB ] }
- { short-8-rep [ PSUBW ] }
- { ushort-8-rep [ PSUBW ] }
- { int-4-rep [ PSUBD ] }
- { uint-4-rep [ PSUBD ] }
- { longlong-2-rep [ PSUBQ ] }
- { ulonglong-2-rep [ PSUBQ ] }
- } case drop ;
+:: emit-shift ( dst src quot -- )
+ src shift-count? [
+ dst CL quot call
+ ] [
+ dst shift-count? [
+ dst src XCHG
+ src CL quot call
+ dst src XCHG
+ ] [
+ ECX native-version-of [
+ CL src MOV
+ drop dst CL quot call
+ ] with-save/restore
+ ] if
+ ] if ; inline
-M: x86 %sub-vector-reps
- {
- { sse? { float-4-rep } }
- { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
- } available-reps ;
+M: x86 %shl int-rep two-operand [ SHL ] emit-shift ;
+M: x86 %shr int-rep two-operand [ SHR ] emit-shift ;
+M: x86 %sar int-rep two-operand [ SAR ] emit-shift ;
-M: x86 %saturated-sub-vector ( dst src1 src2 rep -- )
- {
- { char-16-rep [ PSUBSB ] }
- { uchar-16-rep [ PSUBUSB ] }
- { short-8-rep [ PSUBSW ] }
- { ushort-8-rep [ PSUBUSW ] }
- } case drop ;
+M: x86 %vm-field-ptr ( dst field -- )
+ [ drop 0 MOV rc-absolute-cell rt-vm rel-fixup ]
+ [ vm-field-offset ADD ] 2bi ;
-M: x86 %saturated-sub-vector-reps
- {
- { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } }
- } available-reps ;
+: load-zone-ptr ( reg -- )
+ #! Load pointer to start of zone array
+ "nursery" %vm-field-ptr ;
-M: x86 %mul-vector ( dst src1 src2 rep -- )
- {
- { float-4-rep [ MULPS ] }
- { double-2-rep [ MULPD ] }
- { short-8-rep [ PMULLW ] }
- { ushort-8-rep [ PMULLW ] }
- { int-4-rep [ PMULLD ] }
- { uint-4-rep [ PMULLD ] }
- } case drop ;
+: load-allot-ptr ( nursery-ptr allot-ptr -- )
+ [ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
-M: x86 %mul-vector-reps
- {
- { sse? { float-4-rep } }
- { sse2? { double-2-rep short-8-rep ushort-8-rep } }
- { sse4.1? { int-4-rep uint-4-rep } }
- } available-reps ;
+: inc-allot-ptr ( nursery-ptr n -- )
+ [ cell [+] ] dip 8 align ADD ;
-M: x86 %saturated-mul-vector-reps
- ! No multiplication with saturation on x86
- { } ;
+: store-header ( temp class -- )
+ [ [] ] [ type-number tag-fixnum ] bi* MOV ;
-M: x86 %div-vector ( dst src1 src2 rep -- )
- {
- { float-4-rep [ DIVPS ] }
- { double-2-rep [ DIVPD ] }
- } case drop ;
+: store-tagged ( dst tag -- )
+ tag-number OR ;
-M: x86 %div-vector-reps
- {
- { sse? { float-4-rep } }
- { sse2? { double-2-rep } }
- } available-reps ;
+M:: x86 %allot ( dst size class nursery-ptr -- )
+ nursery-ptr dst load-allot-ptr
+ dst class store-header
+ dst class store-tagged
+ nursery-ptr size inc-allot-ptr ;
-M: x86 %min-vector ( dst src1 src2 rep -- )
- {
- { char-16-rep [ PMINSB ] }
- { uchar-16-rep [ PMINUB ] }
- { short-8-rep [ PMINSW ] }
- { ushort-8-rep [ PMINUW ] }
- { int-4-rep [ PMINSD ] }
- { uint-4-rep [ PMINUD ] }
- { float-4-rep [ MINPS ] }
- { double-2-rep [ MINPD ] }
- } case drop ;
+M:: x86 %write-barrier ( src card# table -- )
+ #! Mark the card pointed to by vreg.
+ ! Mark the card
+ card# src MOV
+ card# card-bits SHR
+ table "cards_offset" %vm-field-ptr
+ table table [] MOV
+ table card# [+] card-mark <byte> MOV
-M: x86 %min-vector-reps
- {
- { sse? { float-4-rep } }
- { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } }
- { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
- } available-reps ;
+ ! Mark the card deck
+ card# deck-bits card-bits - SHR
+ table "decks_offset" %vm-field-ptr
+ table table [] MOV
+ table card# [+] card-mark <byte> MOV ;
-M: x86 %max-vector ( dst src1 src2 rep -- )
- {
- { char-16-rep [ PMAXSB ] }
- { uchar-16-rep [ PMAXUB ] }
- { short-8-rep [ PMAXSW ] }
- { ushort-8-rep [ PMAXUW ] }
- { int-4-rep [ PMAXSD ] }
- { uint-4-rep [ PMAXUD ] }
- { float-4-rep [ MAXPS ] }
- { double-2-rep [ MAXPD ] }
- } case drop ;
+M:: x86 %check-nursery ( label temp1 temp2 -- )
+ temp1 load-zone-ptr
+ temp2 temp1 cell [+] MOV
+ temp2 1024 ADD
+ temp1 temp1 3 cells [+] MOV
+ temp2 temp1 CMP
+ label JLE ;
-M: x86 %max-vector-reps
- {
- { sse? { float-4-rep } }
- { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } }
- { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
- } available-reps ;
+M: x86 %save-gc-root ( gc-root register -- ) [ gc-root@ ] dip MOV ;
-M: x86 %horizontal-add-vector ( dst src rep -- )
- {
- { float-4-rep [ [ float-4-rep %copy ] [ HADDPS ] [ HADDPS ] 2tri ] }
- { double-2-rep [ [ double-2-rep %copy ] [ HADDPD ] 2bi ] }
- } case ;
+M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ MOV ;
-M: x86 %horizontal-add-vector-reps
- {
- { sse3? { float-4-rep double-2-rep } }
- } available-reps ;
+M: x86 %alien-global ( dst symbol library -- )
+ [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
-M: x86 %abs-vector ( dst src rep -- )
- {
- { char-16-rep [ PABSB ] }
- { short-8-rep [ PABSW ] }
- { int-4-rep [ PABSD ] }
- } case ;
+M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
-M: x86 %abs-vector-reps
- {
- { ssse3? { char-16-rep short-8-rep int-4-rep } }
- } available-reps ;
+:: %boolean ( dst temp word -- )
+ dst \ f tag-number MOV
+ temp 0 MOV \ t rc-absolute-cell rel-immediate
+ dst temp word execute ; inline
-M: x86 %sqrt-vector ( dst src rep -- )
- {
- { float-4-rep [ SQRTPS ] }
- { double-2-rep [ SQRTPD ] }
+M:: x86 %compare ( dst src1 src2 cc temp -- )
+ src1 src2 CMP
+ cc order-cc {
+ { cc< [ dst temp \ CMOVL %boolean ] }
+ { cc<= [ dst temp \ CMOVLE %boolean ] }
+ { cc> [ dst temp \ CMOVG %boolean ] }
+ { cc>= [ dst temp \ CMOVGE %boolean ] }
+ { cc= [ dst temp \ CMOVE %boolean ] }
+ { cc/= [ dst temp \ CMOVNE %boolean ] }
} case ;
-M: x86 %sqrt-vector-reps
- {
- { sse? { float-4-rep } }
- { sse2? { double-2-rep } }
- } available-reps ;
-
-M: x86 %and-vector ( dst src1 src2 rep -- )
- {
- { float-4-rep [ ANDPS ] }
- { double-2-rep [ ANDPD ] }
- [ drop PAND ]
- } case drop ;
-
-M: x86 %and-vector-reps
- {
- { sse? { float-4-rep } }
- { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
- } available-reps ;
+M: x86 %compare-imm ( dst src1 src2 cc temp -- )
+ %compare ;
-M: x86 %or-vector ( dst src1 src2 rep -- )
- {
- { float-4-rep [ ORPS ] }
- { double-2-rep [ ORPD ] }
- [ drop POR ]
- } case drop ;
+M:: x86 %compare-branch ( label src1 src2 cc -- )
+ src1 src2 CMP
+ cc order-cc {
+ { cc< [ label JL ] }
+ { cc<= [ label JLE ] }
+ { cc> [ label JG ] }
+ { cc>= [ label JGE ] }
+ { cc= [ label JE ] }
+ { cc/= [ label JNE ] }
+ } case ;
-M: x86 %or-vector-reps
- {
- { sse? { float-4-rep } }
- { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
- } available-reps ;
+M: x86 %compare-imm-branch ( label src1 src2 cc -- )
+ %compare-branch ;
-M: x86 %xor-vector ( dst src1 src2 rep -- )
- {
- { float-4-rep [ XORPS ] }
- { double-2-rep [ XORPD ] }
- [ drop PXOR ]
- } case drop ;
+M: x86 %add-float double-rep two-operand ADDSD ;
+M: x86 %sub-float double-rep two-operand SUBSD ;
+M: x86 %mul-float double-rep two-operand MULSD ;
+M: x86 %div-float double-rep two-operand DIVSD ;
+M: x86 %min-float double-rep two-operand MINSD ;
+M: x86 %max-float double-rep two-operand MAXSD ;
+M: x86 %sqrt SQRTSD ;
-M: x86 %xor-vector-reps
- {
- { sse? { float-4-rep } }
- { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
- } available-reps ;
+M: x86 %single>double-float CVTSS2SD ;
+M: x86 %double>single-float CVTSD2SS ;
-M: x86 %shl-vector ( dst src1 src2 rep -- )
- {
- { short-8-rep [ PSLLW ] }
- { ushort-8-rep [ PSLLW ] }
- { int-4-rep [ PSLLD ] }
- { uint-4-rep [ PSLLD ] }
- { longlong-2-rep [ PSLLQ ] }
- { ulonglong-2-rep [ PSLLQ ] }
- } case drop ;
+M: x86 %integer>float CVTSI2SD ;
+M: x86 %float>integer CVTTSD2SI ;
-M: x86 %shl-vector-reps
- {
- { sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
- } available-reps ;
+M: x86 %unbox-float ( dst src -- )
+ float-offset [+] MOVSD ;
-M: x86 %shr-vector ( dst src1 src2 rep -- )
- {
- { short-8-rep [ PSRAW ] }
- { ushort-8-rep [ PSRLW ] }
- { int-4-rep [ PSRAD ] }
- { uint-4-rep [ PSRLD ] }
- { ulonglong-2-rep [ PSRLQ ] }
- } case drop ;
+M:: x86 %box-float ( dst src temp -- )
+ dst 16 float temp %allot
+ dst float-offset [+] src MOVSD ;
-M: x86 %shr-vector-reps
- {
- { sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep ulonglong-2-rep } }
- } available-reps ;
+: %cmov-float= ( dst src -- )
+ [
+ "no-move" define-label
-M: x86 %integer>scalar drop MOVD ;
+ "no-move" get [ JNE ] [ JP ] bi
+ MOV
+ "no-move" resolve-label
+ ] with-scope ;
-M: x86 %scalar>integer drop MOVD ;
+: %cmov-float/= ( dst src -- )
+ [
+ "no-move" define-label
+ "move" define-label
-M: x86 %unbox-alien ( dst src -- )
- alien-offset [+] MOV ;
+ "move" get JP
+ "no-move" get JE
+ "move" resolve-label
+ MOV
+ "no-move" resolve-label
+ ] with-scope ;
-M:: x86 %unbox-any-c-ptr ( dst src temp -- )
- [
- { "is-byte-array" "end" "start" } [ define-label ] each
- dst 0 MOV
- temp src MOV
- ! We come back here with displaced aliens
- "start" resolve-label
- ! Is the object f?
- temp \ f tag-number CMP
- "end" get JE
- ! Is the object an alien?
- temp header-offset [+] alien type-number tag-fixnum CMP
- "is-byte-array" get JNE
- ! If so, load the offset and add it to the address
- dst temp alien-offset [+] ADD
- ! Now recurse on the underlying alien
- temp temp underlying-alien-offset [+] MOV
- "start" get JMP
- "is-byte-array" resolve-label
- ! Add byte array address to address being computed
- dst temp ADD
- ! Add an offset to start of byte array's data
- dst byte-array-offset ADD
- "end" resolve-label
- ] with-scope ;
+:: (%compare-float) ( dst src1 src2 cc temp compare -- )
+ cc {
+ { cc< [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVA %boolean ] }
+ { cc<= [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
+ { cc> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVA %boolean ] }
+ { cc>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
+ { cc= [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float= %boolean ] }
+ { cc<> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNE %boolean ] }
+ { cc<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNP %boolean ] }
+ { cc/< [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
+ { cc/<= [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVB %boolean ] }
+ { cc/> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
+ { cc/>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVB %boolean ] }
+ { cc/= [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float/= %boolean ] }
+ { cc/<> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVE %boolean ] }
+ { cc/<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVP %boolean ] }
+ } case ; inline
-: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
+M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- )
+ \ COMISD (%compare-float) ;
-:: %allot-alien ( dst displacement base temp -- )
- dst 4 cells alien temp %allot
- dst 1 alien@ base MOV ! alien
- dst 2 alien@ \ f tag-number MOV ! expired
- dst 3 alien@ displacement MOV ! displacement
- ;
+M: x86 %compare-float-unordered ( dst src1 src2 cc temp -- )
+ \ UCOMISD (%compare-float) ;
-M:: x86 %box-alien ( dst src temp -- )
+: %jump-float= ( label -- )
[
- "end" define-label
- dst \ f tag-number MOV
- src 0 CMP
- "end" get JE
- dst src \ f tag-number temp %allot-alien
- "end" resolve-label
+ "no-jump" define-label
+ "no-jump" get JP
+ JE
+ "no-jump" resolve-label
] with-scope ;
-M:: x86 %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
- [
- "end" define-label
- "ok" define-label
- ! If displacement is zero, return the base
- dst base MOV
- displacement 0 CMP
- "end" get JE
- ! Quickly use displacement' before its needed for real, as allot temporary
- dst 4 cells alien displacement' %allot
- ! If base is already a displaced alien, unpack it
- base' base MOV
- displacement' displacement MOV
- base \ f tag-number CMP
- "ok" get JE
- base header-offset [+] alien type-number tag-fixnum CMP
- "ok" get JNE
- ! displacement += base.displacement
- displacement' base 3 alien@ ADD
- ! base = base.base
- base' base 1 alien@ MOV
- "ok" resolve-label
- dst 1 alien@ base' MOV ! alien
- dst 2 alien@ \ f tag-number MOV ! expired
- dst 3 alien@ displacement' MOV ! displacement
- "end" resolve-label
- ] with-scope ;
+: %jump-float/= ( label -- )
+ [ JNE ] [ JP ] bi ;
-! The 'small-reg' mess is pretty crappy, but its only used on x86-32.
-! On x86-64, all registers have 8-bit versions. However, a similar
-! problem arises for shifts, where the shift count must be in CL, and
-! so one day I will fix this properly by adding precoloring to the
-! register allocator.
+:: (%compare-float-branch) ( label src1 src2 cc compare -- )
+ cc {
+ { cc< [ src2 src1 \ compare execute( a b -- ) label JA ] }
+ { cc<= [ src2 src1 \ compare execute( a b -- ) label JAE ] }
+ { cc> [ src1 src2 \ compare execute( a b -- ) label JA ] }
+ { cc>= [ src1 src2 \ compare execute( a b -- ) label JAE ] }
+ { cc= [ src1 src2 \ compare execute( a b -- ) label %jump-float= ] }
+ { cc<> [ src1 src2 \ compare execute( a b -- ) label JNE ] }
+ { cc<>= [ src1 src2 \ compare execute( a b -- ) label JNP ] }
+ { cc/< [ src2 src1 \ compare execute( a b -- ) label JBE ] }
+ { cc/<= [ src2 src1 \ compare execute( a b -- ) label JB ] }
+ { cc/> [ src1 src2 \ compare execute( a b -- ) label JBE ] }
+ { cc/>= [ src1 src2 \ compare execute( a b -- ) label JB ] }
+ { cc/= [ src1 src2 \ compare execute( a b -- ) label %jump-float/= ] }
+ { cc/<> [ src1 src2 \ compare execute( a b -- ) label JE ] }
+ { cc/<>= [ src1 src2 \ compare execute( a b -- ) label JP ] }
+ } case ;
-HOOK: has-small-reg? cpu ( reg size -- ? )
+M: x86 %compare-float-ordered-branch ( label src1 src2 cc -- )
+ \ COMISD (%compare-float-branch) ;
-CONSTANT: have-byte-regs { EAX ECX EDX EBX }
+M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- )
+ \ UCOMISD (%compare-float-branch) ;
-M: x86.32 has-small-reg?
+M:: x86 %box-vector ( dst src rep temp -- )
+ dst rep rep-size 2 cells + byte-array temp %allot
+ 16 tag-fixnum dst 1 byte-array tag-number %set-slot-imm
+ dst byte-array-offset [+]
+ src rep %copy ;
+
+M:: x86 %unbox-vector ( dst src rep -- )
+ dst src byte-array-offset [+]
+ rep %copy ;
+
+MACRO: available-reps ( alist -- )
+ ! Each SSE version adds new representations and supports
+ ! all old ones
+ unzip { } [ append ] accumulate rest swap suffix
+ [ [ 1quotation ] map ] bi@ zip
+ reverse [ { } ] suffix
+ '[ _ cond ] ;
+
+M: x86 %zero-vector
{
- { 8 [ have-byte-regs memq? ] }
- { 16 [ drop t ] }
- { 32 [ drop t ] }
+ { double-2-rep [ dup XORPD ] }
+ { float-4-rep [ dup XORPS ] }
+ [ drop dup PXOR ]
} case ;
-M: x86.64 has-small-reg? 2drop t ;
+M: x86 %zero-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
-: small-reg-that-isn't ( exclude -- reg' )
- [ have-byte-regs ] dip
- [ native-version-of ] map
- '[ _ memq? not ] find nip ;
+: unsign-rep ( rep -- rep' )
+ {
+ { uint-4-rep int-4-rep }
+ { ulonglong-2-rep longlong-2-rep }
+ { ushort-8-rep short-8-rep }
+ { uchar-16-rep char-16-rep }
+ } ?at drop ;
+
+! M:: x86 %broadcast-vector ( dst src rep -- )
+! rep unsign-rep {
+! { float-4-rep [
+! dst src float-4-rep %copy
+! dst dst { 0 0 0 0 } SHUFPS
+! ] }
+! { double-2-rep [
+! dst src MOVDDUP
+! ] }
+! { longlong-2-rep [
+! dst src =
+! [ dst dst PUNPCKLQDQ ]
+! [ dst src { 0 1 0 1 } PSHUFD ]
+! if
+! ] }
+! { int-4-rep [
+! dst src { 0 0 0 0 } PSHUFD
+! ] }
+! { short-8-rep [
+! dst src { 0 0 0 0 } PSHUFLW
+! dst dst PUNPCKLQDQ
+! ] }
+! { char-16-rep [
+! dst src char-16-rep %copy
+! dst dst PUNPCKLBW
+! dst dst { 0 0 0 0 } PSHUFLW
+! dst dst PUNPCKLQDQ
+! ] }
+! } case ;
+!
+! M: x86 %broadcast-vector-reps
+! {
+! ! Can't do this with sse1 since it will want to unbox
+! ! a double-precision float and convert to single precision
+! { sse2? { float-4-rep double-2-rep longlong-2-rep ulonglong-2-rep int-4-rep uint-4-rep short-8-rep ushort-8-rep char-16-rep uchar-16-rep } }
+! } available-reps ;
-: with-save/restore ( reg quot -- )
- [ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
+M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- )
+ rep unsign-rep {
+ { float-4-rep [
+ dst src1 float-4-rep %copy
+ dst src2 UNPCKLPS
+ src3 src4 UNPCKLPS
+ dst src3 MOVLHPS
+ ] }
+ { int-4-rep [
+ dst src1 int-4-rep %copy
+ dst src2 PUNPCKLDQ
+ src3 src4 PUNPCKLDQ
+ dst src3 PUNPCKLQDQ
+ ] }
+ } case ;
-:: with-small-register ( dst exclude size quot: ( new-dst -- ) -- )
- ! If the destination register overlaps a small register with
- ! 'size' bits, we call the quot with that. Otherwise, we find a
- ! small register that is not in exclude, and call quot, saving and
- ! restoring the small register.
- dst size has-small-reg? [ dst quot call ] [
- exclude small-reg-that-isn't
- [ quot call ] with-save/restore
- ] if ; inline
+M: x86 %gather-vector-4-reps
+ {
+ ! Can't do this with sse1 since it will want to unbox
+ ! double-precision floats and convert to single precision
+ { sse2? { float-4-rep int-4-rep uint-4-rep } }
+ } available-reps ;
-M:: x86 %string-nth ( dst src index temp -- )
- ! We request a small-reg of size 8 since those of size 16 are
- ! a superset.
- "end" define-label
- dst { src index temp } 8 [| new-dst |
- ! Load the least significant 7 bits into new-dst.
- ! 8th bit indicates whether we have to load from
- ! the aux vector or not.
- temp src index [+] LEA
- new-dst 8-bit-version-of temp string-offset [+] MOV
- new-dst new-dst 8-bit-version-of MOVZX
- ! Do we have to look at the aux vector?
- new-dst HEX: 80 CMP
- "end" get JL
- ! Yes, this is a non-ASCII character. Load aux vector
- temp src string-aux-offset [+] MOV
- new-dst temp XCHG
- ! Compute index
- new-dst index ADD
- new-dst index ADD
- ! Load high 16 bits
- new-dst 16-bit-version-of new-dst byte-array-offset [+] MOV
- new-dst new-dst 16-bit-version-of MOVZX
- new-dst 7 SHL
- ! Compute code point
- new-dst temp XOR
- "end" resolve-label
- dst new-dst int-rep %copy
- ] with-small-register ;
+M:: x86 %gather-vector-2 ( dst src1 src2 rep -- )
+ rep unsign-rep {
+ { double-2-rep [
+ dst src1 double-2-rep %copy
+ dst src2 UNPCKLPD
+ ] }
+ { longlong-2-rep [
+ dst src1 longlong-2-rep %copy
+ dst src2 PUNPCKLQDQ
+ ] }
+ } case ;
-M:: x86 %set-string-nth-fast ( ch str index temp -- )
- ch { index str temp } 8 [| new-ch |
- new-ch ch int-rep %copy
- temp str index [+] LEA
- temp string-offset [+] new-ch 8-bit-version-of MOV
- ] with-small-register ;
+M: x86 %gather-vector-2-reps
+ {
+ { sse2? { double-2-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
-:: %alien-integer-getter ( dst src size quot -- )
- dst { src } size [| new-dst |
- new-dst dup size n-bit-version-of dup src [] MOV
- quot call
- dst new-dst int-rep %copy
- ] with-small-register ; inline
+: double-2-shuffle ( dst shuffle -- )
+ {
+ { { 0 1 } [ drop ] }
+ { { 0 0 } [ dup UNPCKLPD ] }
+ { { 1 1 } [ dup UNPCKHPD ] }
+ [ dupd SHUFPD ]
+ } case ;
-: %alien-unsigned-getter ( dst src size -- )
- [ MOVZX ] %alien-integer-getter ; inline
+: float-4-shuffle ( dst shuffle -- )
+ {
+ { { 0 1 2 3 } [ drop ] }
+ { { 0 0 2 2 } [ dup MOVSLDUP ] }
+ { { 1 1 3 3 } [ dup MOVSHDUP ] }
+ { { 0 1 0 1 } [ dup MOVLHPS ] }
+ { { 2 3 2 3 } [ dup MOVHLPS ] }
+ { { 0 0 1 1 } [ dup UNPCKLPS ] }
+ { { 2 2 3 3 } [ dup UNPCKHPS ] }
+ [ dupd SHUFPS ]
+ } case ;
-M: x86 %alien-unsigned-1 8 %alien-unsigned-getter ;
-M: x86 %alien-unsigned-2 16 %alien-unsigned-getter ;
-M: x86 %alien-unsigned-4 32 [ 2drop ] %alien-integer-getter ;
+: int-4-shuffle ( dst shuffle -- )
+ {
+ { { 0 1 2 3 } [ drop ] }
+ { { 0 0 1 1 } [ dup PUNPCKLDQ ] }
+ { { 2 2 3 3 } [ dup PUNPCKHDQ ] }
+ { { 0 1 0 1 } [ dup PUNPCKLQDQ ] }
+ { { 2 3 2 3 } [ dup PUNPCKHQDQ ] }
+ [ dupd PSHUFD ]
+ } case ;
-: %alien-signed-getter ( dst src size -- )
- [ MOVSX ] %alien-integer-getter ; inline
+: longlong-2-shuffle ( dst shuffle -- )
+ first2 [ 2 * dup 1 + ] bi@ 4array int-4-shuffle ;
-M: x86 %alien-signed-1 8 %alien-signed-getter ;
-M: x86 %alien-signed-2 16 %alien-signed-getter ;
-M: x86 %alien-signed-4 32 %alien-signed-getter ;
+M:: x86 %shuffle-vector ( dst src shuffle rep -- )
+ dst src rep %copy
+ dst shuffle rep unsign-rep {
+ { double-2-rep [ double-2-shuffle ] }
+ { float-4-rep [ float-4-shuffle ] }
+ { int-4-rep [ int-4-shuffle ] }
+ { longlong-2-rep [ longlong-2-shuffle ] }
+ } case ;
-M: x86 %alien-cell [] MOV ;
-M: x86 %alien-float [] MOVSS ;
-M: x86 %alien-double [] MOVSD ;
-M: x86 %alien-vector [ [] ] dip %copy ;
+M: x86 %shuffle-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
-:: %alien-integer-setter ( ptr value size -- )
- value { ptr } size [| new-value |
- new-value value int-rep %copy
- ptr [] new-value size n-bit-version-of MOV
- ] with-small-register ; inline
+M: x86 %add-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { float-4-rep [ ADDPS ] }
+ { double-2-rep [ ADDPD ] }
+ { char-16-rep [ PADDB ] }
+ { uchar-16-rep [ PADDB ] }
+ { short-8-rep [ PADDW ] }
+ { ushort-8-rep [ PADDW ] }
+ { int-4-rep [ PADDD ] }
+ { uint-4-rep [ PADDD ] }
+ { longlong-2-rep [ PADDQ ] }
+ { ulonglong-2-rep [ PADDQ ] }
+ } case ;
-M: x86 %set-alien-integer-1 8 %alien-integer-setter ;
-M: x86 %set-alien-integer-2 16 %alien-integer-setter ;
-M: x86 %set-alien-integer-4 32 %alien-integer-setter ;
-M: x86 %set-alien-cell [ [] ] dip MOV ;
-M: x86 %set-alien-float [ [] ] dip MOVSS ;
-M: x86 %set-alien-double [ [] ] dip MOVSD ;
-M: x86 %set-alien-vector [ [] ] 2dip %copy ;
+M: x86 %add-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
-: shift-count? ( reg -- ? ) { ECX RCX } memq? ;
+M: x86 %saturated-add-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { char-16-rep [ PADDSB ] }
+ { uchar-16-rep [ PADDUSB ] }
+ { short-8-rep [ PADDSW ] }
+ { ushort-8-rep [ PADDUSW ] }
+ } case ;
-:: emit-shift ( dst src1 src2 quot -- )
- src2 shift-count? [
- dst CL quot call
- ] [
- dst shift-count? [
- dst src2 XCHG
- src2 CL quot call
- dst src2 XCHG
- ] [
- ECX native-version-of [
- CL src2 MOV
- drop dst CL quot call
- ] with-save/restore
- ] if
- ] if ; inline
+M: x86 %saturated-add-vector-reps
+ {
+ { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } }
+ } available-reps ;
-M: x86 %shl [ SHL ] emit-shift ;
-M: x86 %shr [ SHR ] emit-shift ;
-M: x86 %sar [ SAR ] emit-shift ;
+M: x86 %add-sub-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { float-4-rep [ ADDSUBPS ] }
+ { double-2-rep [ ADDSUBPD ] }
+ } case ;
-M: x86 %vm-field-ptr ( dst field -- )
- [ drop 0 MOV rc-absolute-cell rt-vm rel-fixup ]
- [ vm-field-offset ADD ] 2bi ;
+M: x86 %add-sub-vector-reps
+ {
+ { sse3? { float-4-rep double-2-rep } }
+ } available-reps ;
-: load-zone-ptr ( reg -- )
- #! Load pointer to start of zone array
- "nursery" %vm-field-ptr ;
+M: x86 %sub-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { float-4-rep [ SUBPS ] }
+ { double-2-rep [ SUBPD ] }
+ { char-16-rep [ PSUBB ] }
+ { uchar-16-rep [ PSUBB ] }
+ { short-8-rep [ PSUBW ] }
+ { ushort-8-rep [ PSUBW ] }
+ { int-4-rep [ PSUBD ] }
+ { uint-4-rep [ PSUBD ] }
+ { longlong-2-rep [ PSUBQ ] }
+ { ulonglong-2-rep [ PSUBQ ] }
+ } case ;
-: load-allot-ptr ( nursery-ptr allot-ptr -- )
- [ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
+M: x86 %sub-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
+
+M: x86 %saturated-sub-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { char-16-rep [ PSUBSB ] }
+ { uchar-16-rep [ PSUBUSB ] }
+ { short-8-rep [ PSUBSW ] }
+ { ushort-8-rep [ PSUBUSW ] }
+ } case ;
+
+M: x86 %saturated-sub-vector-reps
+ {
+ { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } }
+ } available-reps ;
+
+M: x86 %mul-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { float-4-rep [ MULPS ] }
+ { double-2-rep [ MULPD ] }
+ { short-8-rep [ PMULLW ] }
+ { ushort-8-rep [ PMULLW ] }
+ { int-4-rep [ PMULLD ] }
+ { uint-4-rep [ PMULLD ] }
+ } case ;
+
+M: x86 %mul-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep short-8-rep ushort-8-rep } }
+ { sse4.1? { int-4-rep uint-4-rep } }
+ } available-reps ;
+
+M: x86 %saturated-mul-vector-reps
+ ! No multiplication with saturation on x86
+ { } ;
+
+M: x86 %div-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { float-4-rep [ DIVPS ] }
+ { double-2-rep [ DIVPD ] }
+ } case ;
+
+M: x86 %div-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep } }
+ } available-reps ;
+
+M: x86 %min-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { char-16-rep [ PMINSB ] }
+ { uchar-16-rep [ PMINUB ] }
+ { short-8-rep [ PMINSW ] }
+ { ushort-8-rep [ PMINUW ] }
+ { int-4-rep [ PMINSD ] }
+ { uint-4-rep [ PMINUD ] }
+ { float-4-rep [ MINPS ] }
+ { double-2-rep [ MINPD ] }
+ } case ;
-: inc-allot-ptr ( nursery-ptr n -- )
- [ cell [+] ] dip 8 align ADD ;
+M: x86 %min-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } }
+ { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
+ } available-reps ;
-: store-header ( temp class -- )
- [ [] ] [ type-number tag-fixnum ] bi* MOV ;
+M: x86 %max-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { char-16-rep [ PMAXSB ] }
+ { uchar-16-rep [ PMAXUB ] }
+ { short-8-rep [ PMAXSW ] }
+ { ushort-8-rep [ PMAXUW ] }
+ { int-4-rep [ PMAXSD ] }
+ { uint-4-rep [ PMAXUD ] }
+ { float-4-rep [ MAXPS ] }
+ { double-2-rep [ MAXPD ] }
+ } case ;
-: store-tagged ( dst tag -- )
- tag-number OR ;
+M: x86 %max-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } }
+ { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
+ } available-reps ;
-M:: x86 %allot ( dst size class nursery-ptr -- )
- nursery-ptr dst load-allot-ptr
- dst class store-header
- dst class store-tagged
- nursery-ptr size inc-allot-ptr ;
+M: x86 %dot-vector
+ [ two-operand ] keep
+ {
+ { float-4-rep [
+ sse4.1?
+ [ HEX: ff DPPS ]
+ [ [ MULPS ] [ drop dup float-4-rep %horizontal-add-vector ] 2bi ]
+ if
+ ] }
+ { double-2-rep [
+ sse4.1?
+ [ HEX: ff DPPD ]
+ [ [ MULPD ] [ drop dup double-2-rep %horizontal-add-vector ] 2bi ]
+ if
+ ] }
+ } case ;
+M: x86 %dot-vector-reps
+ {
+ { sse3? { float-4-rep double-2-rep } }
+ } available-reps ;
-M:: x86 %write-barrier ( src card# table -- )
- #! Mark the card pointed to by vreg.
- ! Mark the card
- card# src MOV
- card# card-bits SHR
- table "cards_offset" %vm-field-ptr
- table table [] MOV
- table card# [+] card-mark <byte> MOV
+M: x86 %horizontal-add-vector ( dst src rep -- )
+ {
+ { float-4-rep [ [ float-4-rep %copy ] [ HADDPS ] [ HADDPS ] 2tri ] }
+ { double-2-rep [ [ double-2-rep %copy ] [ HADDPD ] 2bi ] }
+ } case ;
- ! Mark the card deck
- card# deck-bits card-bits - SHR
- table "decks_offset" %vm-field-ptr
- table table [] MOV
- table card# [+] card-mark <byte> MOV ;
+M: x86 %horizontal-add-vector-reps
+ {
+ { sse3? { float-4-rep double-2-rep } }
+ } available-reps ;
-M:: x86 %check-nursery ( label temp1 temp2 -- )
- temp1 load-zone-ptr
- temp2 temp1 cell [+] MOV
- temp2 1024 ADD
- temp1 temp1 3 cells [+] MOV
- temp2 temp1 CMP
- label JLE ;
+M: x86 %horizontal-shl-vector ( dst src1 src2 rep -- )
+ two-operand PSLLDQ ;
-M: x86 %save-gc-root ( gc-root register -- ) [ gc-root@ ] dip MOV ;
+M: x86 %horizontal-shl-vector-reps
+ {
+ { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
-M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ MOV ;
+M: x86 %horizontal-shr-vector ( dst src1 src2 rep -- )
+ two-operand PSRLDQ ;
-M: x86 %alien-global ( dst symbol library -- )
- [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
+M: x86 %horizontal-shr-vector-reps
+ {
+ { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
-M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
+M: x86 %abs-vector ( dst src rep -- )
+ {
+ { char-16-rep [ PABSB ] }
+ { short-8-rep [ PABSW ] }
+ { int-4-rep [ PABSD ] }
+ } case ;
-:: %boolean ( dst temp word -- )
- dst \ f tag-number MOV
- temp 0 MOV \ t rc-absolute-cell rel-immediate
- dst temp word execute ; inline
+M: x86 %abs-vector-reps
+ {
+ { ssse3? { char-16-rep short-8-rep int-4-rep } }
+ } available-reps ;
-M:: x86 %compare ( dst src1 src2 cc temp -- )
- src1 src2 CMP
- cc order-cc {
- { cc< [ dst temp \ CMOVL %boolean ] }
- { cc<= [ dst temp \ CMOVLE %boolean ] }
- { cc> [ dst temp \ CMOVG %boolean ] }
- { cc>= [ dst temp \ CMOVGE %boolean ] }
- { cc= [ dst temp \ CMOVE %boolean ] }
- { cc/= [ dst temp \ CMOVNE %boolean ] }
+M: x86 %sqrt-vector ( dst src rep -- )
+ {
+ { float-4-rep [ SQRTPS ] }
+ { double-2-rep [ SQRTPD ] }
} case ;
-M: x86 %compare-imm ( dst src1 src2 cc temp -- )
- %compare ;
-
-: %cmov-float= ( dst src -- )
- [
- "no-move" define-label
+M: x86 %sqrt-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep } }
+ } available-reps ;
- "no-move" get [ JNE ] [ JP ] bi
- MOV
- "no-move" resolve-label
- ] with-scope ;
+M: x86 %and-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { float-4-rep [ ANDPS ] }
+ { double-2-rep [ ANDPD ] }
+ [ drop PAND ]
+ } case ;
-: %cmov-float/= ( dst src -- )
- [
- "no-move" define-label
- "move" define-label
+M: x86 %and-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
- "move" get JP
- "no-move" get JE
- "move" resolve-label
- MOV
- "no-move" resolve-label
- ] with-scope ;
+M: x86 %andn-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { float-4-rep [ ANDNPS ] }
+ { double-2-rep [ ANDNPD ] }
+ [ drop PANDN ]
+ } case ;
-:: (%compare-float) ( dst src1 src2 cc temp compare -- )
- cc {
- { cc< [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVA %boolean ] }
- { cc<= [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
- { cc> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVA %boolean ] }
- { cc>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
- { cc= [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float= %boolean ] }
- { cc<> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNE %boolean ] }
- { cc<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNP %boolean ] }
- { cc/< [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
- { cc/<= [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVB %boolean ] }
- { cc/> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
- { cc/>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVB %boolean ] }
- { cc/= [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float/= %boolean ] }
- { cc/<> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVE %boolean ] }
- { cc/<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVP %boolean ] }
- } case ; inline
+M: x86 %andn-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
-M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- )
- \ COMISD (%compare-float) ;
+M: x86 %or-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { float-4-rep [ ORPS ] }
+ { double-2-rep [ ORPD ] }
+ [ drop POR ]
+ } case ;
-M: x86 %compare-float-unordered ( dst src1 src2 cc temp -- )
- \ UCOMISD (%compare-float) ;
+M: x86 %or-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
-M:: x86 %compare-branch ( label src1 src2 cc -- )
- src1 src2 CMP
- cc order-cc {
- { cc< [ label JL ] }
- { cc<= [ label JLE ] }
- { cc> [ label JG ] }
- { cc>= [ label JGE ] }
- { cc= [ label JE ] }
- { cc/= [ label JNE ] }
+M: x86 %xor-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { float-4-rep [ XORPS ] }
+ { double-2-rep [ XORPD ] }
+ [ drop PXOR ]
} case ;
-M: x86 %compare-imm-branch ( label src1 src2 cc -- )
- %compare-branch ;
+M: x86 %xor-vector-reps
+ {
+ { sse? { float-4-rep } }
+ { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
-: %jump-float= ( label -- )
- [
- "no-jump" define-label
- "no-jump" get JP
- JE
- "no-jump" resolve-label
- ] with-scope ;
+M: x86 %shl-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { short-8-rep [ PSLLW ] }
+ { ushort-8-rep [ PSLLW ] }
+ { int-4-rep [ PSLLD ] }
+ { uint-4-rep [ PSLLD ] }
+ { longlong-2-rep [ PSLLQ ] }
+ { ulonglong-2-rep [ PSLLQ ] }
+ } case ;
-: %jump-float/= ( label -- )
- [ JNE ] [ JP ] bi ;
+M: x86 %shl-vector-reps
+ {
+ { sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ } available-reps ;
-:: (%compare-float-branch) ( label src1 src2 cc compare -- )
- cc {
- { cc< [ src2 src1 \ compare execute( a b -- ) label JA ] }
- { cc<= [ src2 src1 \ compare execute( a b -- ) label JAE ] }
- { cc> [ src1 src2 \ compare execute( a b -- ) label JA ] }
- { cc>= [ src1 src2 \ compare execute( a b -- ) label JAE ] }
- { cc= [ src1 src2 \ compare execute( a b -- ) label %jump-float= ] }
- { cc<> [ src1 src2 \ compare execute( a b -- ) label JNE ] }
- { cc<>= [ src1 src2 \ compare execute( a b -- ) label JNP ] }
- { cc/< [ src2 src1 \ compare execute( a b -- ) label JBE ] }
- { cc/<= [ src2 src1 \ compare execute( a b -- ) label JB ] }
- { cc/> [ src1 src2 \ compare execute( a b -- ) label JBE ] }
- { cc/>= [ src1 src2 \ compare execute( a b -- ) label JB ] }
- { cc/= [ src1 src2 \ compare execute( a b -- ) label %jump-float/= ] }
- { cc/<> [ src1 src2 \ compare execute( a b -- ) label JE ] }
- { cc/<>= [ src1 src2 \ compare execute( a b -- ) label JP ] }
+M: x86 %shr-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ {
+ { short-8-rep [ PSRAW ] }
+ { ushort-8-rep [ PSRLW ] }
+ { int-4-rep [ PSRAD ] }
+ { uint-4-rep [ PSRLD ] }
+ { ulonglong-2-rep [ PSRLQ ] }
} case ;
-M: x86 %compare-float-ordered-branch ( label src1 src2 cc -- )
- \ COMISD (%compare-float-branch) ;
+M: x86 %shr-vector-reps
+ {
+ { sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep ulonglong-2-rep } }
+ } available-reps ;
-M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- )
- \ UCOMISD (%compare-float-branch) ;
+: scalar-sized-reg ( reg rep -- reg' )
+ rep-size 8 * n-bit-version-of ;
-M:: x86 %spill ( src rep n -- )
- n spill@ src rep %copy ;
+M: x86 %integer>scalar scalar-sized-reg MOVD ;
+M: x86 %scalar>integer swap [ scalar-sized-reg ] dip MOVD ;
+M: x86 %vector>scalar %copy ;
+M: x86 %scalar>vector %copy ;
-M:: x86 %reload ( dst rep n -- )
- dst n spill@ rep %copy ;
+M:: x86 %spill ( src rep dst -- ) dst src rep %copy ;
+M:: x86 %reload ( dst rep src -- ) dst src rep %copy ;
M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
: enable-sse2 ( version -- )
20 >= [
enable-float-intrinsics
- enable-fsqrt
+ enable-float-functions
enable-float-min/max
+ enable-fsqrt
install-sse2-check
] when ;
! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
! tested on debian linux with postgresql 8.1
-USING: alien alien.syntax combinators system alien.libraries ;
+USING: alien alien.c-types alien.syntax combinators system
+alien.libraries ;
IN: db.postgresql.ffi
<< "postgresql" {
TYPEDEF: int PGTransactionStatusType
TYPEDEF: int PGVerbosity
-TYPEDEF: void* PGconn*
-TYPEDEF: void* PGresult*
-TYPEDEF: void* PGcancel*
+C-TYPE: PGconn
+C-TYPE: PGresult
+C-TYPE: PGcancel
TYPEDEF: uint Oid
TYPEDEF: uint* Oid*
TYPEDEF: char pqbool
-TYPEDEF: void* PQconninfoOption*
-TYPEDEF: void* PGnotify*
-TYPEDEF: void* PQArgBlock*
-TYPEDEF: void* PQprintOpt*
-TYPEDEF: void* FILE*
-TYPEDEF: void* SSL*
+C-TYPE: PQconninfoOption
+C-TYPE: PGnotify
+C-TYPE: PQArgBlock
+C-TYPE: PQprintOpt
+C-TYPE: SSL
+C-TYPE: FILE
LIBRARY: postgresql
GENERIC: definition-icon ( definition -- path )
: definition-icon-path ( string -- string' )
- "vocab:definitions/icons/" prepend-path ".tiff" append ;
+ "vocab:definitions/icons/" prepend-path ".png" append ;
<<
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax system environment.unix ;
+USING: alien.c-types alien.syntax system environment.unix ;
IN: environment.unix.macosx
FUNCTION: void* _NSGetEnviron ( ) ;
USING: accessors alien alien.c-types alien.strings arrays
-assocs byte-arrays combinators continuations game-input
-game-input.dinput.keys-array io.encodings.utf16
-io.encodings.utf16n kernel locals math math.bitwise
-math.rectangles namespaces parser sequences shuffle
-specialized-arrays ui.backend.windows vectors windows.com
-windows.dinput windows.dinput.constants windows.errors
-windows.kernel32 windows.messages windows.ole32
-windows.user32 classes.struct alien.data ;
+assocs byte-arrays combinators combinators.short-circuit
+continuations game-input game-input.dinput.keys-array
+io.encodings.utf16 io.encodings.utf16n kernel locals math
+math.bitwise math.rectangles namespaces parser sequences
+shuffle specialized-arrays ui.backend.windows vectors
+windows.com windows.dinput windows.dinput.constants
+windows.errors windows.kernel32 windows.messages
+windows.ole32 windows.user32 classes.struct alien.data ;
SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA
IN: game-input.dinput
handle>> device-guid ;
:: with-acquisition ( device acquired-quot succeeded-quot failed-quot -- result/f )
- device IDirectInputDevice8W::Acquire succeeded? [
+ device { [ ] [ IDirectInputDevice8W::Acquire succeeded? ] } 1&& [
device acquired-quot call
succeeded-quot call
] failed-quot if ; inline
} ;\r
\r
HELP: napply\r
-{ $values { "quot" quotation } { "n" integer } }\r
+{ $values { "n" integer } }\r
{ $description "A generalization of " { $link bi@ } " and " { $link tri@ } " that can work for any stack depth."\r
} \r
{ $examples\r
-USING: tools.test generalizations kernel math arrays sequences ascii ;\r
+USING: tools.test generalizations kernel math arrays sequences\r
+ascii fry math.parser ;\r
IN: generalizations.tests\r
\r
{ 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test\r
1 2 3 4 3 nover ;\r
\r
[ 1 2 3 4 1 2 3 ] [ nover-test ] unit-test\r
+\r
+[ '[ number>string _ append ] 4 napply ] must-infer\r
'[ [ _ _ nspread ] _ ndip @ ]
] if ;
-MACRO: napply ( quot n -- )
- swap <repetition> spread>quot ;
+MACRO: napply ( n -- )
+ [ [ drop ] ] dip [ '[ tuck _ 2dip call ] ] times ;
MACRO: mnswap ( m n -- )
1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
! Copyright (C) 2008 Matthew Willis.
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license
-USING: alien alien.syntax alien.destructors combinators system
-alien.libraries ;
+USING: alien alien.c-types alien.syntax alien.destructors
+combinators system alien.libraries ;
IN: glib
<<
TYPEDEF: int gint
TYPEDEF: bool gboolean
-FUNCTION: void
-g_free ( gpointer mem ) ;
+FUNCTION: void g_free ( gpointer mem ) ;
LIBRARY: gobject
-FUNCTION: void
-g_object_unref ( gpointer object ) ;
+FUNCTION: void g_object_unref ( gpointer object ) ;
DESTRUCTOR: g_object_unref
{ $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
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays combinators
+USING: accessors alien.c-types arrays byte-arrays combinators
compression.run-length fry grouping images images.loader io
io.binary io.encodings.8-bit io.encodings.binary
io.encodings.string io.streams.limited kernel math math.bitwise
+++ /dev/null
-Doug Coleman
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: http.client images.loader images.loader.private kernel ;
-IN: images.http
-
-: load-http-image ( path -- image )
- [ http-get nip ] [ image-class new ] bi load-image* ;
QUALIFIED-WITH: bitstreams bs
-TUPLE: jpeg-image < image
+SINGLETON: jpeg-image
+
+TUPLE: loading-jpeg < image
{ headers }
{ bitstream }
{ color-info initial: { f f f f } }
<PRIVATE
-: <jpeg-image> ( headers bitstream -- image )
- jpeg-image new swap >>bitstream swap >>headers ;
+: <loading-jpeg> ( headers bitstream -- image )
+ loading-jpeg new swap >>bitstream swap >>headers ;
SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
APP JPG COM TEM RES ;
ERROR: not-a-jpeg-image ;
-PRIVATE>
-
-M: jpeg-image stream>image ( stream jpeg-image -- bitmap )
- drop [
- parse-marker { SOI } = [ not-a-jpeg-image ] unless
- parse-headers
- contents <jpeg-image>
- ] with-input-stream
+: loading-jpeg>image ( loading-jpeg -- image )
dup jpeg-image [
baseline-parse
baseline-decompress
] with-variable ;
+
+: load-jpeg ( stream -- loading-jpeg )
+ [
+ parse-marker { SOI } = [ not-a-jpeg-image ] unless
+ parse-headers
+ unlimited-input contents <loading-jpeg>
+ ] with-input-stream ;
+
+PRIVATE>
+
+M: jpeg-image stream>image ( stream jpeg-image -- bitmap )
+ drop load-jpeg loading-jpeg>image ;
USING: accessors assocs byte-arrays combinators images
io.encodings.binary io.pathnames io.streams.byte-array
io.streams.limited kernel namespaces splitting strings
-unicode.case ;
+unicode.case sequences ;
IN: images.loader
ERROR: unknown-image-extension extension ;
[ open-image-file ] [ image-class ] bi load-image* ;
M: byte-array load-image*
- [ binary <byte-reader> ] dip stream>image ;
+ [
+ [ binary <byte-reader> ]
+ [ length stream-throws <limited-stream> ] bi
+ ] dip stream>image ;
M: limited-stream load-image* stream>image ;
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors images io io.binary io.encodings.ascii
-io.encodings.binary io.encodings.string io.files io.files.info kernel
-sequences io.streams.limited fry combinators arrays math checksums
-checksums.crc32 compression.inflate grouping byte-arrays images.loader ;
+USING: accessors arrays checksums checksums.crc32 combinators
+compression.inflate fry grouping images images.loader io
+io.binary io.encodings.ascii io.encodings.string kernel locals
+math math.bitwise math.ranges sequences sorting ;
IN: images.png
SINGLETON: png-image
ERROR: unknown-color-type n ;
ERROR: unimplemented-color-type image ;
-ERROR: unknown-filter-method image ;
: inflate-data ( loading-png -- bytes )
find-compressed-bytes zlib-inflate ;
-: png-group-width ( loading-png -- n )
+: scale-bit-depth ( loading-png -- n ) bit-depth>> 8 / ; inline
+
+: png-bytes-per-pixel ( loading-png -- n )
dup color-type>> {
- { 2 [ [ bit-depth>> 8 / 3 * ] [ width>> ] bi * 1 + ] }
- { 6 [ [ bit-depth>> 8 / 4 * ] [ width>> ] bi * 1 + ] }
+ { 2 [ scale-bit-depth 3 * ] }
+ { 6 [ scale-bit-depth 4 * ] }
[ unknown-color-type ]
- } case ;
+ } case ; inline
-: filter-png ( groups loading-png -- byte-array )
- filter-method>> {
- { filter-none [ reverse-png-filter ] }
- [ unknown-filter-method ]
- } case ;
+: png-group-width ( loading-png -- n )
+ ! 1 + is for the filter type, 1 byte preceding each line
+ [ png-bytes-per-pixel ] [ width>> ] bi * 1 + ;
+
+:: paeth ( a b c -- p )
+ a b + c - { a b c } [ [ - abs ] keep 2array ] with map
+ sort-keys first second ;
+
+:: png-unfilter-line ( width prev curr filter -- curr' )
+ prev :> c
+ prev width tail-slice :> b
+ curr :> a
+ curr width tail-slice :> x
+ x length [0,b)
+ filter {
+ { filter-none [ drop ] }
+ { filter-sub [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
+ { filter-up [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
+ { filter-average [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
+ { filter-paeth [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
+ } case
+ curr width tail ;
+
+:: reverse-png-filter ( n lines -- byte-array )
+ lines dup first length 0 <array> prefix
+ [ n 1 - 0 <array> prepend ] map
+ 2 clump [
+ n swap first2 [ ] [ n 1 - swap nth ] [ [ 0 n 1 - ] dip set-nth ] tri
+ png-unfilter-line
+ ] map B{ } concat-as ;
: png-image-bytes ( loading-png -- byte-array )
- [ [ inflate-data ] [ png-group-width ] bi group ]
- [ filter-png ] bi ;
-
-: decode-greyscale ( loading-png -- loading-png )
- unimplemented-color-type ;
+ [ png-bytes-per-pixel ]
+ [ inflate-data ]
+ [ png-group-width ] tri group reverse-png-filter ;
-: decode-truecolor ( loading-png -- loading-png )
- [ <image> ] dip {
+: loading-png>image ( loading-png -- image )
+ [ image new ] dip {
[ png-image-bytes >>bitmap ]
[ [ width>> ] [ height>> ] bi 2array >>dim ]
- [ drop RGB >>component-order ubyte-components >>component-type ]
+ [ drop ubyte-components >>component-type ]
} cleave ;
+
+: decode-greyscale ( loading-png -- image )
+ unimplemented-color-type ;
+
+: decode-truecolor ( loading-png -- image )
+ loading-png>image RGB >>component-order ;
-: decode-indexed-color ( loading-png -- loading-png )
+: decode-indexed-color ( loading-png -- image )
unimplemented-color-type ;
-: decode-greyscale-alpha ( loading-png -- loading-png )
+: decode-greyscale-alpha ( loading-png -- image )
unimplemented-color-type ;
-: decode-truecolor-alpha ( loading-png -- loading-png )
- [ <image> ] dip {
- [ png-image-bytes >>bitmap ]
- [ [ width>> ] [ height>> ] bi 2array >>dim ]
- [ drop RGBA >>component-order ubyte-components >>component-type ]
- } cleave ;
+: decode-truecolor-alpha ( loading-png -- image )
+ loading-png>image RGBA >>component-order ;
ERROR: invalid-color-type/bit-depth loading-png ;
: validate-truecolor-alpha ( loading-png -- loading-png )
{ 8 16 } validate-bit-depth ;
-: decode-png ( loading-png -- loading-png )
+: png>image ( loading-png -- image )
dup color-type>> {
{ greyscale [ validate-greyscale decode-greyscale ] }
{ truecolor [ validate-truecolor decode-truecolor ] }
[ unknown-color-type ]
} case ;
-M: png-image stream>image
- drop [
+: load-png ( stream -- loading-png )
+ [
<loading-png>
read-png-header
read-png-chunks
parse-ihdr-chunk
- decode-png
] with-input-stream ;
+
+M: png-image stream>image
+ drop load-png png>image ;
math.bitwise math.order math.parser pack prettyprint sequences
strings math.vectors specialized-arrays locals
images.loader ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: images.tiff
: process-tif-ifds ( loading-tiff -- )
ifds>> [ process-ifd ] each ;
-: load-tiff ( path -- loading-tiff )
+: load-tiff ( stream -- loading-tiff )
[ load-tiff-ifds dup ]
[
[ [ 0 seek-absolute ] dip stream-seek ]
--- /dev/null
+Slava Pestov\r
--- /dev/null
+unportable\r
USING: help.markup help.syntax alien math continuations
-destructors ;
+destructors specialized-arrays ;
IN: io.mmap
HELP: mapped-file
HELP: with-mapped-file-reader
{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
{ $contract "Opens a file for read-only access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
-{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." }
+{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. See " { $link "io.mmap.arrays" } " for a discussion of how to access data in a mapped file." }
{ $errors "Throws an error if a memory mapping could not be established." } ;
HELP: close-mapped-file
{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." }
{ $errors "Throws an error if a memory mapping could not be established." } ;
-ARTICLE: "io.mmap.arrays" "Memory-mapped arrays"
-"Mapped file can be viewed as a sequence using the words in sub-vocabularies of " { $vocab-link "io.mmap" } ". For each primitive C type " { $snippet "T" } ", a set of words are defined in the vocabulary named " { $snippet "io.mmap.T" } ":"
-{ $table
- { { $snippet "<mapped-T-array>" } { "Wraps a " { $link mapped-file } " in a sequence; stack effect " { $snippet "( mapped-file -- direct-array )" } } }
- { { $snippet "with-mapped-T-file" } { "Maps a file into memory and wraps it in a sequence by combining " { $link with-mapped-file } " and " { $snippet "<mapped-T-array>" } "; stack effect " { $snippet "( path quot -- )" } } }
-}
-"The primitive C types for which mapped arrays exist:"
-{ $list
- { $snippet "char" }
- { $snippet "uchar" }
- { $snippet "short" }
- { $snippet "ushort" }
- { $snippet "int" }
- { $snippet "uint" }
- { $snippet "long" }
- { $snippet "ulong" }
- { $snippet "longlong" }
- { $snippet "ulonglong" }
- { $snippet "float" }
- { $snippet "double" }
- { $snippet "void*" }
- { $snippet "bool" }
-} ;
-
-ARTICLE: "io.mmap.low-level" "Reading and writing mapped files directly"
-"Data can be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. See " { $link "reading-writing-memory" } "." ;
+ARTICLE: "io.mmap.arrays" "Working with memory-mapped data"
+"The " { $link <mapped-file> } " word returns an instance of " { $link mapped-file } ", which doesn't directly support the sequence protocol. Instead, it needs to be wrapped in a specialized array of the appropriate C type:"
+{ $subsection <mapped-array> }
+"The appropriate specialized array type must first be generated with " { $link POSTPONE: SPECIALIZED-ARRAY: } "."
+$nl
+"Data can also be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. This approach is not recommended, though, since in most cases the compiler will generate efficient code for specialized array usage. See " { $link "reading-writing-memory" } " for a description of low-level memory access primitives." ;
-ARTICLE: "io.mmap.examples" "Memory-mapped file example"
+ARTICLE: "io.mmap.examples" "Memory-mapped file examples"
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
{ $code
- "USING: accessors grouping io.files io.mmap.char kernel sequences ;"
+ "USING: alien.c-types grouping io.mmap sequences" "specialized-arrays ;"
+ "SPECIALIZED-ARRAY: char"
+ ""
+ "\"mydata.dat\" ["
+ " char <mapped-array> 4 <sliced-groups>"
+ " [ reverse-here ] change-each"
+ "] with-mapped-file"
+}
+"Normalize a file containing packed quadrupes of floats:"
+{ $code
+ "USING: kernel io.mmap math.vectors math.vectors.simd" "sequences specialized-arrays ;"
+ "SIMD: float"
+ "SPECIALIZED-ARRAY: float-4"
+ ""
"\"mydata.dat\" ["
- " 4 <sliced-groups> [ reverse-here ] change-each"
- "] with-mapped-char-file"
+ " float-4 <mapped-array>"
+ " [ normalize ] change-each"
+ "] with-mapped-file"
} ;
ARTICLE: "io.mmap" "Memory-mapped files"
"The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files."
{ $subsection <mapped-file> }
-"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "."
-{ $subsection "io.mmap.examples" }
-"A utility combinator which wraps the above:"
+"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } ". A utility combinator which wraps the above:"
{ $subsection with-mapped-file }
"Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:"
{ $subsection "io.mmap.arrays" }
-{ $subsection "io.mmap.low-level" } ;
+{ $subsection "io.mmap.examples" } ;
ABOUT: "io.mmap"
-USING: io io.mmap io.files io.files.temp
-io.directories kernel tools.test continuations sequences
-io.encodings.ascii accessors math ;
+USING: io io.mmap io.files io.files.temp io.directories kernel
+tools.test continuations sequences io.encodings.ascii accessors
+math compiler.tree.debugger alien.data alien.c-types
+sequences.private ;
IN: io.mmap.tests
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
[ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test
-[ ] [ "mmap-test-file.txt" temp-file [ "char" <mapped-array> CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
-[ 5 ] [ "mmap-test-file.txt" temp-file [ "char" <mapped-array> length ] with-mapped-file ] unit-test
-[ 5 ] [ "mmap-test-file.txt" temp-file [ "char" <mapped-array> length ] with-mapped-file-reader ] unit-test
+[ ] [ "mmap-test-file.txt" temp-file [ char <mapped-array> CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
+[ 5 ] [ "mmap-test-file.txt" temp-file [ char <mapped-array> length ] with-mapped-file ] unit-test
+[ 5 ] [ "mmap-test-file.txt" temp-file [ char <mapped-array> length ] with-mapped-file-reader ] unit-test
[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
drop
] with-mapped-file
] [ bad-mmap-size? ] must-fail-with
+
+[ t ] [
+ [ "test.txt" <mapped-file> void* <c-direct-array> first-unsafe ]
+ { nth-unsafe } inlined?
+] unit-test
PRIVATE>
: <mapped-file-reader> ( path -- mmap )
- [ (mapped-file-reader) ] prepare-mapped-file ;
+ [ (mapped-file-reader) ] prepare-mapped-file ; inline
: <mapped-file> ( path -- mmap )
- [ (mapped-file-r/w) ] prepare-mapped-file ;
+ [ (mapped-file-r/w) ] prepare-mapped-file ; inline
: <mapped-array> ( mmap c-type -- direct-array )
[ [ address>> ] [ length>> ] bi ] dip
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: system kernel unix math sequences
+USING: alien.c-types system kernel unix math sequences
io.backend.unix io.ports specialized-arrays accessors ;
QUALIFIED: io.pipes
SPECIALIZED-ARRAY: int
"HELLO"
[ f stream-throws limit-input 4 read ]
with-string-reader
-] unit-test
\ No newline at end of file
+] unit-test
+
+
+[ "asdf" ] [
+ "asdf" <string-reader> 2 stream-eofs <limited-stream> [
+ unlimited-input contents
+ ] with-input-stream
+] unit-test
[ stream>> ] change-stream ;
M: object unlimited ( stream -- stream' )
- stream>> stream>> ;
+ stream>> ;
: limit-input ( limit mode -- )
[ input-stream ] 2dip '[ _ _ limit ] change ;
M: limited-stream dispose
stream>> dispose ;
+
+M: limited-stream stream-element-type
+ stream>> stream-element-type ;
-USING: iokit alien alien.syntax alien.c-types kernel
-system core-foundation core-foundation.data
-core-foundation.dictionaries ;
+USING: iokit alien alien.syntax alien.c-types kernel system
+core-foundation core-foundation.arrays core-foundation.data
+core-foundation.dictionaries core-foundation.run-loop
+core-foundation.strings core-foundation.time ;
IN: iokit.hid
CONSTANT: kIOHIDDeviceKey "IOHIDDevice"
-USING: accessors alien alien.c-types alien.data arrays
-byte-arrays combinators combinators.short-circuit fry
-kernel locals macros math math.blas.ffi math.blas.vectors
-math.blas.vectors.private math.complex math.functions
-math.order functors words sequences sequences.merged
-sequences.private shuffle parser prettyprint.backend
-prettyprint.custom ascii specialized-arrays ;
+USING: accessors alien alien.c-types alien.complex
+alien.data arrays byte-arrays combinators
+combinators.short-circuit fry kernel locals macros math
+math.blas.ffi math.blas.vectors math.blas.vectors.private
+math.complex math.functions math.order functors words
+sequences sequences.merged sequences.private shuffle
+parser prettyprint.backend prettyprint.custom ascii
+specialized-arrays ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: double
-USING: accessors alien alien.c-types arrays ascii byte-arrays combinators
-combinators.short-circuit fry kernel math math.blas.ffi
-math.complex math.functions math.order sequences sequences.private
-functors words locals parser prettyprint.backend prettyprint.custom
-specialized-arrays ;
+USING: accessors alien alien.c-types alien.complex arrays ascii
+byte-arrays combinators combinators.short-circuit fry kernel
+math math.blas.ffi math.complex math.functions math.order
+sequences sequences.private functors words locals parser
+prettyprint.backend prettyprint.custom specialized-arrays ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: double
[ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception-compiled unit-test
[ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception-compiled unit-test
[ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test
+[ t ] +fp-invalid-operation+ [ 2.0 0/0. 1.0e-9 ] [ ~ ] test-fp-exception-compiled unit-test
! No underflow on Linux with this test, just inexact. Reported as an Ubuntu bug:
! https://bugs.launchpad.net/ubuntu/+source/glibc/+bug/429113
-USING: accessors alien.syntax arrays assocs biassocs
-classes.struct combinators kernel literals math math.bitwise
-math.floats.env math.floats.env.private system ;
+USING: accessors alien.c-types alien.syntax arrays assocs
+biassocs classes.struct combinators kernel literals math
+math.bitwise math.floats.env math.floats.env.private system ;
IN: math.floats.env.ppc
STRUCT: ppc-fpu-env
-USING: accessors alien.syntax arrays assocs biassocs
-classes.struct combinators cpu.x86.features kernel literals
-math math.bitwise math.floats.env math.floats.env.private
-system ;
+USING: accessors alien.c-types alien.syntax arrays assocs
+biassocs classes.struct combinators cpu.x86.features kernel
+literals math math.bitwise math.floats.env
+math.floats.env.private system ;
IN: math.floats.env.x86
STRUCT: sse-env
[ 4.0 ] [ 10000.0 log10 ] unit-test
[ t ] [ 1 exp e 1.e-10 ~ ] unit-test
+[ f ] [ 1 exp 0/0. 1.e-10 ~ ] unit-test
+[ f ] [ 0/0. 1 exp 1.e-10 ~ ] unit-test
[ t ] [ 1.0 exp e 1.e-10 ~ ] unit-test
[ t ] [ -1 exp e * 1.0 1.e-10 ~ ] unit-test
+[ f ] [ 1/0. 1/0. 1.e-10 ~ ] unit-test
+[ f ] [ 1/0. -1/0. 1.e-10 ~ ] unit-test
+[ f ] [ 1/0. 0/0. 1.e-10 ~ ] unit-test
+[ f ] [ 0/0. -1/0. 1.e-10 ~ ] unit-test
[ 1.0 ] [ 0 cosh ] unit-test
[ 1.0 ] [ 0.0 cosh ] unit-test
: ~ ( x y epsilon -- ? )
{
- { [ 2over [ fp-nan? ] either? ] [ 3drop f ] }
{ [ dup zero? ] [ drop number= ] }
{ [ dup 0 < ] [ neg ~rel ] }
[ ~abs ]
: m.v ( m v -- v ) [ v. ] curry map ;
: m. ( m m -- m ) flip [ swap m.v ] curry map ;
+: m~ ( m m epsilon -- ? ) [ v~ ] curry 2all? ;
+
: mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ;
: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ;
: mnorm ( m -- n ) dup mmax abs m/n ;
: m^n ( m n -- n )
make-bits over first length identity-matrix
- [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;
\ No newline at end of file
+ [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types assocs byte-arrays classes
-effects fry functors generalizations kernel literals locals
-math math.functions math.vectors math.vectors.simd.intrinsics
+USING: accessors assocs byte-arrays classes effects fry
+functors generalizations kernel literals locals math math.functions
+math.vectors math.vectors.private math.vectors.simd.intrinsics
math.vectors.specialization parser prettyprint.custom sequences
sequences.private strings words definitions macros cpu.architecture
-namespaces arrays quotations ;
-QUALIFIED-WITH: math m
+namespaces arrays quotations combinators sets layouts ;
+QUALIFIED-WITH: alien.c-types c
IN: math.vectors.simd.functor
ERROR: bad-length got expected ;
MACRO: simd-boa ( rep class -- simd-array )
[ rep-components ] [ new ] bi* '[ _ _ nsequence ] ;
+: can-be-unboxed? ( type -- ? )
+ {
+ { c:float [ t ] }
+ { c:double [ t ] }
+ [ c:heap-size cell < ]
+ } case ;
+
+: simd-boa-fast? ( rep -- ? )
+ [ dup rep-gather-word supported-simd-op? ]
+ [ rep-component-type can-be-unboxed? ]
+ bi and ;
+
:: define-boa-custom-inlining ( word rep class -- )
word [
drop
- rep rep rep-gather-word supported-simd-op? [
+ rep simd-boa-fast? [
[ rep (simd-boa) class boa ]
] [ word def>> ] if
] "custom-inlining" set-word-prop ;
: simd-with ( rep class x -- simd-array )
[ rep-components ] [ new ] [ '[ _ ] ] tri* swap replicate-as ; inline
+: simd-with-fast? ( rep -- ? )
+ [ \ (simd-vshuffle) supported-simd-op? ]
+ [ rep-component-type can-be-unboxed? ]
+ bi and ;
+
:: define-with-custom-inlining ( word rep class -- )
word [
drop
- rep \ (simd-broadcast) supported-simd-op? [
- [ rep rep-coerce rep (simd-broadcast) class boa ]
+ rep simd-with-fast? [
+ [ rep rep-coerce rep (simd-with) class boa ]
] [ word def>> ] if
] "custom-inlining" set-word-prop ;
+: simd-nth-fast? ( rep -- ? )
+ [ \ (simd-vshuffle) supported-simd-op? ]
+ [ rep-component-type can-be-unboxed? ]
+ bi and ;
+
+: simd-nth-fast ( rep -- quot )
+ [ rep-components ] keep
+ '[ swap _ '[ _ _ (simd-select) ] 2array ] map-index
+ '[ swap >fixnum _ case ] ;
+
+: simd-nth-slow ( rep -- quot )
+ rep-component-type dup c:c-type-getter-boxer c:array-accessor ;
+
+MACRO: simd-nth ( rep -- x )
+ dup simd-nth-fast? [ simd-nth-fast ] [ simd-nth-slow ] if ;
+
: boa-effect ( rep n -- effect )
[ rep-components ] dip *
[ CHAR: a + 1string ] map
ERROR: bad-schema schema ;
-: low-level-ops ( box-quot: ( inputs... simd-op -- outputs... ) -- alist )
- [ simd-ops get ] dip '[
+: low-level-ops ( simd-ops alist -- alist' )
+ '[
1quotation
over word-schema _ ?at [ bad-schema ] unless
[ ] 2sequence
:: high-level-ops ( ctor elt-class -- assoc )
! Some SIMD operations are defined in terms of others.
{
- { vneg [ [ dup v- ] keep v- ] }
+ { vbroadcast [ swap nth ctor execute ] }
+ { vneg [ [ dup vbitxor ] keep v- ] }
{ n+v [ [ ctor execute ] dip v+ ] }
{ v+n [ ctor execute v+ ] }
{ n-v [ [ ctor execute ] dip v- ] }
! To compute dot product and distance with integer vectors, we
! have to do things less efficiently, with integer overflow checks,
! in the general case.
- elt-class m:float = [
- {
- { distance [ v- norm ] }
- { v. [ v* sum ] }
- } append
- ] when ;
-
-:: simd-vector-words ( class ctor rep vv->v vn->v v->v v->n -- )
- rep rep-component-type c-type-boxed-class :> elt-class
- class
- elt-class
+ elt-class float = [ { distance [ v- norm ] } suffix ] when ;
+
+TUPLE: simd class elt-class ops wrappers ctor rep ;
+
+: define-simd ( simd -- )
+ dup rep>> rep-component-type c:c-type-boxed-class >>elt-class
{
- { { +vector+ +vector+ -> +vector+ } vv->v }
- { { +vector+ +scalar+ -> +vector+ } vn->v }
- { { +vector+ -> +vector+ } v->v }
- { { +vector+ -> +scalar+ } v->n }
- { { +vector+ -> +nonnegative+ } v->n }
- } low-level-ops
- rep supported-simd-ops
- ctor elt-class high-level-ops assoc-union
+ [ class>> ]
+ [ elt-class>> ]
+ [ [ ops>> ] [ wrappers>> ] bi low-level-ops ]
+ [ rep>> supported-simd-ops ]
+ [ [ ctor>> ] [ elt-class>> ] bi high-level-ops assoc-union ]
+ } cleave
specialize-vector-words ;
:: define-simd-128-type ( class rep -- )
- <c-type>
+ c:<c-type>
byte-array >>class
class >>boxed-class
[ rep alien-vector class boa ] >>getter
16 >>size
8 >>align
rep >>rep
- class typedef ;
+ class c:typedef ;
+
+: (define-simd-128) ( simd -- )
+ simd-ops get >>ops
+ [ define-simd ]
+ [ [ class>> ] [ rep>> ] bi define-simd-128-type ] bi ;
FUNCTOR: define-simd-128 ( T -- )
-N [ 16 T heap-size /i ]
+N [ 16 T c:heap-size /i ]
A DEFINES-CLASS ${T}-${N}
A-boa DEFINES ${A}-boa
A-with DEFINES ${A}-with
+A-cast DEFINES ${A}-cast
>A DEFINES >${A}
A{ DEFINES ${A}{
-NTH [ T dup c-type-getter-boxer array-accessor ]
-SET-NTH [ T dup c-setter array-accessor ]
+SET-NTH [ T dup c:c-setter c:array-accessor ]
A-rep [ A name>> "-rep" append "cpu.architecture" lookup ]
A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
A-vn->v-op DEFINES-PRIVATE ${A}-vn->v-op
+A-vv->n-op DEFINES-PRIVATE ${A}-vv->n-op
A-v->v-op DEFINES-PRIVATE ${A}-v->v-op
A-v->n-op DEFINES-PRIVATE ${A}-v->n-op
M: A length drop N ; inline
-M: A nth-unsafe underlying>> NTH call ; inline
+M: A nth-unsafe underlying>> A-rep simd-nth ; inline
M: A set-nth-unsafe underlying>> SET-NTH call ; inline
M: A like drop dup \ A instance? [ >A ] unless ; inline
+M: A new-underlying drop \ A boa ; inline
+
M: A new-sequence
drop dup N =
[ drop 16 <byte-array> \ A boa ]
M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
-M: A byte-length underlying>> length ; inline
+M: A c:byte-length underlying>> length ; inline
M: A element-type drop A-rep rep-component-type ;
\ A-boa \ A-rep \ A define-boa-custom-inlining
] when
+: A-cast ( simd-array -- simd-array' )
+ underlying>> \ A boa ; inline
+
INSTANCE: A sequence
<PRIVATE
: A-vn->v-op ( v1 v2 quot -- v3 )
[ [ underlying>> ] dip A-rep ] dip call \ A boa ; inline
+: A-vv->n-op ( v1 v2 quot -- n )
+ [ [ underlying>> ] bi@ A-rep ] dip call ; inline
+
: A-v->v-op ( v1 quot -- v2 )
[ underlying>> A-rep ] dip call \ A boa ; inline
: A-v->n-op ( v quot -- n )
[ underlying>> A-rep ] dip call ; inline
-\ A \ A-with \ A-rep \ A-vv->v-op \ A-vn->v-op \ A-v->v-op \ A-v->n-op simd-vector-words
-\ A \ A-rep define-simd-128-type
+simd new
+ \ A >>class
+ \ A-with >>ctor
+ \ A-rep >>rep
+ {
+ { { +vector+ +vector+ -> +vector+ } A-vv->v-op }
+ { { +vector+ +scalar+ -> +vector+ } A-vn->v-op }
+ { { +vector+ +literal+ -> +vector+ } A-vn->v-op }
+ { { +vector+ +vector+ -> +scalar+ } A-vv->n-op }
+ { { +vector+ -> +vector+ } A-v->v-op }
+ { { +vector+ -> +scalar+ } A-v->n-op }
+ { { +vector+ -> +nonnegative+ } A-v->n-op }
+ } >>wrappers
+(define-simd-128)
PRIVATE>
SLOT: underlying2
:: define-simd-256-type ( class rep -- )
- <c-type>
+ c:<c-type>
class >>class
class >>boxed-class
[
32 >>size
8 >>align
rep >>rep
- class typedef ;
+ class c:typedef ;
+
+: (define-simd-256) ( simd -- )
+ simd-ops get { vshuffle hlshift hrshift } unique assoc-diff >>ops
+ [ define-simd ]
+ [ [ class>> ] [ rep>> ] bi define-simd-256-type ] bi ;
FUNCTOR: define-simd-256 ( T -- )
-N [ 32 T heap-size /i ]
+N [ 32 T c:heap-size /i ]
N/2 [ N 2 / ]
A/2 IS ${T}-${N/2}
A DEFINES-CLASS ${T}-${N}
A-boa DEFINES ${A}-boa
A-with DEFINES ${A}-with
+A-cast DEFINES ${A}-cast
>A DEFINES >${A}
A{ DEFINES ${A}{
A-rep [ A/2 name>> "-rep" append "cpu.architecture" lookup ]
A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
A-vn->v-op DEFINES-PRIVATE ${A}-vn->v-op
+A-vv->n-op DEFINES-PRIVATE ${A}-vv->n-op
A-v->v-op DEFINES-PRIVATE ${A}-v->v-op
A-v->n-op DEFINES-PRIVATE ${A}-v->n-op
M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
-M: A byte-length drop 32 ; inline
+M: A c:byte-length drop 32 ; inline
M: A element-type drop A-rep rep-component-type ;
\ A-rep 2 boa-effect \ A-boa set-stack-effect
+: A-cast ( simd-array -- simd-array' )
+ [ underlying1>> ] [ underlying2>> ] bi \ A boa ; inline
+
INSTANCE: A sequence
: A-vv->v-op ( v1 v2 quot -- v3 )
[ [ [ underlying2>> ] dip A-rep ] dip call ] 3bi
\ A boa ; inline
+: A-vv->n-op ( v1 v2 quot -- v3 )
+ [ [ [ underlying1>> ] bi@ A-rep ] dip call ]
+ [ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi
+ + ; inline
+
: A-v->v-op ( v1 combine-quot -- v2 )
[ [ underlying1>> A-rep ] dip call ]
[ [ underlying2>> A-rep ] dip call ] 2bi
: A-v->n-op ( v1 combine-quot -- v2 )
[ [ underlying1>> ] [ underlying2>> ] bi A-rep (simd-v+) A-rep ] dip call ; inline
-\ A \ A-with \ A-rep \ A-vv->v-op \ A-vn->v-op \ A-v->v-op \ A-v->n-op simd-vector-words
-\ A \ A-rep define-simd-256-type
+simd new
+ \ A >>class
+ \ A-with >>ctor
+ \ A-rep >>rep
+ {
+ { { +vector+ +vector+ -> +vector+ } A-vv->v-op }
+ { { +vector+ +scalar+ -> +vector+ } A-vn->v-op }
+ { { +vector+ +literal+ -> +vector+ } A-vn->v-op }
+ { { +vector+ +vector+ -> +scalar+ } A-vv->n-op }
+ { { +vector+ -> +vector+ } A-v->v-op }
+ { { +vector+ -> +scalar+ } A-v->n-op }
+ { { +vector+ -> +nonnegative+ } A-v->n-op }
+ } >>wrappers
+(define-simd-256)
;FUNCTOR
SIMD-OP: v/
SIMD-OP: vmin
SIMD-OP: vmax
+SIMD-OP: v.
SIMD-OP: vsqrt
SIMD-OP: sum
SIMD-OP: vabs
SIMD-OP: vbitand
+SIMD-OP: vbitandn
SIMD-OP: vbitor
SIMD-OP: vbitxor
SIMD-OP: vlshift
SIMD-OP: vrshift
+SIMD-OP: hlshift
+SIMD-OP: hrshift
+SIMD-OP: vshuffle
-: (simd-broadcast) ( x rep -- v ) bad-simd-call ;
+: (simd-with) ( x rep -- v ) bad-simd-call ;
: (simd-gather-2) ( a b rep -- v ) bad-simd-call ;
: (simd-gather-4) ( a b c d rep -- v ) bad-simd-call ;
+: (simd-select) ( v n rep -- x ) bad-simd-call ;
+
: assert-positive ( x -- y ) ;
: alien-vector ( c-ptr n rep -- value )
M: vector-rep supported-simd-op?
{
- { \ (simd-v+) [ %add-vector-reps ] }
- { \ (simd-vs+) [ %saturated-add-vector-reps ] }
- { \ (simd-v+-) [ %add-sub-vector-reps ] }
- { \ (simd-v-) [ %sub-vector-reps ] }
- { \ (simd-vs-) [ %saturated-sub-vector-reps ] }
- { \ (simd-v*) [ %mul-vector-reps ] }
- { \ (simd-vs*) [ %saturated-mul-vector-reps ] }
- { \ (simd-v/) [ %div-vector-reps ] }
- { \ (simd-vmin) [ %min-vector-reps ] }
- { \ (simd-vmax) [ %max-vector-reps ] }
- { \ (simd-vsqrt) [ %sqrt-vector-reps ] }
- { \ (simd-sum) [ %horizontal-add-vector-reps ] }
- { \ (simd-vabs) [ %abs-vector-reps ] }
- { \ (simd-vbitand) [ %and-vector-reps ] }
- { \ (simd-vbitor) [ %or-vector-reps ] }
- { \ (simd-vbitxor) [ %xor-vector-reps ] }
- { \ (simd-vlshift) [ %shl-vector-reps ] }
- { \ (simd-vrshift) [ %shr-vector-reps ] }
- { \ (simd-broadcast) [ %broadcast-vector-reps ] }
- { \ (simd-gather-2) [ %gather-vector-2-reps ] }
- { \ (simd-gather-4) [ %gather-vector-4-reps ] }
+ { \ (simd-v+) [ %add-vector-reps ] }
+ { \ (simd-vs+) [ %saturated-add-vector-reps ] }
+ { \ (simd-v+-) [ %add-sub-vector-reps ] }
+ { \ (simd-v-) [ %sub-vector-reps ] }
+ { \ (simd-vs-) [ %saturated-sub-vector-reps ] }
+ { \ (simd-v*) [ %mul-vector-reps ] }
+ { \ (simd-vs*) [ %saturated-mul-vector-reps ] }
+ { \ (simd-v/) [ %div-vector-reps ] }
+ { \ (simd-vmin) [ %min-vector-reps ] }
+ { \ (simd-vmax) [ %max-vector-reps ] }
+ { \ (simd-v.) [ %dot-vector-reps ] }
+ { \ (simd-vsqrt) [ %sqrt-vector-reps ] }
+ { \ (simd-sum) [ %horizontal-add-vector-reps ] }
+ { \ (simd-vabs) [ %abs-vector-reps ] }
+ { \ (simd-vbitand) [ %and-vector-reps ] }
+ { \ (simd-vbitandn) [ %andn-vector-reps ] }
+ { \ (simd-vbitor) [ %or-vector-reps ] }
+ { \ (simd-vbitxor) [ %xor-vector-reps ] }
+ { \ (simd-vlshift) [ %shl-vector-reps ] }
+ { \ (simd-vrshift) [ %shr-vector-reps ] }
+ { \ (simd-hlshift) [ %horizontal-shl-vector-reps ] }
+ { \ (simd-hrshift) [ %horizontal-shr-vector-reps ] }
+ { \ (simd-vshuffle) [ %shuffle-vector-reps ] }
+ { \ (simd-gather-2) [ %gather-vector-2-reps ] }
+ { \ (simd-gather-4) [ %gather-vector-4-reps ] }
} case member? ;
$nl
"SSE1 only supports single-precision SIMD (" { $snippet "float-4" } " and " { $snippet "float-8" } ")."
$nl
-"SSE2 introduces double-precision SIMD (" { $snippet "double-2" } " and " { $snippet "double-4" } ") and integer SIMD (all types). Integer SIMD in missing a few features, in particular the " { $link vmin } " and " { $link vmax } " operations only work on " { $snippet "uchar-16" } " and " { $snippet "short-8" } "."
+"SSE2 introduces double-precision SIMD (" { $snippet "double-2" } " and " { $snippet "double-4" } ") and integer SIMD (all types). Integer SIMD is missing a few features, in particular the " { $link vmin } " and " { $link vmax } " operations only work on " { $snippet "uchar-16" } " and " { $snippet "short-8" } "."
$nl
"SSE3 introduces horizontal adds (summing all components of a single vector register), which is useful for computing dot products. Where available, SSE3 operations are used to speed up " { $link sum } ", " { $link v. } ", " { $link norm-sq } ", " { $link norm } ", and " { $link distance } "."
$nl
"SSSE3 introduces " { $link vabs } " for " { $snippet "char-16" } ", " { $snippet "short-8" } " and " { $snippet "int-4" } "."
$nl
-"SSE4.1 introduces " { $link vmin } " and " { $link vmax } " for all remaining integer types."
+"SSE4.1 introduces " { $link vmin } " and " { $link vmax } " for all remaining integer types, a faster instruction for " { $link v. } ", and a few other things."
$nl
"On PowerPC, or older x86 chips without SSE, software fallbacks are used for all high-level vector operations. SIMD code can run with no loss in functionality, just decreased performance."
$nl
} ;
ARTICLE: "math.vectors.simd.words" "SIMD vector words"
-"For each SIMD vector type, several words are defined:"
+"For each SIMD vector type, several words are defined, where " { $snippet "type" } " is the type in question:"
{ $table
{ "Word" "Stack effect" "Description" }
{ { $snippet "type-with" } { $snippet "( x -- simd-array )" } "creates a new instance where all components are set to a single scalar" }
{ { $snippet "type-boa" } { $snippet "( ... -- simd-array )" } "creates a new instance where components are read from the stack" }
+ { { $snippet "type-cast" } { $snippet "( simd-array -- simd-array' )" } "creates a new SIMD array where the underlying data is taken from another SIMD array, with no format conversion" }
{ { $snippet ">type" } { $snippet "( seq -- simd-array )" } "creates a new instance initialized with the elements of an existing sequence, which must have the correct length" }
{ { $snippet "type{" } { $snippet "type{ elements... }" } "parsing word defining literal syntax for an SIMD vector; the correct number of elements must be given" }
}
ARTICLE: "math.vectors.simd.accuracy" "Numerical accuracy of SIMD primitives"
"No guarantees are made that " { $vocab-link "math.vectors.simd" } " words will give identical results on different SSE versions, or between the hardware intrinsics and the software fallbacks."
$nl
-"In particular, horizontal operations on " { $snippet "float-4" } " and " { $snippet "float-8" } " are affected by this. They are computed with lower precision in intrinsics than the software fallback. Horizontal opeartions include anything involving adding together the components of a vector, such as " { $link sum } " or " { $link normalize } "." ;
+"In particular, horizontal operations on " { $snippet "float-4" } " and " { $snippet "float-8" } " are affected by this. They are computed with lower precision in intrinsics than the software fallback. Horizontal operations include anything involving adding together the components of a vector, such as " { $link sum } " or " { $link normalize } "." ;
ARTICLE: "math.vectors.simd" "Hardware vector arithmetic (SIMD)"
"The " { $vocab-link "math.vectors.simd" } " vocabulary extends the " { $vocab-link "math.vectors" } " vocabulary to support efficient vector arithmetic on small, fixed-size vectors."
tools.test vocabs assocs compiler.cfg.debugger words
locals math.vectors.specialization combinators cpu.architecture
math.vectors.simd.intrinsics namespaces byte-arrays alien
-specialized-arrays classes.struct eval ;
-FROM: alien.c-types => c-type-boxed-class ;
-SPECIALIZED-ARRAY: float
-SIMD: char
-SIMD: uchar
-SIMD: short
-SIMD: ushort
-SIMD: int
-SIMD: uint
-SIMD: longlong
-SIMD: ulonglong
-SIMD: float
-SIMD: double
+specialized-arrays classes.struct eval classes.algebra sets
+quotations math.constants ;
+QUALIFIED-WITH: alien.c-types c
+SPECIALIZED-ARRAY: c:float
+SIMD: c:char
+SIMD: c:uchar
+SIMD: c:short
+SIMD: c:ushort
+SIMD: c:int
+SIMD: c:uint
+SIMD: c:longlong
+SIMD: c:ulonglong
+SIMD: c:float
+SIMD: c:double
IN: math.vectors.simd.tests
! Make sure the functor doesn't generate bogus vocabularies
[ V{ float-4 } ] [ [ { float-4 float-4 } declare v+ ] final-classes ] unit-test
+[ V{ float } ] [ [ { float-4 } declare second ] final-classes ] unit-test
+
+[ V{ int-4 } ] [ [ { int-4 int-4 } declare v+ ] final-classes ] unit-test
+
+[ t ] [ [ { int-4 } declare second ] final-classes first integer class<= ] unit-test
+
+[ V{ longlong-2 } ] [ [ { longlong-2 longlong-2 } declare v+ ] final-classes ] unit-test
+
+[ V{ integer } ] [ [ { longlong-2 } declare second ] final-classes ] unit-test
+
+[ V{ int-8 } ] [ [ { int-8 int-8 } declare v+ ] final-classes ] unit-test
+
+[ t ] [ [ { int-8 } declare second ] final-classes first integer class<= ] unit-test
+
! Test puns; only on x86
cpu x86? [
[ double-2{ 4 1024 } ] [
: boa-ctors ( -- seq )
simd-classes [ [ name>> "-boa" append ] [ vocabulary>> ] bi lookup ] map ;
-: check-optimizer ( seq inputs quot eq-quot -- )
+: check-optimizer ( seq quot eq-quot -- failures )
'[
@
+ [ dup [ class ] { } map-as ] dip '[ _ declare @ ]
{
[ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ]
[ "print-checks" get [ [ . ] bi@ ] [ 2drop ] if ]
[ { } ] [
with-ctors [
- [ 1000 random '[ _ ] ] dip '[ { fixnum } declare _ execute ]
+ [ 1000 random '[ _ ] ] dip '[ _ execute ]
] [ = ] check-optimizer
] unit-test
+[ HEX: ffffffff ] [ HEX: ffffffff uint-4-with first ] unit-test
+
+[ HEX: ffffffff ] [ HEX: ffffffff [ uint-4-with ] compile-call first ] unit-test
+
"== Checking -boa constructors" print
[ { } ] [
boa-ctors [
- dup stack-effect in>> length
- [ nip [ 1000 random ] [ ] replicate-as ]
- [ fixnum <array> swap '[ _ declare _ execute ] ]
- 2bi
+ [ stack-effect in>> length [ 1000 random ] [ ] replicate-as ] keep
+ '[ _ execute ]
] [ = ] check-optimizer
] unit-test
+[ HEX: ffffffff ] [ HEX: ffffffff 2 3 4 [ uint-4-boa ] compile-call first ] unit-test
+
"== Checking vector operations" print
: random-vector ( class -- vec )
:: check-vector-op ( word inputs class elt-class -- inputs quot )
inputs [
- [
- {
- { +vector+ [ class random-vector ] }
- { +scalar+ [ 1000 random elt-class float = [ >float ] when ] }
- } case
- ] [ ] map-as
- ] [
- [
- {
- { +vector+ [ class ] }
- { +scalar+ [ elt-class ] }
- } case
- ] map
- ] bi
- word '[ _ declare _ execute ] ;
+ {
+ { +vector+ [ class random-vector ] }
+ { +scalar+ [ 1000 random elt-class float = [ >float ] when ] }
+ } case
+ ] [ ] map-as
+ word '[ _ execute ] ;
: remove-float-words ( alist -- alist' )
- [ drop { vsqrt n/v v/n v/ normalize } member? not ] assoc-filter ;
+ { vsqrt n/v v/n v/ normalize } unique assoc-diff ;
: remove-integer-words ( alist -- alist' )
- [ drop { vlshift vrshift } member? not ] assoc-filter ;
+ { vlshift vrshift } unique assoc-diff ;
+
+: remove-special-words ( alist -- alist' )
+ ! These have their own tests later
+ { hlshift hrshift vshuffle vbroadcast } unique assoc-diff ;
: ops-to-check ( elt-class -- alist )
[ vector-words >alist ] dip
- float = [ remove-integer-words ] [ remove-float-words ] if ;
+ float = [ remove-integer-words ] [ remove-float-words ] if
+ remove-special-words ;
: check-vector-ops ( class elt-class compare-quot -- )
[
: approx= ( x y -- ? )
{
{ [ 2dup [ float? ] both? ] [ -1.e8 ~ ] }
+ { [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] }
{ [ 2dup [ sequence? ] both? ] [
[
{
{ [ 2dup [ fp-nan? ] both? ] [ 2drop t ] }
+ { [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] }
{ [ 2dup [ fp-nan? ] either? not ] [ -1.e8 ~ ] }
} cond
] 2all?
] }
} cond ;
+: exact= ( x y -- ? )
+ {
+ { [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
+ { [ 2dup [ sequence? ] both? ] [ [ fp-bitwise= ] 2all? ] }
+ } cond ;
+
: simd-classes&reps ( -- alist )
simd-classes [
{
{ [ dup name>> "float" head? ] [ float [ approx= ] ] }
- { [ dup name>> "double" head? ] [ float [ = ] ] }
+ { [ dup name>> "double" head? ] [ float [ exact= ] ] }
[ fixnum [ = ] ]
} cond 3array
] map ;
[ [ { } ] ] dip first3 '[ _ _ _ check-vector-ops ] unit-test
] each
-! Other regressions
-[ 8000000 ] [
- int-8{ 1000 1000 1000 1000 1000 1000 1000 1000 }
- [ { int-8 } declare dup [ * ] [ + ] 2map-reduce ] compile-call
-] unit-test
+"== Checking shifts and permutations" print
+
+[ int-4{ 256 512 1024 2048 } ]
+[ int-4{ 1 2 4 8 } 1 hlshift ] unit-test
+
+[ int-4{ 256 512 1024 2048 } ]
+[ int-4{ 1 2 4 8 } [ { int-4 } declare 1 hlshift ] compile-call ] unit-test
+
+[ int-4{ 1 2 4 8 } ]
+[ int-4{ 256 512 1024 2048 } 1 hrshift ] unit-test
+
+[ int-4{ 1 2 4 8 } ]
+[ int-4{ 256 512 1024 2048 } [ { int-4 } declare 1 hrshift ] compile-call ] unit-test
+
+! Shuffles
+: shuffles-for ( n -- shuffles )
+ {
+ { 2 [
+ {
+ { 0 1 }
+ { 1 1 }
+ { 1 0 }
+ { 0 0 }
+ }
+ ] }
+ { 4 [
+ {
+ { 1 2 3 0 }
+ { 0 1 2 3 }
+ { 1 1 2 2 }
+ { 0 0 1 1 }
+ { 2 2 3 3 }
+ { 0 1 0 1 }
+ { 2 3 2 3 }
+ { 0 0 2 2 }
+ { 1 1 3 3 }
+ { 0 1 0 1 }
+ { 2 2 3 3 }
+ }
+ ] }
+ { 8 [
+ 4 shuffles-for
+ 4 shuffles-for
+ [ [ 4 + ] map ] map
+ [ append ] 2map
+ ] }
+ [ dup '[ _ random ] replicate 1array ]
+ } case ;
+
+simd-classes [
+ [ [ { } ] ] dip
+ [ new length shuffles-for ] keep
+ '[
+ _ [ [ _ new [ length iota ] keep like 1quotation ] dip '[ _ vshuffle ] ]
+ [ = ] check-optimizer
+ ] unit-test
+] each
+
+"== Checking element access" print
+
+! Test element access -- it should box bignums for int-4 on x86
+: test-accesses ( seq -- failures )
+ [ length >array ] keep
+ '[ [ _ 1quotation ] dip '[ _ swap nth ] ] [ = ] check-optimizer ; inline
+
+[ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test
+[ { } ] [ int-4{ HEX: 7fffffff 3 4 -8 } test-accesses ] unit-test
+[ { } ] [ uint-4{ HEX: ffffffff 2 3 4 } test-accesses ] unit-test
+
+[ HEX: 7fffffff ] [ int-4{ HEX: 7fffffff 3 4 -8 } first ] unit-test
+[ HEX: ffffffff ] [ uint-4{ HEX: ffffffff 2 3 4 } first ] unit-test
+
+[ { } ] [ double-2{ 1.0 2.0 } test-accesses ] unit-test
+[ { } ] [ longlong-2{ 1 2 } test-accesses ] unit-test
+[ { } ] [ ulonglong-2{ 1 2 } test-accesses ] unit-test
+
+[ { } ] [ float-8{ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 } test-accesses ] unit-test
+[ { } ] [ int-8{ 1 2 3 4 5 6 7 8 } test-accesses ] unit-test
+[ { } ] [ uint-8{ 1 2 3 4 5 6 7 8 } test-accesses ] unit-test
+
+[ { } ] [ double-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test
+[ { } ] [ longlong-4{ 1 2 3 4 } test-accesses ] unit-test
+[ { } ] [ ulonglong-4{ 1 2 3 4 } test-accesses ] unit-test
+
+"== Checking broadcast" print
+: test-broadcast ( seq -- failures )
+ [ length >array ] keep
+ '[ [ _ 1quotation ] dip '[ _ vbroadcast ] ] [ = ] check-optimizer ; inline
+
+[ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test
+[ { } ] [ int-4{ HEX: 7fffffff 3 4 -8 } test-broadcast ] unit-test
+[ { } ] [ uint-4{ HEX: ffffffff 2 3 4 } test-broadcast ] unit-test
+
+[ { } ] [ double-2{ 1.0 2.0 } test-broadcast ] unit-test
+[ { } ] [ longlong-2{ 1 2 } test-broadcast ] unit-test
+[ { } ] [ ulonglong-2{ 1 2 } test-broadcast ] unit-test
+
+[ { } ] [ float-8{ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 } test-broadcast ] unit-test
+[ { } ] [ int-8{ 1 2 3 4 5 6 7 8 } test-broadcast ] unit-test
+[ { } ] [ uint-8{ 1 2 3 4 5 6 7 8 } test-broadcast ] unit-test
+
+[ { } ] [ double-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test
+[ { } ] [ longlong-4{ 1 2 3 4 } test-broadcast ] unit-test
+[ { } ] [ ulonglong-4{ 1 2 3 4 } test-broadcast ] unit-test
+
+"== Checking alien operations" print
-! Vector alien intrinsics
[ float-4{ 1 2 3 4 } ] [
[
float-4{ 1 2 3 4 }
] compile-call
] unit-test
+"== Misc tests" print
+
[ ] [ char-16 new 1array stack. ] unit-test
+
+! CSSA bug
+[ 8000000 ] [
+ int-8{ 1000 1000 1000 1000 1000 1000 1000 1000 }
+ [ { int-8 } declare dup [ * ] [ + ] 2map-reduce ] compile-call
+] unit-test
+
+! Coalescing was too aggressive
+:: broken ( axis theta -- a b c )
+ axis { float-4 } declare drop
+ theta { float } declare drop
+
+ theta cos float-4-with :> cc
+ theta sin float-4-with :> ss
+
+ axis cc v+ :> diagonal
+
+ diagonal cc ss ; inline
+
+[ t ] [
+ float-4{ 1.0 0.0 1.0 0.0 } pi [ broken 3array ]
+ [ compile-call ] [ call ] 3bi =
+] unit-test
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types combinators fry kernel lexer math math.parser
+USING: alien.c-types combinators fry kernel parser math math.parser
math.vectors.simd.functor sequences splitting vocabs.generated
-vocabs.loader vocabs.parser words ;
+vocabs.loader vocabs.parser words accessors vocabs compiler.units
+definitions ;
QUALIFIED-WITH: alien.c-types c
IN: math.vectors.simd
<PRIVATE
: simd-vocab ( base-type -- vocab )
- "math.vectors.simd.instances." prepend ;
-
-: parse-base-type ( string -- c-type )
- {
- { "char" [ c:char ] }
- { "uchar" [ c:uchar ] }
- { "short" [ c:short ] }
- { "ushort" [ c:ushort ] }
- { "int" [ c:int ] }
- { "uint" [ c:uint ] }
- { "longlong" [ c:longlong ] }
- { "ulonglong" [ c:ulonglong ] }
- { "float" [ c:float ] }
- { "double" [ c:double ] }
- [ bad-base-type ]
- } case ;
+ name>> "math.vectors.simd.instances." prepend ;
+
+: parse-base-type ( c-type -- c-type )
+ dup { c:char c:uchar c:short c:ushort c:int c:uint c:longlong c:ulonglong c:float c:double } memq?
+ [ bad-base-type ] unless ;
+
+: forget-instances ( -- )
+ [
+ "math.vectors.simd.instances" child-vocabs
+ [ forget-vocab ] each
+ ] with-compilation-unit ;
PRIVATE>
: define-simd-vocab ( type -- vocab )
+ parse-base-type
[ simd-vocab ] keep '[
- _ parse-base-type
+ _
[ define-simd-128 ]
[ define-simd-256 ] bi
] generate-vocab ;
SYNTAX: SIMD:
- scan define-simd-vocab use-vocab ;
+ scan-word define-simd-vocab use-vocab ;
+
IN: math.vectors.specialization.tests
USING: compiler.tree.debugger math.vectors tools.test kernel
kernel.private math specialized-arrays ;
-SPECIALIZED-ARRAY: double
-SPECIALIZED-ARRAY: complex-float
-SPECIALIZED-ARRAY: float
+QUALIFIED-WITH: alien.c-types c
+QUALIFIED-WITH: alien.complex c
+SPECIALIZED-ARRAY: c:double
+SPECIALIZED-ARRAY: c:complex-float
+SPECIALIZED-ARRAY: c:float
[ V{ t } ] [
[ { double-array double-array } declare distance 0.0 < not ] final-literals
locals compiler.tree.propagation.info ;
IN: math.vectors.specialization
-SYMBOLS: -> +vector+ +scalar+ +nonnegative+ ;
+SYMBOLS: -> +vector+ +scalar+ +nonnegative+ +literal+ ;
: signature-for-schema ( array-type elt-type schema -- signature )
[
{ +vector+ [ drop ] }
{ +scalar+ [ nip ] }
{ +nonnegative+ [ nip ] }
+ { +literal+ [ 2drop object ] }
} case
] with with map ;
{ vabs { +vector+ -> +vector+ } }
{ vsqrt { +vector+ -> +vector+ } }
{ vbitand { +vector+ +vector+ -> +vector+ } }
+ { vbitandn { +vector+ +vector+ -> +vector+ } }
{ vbitor { +vector+ +vector+ -> +vector+ } }
{ vbitxor { +vector+ +vector+ -> +vector+ } }
{ vlshift { +vector+ +scalar+ -> +vector+ } }
{ vrshift { +vector+ +scalar+ -> +vector+ } }
+ { hlshift { +vector+ +literal+ -> +vector+ } }
+ { hrshift { +vector+ +literal+ -> +vector+ } }
+ { vshuffle { +vector+ +literal+ -> +vector+ } }
+ { vbroadcast { +vector+ +literal+ -> +vector+ } }
}
PREDICATE: vector-word < word vector-words key? ;
: add-specialization ( new-word signature word -- )
specializations set-at ;
-: word-schema ( word -- schema ) vector-words at ;
+ERROR: bad-vector-word word ;
+
+: word-schema ( word -- schema )
+ vector-words ?at [ bad-vector-word ] unless ;
: inputs ( schema -- seq ) { -> } split first ;
:: input-signature ( word array-type elt-type -- signature )
array-type elt-type word word-schema inputs signature-for-schema ;
-: vector-words-for-type ( elt-type -- alist )
+: vector-words-for-type ( elt-type -- words )
{
! Can't do shifts on floats
{ [ dup float class<= ] [ vector-words keys { vlshift vrshift } diff ] }
! Can't compute square root of complex numbers (vsqrt uses fsqrt not sqrt)
{ [ dup complex class<= ] [ vector-words keys { vsqrt } diff ] }
[ { } ]
- } cond nip ;
+ } cond
+ ! Don't specialize horizontal shifts or shuffles at all, they're only for SIMD
+ { hlshift hrshift vshuffle } diff
+ nip ;
:: specialize-vector-words ( array-type elt-type simd -- )
- elt-type vector-words-for-type [
+ elt-type vector-words-for-type simd keys union [
[ array-type elt-type simd specialize-vector-word ]
[ array-type elt-type input-signature ]
[ ]
{ $subsection vs+ }
{ $subsection vs- }
{ $subsection vs* }
-"Comparisons:"
+"Componentwise vector operations:"
+{ $subsection v< }
+{ $subsection v<= }
+{ $subsection v= }
+{ $subsection v>= }
+{ $subsection v> }
+{ $subsection vunordered? }
{ $subsection vmax }
{ $subsection vmin }
"Bitwise operations:"
{ $subsection vbitand }
+{ $subsection vbitandn }
{ $subsection vbitor }
{ $subsection vbitxor }
{ $subsection vlshift }
{ $subsection vrshift }
+"Componentwise logical operations:"
+{ $subsection vand }
+{ $subsection vor }
+{ $subsection vxor }
+{ $subsection vmask }
+{ $subsection v? }
+"Shuffling:"
+{ $subsection vshuffle }
"Inner product and norm:"
{ $subsection v. }
{ $subsection norm }
{ $subsection norm-sq }
{ $subsection normalize }
-"Comparing vectors:"
+"Comparing entire vectors:"
{ $subsection distance }
{ $subsection v~ }
"Other functions:"
HELP: vmax
{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
-{ $description "Creates a sequence where each element is the maximum of the corresponding elements from " { $snippet "u" } " andd " { $snippet "v" } "." }
+{ $description "Creates a sequence where each element is the maximum of the corresponding elements from " { $snippet "u" } " and " { $snippet "v" } "." }
{ $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 5 } { -7 6 3 } vmax ." "{ 1 6 5 }" } } ;
HELP: vmin
{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
-{ $description "Creates a sequence where each element is the minimum of the corresponding elements from " { $snippet "u" } " andd " { $snippet "v" } "." }
+{ $description "Creates a sequence where each element is the minimum of the corresponding elements from " { $snippet "u" } " and " { $snippet "v" } "." }
{ $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 5 } { -7 6 3 } vmin ." "{ -7 2 3 }" } } ;
HELP: v.
{ $examples
"With saturation:"
{ $example
- "USING: math.vectors prettyprint specialized-arrays ;"
+ "USING: alien.c-types math.vectors prettyprint specialized-arrays ;"
"SPECIALIZED-ARRAY: uchar"
"uchar-array{ 100 200 150 } uchar-array{ 70 70 70 } vs+ ."
"uchar-array{ 170 255 220 }"
}
"Without saturation:"
{ $example
- "USING: math.vectors prettyprint specialized-arrays ;"
+ "USING: alien.c-types math.vectors prettyprint specialized-arrays ;"
"SPECIALIZED-ARRAY: uchar"
"uchar-array{ 100 200 150 } uchar-array{ 70 70 70 } v+ ."
"uchar-array{ 170 14 220 }"
{ $description "Takes the bitwise and of " { $snippet "u" } " and " { $snippet "v" } " component-wise." }
{ $notes "Unlike " { $link bitand } ", this word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ;
+HELP: vbitandn
+{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
+{ $description "Takes the bitwise and-not of " { $snippet "u" } " and " { $snippet "v" } " component-wise, where " { $snippet "x and-not y" } " is defined as " { $snippet "not(x) and y" } "." }
+{ $notes "This word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ;
+
HELP: vbitor
{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
{ $description "Takes the bitwise or of " { $snippet "u" } " and " { $snippet "v" } " component-wise." }
{ $description "Shifts each element of " { $snippet "u" } " to the right by " { $snippet "n" } " bits." }
{ $notes "Undefined behavior will result if " { $snippet "n" } " is negative." } ;
+HELP: hlshift
+{ $values { "u" "a SIMD array" } { "n" "a non-negative integer" } { "w" "a SIMD array" } }
+{ $description "Shifts the entire SIMD array to the left by " { $snippet "n" } " bytes. This word may only be used in a context where the compiler can statically infer that the input is a SIMD array." } ;
+
+HELP: hrshift
+{ $values { "u" "a SIMD array" } { "n" "a non-negative integer" } { "w" "a SIMD array" } }
+{ $description "Shifts the entire SIMD array to the right by " { $snippet "n" } " bytes. This word may only be used in a context where the compiler can statically infer that the input is a SIMD array." } ;
+
+HELP: vbroadcast
+{ $values { "u" "a SIMD array" } { "n" "a non-negative integer" } { "v" "a SIMD array" } }
+{ $description "Outputs a new SIMD array of the same type as " { $snippet "u" } " where every element is equal to the " { $snippet "n" } "th element of " { $snippet "u" } "." }
+{ $examples
+ { $example
+ "USING: alien.c-types math.vectors math.vectors.simd" "prettyprint ;"
+ "SIMD: int"
+ "int-4{ 69 42 911 13 } 2 vbroadcast ."
+ "int-4{ 911 911 911 911 }"
+ }
+} ;
+
+HELP: vshuffle
+{ $values { "u" "a SIMD array" } { "perm" "an array of integers" } { "v" "a SIMD array" } }
+{ $description "Permutes the elements of a SIMD array. Duplicate entries are allowed in the permutation." }
+{ $examples
+ { $example
+ "USING: alien.c-types math.vectors math.vectors.simd" "prettyprint ;"
+ "SIMD: int"
+ "int-4{ 69 42 911 13 } { 1 3 2 3 } vshuffle ."
+ "int-4{ 42 13 911 13 }"
+ }
+} ;
+
HELP: norm-sq
{ $values { "v" "a sequence of numbers" } { "x" "a non-negative real number" } }
{ $description "Computes the squared length of a mathematical vector." } ;
{ $description "Using " { $snippet "w" } " as a template, creates a new sequence containing corresponding elements from " { $snippet "u" } " in place of 0, and corresponding elements from " { $snippet "v" } " in place of 1." }
{ $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 3 } { 4 5 6 } { 0 1 0 } set-axis ." "{ 1 5 3 }" } } ;
+HELP: v<
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of booleans" } }
+{ $description "Compares each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", returning " { $link t } " in the result vector when the former is less than the latter or " { $link f } " otherwise." } ;
+
+HELP: v<=
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of booleans" } }
+{ $description "Compares each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", returning " { $link t } " in the result vector when the former is less than or equal to the latter or " { $link f } " otherwise." } ;
+
+HELP: v=
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of booleans" } }
+{ $description "Compares each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", returning " { $link t } " in the result vector when they are equal or " { $link f } " otherwise." } ;
+
+HELP: v>
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of booleans" } }
+{ $description "Compares each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", returning " { $link t } " in the result vector when the former is greater than the latter or " { $link f } " otherwise." } ;
+
+HELP: v>=
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of booleans" } }
+{ $description "Compares each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", returning " { $link t } " in the result vector when the former is greater than or equal to the latter or " { $link f } " otherwise." } ;
+
+HELP: vunordered?
+{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of booleans" } }
+{ $description "Compares each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", returning " { $link t } " in the result vector when either value is Not-a-Number or " { $link f } " otherwise." } ;
+
+HELP: vand
+{ $values { "u" "a sequence of booleans" } { "v" "a sequence of booleans" } { "w" "a sequence of booleans" } }
+{ $description "Takes the logical AND of each corresponding element of " { $snippet "u" } " and " { $snippet "v" } "." } ;
+
+HELP: vor
+{ $values { "u" "a sequence of booleans" } { "v" "a sequence of booleans" } { "w" "a sequence of booleans" } }
+{ $description "Takes the logical OR of each corresponding element of " { $snippet "u" } " and " { $snippet "v" } "." } ;
+
+HELP: vxor
+{ $values { "u" "a sequence of booleans" } { "v" "a sequence of booleans" } { "w" "a sequence of booleans" } }
+{ $description "Takes the logical XOR of each corresponding element of " { $snippet "u" } " and " { $snippet "v" } "." } ;
+
+HELP: vnot
+{ $values { "u" "a sequence of booleans" } { "w" "a sequence of booleans" } }
+{ $description "Takes the logical NOT of each element of " { $snippet "u" } "." } ;
+
+HELP: vmask
+{ $values { "u" "a sequence of numbers" } { "?" "a sequence of booleans" } { "u'" "a sequence of numbers" } }
+{ $description "Returns a copy of " { $snippet "u" } " with the elements for which the corresponding element of " { $snippet "?" } " is false replaced by zero." } ;
+
+HELP: v?
+{ $values { "?" "a sequence of booleans" } { "true" "a sequence of numbers" } { "false" "a sequence of numbers" } { "w" "a sequence of numbers" } }
+{ $description "Creates a new sequence by selecting elements from the " { $snippet "true" } " and " { $snippet "false" } " sequences based on whether the corresponding element of the " { $snippet "?" } " sequence is true or false." } ;
+
{ 2map v+ v- v* v/ } related-words
{ 2reduce v. } related-words
{ vs+ vs- vs* } related-words
+
+{ v< v<= v= v> v>= vunordered? vand vor vxor vnot vmask v? } related-words
+
+{ vbitand vbitandn vbitor vbitxor vbitnot } related-words
IN: math.vectors.tests
USING: math.vectors tools.test kernel specialized-arrays compiler
-kernel.private ;
+kernel.private alien.c-types ;
SPECIALIZED-ARRAY: int
[ { 1 2 3 } ] [ 1/2 { 2 4 6 } n*v ] unit-test
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien.c-types kernel sequences math math.functions
-hints math.order math.libm fry combinators ;
+hints math.order math.libm fry combinators byte-arrays accessors
+locals ;
QUALIFIED-WITH: alien.c-types c
IN: math.vectors
[ drop call ]
} case ; inline
+: fp-bitwise-unary ( x seq quot -- z )
+ swap element-type {
+ { c:double [ [ double>bits ] dip call bits>double ] }
+ { c:float [ [ float>bits ] dip call bits>float ] }
+ [ drop call ]
+ } case ; inline
+
+: bitandn ( x y -- z ) [ bitnot ] dip bitand ; inline
+
+GENERIC: new-underlying ( underlying seq -- seq' )
+
+: change-underlying ( seq quot -- seq' )
+ '[ underlying>> @ ] keep new-underlying ; inline
+
PRIVATE>
: vbitand ( u v -- w ) over '[ _ [ bitand ] fp-bitwise-op ] 2map ;
+: vbitandn ( u v -- w ) over '[ _ [ bitandn ] fp-bitwise-op ] 2map ;
: vbitor ( u v -- w ) over '[ _ [ bitor ] fp-bitwise-op ] 2map ;
: vbitxor ( u v -- w ) over '[ _ [ bitxor ] fp-bitwise-op ] 2map ;
+: vbitnot ( u -- w ) dup '[ _ [ bitnot ] fp-bitwise-unary ] map ;
+
+:: vbroadcast ( u n -- v ) u length n u nth <repetition> u like ;
+: vshuffle ( u perm -- v ) swap [ '[ _ nth ] ] keep map-as ;
: vlshift ( u n -- w ) '[ _ shift ] map ;
: vrshift ( u n -- w ) neg '[ _ shift ] map ;
+: hlshift ( u n -- w ) '[ _ <byte-array> prepend 16 head ] change-underlying ;
+: hrshift ( u n -- w ) '[ _ <byte-array> append 16 tail* ] change-underlying ;
+
+: vand ( u v -- w ) [ and ] 2map ;
+: vor ( u v -- w ) [ or ] 2map ;
+: vxor ( u v -- w ) [ xor ] 2map ;
+: vnot ( u -- w ) [ not ] map ;
+
+: v< ( u v -- w ) [ < ] { } 2map-as ;
+: v<= ( u v -- w ) [ <= ] { } 2map-as ;
+: v>= ( u v -- w ) [ >= ] { } 2map-as ;
+: v> ( u v -- w ) [ > ] { } 2map-as ;
+: vunordered? ( u v -- w ) [ unordered? ] { } 2map-as ;
+: v= ( u v -- w ) [ = ] { } 2map-as ;
+
+: v? ( ? true false -- w ) [ ? ] pick 3map-as ;
+
+: vmask ( u ? -- u' ) swap dup dup vbitxor v? ;
+
: vfloor ( u -- v ) [ floor ] map ;
: vceiling ( u -- v ) [ ceiling ] map ;
: vtruncate ( u -- v ) [ truncate ] map ;
USING: assocs hashtables kernel sequences generic words
arrays classes slots slots.private classes.tuple
classes.tuple.private math vectors quotations accessors
-combinators ;
+combinators byte-arrays specialized-arrays ;
IN: mirrors
TUPLE: mirror { object read-only } ;
INSTANCE: mirror assoc
+MIXIN: enumerated-sequence
+INSTANCE: array enumerated-sequence
+INSTANCE: vector enumerated-sequence
+INSTANCE: callable enumerated-sequence
+INSTANCE: byte-array enumerated-sequence
+INSTANCE: specialized-array enumerated-sequence
+
GENERIC: make-mirror ( obj -- assoc )
M: hashtable make-mirror ;
M: integer make-mirror drop f ;
-M: array make-mirror <enum> ;
-M: vector make-mirror <enum> ;
-M: quotation make-mirror <enum> ;
+M: enumerated-sequence make-mirror <enum> ;
M: object make-mirror <mirror> ;
! This file is based on the gl.h that comes with xorg-x11 6.8.2
-USING: alien alien.syntax combinators kernel parser sequences
-system words opengl.gl.extensions ;
-
+USING: alien alien.c-types alien.syntax combinators kernel parser
+sequences system words opengl.gl.extensions ;
+FROM: alien.c-types => short ;
IN: opengl.gl
TYPEDEF: uint GLenum
-USING: alien.syntax kernel windows.types ;
+USING: alien.c-types alien.syntax kernel windows.types ;
IN: opengl.gl.windows
LIBRARY: gl
images.tesselation grouping sequences math math.vectors
math.matrices generalizations fry arrays namespaces system
locals literals specialized-arrays ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: opengl.textures
CONSTANT: EVP_MAX_MD_SIZE 64
+TYPEDEF: void* EVP_MD*
+C-TYPE: ENGINE
+
STRUCT: EVP_MD_CTX
{ digest EVP_MD* }
{ engine ENGINE* }
{ flags ulong }
{ md_data void* } ;
-TYPEDEF: void* EVP_MD*
-TYPEDEF: void* ENGINE*
-
! Initialize ciphers and digest tables
FUNCTION: void OpenSSL_add_all_ciphers ( ) ;
! Copyright (C) 2007 Elie CHAFTARI
! Portions copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax combinators kernel system namespaces
-assocs parser lexer sequences words quotations math.bitwise
-alien.libraries ;
+USING: alien alien.c-types alien.syntax combinators kernel
+system namespaces assocs parser lexer sequences words
+quotations math.bitwise alien.libraries ;
IN: openssl.libssl
TYPEDEF: void* ssl-method
TYPEDEF: void* SSL_CTX*
TYPEDEF: void* SSL_SESSION*
-TYPEDEF: void* SSL*
+C-TYPE: SSL
LIBRARY: libssl
+! ===============================================
+! x509.h
+! ===============================================
+
+TYPEDEF: void* X509_NAME*
+
+C-TYPE: X509
+
+FUNCTION: int X509_NAME_get_text_by_NID ( X509_NAME* name, int nid, void* buf, int len ) ;
+FUNCTION: X509_NAME* X509_get_subject_name ( X509* a ) ;
+
! ===============================================
! ssl.h
! ===============================================
: SSL_SESS_CACHE_NO_INTERNAL ( -- n )
{ SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } flags ; inline
-! ===============================================
-! x509.h
-! ===============================================
-
-TYPEDEF: void* X509_NAME*
-
-TYPEDEF: void* X509*
-
-FUNCTION: int X509_NAME_get_text_by_NID ( X509_NAME* name, int nid, void* buf, int len ) ;
-FUNCTION: X509_NAME* X509_get_subject_name ( X509* a ) ;
-
! ===============================================
! x509_vfy.h
! ===============================================
! See http://factorcode.org/license.txt for BSD license.
!
! pangocairo bindings, from pango/pangocairo.h
-USING: alien alien.syntax combinators system cairo.ffi
-alien.libraries ;
+USING: arrays sequences alien alien.c-types alien.destructors
+alien.libraries alien.syntax math math.functions math.vectors
+destructors combinators colors fonts accessors assocs namespaces
+kernel pango pango.fonts pango.layouts glib unicode.data images
+cache init system math.rectangles fry memoize io.encodings.utf8
+classes.struct cairo cairo.ffi ;
IN: pango.cairo
<< {
LIBRARY: pangocairo
+C-TYPE: PangoCairoFontMap
+C-TYPE: PangoCairoFont
+
FUNCTION: PangoFontMap*
pango_cairo_font_map_new ( ) ;
FUNCTION: void
pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width, double height ) ;
+
+TUPLE: layout < disposable font string selection layout metrics ink-rect logical-rect image ;
+
+SYMBOL: dpi
+
+72 dpi set-global
+
+: set-layout-font ( font layout -- )
+ swap cache-font-description pango_layout_set_font_description ;
+
+: set-layout-text ( str layout -- )
+ #! Replace nulls with something else since Pango uses null-terminated
+ #! strings
+ swap -1 pango_layout_set_text ;
+
+: layout-extents ( layout -- ink-rect logical-rect )
+ PangoRectangle <struct>
+ PangoRectangle <struct>
+ [ pango_layout_get_extents ] 2keep
+ [ PangoRectangle>rect ] bi@ ;
+
+: layout-baseline ( layout -- baseline )
+ pango_layout_get_iter &pango_layout_iter_free
+ pango_layout_iter_get_baseline
+ pango>float ;
+
+: set-foreground ( cr font -- )
+ foreground>> set-source-color ;
+
+: fill-background ( cr font dim -- )
+ [ background>> set-source-color ]
+ [ [ { 0 0 } ] dip <rect> fill-rect ] bi-curry* bi ;
+
+: rect-translate-x ( rect x -- rect' )
+ '[ _ 0 2array v- ] change-loc ;
+
+: first-line ( layout -- line )
+ layout>> 0 pango_layout_get_line_readonly ;
+
+: line-offset>x ( layout n -- x )
+ #! n is an index into the UTF8 encoding of the text
+ [ drop first-line ] [ swap string>> >utf8-index ] 2bi
+ 0 0 <int> [ pango_layout_line_index_to_x ] keep
+ *int pango>float ;
+
+: x>line-offset ( layout x -- n )
+ #! n is an index into the UTF8 encoding of the text
+ [
+ [ first-line ] dip
+ float>pango 0 <int> 0 <int>
+ [ pango_layout_line_x_to_index drop ] 2keep
+ [ *int ] bi@ swap
+ ] [ drop string>> ] 2bi utf8-index> + ;
+
+: selection-start/end ( selection -- start end )
+ selection>> [ start>> ] [ end>> ] bi ;
+
+: selection-rect ( layout -- rect )
+ [ ink-rect>> dim>> ] [ ] [ selection-start/end ] tri [ line-offset>x ] bi-curry@ bi
+ [ drop nip 0 2array ] [ swap - swap second 2array ] 3bi <rect> ;
+
+: fill-selection-background ( cr layout -- )
+ dup selection>> [
+ [ selection>> color>> set-source-color ]
+ [
+ [ selection-rect ] [ ink-rect>> loc>> first ] bi
+ rect-translate-x
+ fill-rect
+ ] 2bi
+ ] [ 2drop ] if ;
+
+: text-position ( layout -- loc )
+ [ logical-rect>> ] [ ink-rect>> ] bi [ loc>> ] bi@ v- ;
+
+: set-text-position ( cr loc -- )
+ first2 cairo_move_to ;
+
+: draw-layout ( layout -- image )
+ dup ink-rect>> dim>> [ >fixnum ] map [
+ swap {
+ [ layout>> pango_cairo_update_layout ]
+ [ [ font>> ] [ ink-rect>> dim>> ] bi fill-background ]
+ [ fill-selection-background ]
+ [ text-position set-text-position ]
+ [ font>> set-foreground ]
+ [ layout>> pango_cairo_show_layout ]
+ } 2cleave
+ ] make-bitmap-image ;
+
+: escape-nulls ( str -- str' )
+ { { 0 CHAR: zero-width-no-break-space } } substitute ;
+
+: unpack-selection ( layout string/selection -- layout )
+ dup selection? [
+ [ string>> escape-nulls >>string ] [ >>selection ] bi
+ ] [ escape-nulls >>string ] if ; inline
+
+: set-layout-resolution ( layout -- )
+ pango_layout_get_context dpi get pango_cairo_context_set_resolution ;
+
+: <PangoLayout> ( text font -- layout )
+ dummy-cairo pango_cairo_create_layout |g_object_unref
+ [ set-layout-resolution ] keep
+ [ set-layout-font ] keep
+ [ set-layout-text ] keep ;
+
+: glyph-height ( font string -- y )
+ swap <PangoLayout> &g_object_unref layout-extents drop dim>> second ;
+
+MEMO: missing-font-metrics ( font -- metrics )
+ #! Pango doesn't provide x-height and cap-height but Core Text does, so we
+ #! simulate them on Pango.
+ [
+ [ metrics new ] dip
+ [ "x" glyph-height >>x-height ]
+ [ "Y" glyph-height >>cap-height ] bi
+ ] with-destructors ;
+
+: layout-metrics ( layout -- metrics )
+ dup font>> missing-font-metrics clone
+ swap
+ [ layout>> layout-baseline >>ascent ]
+ [ logical-rect>> dim>> [ first >>width ] [ second >>height ] bi ] bi
+ dup [ height>> ] [ ascent>> ] bi - >>descent ;
+
+: <layout> ( font string -- line )
+ [
+ layout new-disposable
+ swap unpack-selection
+ swap >>font
+ dup [ string>> ] [ font>> ] bi <PangoLayout> >>layout
+ dup layout>> layout-extents [ >>ink-rect ] [ >>logical-rect ] bi*
+ dup layout-metrics >>metrics
+ dup draw-layout >>image
+ ] with-destructors ;
+
+M: layout dispose* layout>> g_object_unref ;
+
+SYMBOL: cached-layouts
+
+: cached-layout ( font string -- layout )
+ cached-layouts get [ <layout> ] 2cache ;
+
+: cached-line ( font string -- line )
+ cached-layout layout>> first-line ;
+
+[ <cache-assoc> cached-layouts set-global ] "pango.cairo" add-init-hook
PANGO_STYLE_ITALIC ;
TYPEDEF: int PangoWeight
+C-TYPE: PangoFont
+C-TYPE: PangoFontFamily
+C-TYPE: PangoFontFace
+C-TYPE: PangoFontMap
+C-TYPE: PangoFontMetrics
+C-TYPE: PangoFontDescription
+C-TYPE: PangoGlyphString
+C-TYPE: PangoLanguage
+
CONSTANT: PANGO_WEIGHT_THIN 100
CONSTANT: PANGO_WEIGHT_ULTRALIGHT 200
CONSTANT: PANGO_WEIGHT_LIGHT 300
: cache-font-description ( font -- description )
strip-font-colors (cache-font-description) ;
-[ \ (cache-font-description) reset-memoized ] "pango.fonts" add-init-hook
\ No newline at end of file
+[ \ (cache-font-description) reset-memoized ] "pango.fonts" add-init-hook
IN: pango.layouts.tests
-USING: pango.layouts tools.test glib fonts accessors
+USING: pango.layouts pango.cairo tools.test glib fonts accessors
sequences combinators.short-circuit math destructors ;
[ t ] [
USING: arrays sequences alien alien.c-types alien.destructors
alien.syntax math math.functions math.vectors destructors combinators
colors fonts accessors assocs namespaces kernel pango pango.fonts
-pango.cairo cairo cairo.ffi glib unicode.data images cache init
+glib unicode.data images cache init
math.rectangles fry memoize io.encodings.utf8 classes.struct ;
IN: pango.layouts
LIBRARY: pango
+C-TYPE: PangoLayout
+C-TYPE: PangoLayoutIter
+C-TYPE: PangoLayoutLine
+
FUNCTION: PangoLayout*
pango_layout_new ( PangoContext* context ) ;
DESTRUCTOR: pango_layout_iter_free
-TUPLE: layout < disposable font string selection layout metrics ink-rect logical-rect image ;
-
-SYMBOL: dpi
-
-72 dpi set-global
-
-: set-layout-font ( font layout -- )
- swap cache-font-description pango_layout_set_font_description ;
-
-: set-layout-text ( str layout -- )
- #! Replace nulls with something else since Pango uses null-terminated
- #! strings
- swap -1 pango_layout_set_text ;
-
-: set-layout-resolution ( layout -- )
- pango_layout_get_context dpi get pango_cairo_context_set_resolution ;
-
-: <PangoLayout> ( text font -- layout )
- dummy-cairo pango_cairo_create_layout |g_object_unref
- [ set-layout-resolution ] keep
- [ set-layout-font ] keep
- [ set-layout-text ] keep ;
-
-: layout-extents ( layout -- ink-rect logical-rect )
- PangoRectangle <struct>
- PangoRectangle <struct>
- [ pango_layout_get_extents ] 2keep
- [ PangoRectangle>rect ] bi@ ;
-
-: glyph-height ( font string -- y )
- swap <PangoLayout> &g_object_unref layout-extents drop dim>> second ;
-
-MEMO: missing-font-metrics ( font -- metrics )
- #! Pango doesn't provide x-height and cap-height but Core Text does, so we
- #! simulate them on Pango.
- [
- [ metrics new ] dip
- [ "x" glyph-height >>x-height ]
- [ "Y" glyph-height >>cap-height ] bi
- ] with-destructors ;
-
-: layout-baseline ( layout -- baseline )
- pango_layout_get_iter &pango_layout_iter_free
- pango_layout_iter_get_baseline
- pango>float ;
-
-: set-foreground ( cr font -- )
- foreground>> set-source-color ;
-
-: fill-background ( cr font dim -- )
- [ background>> set-source-color ]
- [ [ { 0 0 } ] dip <rect> fill-rect ] bi-curry* bi ;
-
-: rect-translate-x ( rect x -- rect' )
- '[ _ 0 2array v- ] change-loc ;
-
-: first-line ( layout -- line )
- layout>> 0 pango_layout_get_line_readonly ;
-
-: line-offset>x ( layout n -- x )
- #! n is an index into the UTF8 encoding of the text
- [ drop first-line ] [ swap string>> >utf8-index ] 2bi
- 0 0 <int> [ pango_layout_line_index_to_x ] keep
- *int pango>float ;
-
-: x>line-offset ( layout x -- n )
- #! n is an index into the UTF8 encoding of the text
- [
- [ first-line ] dip
- float>pango 0 <int> 0 <int>
- [ pango_layout_line_x_to_index drop ] 2keep
- [ *int ] bi@ swap
- ] [ drop string>> ] 2bi utf8-index> + ;
-
-: selection-start/end ( selection -- start end )
- selection>> [ start>> ] [ end>> ] bi ;
-
-: selection-rect ( layout -- rect )
- [ ink-rect>> dim>> ] [ ] [ selection-start/end ] tri [ line-offset>x ] bi-curry@ bi
- [ drop nip 0 2array ] [ swap - swap second 2array ] 3bi <rect> ;
-
-: fill-selection-background ( cr layout -- )
- dup selection>> [
- [ selection>> color>> set-source-color ]
- [
- [ selection-rect ] [ ink-rect>> loc>> first ] bi
- rect-translate-x
- fill-rect
- ] 2bi
- ] [ 2drop ] if ;
-
-: text-position ( layout -- loc )
- [ logical-rect>> ] [ ink-rect>> ] bi [ loc>> ] bi@ v- ;
-
-: set-text-position ( cr loc -- )
- first2 cairo_move_to ;
-
-: layout-metrics ( layout -- metrics )
- dup font>> missing-font-metrics clone
- swap
- [ layout>> layout-baseline >>ascent ]
- [ logical-rect>> dim>> [ first >>width ] [ second >>height ] bi ] bi
- dup [ height>> ] [ ascent>> ] bi - >>descent ;
-
-: draw-layout ( layout -- image )
- dup ink-rect>> dim>> [ >fixnum ] map [
- swap {
- [ layout>> pango_cairo_update_layout ]
- [ [ font>> ] [ ink-rect>> dim>> ] bi fill-background ]
- [ fill-selection-background ]
- [ text-position set-text-position ]
- [ font>> set-foreground ]
- [ layout>> pango_cairo_show_layout ]
- } 2cleave
- ] make-bitmap-image ;
-
-: escape-nulls ( str -- str' )
- { { 0 CHAR: zero-width-no-break-space } } substitute ;
-
-: unpack-selection ( layout string/selection -- layout )
- dup selection? [
- [ string>> escape-nulls >>string ] [ >>selection ] bi
- ] [ escape-nulls >>string ] if ; inline
-
-: <layout> ( font string -- line )
- [
- layout new-disposable
- swap unpack-selection
- swap >>font
- dup [ string>> ] [ font>> ] bi <PangoLayout> >>layout
- dup layout>> layout-extents [ >>ink-rect ] [ >>logical-rect ] bi*
- dup layout-metrics >>metrics
- dup draw-layout >>image
- ] with-destructors ;
-
-M: layout dispose* layout>> g_object_unref ;
-
-SYMBOL: cached-layouts
-
-: cached-layout ( font string -- layout )
- cached-layouts get [ <layout> ] 2cache ;
-
-: cached-line ( font string -- line )
- cached-layout layout>> first-line ;
-
-[ <cache-assoc> cached-layouts set-global ] "pango.layouts" add-init-hook
: pango>float ( n -- x ) PANGO_SCALE /f ; inline
: float>pango ( x -- n ) PANGO_SCALE * >integer ; inline
-FUNCTION: PangoContext*
-pango_context_new ( ) ;
+C-TYPE: PangoContext
+
+FUNCTION: PangoContext* pango_context_new ( ) ;
STRUCT: PangoRectangle
{ x int }
! See http://factorcode.org/license.txt for BSD license.
! mersenne twister based on
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
-USING: kernel math namespaces sequences sequences.private system
-init accessors math.ranges random math.bitwise combinators
-specialized-arrays fry ;
+USING: alien.c-types kernel math namespaces sequences
+sequences.private system init accessors math.ranges random
+math.bitwise combinators specialized-arrays fry ;
SPECIALIZED-ARRAY: uint
IN: random.mersenne-twister
HELP: complex-sequence
{ $class-description "Sequence wrapper class that transforms a sequence of " { $link real } " number values into a sequence of " { $link complex } " values, treating the underlying sequence as pairs of alternating real and imaginary values." }
{ $examples { $example """USING: prettyprint specialized-arrays
-sequences.complex sequences arrays ;
+sequences.complex sequences alien.c-types arrays ;
SPECIALIZED-ARRAY: double
double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> >array ."""
"{ C{ 1.0 -1.0 } C{ -2.0 2.0 } C{ 3.0 0.0 } }" } } ;
{ $values { "sequence" sequence } { "complex-sequence" complex-sequence } }
{ $description "Wraps " { $snippet "sequence" } " in a " { $link complex-sequence } "." }
{ $examples { $example """USING: prettyprint specialized-arrays
-sequences.complex sequences arrays ;
+sequences.complex sequences alien.c-types arrays ;
SPECIALIZED-ARRAY: double
double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> second ."""
"C{ -2.0 2.0 }" } } ;
USING: specialized-arrays sequences.complex
kernel sequences tools.test arrays accessors ;
-SPECIALIZED-ARRAY: float
+QUALIFIED-WITH: alien.c-types c
+SPECIALIZED-ARRAY: c:float
IN: sequences.complex.tests
: test-array ( -- x )
USING: tools.test kernel serialize io io.streams.byte-array
alien arrays byte-arrays bit-arrays specialized-arrays
sequences math prettyprint parser classes math.constants
-io.encodings.binary random assocs serialize.private ;
+io.encodings.binary random assocs serialize.private alien.c-types ;
SPECIALIZED-ARRAY: double
IN: serialize.tests
"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" }
[ ] [
"""
IN: specialized-arrays.tests
-USING: classes.struct specialized-arrays ;
+USING: alien.c-types classes.struct specialized-arrays ;
STRUCT: __does_not_exist__ { x int } ;
IN: specialized-vectors.tests
USING: specialized-arrays specialized-vectors
-tools.test kernel sequences ;
+tools.test kernel sequences alien.c-types ;
SPECIALIZED-ARRAY: float
SPECIALIZED-VECTOR: float
SPECIALIZED-VECTOR: double
! Copyright (C) 2004, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors alien alien.accessors arrays byte-arrays classes
-continuations.private effects generic hashtables
+USING: fry accessors alien alien.accessors arrays byte-arrays
+classes continuations.private effects generic hashtables
hashtables.private io io.backend io.files io.files.private
io.streams.c kernel kernel.private math math.private
math.parser.private memory memory.private namespaces
namespaces.private parser quotations quotations.private sbufs
sbufs.private sequences sequences.private slots.private strings
strings.private system threads.private classes.tuple
-classes.tuple.private vectors vectors.private words definitions assocs
-summary compiler.units system.private combinators
-combinators.short-circuit locals locals.backend locals.types
-combinators.private stack-checker.values
-generic.single generic.single.private
+classes.tuple.private vectors vectors.private words
+words.private definitions assocs summary compiler.units
+system.private combinators combinators.short-circuit locals
+locals.backend locals.types combinators.private
+stack-checker.values generic.single generic.single.private
alien.libraries
stack-checker.alien
stack-checker.state
\ float-u>= { float float } { object } define-primitive
\ float-u>= make-foldable
-\ <word> { object object } { word } define-primitive
-\ <word> make-flushable
+\ (word) { object object object } { word } define-primitive
+\ (word) make-flushable
\ word-xt { word } { integer integer } define-primitive
\ word-xt make-flushable
{ inp_hook void* }
{ inp_curr uchar }
{ inp_fill uchar }
- { inp_file FILE* }
+ { inp_file void* }
{ inp_ctr uchar }
{ inp_buff uchar* }
{ inp_buff_end uchar* }
{ c3 uchar }
{ inp_cache uchar[256] }
{ inp_sess uchar[64] }
- { itab_entry ud_itab_entry* } ;
+ { itab_entry void* } ;
FUNCTION: void ud_translate_intel ( ud* u ) ;
FUNCTION: void ud_translate_att ( ud* u ) ;
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces cache images images.loader accessors assocs
kernel opengl opengl.gl opengl.textures ui.gadgets.worlds
-memoize images.tiff ;
+memoize images.png images.tiff ;
IN: ui.images
TUPLE: image-name path ;
USING: kernel accessors math math.vectors locals sequences
specialized-arrays colors arrays combinators
opengl opengl.gl ui.pens ui.pens.caching ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: ui.pens.gradient
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors help.markup help.syntax kernel opengl
-opengl.gl sequences math.vectors ui.gadgets ui.pens
-specialized-arrays ;
+USING: accessors alien.c-types colors help.markup help.syntax
+kernel opengl opengl.gl sequences math.vectors ui.gadgets
+ui.pens specialized-arrays ;
SPECIALIZED-ARRAY: float
IN: ui.pens.polygon
: <polygon-gadget> ( color points -- gadget )
[ <polygon> ] [ { 0 0 } [ vmax ] reduce ] bi
- [ <gadget> ] 2dip [ >>interior ] [ >>dim ] bi* ;
\ No newline at end of file
+ [ <gadget> ] 2dip [ >>interior ] [ >>dim ] bi* ;
-USING: accessors assocs classes destructors functors kernel
-lexer math parser sequences specialized-arrays ui.backend
-words ;
+USING: alien.c-types accessors assocs classes destructors
+functors kernel lexer math parser sequences specialized-arrays
+ui.backend words ;
SPECIALIZED-ARRAY: int
IN: ui.pixel-formats
error-summary? off
tip-of-the-day. nl
listener
+ nl
+ "The listener has exited. To start it again, click “Restart Listener”." print
] with-streams* ;
: start-listener-thread ( listener -- )
[ wait-for-listener ]
} cleave ;
-: listener-help ( -- ) "help.home" com-browse ;
+: com-help ( -- ) "help.home" com-browse ;
-\ listener-help H{ { +nullary+ t } } define-command
+\ com-help H{ { +nullary+ t } } define-command
: com-auto-use ( -- )
auto-use? [ not ] change ;
\ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
-listener-gadget "misc" "Miscellaneous commands" {
- { T{ key-down f f "F1" } listener-help }
-} define-command-map
-
listener-gadget "toolbar" f {
{ f restart-listener }
{ T{ key-down f { A+ } "u" } com-auto-use }
{ T{ key-down f { A+ } "k" } clear-output }
{ T{ key-down f { A+ } "K" } clear-stack }
{ T{ key-down f { C+ } "d" } com-end }
+ { T{ key-down f f "F1" } com-help }
} define-command-map
listener-gadget "scrolling"
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax classes.struct combinators system
-vocabs.loader ;
+USING: alien.c-types alien.syntax classes.struct combinators
+system unix.types vocabs.loader ;
IN: unix
CONSTANT: MAXPATHLEN 1024
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.types ;
IN: unix
CONSTANT: FD_SETSIZE 1024
USING: alien.syntax alien.c-types math vocabs.loader
-classes.struct ;
+classes.struct unix.types ;
IN: unix
CONSTANT: FD_SETSIZE 256
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.types ;
IN: unix
CONSTANT: FD_SETSIZE 1024
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.c-types alien.syntax unix.statfs.freebsd ;
IN: unix.getfsstat.freebsd
CONSTANT: MNT_WAIT 1 ! synchronously wait for I/O to complete
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.c-types alien.syntax unix.statfs.macosx ;
IN: unix.getfsstat.macosx
CONSTANT: MNT_WAIT 1 ! synchronously wait for I/O to complete
CONSTANT: MNT_NOWAIT 2 ! start all I/O, but do not wait for it
-FUNCTION: int getfsstat64 ( statfs* buf, int bufsize, int flags ) ;
+FUNCTION: int getfsstat64 ( statfs64* buf, int bufsize, int flags ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.c-types alien.syntax unix.statvfs.netbsd ;
IN: unix.getfsstat.netbsd
CONSTANT: MNT_WAIT 1 ! synchronously wait for I/O to complete
CONSTANT: MNT_NOWAIT 2 ! start all I/O, but do not wait for it
CONSTANT: MNT_LAZY 3 ! push data not written by filesystem syncer
-FUNCTION: int getvfsstat ( statfs* buf, int bufsize, int flags ) ;
+FUNCTION: int getvfsstat ( statvfs* buf, int bufsize, int flags ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.c-types alien.syntax unix.statfs.openbsd ;
IN: unix.getfsstat.openbsd
CONSTANT: MNT_WAIT 1 ! synchronously wait for I/O to complete
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.time ;
IN: unix.kqueue
STRUCT: kevent
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax system sequences vocabs.loader words
+USING: alien.c-types alien.syntax system sequences vocabs.loader words
accessors ;
IN: unix.kqueue
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.time ;
IN: unix.kqueue
STRUCT: kevent
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.time ;
IN: unix.kqueue
STRUCT: kevent
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.time ;
IN: unix.kqueue
STRUCT: kevent
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: unix.linux.epoll
-USING: alien.syntax classes.struct math ;
+USING: alien.c-types alien.syntax classes.struct math ;
FUNCTION: int epoll_create ( int size ) ;
-FUNCTION: int epoll_ctl ( int epfd, int op, int fd, epoll_event* event ) ;
-
STRUCT: epoll-event
{ events uint }
{ fd uint }
{ padding uint } ;
-FUNCTION: int epoll_wait ( int epfd, epoll_event* events, int maxevents, int timeout ) ;
+FUNCTION: int epoll_ctl ( int epfd, int op, int fd, epoll-event* event ) ;
+
+FUNCTION: int epoll_wait ( int epfd, epoll-event* events, int maxevents, int timeout ) ;
CONSTANT: EPOLL_CTL_ADD 1 ! Add a file decriptor to the interface.
CONSTANT: EPOLL_CTL_DEL 2 ! Remove a file decriptor from the interface.
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: alien.syntax math math.bitwise classes.struct ;\r
+USING: alien.c-types alien.syntax math math.bitwise classes.struct ;\r
IN: unix.linux.inotify\r
\r
STRUCT: inotify-event\r
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax alien system classes.struct ;
+USING: alien.c-types alien.syntax alien system classes.struct
+unix.types ;
IN: unix
! Linux.
STRUCT: sockaddr-un
{ family ushort }
- { path { "char" max-un-path } } ;
+ { path { char max-un-path } } ;
CONSTANT: SOCK_STREAM 1
CONSTANT: SOCK_DGRAM 2
{ d_name char[256] } ;
FUNCTION: int open64 ( char* path, int flags, int prot ) ;
-FUNCTION: dirent64* readdir64 ( DIR* dirp ) ;
+FUNCTION: dirent* readdir64 ( DIR* dirp ) ;
FUNCTION: int readdir64_r ( void* dirp, dirent* entry, dirent** result ) ;
M: linux open-file [ open64 ] unix-system-call ;
USING: kernel alien.c-types alien.data alien.strings sequences
math alien.syntax unix namespaces continuations threads assocs
-io.backend.unix io.encodings.utf8 unix.utilities fry ;
+io.backend.unix io.encodings.utf8 unix.types unix.utilities fry ;
IN: unix.process
! Low-level Unix process launching utilities. These are used
! Copyright (C) 2006 Patrick Mauritz.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax system kernel layouts ;
+USING: alien.c-types alien.syntax system kernel layouts ;
IN: unix
! Solaris.
-USING: kernel alien.syntax math classes.struct ;
+USING: kernel alien.c-types alien.syntax math classes.struct
+unix.time unix.types ;
IN: unix.stat
! FreeBSD 8.0-CURRENT
-USING: kernel alien.syntax math classes.struct ;
+USING: kernel alien.c-types alien.syntax math classes.struct
+unix.time unix.types ;
IN: unix.stat
! stat64
-USING: kernel alien.syntax math classes.struct ;
+USING: kernel alien.c-types alien.syntax math classes.struct
+unix.time unix.types ;
IN: unix.stat
! Ubuntu 7.10 64-bit
USING: alien.c-types arrays accessors combinators classes.struct
-alien.syntax ;
+alien.syntax unix.time unix.types ;
IN: unix.stat
-! Mac OS X ppc
+! Mac OS X
! stat64 structure
STRUCT: stat
-USING: kernel alien.syntax math classes.struct ;
+USING: kernel alien.c-types alien.syntax math classes.struct
+unix.time unix.types ;
IN: unix.stat
! NetBSD 4.0
-USING: kernel alien.syntax math classes.struct ;
+USING: kernel alien.c-types alien.syntax math classes.struct
+unix.time unix.types ;
IN: unix.stat
! NetBSD 4.0
-USING: kernel alien.syntax math classes.struct ;
+USING: kernel alien.c-types alien.syntax math classes.struct
+unix.time unix.types ;
IN: unix.stat
! OpenBSD 4.2
{ f_owner uid_t }
{ f_fsid fsid_t }
{ f_charspare char[80] }
- { f_fstypename { "char" MFSNAMELEN } }
- { f_mntfromname { "char" MNAMELEN } }
- { f_mntonname { "char" MNAMELEN } } ;
+ { f_fstypename { char MFSNAMELEN } }
+ { f_mntfromname { char MNAMELEN } }
+ { f_mntonname { char MNAMELEN } } ;
FUNCTION: int statfs ( char* path, statvfs* buf ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax unix.types unix.stat classes.struct ;
+USING: alien.c-types alien.syntax unix.types unix.stat classes.struct ;
IN: unix.statfs.linux
STRUCT: statfs64
{ f_type uint32_t }
{ f_flags uint32_t }
{ f_fssubtype uint32_t }
- { f_fstypename { "char" MFSTYPENAMELEN } }
- { f_mntonname { "char" MAXPATHLEN } }
- { f_mntfromname { "char" MAXPATHLEN } }
+ { f_fstypename { char MFSTYPENAMELEN } }
+ { f_mntonname { char MAXPATHLEN } }
+ { f_mntfromname { char MAXPATHLEN } }
{ f_reserved uint32_t[8] } ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax unix.types unix.stat classes.struct ;
+USING: alien.c-types alien.syntax unix.types unix.stat classes.struct ;
IN: unix.statfs.openbsd
CONSTANT: MFSNAMELEN 16
{ f_owner uid_t }
{ f_ctime u_int32_t }
{ f_spare u_int32_t[3] }
- { f_fstypename { "char" MFSNAMELEN } }
- { f_mntonname { "char" MNAMELEN } }
- { f_mntfromname { "char" MNAMELEN } }
+ { f_fstypename { char MFSNAMELEN } }
+ { f_mntonname { char MNAMELEN } }
+ { f_mntfromname { char MNAMELEN } }
{ mount_info char[160] } ;
FUNCTION: int statfs ( char* path, statvfs* buf ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.types ;
IN: unix.statvfs.freebsd
STRUCT: statvfs
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.types ;
IN: unix.statvfs.linux
STRUCT: statvfs64
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.types ;
IN: unix.statvfs.macosx
STRUCT: statvfs
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.types
+unix.stat ;
IN: unix.statvfs.netbsd
CONSTANT: _VFS_NAMELEN 32
{ f_namemax ulong }
{ f_owner uid_t }
{ f_spare uint32_t[4] }
- { f_fstypename { "char" _VFS_NAMELEN } }
- { f_mntonname { "char" _VFS_MNAMELEN } }
- { f_mntfromname { "char" _VFS_MNAMELEN } } ;
+ { f_fstypename { char _VFS_NAMELEN } }
+ { f_mntonname { char _VFS_MNAMELEN } }
+ { f_mntfromname { char _VFS_MNAMELEN } } ;
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax classes.struct ;
+USING: alien.c-types alien.syntax classes.struct unix.types ;
IN: unix.statvfs.openbsd
STRUCT: statvfs
-USING: kernel system alien.syntax combinators vocabs.loader ;
+USING: kernel system alien.c-types alien.syntax combinators vocabs.loader ;
IN: unix.types
TYPEDEF: char int8_t
TYPEDEF: __uint64_t rlim_t
TYPEDEF: uint32_t id_t
+C-TYPE: DIR
+C-TYPE: FILE
+C-TYPE: rlimit
+C-TYPE: rusage
+C-TYPE: sockaddr
+
os {
{ linux [ "unix.types.linux" require ] }
{ macosx [ "unix.types.macosx" require ] }
{ netbsd [ "unix.types.netbsd" require ] }
{ winnt [ ] }
} case
+
sequences continuations byte-arrays strings math namespaces
system combinators vocabs.loader accessors
stack-checker macros locals generalizations unix.types
-io vocabs classes.struct ;
+io vocabs classes.struct unix.time ;
IN: unix
CONSTANT: PROT_NONE 0
CONSTANT: DT_SOCK 12
CONSTANT: DT_WHT 14
-STRUCT: group
- { gr_name char* }
- { gr_passwd char* }
- { gr_gid int }
- { gr_mem char** } ;
-
LIBRARY: libc
FUNCTION: char* strerror ( int errno ) ;
]
] ;
+HOOK: open-file os ( path flags mode -- fd )
+
+<<
+
+{
+ { [ os linux? ] [ "unix.linux" require ] }
+ { [ os bsd? ] [ "unix.bsd" require ] }
+ { [ os solaris? ] [ "unix.solaris" require ] }
+} cond
+
+"debugger" vocab [
+ "unix.debugger" require
+] when
+
+>>
+
+STRUCT: group
+ { gr_name char* }
+ { gr_passwd char* }
+ { gr_gid int }
+ { gr_mem char** } ;
+
FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ;
FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ;
FUNCTION: int chdir ( char* path ) ;
! FUNCTION: int dup ( int oldd ) ;
: _exit ( status -- * )
#! We throw to give this a terminating stack effect.
- "int" f "_exit" { "int" } alien-invoke "Exit failed" throw ;
+ int f "_exit" { int } alien-invoke "Exit failed" throw ;
FUNCTION: void endpwent ( ) ;
FUNCTION: int fchdir ( int fd ) ;
FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
FUNCTION: int open ( char* path, int flags, int prot ) ;
-HOOK: open-file os ( path flags mode -- fd )
-
M: unix open-file [ open ] unix-system-call ;
FUNCTION: DIR* opendir ( char* path ) ;
FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
-{
- { [ os linux? ] [ "unix.linux" require ] }
- { [ os bsd? ] [ "unix.bsd" require ] }
- { [ os solaris? ] [ "unix.solaris" require ] }
-} cond
-
-"debugger" vocab [
- "unix.debugger" require
-] when
! Copyright (C) 2009 Phil Dawes.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes.struct alien.syntax ;
+USING: classes.struct alien.c-types alien.syntax ;
IN: vm
TYPEDEF: void* cell
+C-TYPE: context
STRUCT: zone
{ start cell }
-USING: alien.syntax kernel math windows.types windows.kernel32
-math.bitwise classes.struct ;
+USING: alien.c-types alien.syntax kernel math windows.types
+windows.kernel32 math.bitwise classes.struct ;
IN: windows.advapi32
LIBRARY: advapi32
SE_WMIGUID_OBJECT
SE_REGISTRY_WOW64_32KEY ;
-TYPEDEF: TRUSTEE* PTRUSTEE
-
STRUCT: TRUSTEE
- { pMultipleTrustee PTRUSTEE }
+ { pMultipleTrustee TRUSTEE* }
{ MultipleTrusteeOperation MULTIPLE_TRUSTEE_OPERATION }
{ TrusteeForm TRUSTEE_FORM }
{ TrusteeType TRUSTEE_TYPE }
{ ptstrName LPTSTR } ;
+TYPEDEF: TRUSTEE* PTRUSTEE
+
STRUCT: EXPLICIT_ACCESS
{ grfAccessPermissions DWORD }
{ grfAccessMode ACCESS_MODE }
-USING: alien alien.c-types alien.destructors windows.com.syntax\r
-windows.ole32 windows.types continuations kernel alien.syntax\r
-libc destructors accessors alien.data ;\r
-IN: windows.com\r
-\r
-LIBRARY: ole32\r
-\r
-COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}\r
- HRESULT QueryInterface ( REFGUID iid, void** ppvObject )\r
- ULONG AddRef ( )\r
- ULONG Release ( ) ;\r
-\r
-COM-INTERFACE: IDataObject IUnknown {0000010E-0000-0000-C000-000000000046}\r
- HRESULT GetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )\r
- HRESULT GetDataHere ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )\r
- HRESULT QueryGetData ( FORMATETC* pFormatetc )\r
- HRESULT GetCanonicalFormatEtc ( FORMATETC* pFormatetcIn, FORMATETC* pFormatetcOut )\r
- HRESULT SetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium, BOOL fRelease )\r
- HRESULT EnumFormatEtc ( DWORD dwDirection, IEnumFORMATETC** ppenumFormatetc )\r
- HRESULT DAdvise ( FORMATETC* pFormatetc, DWORD advf, IAdviseSink* pAdvSink, DWORD* pdwConnection )\r
- HRESULT DUnadvise ( DWORD pdwConnection )\r
- HRESULT EnumDAdvise ( IEnumSTATDATA** ppenumAdvise ) ;\r
-\r
-COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}\r
- HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )\r
- HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )\r
- HRESULT DragLeave ( )\r
- HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;\r
-\r
-: com-query-interface ( interface iid -- interface' )\r
- [\r
- "void*" malloc-object &free\r
- [ IUnknown::QueryInterface ole32-error ] keep *void*\r
- ] with-destructors ;\r
-\r
-: com-add-ref ( interface -- interface )\r
- [ IUnknown::AddRef drop ] keep ; inline\r
-\r
-: com-release ( interface -- )\r
- IUnknown::Release drop ; inline\r
-\r
-: with-com-interface ( interface quot -- )\r
- over [ com-release ] curry [ ] cleanup ; inline\r
-\r
-DESTRUCTOR: com-release\r
+USING: alien alien.c-types alien.destructors windows.com.syntax
+windows.ole32 windows.types continuations kernel alien.syntax
+libc destructors accessors alien.data ;
+IN: windows.com
+
+LIBRARY: ole32
+
+COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
+ HRESULT QueryInterface ( REFGUID iid, void** ppvObject )
+ ULONG AddRef ( )
+ ULONG Release ( ) ;
+
+C-TYPE: IAdviseSink
+
+COM-INTERFACE: IDataObject IUnknown {0000010E-0000-0000-C000-000000000046}
+ HRESULT GetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )
+ HRESULT GetDataHere ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )
+ HRESULT QueryGetData ( FORMATETC* pFormatetc )
+ HRESULT GetCanonicalFormatEtc ( FORMATETC* pFormatetcIn, FORMATETC* pFormatetcOut )
+ HRESULT SetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium, BOOL fRelease )
+ HRESULT EnumFormatEtc ( DWORD dwDirection, IEnumFORMATETC** ppenumFormatetc )
+ HRESULT DAdvise ( FORMATETC* pFormatetc, DWORD advf, IAdviseSink* pAdvSink, DWORD* pdwConnection )
+ HRESULT DUnadvise ( DWORD pdwConnection )
+ HRESULT EnumDAdvise ( IEnumSTATDATA** ppenumAdvise ) ;
+
+COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}
+ HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
+ HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
+ HRESULT DragLeave ( )
+ HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;
+
+FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ;
+FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ;
+FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
+
+: com-query-interface ( interface iid -- interface' )
+ [
+ "void*" malloc-object &free
+ [ IUnknown::QueryInterface ole32-error ] keep *void*
+ ] with-destructors ;
+
+: com-add-ref ( interface -- interface )
+ [ IUnknown::AddRef drop ] keep ; inline
+
+: com-release ( interface -- )
+ IUnknown::Release drop ; inline
+
+: with-com-interface ( interface quot -- )
+ over [ com-release ] curry [ ] cleanup ; inline
+
+DESTRUCTOR: com-release
-USING: alien alien.c-types alien.accessors effects kernel
-windows.ole32 parser lexer splitting grouping sequences
-namespaces assocs quotations generalizations accessors words
-macros alien.syntax fry arrays layouts math classes.struct
-windows.kernel32 ;
+USING: alien alien.c-types alien.accessors alien.parser
+effects kernel windows.ole32 parser lexer splitting grouping
+sequences namespaces assocs quotations generalizations
+accessors words macros alien.syntax fry arrays layouts math
+classes.struct windows.kernel32 ;
IN: windows.com.syntax
<PRIVATE
"stdcall" alien-indirect
] ;
-TUPLE: com-interface-definition name parent iid functions ;
+TUPLE: com-interface-definition word parent iid functions ;
C: <com-interface-definition> com-interface-definition
TUPLE: com-function-definition name return parameters ;
[ H{ } +com-interface-definitions+ set-global ]
unless
+ERROR: no-com-interface interface ;
+
: find-com-interface-definition ( name -- definition )
- dup "f" = [ drop f ] [
+ [
dup +com-interface-definitions+ get-global at*
- [ nip ]
- [ " COM interface hasn't been defined" prepend throw ]
- if
- ] if ;
+ [ nip ] [ drop no-com-interface ] if
+ ] [ f ] if* ;
: save-com-interface-definition ( definition -- )
- dup name>> +com-interface-definitions+ get-global set-at ;
+ dup word>> +com-interface-definitions+ get-global set-at ;
: (parse-com-function) ( tokens -- definition )
[ second ]
[ first ]
- [ 3 tail [ CHAR: , swap remove ] map 2 group { "void*" "this" } prefix ]
- tri
+ [
+ 3 tail [ CHAR: , swap remove ] map
+ 2 group [ first2 normalize-c-arg 2array ] map
+ { void* "this" } prefix
+ ] tri
<com-function-definition> ;
: parse-com-functions ( -- functions )
[ (parse-com-function) ] map ;
: (iid-word) ( definition -- word )
- name>> "-iid" append create-in ;
+ word>> name>> "-iid" append create-in ;
: (function-word) ( function interface -- word )
- name>> "::" rot name>> 3append create-in ;
+ swap [ word>> name>> "::" ] [ name>> ] bi*
+ 3append create-in ;
: family-tree ( definition -- definitions )
dup parent>> [ family-tree ] [ { } ] if*
: define-words-for-com-interface ( definition -- )
[ [ (iid-word) ] [ iid>> 1quotation ] bi (( -- iid )) define-declared ]
- [ name>> "com-interface" swap typedef ]
+ [ word>> void* swap typedef ]
[
dup family-tree-functions
[ (define-word-for-function) ] with each-index
PRIVATE>
SYNTAX: COM-INTERFACE:
- scan
- scan find-com-interface-definition
+ CREATE-C-TYPE
+ scan-object find-com-interface-definition
scan string>guid
parse-com-functions
<com-interface-definition>
USING: windows.kernel32 windows.ole32 windows.com windows.com.syntax
alien alien.c-types alien.syntax kernel system namespaces math
-classes.struct ;
+classes.struct windows.types ;
IN: windows.dinput
LIBRARY: dinput
TYPEDEF: DIJOYSTATE2* LPDIJOYSTATE2
TYPEDEF: DIJOYSTATE2* LPCDIJOYSTATE2
-STDCALL-CALLBACK: BOOL LPDIENUMDEVICESCALLBACKW (
+CALLBACK: BOOL LPDIENUMDEVICESCALLBACKW (
LPCDIDEVICEINSTANCEW lpddi,
LPVOID pvRef
) ;
-STDCALL-CALLBACK: BOOL LPDICONFIGUREDEVICESCALLBACK (
+CALLBACK: BOOL LPDICONFIGUREDEVICESCALLBACK (
IUnknown* lpDDSTarget,
LPVOID pvRef
) ;
-STDCALL-CALLBACK: BOOL LPDIENUMEFFECTSCALLBACKW (
+CALLBACK: BOOL LPDIENUMEFFECTSCALLBACKW (
LPCDIEFFECTINFOW pdei,
LPVOID pvRef
) ;
-STDCALL-CALLBACK: BOOL LPDIENUMEFFECTSINFILECALLBACK (
+CALLBACK: BOOL LPDIENUMEFFECTSINFILECALLBACK (
LPCDIFILEEFFECT lpDiFileEf,
LPVOID pvRef
) ;
-STDCALL-CALLBACK: BOOL LPDIENUMDEVICEOBJECTSCALLBACKW (
+CALLBACK: BOOL LPDIENUMDEVICEOBJECTSCALLBACKW (
LPCDIDEVICEOBJECTINSTANCEW lpddoi,
LPVOID pvRef
) ;
HRESULT Unload ( )
HRESULT Escape ( LPDIEFFESCAPE pesc ) ;
-STDCALL-CALLBACK: BOOL LPDIENUMCREATEDEFFECTOBJECTSCALLBACK (
+CALLBACK: BOOL LPDIENUMCREATEDEFFECTOBJECTSCALLBACK (
IDirectInputEffect* peff,
LPVOID pvRef
) ;
HRESULT SetActionMap ( LPDIACTIONFORMATW lpdiActionFormat, LPCWSTR lpwszUserName, DWORD dwFlags )
HRESULT GetImageInfo ( LPDIDEVICEIMAGEINFOHEADERW lpdiDeviceImageInfoHeader ) ;
-STDCALL-CALLBACK: BOOL LPDIENUMDEVICESBYSEMANTICSCBW (
+CALLBACK: BOOL LPDIENUMDEVICESBYSEMANTICSCBW (
LPCDIDEVICEINSTANCEW lpddi,
IDirectInputDevice8W* lpdid,
DWORD dwFlags,
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax alien.destructors kernel windows.types
-math.bitwise ;
+USING: alien alien.c-types alien.syntax alien.destructors
+kernel windows.types math.bitwise ;
IN: windows.gdi32
CONSTANT: BI_RGB 0
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax kernel windows.types multiline
-classes.struct ;
+USING: alien alien.c-types alien.syntax kernel windows.types
+multiline classes.struct ;
IN: windows.kernel32
CONSTANT: MAX_PATH 260
TYPEDEF: DCB* PDCB
TYPEDEF: DCB* LPDCB
-STRUCT: COMM_CONFIG
+STRUCT: COMMCONFIG
{ dwSize DWORD }
{ wVersion WORD }
{ wReserved WORD }
{ nFileSizeLow DWORD }
{ dwReserved0 DWORD }
{ dwReserved1 DWORD }
- { cFileName { "TCHAR" MAX_PATH } }
+ { cFileName { TCHAR MAX_PATH } }
{ cAlternateFileName TCHAR[14] } ;
TYPEDEF: WIN32_FIND_DATA* PWIN32_FIND_DATA
FUNCTION: HRESULT OleInitialize ( void* reserved ) ;
FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit ) ;
-FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ;
-FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ;
-FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
-
: succeeded? ( hresult -- ? )
0 HEX: 7FFFFFFF between? ;
USING: alien alien.c-types alien.strings alien.syntax
classes.struct combinators io.encodings.utf16n io.files
io.pathnames kernel windows.errors windows.com
-windows.com.syntax windows.user32 windows.ole32 windows
-specialized-arrays ;
+windows.com.syntax windows.types windows.user32
+windows.ole32 windows specialized-arrays ;
SPECIALIZED-ARRAY: ushort
IN: windows.shell32
TYPEDEF: int INT32
TYPEDEF: uint UINT32
TYPEDEF: uint DWORD32
+TYPEDEF: long LONG32
TYPEDEF: ulong ULONG32
TYPEDEF: ulonglong ULONG64
TYPEDEF: long* POINTER_32
TYPEDEF: ulonglong ULARGE_INTEGER
TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER
TYPEDEF: ULARGE_INTEGER* PULARGE_INTEGER
+TYPEDEF: size_t SIZE_T
+TYPEDEF: ptrdiff_t SSIZE_T
TYPEDEF: wchar_t* LPCSTR
TYPEDEF: wchar_t* LPWSTR
TYPEDEF: LONGLONG USN
TYPEDEF: UINT_PTR WPARAM
-TYPEDEF: RECT* LPRECT
-TYPEDEF: void* PWNDCLASS
-TYPEDEF: void* PWNDCLASSEX
-TYPEDEF: void* LPWNDCLASS
-TYPEDEF: void* LPWNDCLASSEX
-TYPEDEF: void* MSGBOXPARAMSA
-TYPEDEF: void* MSGBOXPARAMSW
-TYPEDEF: void* LPOVERLAPPED_COMPLETION_ROUTINE
-
TYPEDEF: size_t socklen_t
TYPEDEF: void* WNDPROC
TYPEDEF: HANDLE HGLRC
TYPEDEF: HANDLE HRGN
+TYPEDEF: void* PWNDCLASS
+TYPEDEF: void* PWNDCLASSEX
+TYPEDEF: void* LPWNDCLASS
+TYPEDEF: void* LPWNDCLASSEX
+TYPEDEF: void* MSGBOXPARAMSA
+TYPEDEF: void* MSGBOXPARAMSW
+TYPEDEF: void* LPOVERLAPPED_COMPLETION_ROUTINE
+
STRUCT: LVITEM
{ mask uint }
{ iItem int }
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax parser namespaces kernel math
-windows.types generalizations math.bitwise classes.struct
-literals ;
+USING: alien alien.c-types alien.syntax parser namespaces
+kernel math windows.types generalizations math.bitwise
+classes.struct literals windows.kernel32 ;
IN: windows.user32
! HKL for ActivateKeyboardLayout
{ rcMonitor RECT }
{ rcWork RECT }
{ dwFlags DWORD }
- { szDevice { "TCHAR" $ CCHDEVICENAME } } ;
+ { szDevice { TCHAR CCHDEVICENAME } } ;
TYPEDEF: MONITORINFOEX* LPMONITORINFOEX
TYPEDEF: MONITORINFOEX* LPMONITORINFO
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax alien.destructors classes.struct ;
+USING: alien.c-types alien.syntax alien.destructors classes.struct
+windows.types ;
IN: windows.usp10
LIBRARY: usp10
STRUCT: SCRIPT_VISATTR
{ flags WORD } ;
+TYPEDEF: void* SCRIPT_CACHE*
+C-TYPE: ABC
+
FUNCTION: HRESULT ScriptShape (
HDC hdc,
SCRIPT_CACHE* psc,
CONSTANT: SOL_SOCKET HEX: ffff
+C-TYPE: sockaddr
+
STRUCT: sockaddr-in
{ family short }
{ port ushort }
{ sec long }
{ usec long } ;
+TYPEDEF: void* fd_set*
+
LIBRARY: winsock
FUNCTION: int setsockopt ( SOCKET s, int level, int optname, char* optval, int optlen ) ;
FUNCTION: ushort htons ( ushort n ) ;
FUNCTION: ushort ntohs ( ushort n ) ;
-FUNCTION: int bind ( void* socket, sockaddr_in* sockaddr, int len ) ;
+FUNCTION: int bind ( void* socket, sockaddr-in* sockaddr, int len ) ;
FUNCTION: int listen ( void* socket, int backlog ) ;
FUNCTION: char* inet_ntoa ( int in-addr ) ;
FUNCTION: int getaddrinfo ( char* nodename,
FUNCTION: hostent* gethostbyname ( char* name ) ;
FUNCTION: int gethostname ( char* name, int len ) ;
-FUNCTION: int connect ( void* socket, sockaddr_in* sockaddr, int addrlen ) ;
+FUNCTION: int connect ( void* socket, sockaddr-in* sockaddr, int addrlen ) ;
FUNCTION: int select ( int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, timeval* timeout ) ;
FUNCTION: int closesocket ( SOCKET s ) ;
FUNCTION: int shutdown ( SOCKET s, int how ) ;
FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ;
FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ;
-FUNCTION: int getsockname ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
-FUNCTION: int getpeername ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
+FUNCTION: int getsockname ( SOCKET s, sockaddr-in* address, int* addrlen ) ;
+FUNCTION: int getpeername ( SOCKET s, sockaddr-in* address, int* addrlen ) ;
TYPEDEF: uint SERVICETYPE
TYPEDEF: OVERLAPPED WSAOVERLAPPED
! Based on X.h
-USING: alien alien.syntax math x11.xlib ;
+USING: alien alien.c-types alien.syntax math x11.xlib ;
IN: x11.constants
TYPEDEF: ulong Mask
! * EXTENDED WINDOW MANAGER HINTS
! *****************************************************************
-C-ENUM: _NET_WM_STATE_REMOVE _NET_WM_STATE_ADD _NET_WM_STATE_TOGGLE ;
\ No newline at end of file
+C-ENUM: _NET_WM_STATE_REMOVE _NET_WM_STATE_ADD _NET_WM_STATE_TOGGLE ;
TYPEDEF: ulong Atom
TYPEDEF: char* XPointer
-TYPEDEF: void* Screen*
+C-TYPE: Screen
TYPEDEF: void* GC
-TYPEDEF: void* Visual*
-TYPEDEF: void* XExtData*
-TYPEDEF: void* XFontProp*
-TYPEDEF: void* XComposeStatus*
+C-TYPE: Visual
+C-TYPE: XExtData
+C-TYPE: XFontProp
+C-TYPE: XComposeStatus
TYPEDEF: void* XIM
TYPEDEF: void* XIC
TYPEDEF: ulong VisualID
TYPEDEF: ulong Time
-TYPEDEF: void* Window**
-TYPEDEF: void* Atom**
-
ALIAS: <XID> <ulong>
ALIAS: <Window> <XID>
ALIAS: <Drawable> <XID>
{ descent short }
{ attributes ushort } ;
-X-FUNCTION: Font XLoadFont ( Display* display, char* name ) ;
-X-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ;
-X-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ;
-
STRUCT: XFontStruct
{ ext_data XExtData* }
{ fid Font }
{ ascent int }
{ descent int } ;
+X-FUNCTION: Font XLoadFont ( Display* display, char* name ) ;
+X-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ;
+X-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ;
+
X-FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ;
! 8.6 - Drawing Text
"Callbacks can be defined and passed to C code as function pointers; the C code can then invoke the callback and run Factor code:"
{ $subsection alien-callback }
{ $subsection POSTPONE: CALLBACK: }
-{ $subsection POSTPONE: STDCALL-CALLBACK: }
"There are some caveats concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
{ $subsection "alien-callback-gc" }
{ $see-also "byte-arrays-gc" } ;
$nl
"The C library interface is entirely self-contained; there is no C code which one must write in order to wrap a library."
$nl
-"C library interface words are found in the " { $vocab-link "alien" } " vocabulary."
+"C library interface words are found in the " { $vocab-link "alien" } " vocabulary and its subvocabularies."
{ $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" }
+{ $subsection "classes.struct" }
{ $subsection "dll.private" }
{ $subsection "embedding" } ;
USING: kernel math namespaces make tools.test vectors sequences
sequences.private hashtables io prettyprint assocs
-continuations specialized-arrays ;
+continuations specialized-arrays alien.c-types ;
SPECIALIZED-ARRAY: double
IN: assocs.tests
"threads.private"
"tools.profiler.private"
"words"
+ "words.private"
"vectors"
"vectors.private"
"vm"
{ "float-u<=" "math.private" (( x y -- ? )) }
{ "float-u>" "math.private" (( x y -- ? )) }
{ "float-u>=" "math.private" (( x y -- ? )) }
- { "<word>" "words" (( name vocab -- word )) }
+ { "(word)" "words.private" (( name vocab -- word )) }
{ "word-xt" "words" (( word -- start end )) }
{ "getenv" "kernel.private" (( n -- obj )) }
{ "setenv" "kernel.private" (( obj n -- )) }
$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 }
over bytes>> [ push-all ] keep
[ dup length pick block-size>> >= ]
[
- 64 cut-slice [ >byte-array ] dip [
+ over block-size>> cut-slice [ >byte-array ] dip [
over [ checksum-block ]
- [ [ 64 + ] change-bytes-read drop ] bi
+ [ [ ] [ block-size>> ] bi [ + ] curry change-bytes-read drop ] bi
] dip
] while
>byte-vector
[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
[ t ] [ \ redefine-tuple-twice symbol? ] unit-test
+
+ERROR: base-error x y ;
+ERROR: derived-error < base-error z ;
+
+[ (( x y z -- * )) ] [ \ derived-error stack-effect ] unit-test
[ 2drop ?define-symbol ] [ redefine-tuple-class ] if ;
: thrower-effect ( slots -- effect )
- [ dup array? [ first ] when ] map { "*" } <effect> ;
+ [ name>> ] map { "*" } <effect> ;
: define-error-class ( class superclass slots -- )
[ define-tuple-class ]
[ 2drop reset-generic ]
[
+ 2drop
[ dup [ boa throw ] curry ]
- [ drop ]
- [ thrower-effect ]
- tri* define-declared
+ [ all-slots thrower-effect ]
+ bi define-declared
] 3tri ;
: boa-effect ( class -- effect )
GENERIC: forget* ( defspec -- )
-M: f forget* drop ;
-
-M: wrapper forget* wrapped>> forget* ;
-
SYMBOL: forgotten-definitions
: forgotten-definition ( defspec -- )
: forget ( defspec -- ) [ forgotten-definition ] [ forget* ] bi ;
+M: f forget* drop ;
+
+M: wrapper forget* wrapped>> forget ;
+
: forget-all ( definitions -- ) [ forget ] each ;
GENERIC: definer ( defspec -- start end )
definitions eval generic generic.math generic.standard
hashtables io io.streams.string kernel layouts math math.order
namespaces parser prettyprint quotations sequences sorting
-strings tools.test vectors words ;
+strings tools.test vectors words generic.single ;
IN: generic.tests
GENERIC: foobar ( x -- y )
real \ <=> method
eq?
] unit-test
+
+! FORGET: on method wrappers
+GENERIC: forget-test ( a -- b )
+
+M: integer forget-test 3 + ;
+
+[ ] [ "IN: generic.tests USE: math FORGET: M\\ integer forget-test" eval( -- ) ] unit-test
+
+[ { } ] [
+ \ + compiled-usage keys
+ [ method-body? ] filter
+ [ "method-generic" word-prop \ forget-test eq? ] filter
+] unit-test
+
+[ 10 forget-test ] [ no-method? ] must-fail-with
\r
! Smoke test\r
[ t ] [ max-array-capacity cell-bits 2^ < ] unit-test\r
+\r
+[ t ] [ most-negative-fixnum fixnum? ] unit-test\r
+[ t ] [ most-positive-fixnum fixnum? ] unit-test\r
cell-bits (first-bignum) ; inline
: most-positive-fixnum ( -- n )
- first-bignum 1 - ; inline
+ first-bignum 1 - >fixnum ; inline
: most-negative-fixnum ( -- n )
- first-bignum neg ; inline
+ first-bignum neg >fixnum ; inline
: (max-array-capacity) ( b -- n )
5 - 2^ 1 - ; inline
USING: accessors arrays definitions graphs kernel
kernel.private slots.private math namespaces sequences
strings vectors sbufs quotations assocs hashtables sorting vocabs
-math.order sets ;
+math.order sets words.private ;
IN: words
: word ( -- word ) \ word get-global ;
} reset-props
] tri ;
+: <word> ( name vocab -- word )
+ 2dup [ hashcode ] bi@ bitxor >fixnum (word) ;
+
: gensym ( -- word )
- "( gensym )" f <word> ;
+ "( gensym )" f \ gensym counter >fixnum (word) ;
: define-temp ( quot effect -- word )
[ gensym dup ] 2dip define-declared ;
+++ /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 ;
-USING: sequences kernel math specialized-arrays fry ;
+USING: alien.c-types sequences kernel math specialized-arrays
+fry ;
SPECIALIZED-ARRAY: int
IN: benchmark.dawes
-USING: make math sequences splitting grouping
+USING: alien.c-types make math sequences splitting grouping
kernel columns specialized-arrays bit-arrays ;
SPECIALIZED-ARRAY: double
IN: benchmark.dispatch2
1000000 sequences
[ [ 0 swap nth don't-flush-me ] each ] curry times ;
-MAIN: dispatch-test
\ No newline at end of file
+MAIN: dispatch-test
-USING: sequences math mirrors splitting grouping
+USING: alien.c-types sequences math mirrors splitting grouping
kernel make assocs alien.syntax columns
specialized-arrays bit-arrays ;
SPECIALIZED-ARRAY: double
! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=fasta&lang=java&id=2
-USING: math kernel io io.files locals multiline assocs sequences
-sequences.private benchmark.reverse-complement hints
-io.encodings.ascii byte-arrays specialized-arrays ;
+USING: alien.c-types math kernel io io.files locals multiline
+assocs sequences sequences.private benchmark.reverse-complement
+hints io.encodings.ascii byte-arrays specialized-arrays ;
SPECIALIZED-ARRAY: double
IN: benchmark.fasta
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors fry kernel locals math math.constants
-math.functions math.vectors math.vectors.simd prettyprint
-combinators.smart sequences hints classes.struct
+USING: accessors alien.c-types fry kernel locals math
+math.constants math.functions math.vectors math.vectors.simd
+prettyprint combinators.smart sequences hints classes.struct
specialized-arrays ;
SIMD: double
IN: benchmark.nbody-simd
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors specialized-arrays fry kernel locals math
-math.constants math.functions math.vectors prettyprint
-combinators.smart sequences hints arrays ;
+USING: accessors specialized-arrays fry kernel
+locals math math.constants math.functions math.vectors
+prettyprint combinators.smart sequences hints arrays ;
+FROM: alien.c-types => double ;
SPECIALIZED-ARRAY: double
IN: benchmark.nbody
io.encodings.binary kernel math math.constants math.functions
math.vectors math.vectors.simd math.parser make sequences
sequences.private words hints classes.struct ;
-SIMD: double
+QUALIFIED-WITH: alien.c-types c
+SIMD: c:double
IN: benchmark.raytracer-simd
! parameters
! Factor port of the raytracer benchmark from
! http://www.ffconsultancy.com/free/ray_tracer/languages.html
-
-USING: arrays accessors specialized-arrays io io.files
-io.files.temp io.encodings.binary kernel math math.constants
-math.functions math.vectors math.parser make sequences
-sequences.private words hints ;
+USING: arrays accessors specialized-arrays io
+io.files io.files.temp io.encodings.binary kernel math
+math.constants math.functions math.vectors math.parser make
+sequences sequences.private words hints ;
+FROM: alien.c-types => double ;
SPECIALIZED-ARRAY: double
IN: benchmark.raytracer
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io math math.functions math.parser math.vectors
math.vectors.simd sequences specialized-arrays ;
-SIMD: float
+QUALIFIED-WITH: alien.c-types c
+SIMD: c:float
SPECIALIZED-ARRAY: float-4
IN: benchmark.simd-1
! Factor port of
! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all
-USING: specialized-arrays kernel math math.functions
-math.vectors sequences prettyprint words hints locals ;
+USING: alien.c-types specialized-arrays kernel math
+math.functions math.vectors sequences prettyprint words hints
+locals ;
SPECIALIZED-ARRAY: double
IN: benchmark.spectral-norm
USING: accessors classes.struct combinators.smart fry kernel
math math.functions math.order math.parser sequences
specialized-arrays io ;
+FROM: alien.c-types => float ;
IN: benchmark.struct-arrays
STRUCT: point { x float } { y float } { z float } ;
! Make sure it's a fixnum here to speed up double-hashing.
: hashcodes-from-hashcode ( n -- n n )
- dup most-positive-fixnum >fixnum bitxor ;
+ dup most-positive-fixnum bitxor ;
: hashcodes-from-object ( obj -- n n )
hashcode abs hashcodes-from-hashcode ;
{ [ os unix? ] [ "libcurses.so" ] }
} cond "cdecl" add-library >>
-TYPEDEF: void* WINDOW*
-TYPEDEF: void* SCREEN*
+C-TYPE: WINDOW
+C-TYPE: SCREEN
TYPEDEF: void* va_list
TYPEDEF: uint chtype
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax kernel system combinators
+USING: alien alien.c-types alien.syntax kernel system combinators
alien.libraries classes.struct ;
IN: freetype
FUNCTION: FT_Error FT_Init_FreeType ( void* library ) ;
! circular reference between glyph and face
-TYPEDEF: void face
-TYPEDEF: void glyph
+C-TYPE: face
+C-TYPE: glyph
STRUCT: glyph
{ library void* }
{ palette_mode char }
{ palette void* } ;
+TYPEDEF: void* FT_Face*
+
FUNCTION: FT_Error FT_New_Face ( void* library, FT_Char* font, FT_Long index, face* face ) ;
FUNCTION: FT_Error FT_New_Memory_Face ( void* library, FT_Byte* file_base, FT_Long file_size, FT_Long face_index, FT_Face* aface ) ;
! (c)2009 Joe Groff bsd license
-USING: alien alien.syntax byte-arrays classes gpu.buffers
-gpu.framebuffers gpu.shaders gpu.textures help.markup
+USING: alien alien.c-types alien.syntax byte-arrays classes
+gpu.buffers gpu.framebuffers gpu.shaders gpu.textures help.markup
help.syntax images kernel math sequences
specialized-arrays strings ;
-SPECIALIZED-ARRAY: float
+QUALIFIED-WITH: alien.c-types c
+QUALIFIED-WITH: math m
+SPECIALIZED-ARRAY: c:float
SPECIALIZED-ARRAY: int
SPECIALIZED-ARRAY: uint
SPECIALIZED-ARRAY: ulong
"Uniform parameters are passed from Factor to the shader program through the uniform tuple as follows:"
{ $list
{ { $link int-uniform } "s and " { $link uint-uniform } "s take their values from Factor " { $link integer } "s." }
-{ { $link float-uniform } "s take their values from Factor " { $link float } "s." }
+{ { $link float-uniform } "s take their values from Factor " { $link m:float } "s." }
{ { $link bool-uniform } "s take their values from Factor " { $link boolean } "s." }
{ { $link texture-uniform } "s take their values from " { $link texture } " objects." }
{ "Vector uniforms take their values from Factor " { $link sequence } "s of the corresponding component type."
opengl opengl.gl opengl.shaders parser quotations sequences
specialized-arrays splitting strings tr ui.gadgets.worlds
variants vectors vocabs vocabs.loader vocabs.parser words
-words.constant ;
+words.constant half-floats ;
+QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: int
SPECIALIZED-ARRAY: void*
IN: gpu.shaders
: component-type>c-type ( component-type -- c-type )
{
- { ubyte-components [ "uchar" ] }
- { ushort-components [ "ushort" ] }
- { uint-components [ "uint" ] }
- { half-components [ "half" ] }
- { float-components [ "float" ] }
- { byte-integer-components [ "char" ] }
- { ubyte-integer-components [ "uchar" ] }
- { short-integer-components [ "short" ] }
- { ushort-integer-components [ "ushort" ] }
- { int-integer-components [ "int" ] }
- { uint-integer-components [ "uint" ] }
+ { ubyte-components [ c:uchar ] }
+ { ushort-components [ c:ushort ] }
+ { uint-components [ c:uint ] }
+ { half-components [ half ] }
+ { float-components [ c:float ] }
+ { byte-integer-components [ c:char ] }
+ { ubyte-integer-components [ c:uchar ] }
+ { short-integer-components [ c:short ] }
+ { ushort-integer-components [ c:ushort ] }
+ { int-integer-components [ c:int ] }
+ { uint-integer-components [ c:uint ] }
} case ;
: c-array-dim ( type dim -- type' )
! (c)2009 Joe Groff bsd license
USING: gpu.buffers gpu.render gpu.shaders gpu.textures images kernel
specialized-arrays ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: gpu.util
locals math math.constants math.functions math.matrices
math.order math.vectors opengl.gl sequences
ui ui.gadgets.worlds specialized-arrays ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: gpu.util.wasd
! (c)2009 Joe Groff bsd license
USING: accessors arrays destructors kernel math opengl
opengl.gl sequences sequences.product specialized-arrays ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: grid-meshes
fry namespaces combinators.smart splitting io.encodings.ascii
arrays io.files.info unicode.case io.directories.search literals
math.functions continuations ;
+FROM: alien.c-types => uchar ;
IN: id3
<PRIVATE
: mp3>id3 ( path -- id3/f )
[
- [ <id3> ] dip "uchar" <mapped-array>
+ [ <id3> ] dip uchar <mapped-array>
[ dup id3v1? [ read-v1-tags merge-id3v1 ] [ drop ] if ]
[ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ]
[ dup id3v2? [ read-v2-tags ] [ drop ] if ]
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: http.client images.loader images.loader.private kernel
+images.viewer ;
+IN: images.http
+
+: load-http-image ( path -- image )
+ [ http-get nip ] [ image-class ] bi load-image* ;
+
+: http-image. ( path -- )
+ load-http-image image. ;
! Copyright (C) 2009 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors grouping sequences combinators math
-byte-arrays fry images half-floats specialized-arrays ;
+USING: alien.c-types kernel accessors grouping sequences
+combinators math byte-arrays fry images half-floats
+specialized-arrays ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: uint
SPECIALIZED-ARRAY: ushort
SPECIALIZED-ARRAY: float
jamshred.oint jamshred.sound jamshred.tunnel kernel locals math
math.constants math.order math.ranges math.vectors math.matrices
sequences shuffle specialized-arrays strings system ;
-SPECIALIZED-ARRAY: float
+QUALIFIED-WITH: alien.c-types c
+SPECIALIZED-ARRAY: c:float
IN: jamshred.player
TUPLE: player < oint
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays jamshred.oint jamshred.tunnel kernel
-math.vectors sequences specialized-arrays tools.test ;
+math.vectors sequences specialized-arrays tools.test
+alien.c-types ;
SPECIALIZED-ARRAY: float
IN: jamshred.tunnel.tests
math.order math.quadratic math.ranges math.vectors random
sequences specialized-arrays vectors ;
FROM: jamshred.oint => distance ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: jamshred.tunnel
--- /dev/null
+! (c)Joe Groff bsd license
+USING: classes.struct math.matrices.simd math.vectors.simd
+literals math.constants math.functions specialized-arrays tools.test ;
+QUALIFIED-WITH: alien.c-types c
+FROM: math.matrices => m~ ;
+SIMD: c:float
+SPECIALIZED-ARRAY: float-4
+IN: math.matrices.simd.tests
+
+[
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 3.0 0.0 0.0 0.0 }
+ float-4{ 0.0 4.0 0.0 0.0 }
+ float-4{ 0.0 0.0 2.0 0.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+] [ float-4{ 3.0 4.0 2.0 0.0 } scale-matrix4 ] unit-test
+
+[
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1/8. 0.0 0.0 0.0 }
+ float-4{ 0.0 1/4. 0.0 0.0 }
+ float-4{ 0.0 0.0 1/2. 0.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+] [ float-4{ 8.0 4.0 2.0 0.0 } ortho-matrix4 ] unit-test
+
+[
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1.0 0.0 0.0 3.0 }
+ float-4{ 0.0 1.0 0.0 4.0 }
+ float-4{ 0.0 0.0 1.0 2.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+] [ float-4{ 3.0 4.0 2.0 0.0 } translation-matrix4 ] unit-test
+
+[ t ] [
+ float-4{ $[ 1/2. sqrt ] 0.0 $[ 1/2. sqrt ] 0.0 } pi rotation-matrix4
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 0.0 0.0 1.0 0.0 }
+ float-4{ 0.0 -1.0 0.0 0.0 }
+ float-4{ 1.0 0.0 0.0 0.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ 1.0e-7 m~
+] unit-test
+
+[
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 2.0 0.0 0.0 10.0 }
+ float-4{ 0.0 3.0 0.0 18.0 }
+ float-4{ 0.0 0.0 4.0 28.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+] [
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 2.0 0.0 0.0 0.0 }
+ float-4{ 0.0 3.0 0.0 0.0 }
+ float-4{ 0.0 0.0 4.0 0.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1.0 0.0 0.0 5.0 }
+ float-4{ 0.0 1.0 0.0 6.0 }
+ float-4{ 0.0 0.0 1.0 7.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ m4.
+] unit-test
+
+[
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 3.0 0.0 0.0 5.0 }
+ float-4{ 0.0 4.0 0.0 6.0 }
+ float-4{ 0.0 0.0 5.0 7.0 }
+ float-4{ 0.0 0.0 0.0 2.0 }
+ }
+ }
+] [
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 2.0 0.0 0.0 0.0 }
+ float-4{ 0.0 3.0 0.0 0.0 }
+ float-4{ 0.0 0.0 4.0 0.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1.0 0.0 0.0 5.0 }
+ float-4{ 0.0 1.0 0.0 6.0 }
+ float-4{ 0.0 0.0 1.0 7.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ m4+
+] unit-test
+
+[
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1.0 0.0 0.0 -5.0 }
+ float-4{ 0.0 2.0 0.0 -6.0 }
+ float-4{ 0.0 0.0 3.0 -7.0 }
+ float-4{ 0.0 0.0 0.0 0.0 }
+ }
+ }
+] [
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 2.0 0.0 0.0 0.0 }
+ float-4{ 0.0 3.0 0.0 0.0 }
+ float-4{ 0.0 0.0 4.0 0.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1.0 0.0 0.0 5.0 }
+ float-4{ 0.0 1.0 0.0 6.0 }
+ float-4{ 0.0 0.0 1.0 7.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ m4-
+] unit-test
+
+[
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 3.0 0.0 0.0 15.0 }
+ float-4{ 0.0 3.0 0.0 18.0 }
+ float-4{ 0.0 0.0 3.0 21.0 }
+ float-4{ 0.0 0.0 0.0 3.0 }
+ }
+ }
+] [
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1.0 0.0 0.0 5.0 }
+ float-4{ 0.0 1.0 0.0 6.0 }
+ float-4{ 0.0 0.0 1.0 7.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ 3.0 m4*n
+] unit-test
+
+[
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 3.0 0.0 0.0 15.0 }
+ float-4{ 0.0 3.0 0.0 18.0 }
+ float-4{ 0.0 0.0 3.0 21.0 }
+ float-4{ 0.0 0.0 0.0 3.0 }
+ }
+ }
+] [
+ 3.0
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1.0 0.0 0.0 5.0 }
+ float-4{ 0.0 1.0 0.0 6.0 }
+ float-4{ 0.0 0.0 1.0 7.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ n*m4
+] unit-test
+
+[
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1/2. 0.0 0.0 0.0 }
+ float-4{ 0.0 1/2. 0.0 0.0 }
+ float-4{ 0.0 0.0 -6/4. -10/4. }
+ float-4{ 0.0 0.0 -1.0 0.0 }
+ }
+ }
+] [
+ float-4{ 2.0 2.0 0.0 0.0 } 1.0 5.0
+ frustum-matrix4
+] unit-test
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors classes.struct generalizations kernel locals
+math math.functions math.matrices.simd math.vectors
+math.vectors.simd sequences sequences.private specialized-arrays
+typed ;
+QUALIFIED-WITH: alien.c-types c
+SIMD: c:float
+SPECIALIZED-ARRAY: float-4
+IN: math.matrices.simd
+
+STRUCT: matrix4
+ { rows float-4[4] } ;
+
+INSTANCE: matrix4 immutable-sequence
+
+M: matrix4 length drop 4 ; inline
+M: matrix4 nth-unsafe rows>> nth-unsafe ; inline
+M: matrix4 new-sequence 2drop matrix4 (struct) ; inline
+
+<PRIVATE
+
+: rows ( a -- a1 a2 a3 a4 )
+ rows>> 4 firstn ; inline
+
+:: set-rows ( c1 c2 c3 c4 c -- c )
+ c rows>> :> rows
+ c1 rows set-first
+ c2 rows set-second
+ c3 rows set-third
+ c4 rows set-fourth
+ c ; inline
+
+:: 2map-rows ( a b quot -- c )
+ matrix4 (struct) :> c
+
+ a rows :> a4 :> a3 :> a2 :> a1
+ b rows :> b4 :> b3 :> b2 :> b1
+
+ a1 b1 quot call
+ a2 b2 quot call
+ a3 b3 quot call
+ a4 b4 quot call
+
+ c set-rows ; inline
+
+:: map-rows ( a quot -- c )
+ matrix4 (struct) :> c
+
+ a rows :> a4 :> a3 :> a2 :> a1
+
+ a1 quot call
+ a2 quot call
+ a3 quot call
+ a4 quot call
+
+ c set-rows ; inline
+
+PRIVATE>
+
+TYPED: m4+ ( a: matrix4 b: matrix4 -- c: matrix4 ) [ v+ ] 2map-rows ;
+TYPED: m4- ( a: matrix4 b: matrix4 -- c: matrix4 ) [ v- ] 2map-rows ;
+TYPED: m4* ( a: matrix4 b: matrix4 -- c: matrix4 ) [ v* ] 2map-rows ;
+TYPED: m4/ ( a: matrix4 b: matrix4 -- c: matrix4 ) [ v/ ] 2map-rows ;
+
+TYPED: m4*n ( a: matrix4 b: float -- c: matrix4 ) [ v*n ] curry map-rows ;
+TYPED: m4/n ( a: matrix4 b: float -- c: matrix4 ) [ v/n ] curry map-rows ;
+TYPED: n*m4 ( a: float b: matrix4 -- c: matrix4 ) [ n*v ] with map-rows ;
+TYPED: n/m4 ( a: float b: matrix4 -- c: matrix4 ) [ n/v ] with map-rows ;
+
+TYPED:: m4. ( a: matrix4 b: matrix4 -- c: matrix4 )
+ matrix4 (struct) :> c
+
+ a rows :> a4 :> a3 :> a2 :> a1
+ b rows :> b4 :> b3 :> b2 :> b1
+
+ a1 first b1 n*v :> c1a
+ a2 first b1 n*v :> c2a
+ a3 first b1 n*v :> c3a
+ a4 first b1 n*v :> c4a
+
+ a1 second b2 n*v c1a v+ :> c1b
+ a2 second b2 n*v c2a v+ :> c2b
+ a3 second b2 n*v c3a v+ :> c3b
+ a4 second b2 n*v c4a v+ :> c4b
+
+ a1 third b3 n*v c1b v+ :> c1c
+ a2 third b3 n*v c2b v+ :> c2c
+ a3 third b3 n*v c3b v+ :> c3c
+ a4 third b3 n*v c4b v+ :> c4c
+
+ a1 fourth b4 n*v c1c v+
+ a2 fourth b4 n*v c2c v+
+ a3 fourth b4 n*v c3c v+
+ a4 fourth b4 n*v c4c v+
+
+ c set-rows ;
+
+CONSTANT: identity-matrix4
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1.0 0.0 0.0 0.0 }
+ float-4{ 0.0 1.0 0.0 0.0 }
+ float-4{ 0.0 0.0 1.0 0.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+
+TYPED:: scale-matrix4 ( factors: float-4 -- matrix: matrix4 )
+ matrix4 (struct) :> c
+
+ factors { t t t f } vmask :> factors'
+
+ factors' { 0 3 3 3 } vshuffle
+ factors' { 3 1 3 3 } vshuffle
+ factors' { 3 3 2 3 } vshuffle
+ float-4{ 0.0 0.0 0.0 1.0 }
+
+ c set-rows ;
+
+: ortho-matrix4 ( factors -- matrix )
+ float-4{ 1.0 1.0 1.0 1.0 } swap v/ scale-matrix4 ; inline
+
+TYPED:: translation-matrix4 ( offset: float-4 -- matrix: matrix4 )
+ matrix4 (struct) :> c
+
+ float-4{ 0.0 0.0 0.0 1.0 } :> c4
+ { t t t f } offset c4 v? :> offset'
+
+ offset' { 3 3 3 0 } vshuffle { t f f t } vmask
+ offset' { 3 3 3 1 } vshuffle { f t f t } vmask
+ offset' { 3 3 3 2 } vshuffle { f f t t } vmask
+ c4
+
+ c set-rows ;
+
+TYPED:: rotation-matrix4 ( axis: float-4 theta: float -- matrix: matrix4 )
+ ! x*x + c*(1.0 - x*x) x*y*(1.0 - c) - s*z x*z*(1.0 - c) + s*y 0
+ ! x*y*(1.0 - c) + s*z y*y + c*(1.0 - y*y) y*z*(1.0 - c) - s*x 0
+ ! x*z*(1.0 - c) - s*y y*z*(1.0 - c) + s*x z*z + c*(1.0 - z*z) 0
+ ! 0 0 0 1
+ matrix4 (struct) :> triangle-m
+ theta cos :> c
+ theta sin :> s
+
+ float-4{ 1.0 -1.0 1.0 0.0 } :> triangle-sign
+
+ c float-4-with :> cc
+ s float-4-with :> ss
+ 1.0 float-4-with :> ones
+ ones cc v- :> 1-c
+ axis axis v* :> axis2
+
+ axis2 cc ones axis2 v- v* v+ :> diagonal
+
+ axis { 0 0 1 3 } vshuffle axis { 1 2 2 3 } vshuffle v* 1-c v*
+ { t t t f } vmask :> triangle-a
+ ss { 2 1 0 3 } vshuffle triangle-sign v* :> triangle-b
+ triangle-a triangle-b v+ :> triangle-lo
+ triangle-a triangle-b v- :> triangle-hi
+
+ diagonal scale-matrix4 :> diagonal-m
+
+ triangle-hi { 3 0 1 3 } vshuffle
+ triangle-hi { 3 3 2 3 } vshuffle triangle-lo { 0 3 3 3 } vshuffle v+
+ triangle-lo { 1 2 3 3 } vshuffle
+ float-4 new
+
+ triangle-m set-rows drop
+
+ diagonal-m triangle-m m4+ ;
+
+TYPED:: frustum-matrix4 ( xy: float-4 near: float far: float -- matrix: matrix4 )
+ matrix4 (struct) :> c
+
+ near near near far + 2 near far * * float-4-boa :> num
+ { t t f f } xy near far - float-4-with v? :> denom
+ num denom v/ :> fov
+
+ fov { 0 0 0 0 } vshuffle { t f f f } vmask
+ fov { 1 1 1 1 } vshuffle { f t f f } vmask
+ fov { 2 2 2 3 } vshuffle { f f t t } vmask
+ float-4{ 0.0 0.0 -1.0 0.0 }
+
+ c set-rows ;
+
--- /dev/null
+SIMD accelerated 4x4 matrix math
-USING: alien.syntax io io.encodings.utf16n io.encodings.utf8 io.files
-kernel namespaces sequences system threads unix.utilities ;
+USING: alien.c-types alien.syntax io io.encodings.utf16n
+io.encodings.utf8 io.files kernel namespaces sequences system threads
+unix.utilities ;
IN: native-thread-test
FUNCTION: void* start_standalone_factor_in_new_thread ( int argc, char** argv ) ;
: testthread ( -- )
"/tmp/hello" utf8 [ "hello!\n" write ] with-file-appender 5000000 sleep ;
-MAIN: testthread
\ No newline at end of file
+MAIN: testthread
! (c)2009 Joe Groff bsd license
-USING: accessors arrays grouping kernel locals math math.order
-math.ranges math.vectors math.vectors.homogeneous sequences
-specialized-arrays ;
+USING: accessors alien.c-types arrays grouping kernel locals
+math math.order math.ranges math.vectors
+math.vectors.homogeneous sequences specialized-arrays ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: nurbs
--- /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
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel alien alien.syntax shuffle
-openal.backend namespaces system generalizations ;
+openal openal.backend namespaces system generalizations ;
IN: openal.macosx
LIBRARY: alut
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax combinators generalizations
-kernel openal.backend ;
+kernel openal openal.backend ;
IN: openal.other
LIBRARY: alut
! Copyright (C) 2005 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.libraries alien.syntax kernel sequences words system
-combinators ;
+USING: alien alien.c-types alien.libraries alien.syntax kernel
+sequences words system combinators opengl.gl ;
IN: opengl.glu
<<
LIBRARY: glu
! These are defined as structs in glu.h, but we only ever use pointers to them
-TYPEDEF: void* GLUnurbs*
-TYPEDEF: void* GLUquadric*
-TYPEDEF: void* GLUtesselator*
-TYPEDEF: void* GLubyte*
+C-TYPE: GLUnurbs
+C-TYPE: GLUquadric
+C-TYPE: GLUtesselator
+C-TYPE: GLubyte
TYPEDEF: void* GLUfuncptr
! StringName
! FUNCTION: GLint gluUnProject4 ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble clipW, GLdouble* model, GLdouble* proj, GLint* view, GLdouble nearVal, GLdouble farVal, GLdouble* objX, GLdouble* objY, GLdouble* objZ, GLdouble* objW ) ;
: gl-look-at ( eye focus up -- )
- [ first3 ] tri@ gluLookAt ;
\ No newline at end of file
+ [ first3 ] tri@ gluLookAt ;
PRIVATE>
: euler044 ( -- answer )
- most-positive-fixnum >fixnum
+ most-positive-fixnum
2500 [1,b] [
dup [1,b] [
euler044-step
ui.gadgets.worlds ui.pixel-formats game-worlds method-chains
math.affine-transforms noise ui.gestures combinators.short-circuit
destructors grid-meshes ;
+FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: terrain
LIBRARY: tokyocabinet
-TYPEDEF: void* TCHDB*
+C-TYPE: TCXSTR
+C-TYPE: TCHDB
CONSTANT: HDBFOPEN 1
CONSTANT: HDBFFATAL 2
LIBRARY: tokyotyrant
-TYPEDEF: void* TCRDB*
+C-TYPE: TCRDB
! STRUCT: TCRDB
! { mmtx pthread_mutex_t }
! { eckey pthread_key_t }
CONSTANT: RDBITVOID TDBITVOID
CONSTANT: RDBITKEEP TDBITKEEP
-TYPEDEF: void* RDBQRY*
+C-TYPE: RDBQRY
! STRUCT: RDBQRY
! { rdb TCRDB* }
! { args TCLIST* } ;
LIBRARY: tokyocabinet
-TYPEDEF: void* TDBIDX*
-TYPEDEF: void* TCTDB*
+C-TYPE: TDBIDX
+C-TYPE: TCTDB
+C-TYPE: TCMAP
CONSTANT: TDBFOPEN HDBFOPEN
CONSTANT: TDBFFATAL HDBFFATAL
CONSTANT: TDBITVOID 9999
CONSTANT: TDBITKEEP 16777216
-TYPEDEF: void* TDBCOND*
-TYPEDEF: void* TDBQRY*
+C-TYPE: TDBCOND
+C-TYPE: TDBQRY
C-ENUM:
TDBQCSTREQ
! FIXME: on windows 64bits this isn't correct, because long is 32bits there, and time_t is int64
TYPEDEF: long tokyo_time_t
-TYPEDEF: void* TCLIST*
+C-TYPE: TCLIST
FUNCTION: TCLIST* tclistnew ( ) ;
FUNCTION: TCLIST* tclistnew2 ( int anum ) ;
--- /dev/null
+! (c)Joe Groff bsd license
+USING: typed compiler.cfg.debugger compiler.tree.debugger words ;
+IN: typed.debugger
+
+: typed-test-mr ( word -- mrs )
+ "typed-word" word-prop test-mr ; inline
+: typed-optimized. ( word -- )
+ "typed-word" word-prop optimized. ; inline
--- /dev/null
+USING: kernel layouts math quotations tools.test typed ;
+IN: typed.tests
+
+TYPED: f+ ( a: float b: float -- c: float )
+ + ;
+
+[ 3.5 ]
+[ 2 1+1/2 f+ ] unit-test
+
+TYPED: fix+ ( a: fixnum b: fixnum -- c: fixnum )
+ + ;
+
+most-positive-fixnum neg 1 - 1quotation
+[ most-positive-fixnum 1 fix+ ] unit-test
+
+TUPLE: tweedle-dee ;
+TUPLE: tweedle-dum ;
+
+TYPED: dee ( x: tweedle-dee -- y )
+ drop \ tweedle-dee ;
+
+TYPED: dum ( x: tweedle-dum -- y )
+ drop \ tweedle-dum ;
+
+[ \ tweedle-dum new dee ] [ input-mismatch-error? ] must-fail-with
+[ \ tweedle-dee new dum ] [ input-mismatch-error? ] must-fail-with
+
+
+TYPED: dumdum ( x -- y: tweedle-dum )
+ drop \ tweedle-dee new ;
+
+[ f dumdum ] [ output-mismatch-error? ] must-fail-with
+
+TYPED:: f+locals ( a: float b: float -- c: float )
+ a b + ;
+
+[ 3.5 ] [ 2 1+1/2 f+locals ] unit-test
! (c)Joe Groff bsd license
-USING: accessors combinators combinators.short-circuit
-definitions effects fry hints kernel kernel.private namespaces
-parser quotations see.private sequences words ;
+USING: accessors arrays combinators combinators.short-circuit
+definitions effects fry hints math kernel kernel.private namespaces
+parser quotations see.private sequences words
+locals locals.definitions locals.parser ;
IN: typed
ERROR: type-mismatch-error word expected-types ;
[ nip effect-in-types swap '[ _ declare @ ] ]
[ effect-out-types dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if ] 2bi ;
+: typed-gensym ( parent-word -- word )
+ name>> "( typed " " )" surround f <word> ;
+
: define-typed-gensym ( word def effect -- gensym )
- [ 3drop gensym dup ]
+ [ 2drop typed-gensym dup ]
[ [ swap ] dip typed-gensym-quot ]
[ 2nip ] 3tri define-declared ;
-PREDICATE: typed < word "typed-word" word-prop ;
+PREDICATE: typed-standard-word < word "typed-word" word-prop ;
+PREDICATE: typed-lambda-word < lambda-word "typed-word" word-prop ;
+
+UNION: typed-word typed-standard-word typed-lambda-word ;
: typed-quot ( quot word effect -- quot' )
[ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
SYNTAX: TYPED:
(:) define-typed ;
+SYNTAX: TYPED::
+ (::) define-typed ;
+
+M: typed-standard-word definer drop \ TYPED: \ ; ;
+M: typed-lambda-word definer drop \ TYPED:: \ ; ;
-M: typed definer drop \ TYPED: \ ; ;
-M: typed definition "typed-def" word-prop ;
-M: typed declarations. "typed-word" word-prop declarations. ;
+M: typed-word definition "typed-def" word-prop ;
+M: typed-word declarations. "typed-word" word-prop declarations. ;
+M: typed-word subwords "typed-word" word-prop 1array ;
<tr><th class="field-label">Date: </th><td><t:label t:name="date" /></td></tr>
</table>
- <pre class="description"><t:code t:name="contents" t:mode="mode" /></pre>
-
+ <t:a t:href="$pastebin/paste.txt" t:query="id">Plain Text</t:a> |
<t:button t:action="$pastebin/delete-paste" t:for="id" class="link-button link">Delete Paste</t:button>
+ <pre class="description"><t:code t:name="contents" t:mode="mode" /></pre>
+
<t:bind-each t:name="annotations">
<h2><a name="@id">Annotation: <t:label t:name="summary" /></a></h2>
<tr><th class="field-label">Date: </th><td><t:label t:name="date" /></td></tr>
</table>
- <pre class="description"><t:code t:name="contents" t:mode="mode"/></pre>
-
+ <t:a t:href="$pastebin/annotation.txt" t:query="id">Plain Text</t:a> |
<t:button t:action="$pastebin/delete-annotation" t:for="id" class="link-button link">Delete Annotation</t:button>
+ <pre class="description"><t:code t:name="contents" t:mode="mode"/></pre>
+
</t:bind-each>
<t:bind t:name="new-annotation">
http.server
http.server.dispatchers
http.server.redirection
+http.server.responses
furnace
furnace.actions
furnace.redirection
TUPLE: annotation < entity parent ;
-annotation "ANNOTATIONS"
+\ annotation "ANNOTATIONS"
{
{ "parent" "PARENT" INTEGER +not-null+ }
} define-persistent
: <annotation> ( parent id -- annotation )
- annotation new
+ \ annotation new
swap >>id
swap >>parent ;
+: annotation ( id -- annotation )
+ [ f ] dip <annotation> select-tuple ;
+
: paste ( id -- paste )
[ <paste> select-tuple ]
[ f <annotation> select-tuples ]
{ pastebin "paste" } >>template ;
+: <raw-paste-action> ( -- action )
+ <action>
+ [ validate-integer-id "id" value paste from-object ] >>init
+ [ "contents" value "text/plain" <content> ] >>display ;
+
: <paste-feed-action> ( -- action )
<feed-action>
[ validate-integer-id ] >>init
tri
] >>submit ;
+: <raw-annotation-action> ( -- action )
+ <action>
+ [ validate-integer-id "id" value annotation from-object ] >>init
+ [ "contents" value "text/plain" <content> ] >>display ;
+
: <delete-annotation-action> ( -- action )
<action>
[ { { "id" [ v-number ] } } validate-params ] >>validate
[
- f "id" value <annotation> select-tuple
+ f "id" value annotation
[ delete-tuples ]
[ parent>> paste-url <redirect> ]
bi
<pastebin-action> "" add-responder
<pastebin-feed-action> "list.atom" add-responder
<paste-action> "paste" add-responder
+ <raw-paste-action> "paste.txt" add-responder
<paste-feed-action> "paste.atom" add-responder
<new-paste-action> "new-paste" add-responder
<delete-paste-action> "delete-paste" add-responder
<new-annotation-action> "new-annotation" add-responder
+ <raw-annotation-action> "annotation.txt" add-responder
<delete-annotation-action> "delete-annotation" add-responder
<boilerplate>
{ pastebin "pastebin-common" } >>template ;
set iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255
endif
-syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple
+syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorTriString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple,factorStruct
syn match factorTodo /\(TODO\|FIXME\|XXX\):\=/ contained
-syn match factorComment /\<#! .*/ contains=factorTodo
-syn match factorComment /\<! .*/ contains=factorTodo
+syn match factorComment /\<#!\>.*/ contains=factorTodo
+syn match factorComment /\<!\>.*/ contains=factorTodo
syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorLiteralStackEffect,factorArray0,factorQuotation0
syn cluster factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal
syn cluster factorNumber contains=@factorReal,factorComplex
syn cluster factorNumErr contains=factorBinErr,factorHexErr,factorOctErr
-syn match factorInt /\<-\=\d\+\>/
-syn match factorFloat /\<-\=\d*\.\d\+\>/
-syn match factorRatio /\<-\=\d*\.*\d\+\/-\=\d*\.*\d\+\>/
+syn match factorInt /\<-\=[0-9]\([0-9,]*[0-9]\)\?\>/
+syn match factorFloat /\<-\=[0-9]\([0-9,]*[0-9]\)\?\.[0-9,]*[0-9]\+\>/
+syn match factorRatio /\<-\=[0-9]\([0-9,]*[0-9]\)\?\(+[0-9]\([0-9,]*[0-9]\+\)\?\)\?\/-\=[0-9]\([0-9,]*[0-9]\+\)\?\.\?\>/
syn region factorComplex start=/\<C{\>/ end=/\<}\>/ contains=@factorReal
-syn match factorBinErr /\<BIN:\s\+[01]*[^\s01]\S*\>/
-syn match factorBinary /\<BIN:\s\+[01]\+\>/
-syn match factorHexErr /\<HEX:\s\+\x*[^\x\s]\S*\>/
-syn match factorHex /\<HEX:\s\+\x\+\>/
-syn match factorOctErr /\<OCT:\s\+\o*[^\o\s]\S*\>/
-syn match factorOctal /\<OCT:\s\+\o\+\>/
+syn match factorBinErr /\<BIN:\s\+-\=[01,]*[^01 ]\S*\>/
+syn match factorBinary /\<BIN:\s\+-\=[01,]\+\>/
+syn match factorHexErr /\<HEX:\s\+-\=\(,\S*\|\S*,\|[-0-9a-fA-Fp,]*[^-0-9a-fA-Fp, ]\S*\)\>/
+syn match factorHex /\<HEX:\s\+-\=[0-9a-fA-F]\([0-9a-fA-F,]*[0-9a-fA-F]\)\?\(\.[0-9a-fA-F]\([0-9a-fA-F,]*[0-9a-fA-F]\)\?\)\?\(p-\=[0-9]\([0-9,]*[0-9]\)\?\)\?\>/
+syn match factorOctErr /\<OCT:\s\+-\=\(,\S*\|\S*,\|[0-7,]*[^0-7, ]\S*\)\>/
+syn match factorOctal /\<OCT:\s\+-\=[0-7,]\+\>/
+syn match factorNan /\<NAN:\s\+[0-9a-fA-F]\([0-9a-fA-F,]*[0-9a-fA-F]\)\?\>/
syn match factorIn /\<IN:\s\+\S\+\>/
syn match factorUse /\<USE:\s\+\S\+\>/
syn match factorBackslash /\<\\\>\s\+\S\+\>/
syn region factorUsing start=/\<USING:\>/ end=/;/
+syn match factorQualified /\<QUALIFIED:\s\+\S\+\>/
+syn match factorQualifiedWith /\<QUALIFIED-WITH:\s\+\S\+\s\+\S\+\>/
+syn region factorFrom start=/\<FROM:\>/ end=/;/
syn region factorSingletons start=/\<SINGLETONS:\>/ end=/;/
syn match factorSymbol /\<SYMBOL:\s\+\S\+\>/
syn region factorSymbols start=/\<SYMBOLS:\>/ end=/;/
syn region factorConstructor2 start=/\<CONSTRUCTOR:\?/ end=/;/
syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
+syn region factorStruct start=/\<\(UNION-STRUCT:\|STRUCT:\)\>/ end=/\<;\>/
syn match factorConstant /\<CONSTANT:\s\+\S\+\>/
+syn match factorAlias /\<ALIAS:\s\+\S\+\>/
syn match factorSingleton /\<SINGLETON:\s\+\S\+\>/
syn match factorPostpone /\<POSTPONE:\s\+\S\+\>/
syn match factorDefer /\<DEFER:\s\+\S\+\>/
syn match factorHook /\<HOOK:\s\+\S\+\s\+\S\+\>/
syn match factorMain /\<MAIN:\s\+\S\+\>/
syn match factorConstructor /\<C:\s\+\S\+\s\+\S\+\>/
-syn match factorAlien /\<ALIEN:\s\+\d\+\>/
-
-syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor
+syn match factorAlien /\<ALIEN:\s\+[0-9a-fA-F]\([0-9a-fA-F,]*[0-9a-fA-F]\)\?\>/
+syn cluster factorWordOps contains=factorConstant,factorAlias,factorSingleton,factorSingletons,factorSymbol,factorSymbols,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor
"TODO:
"misc:
" PRIMITIVE:
"C interface:
-" FIELD:
-" BEGIN-STRUCT:
" C-ENUM:
" FUNCTION:
-" END-STRUCT
-" DLL"
" TYPEDEF:
" LIBRARY:
-" C-UNION:
-"QUALIFIED:
-"QUALIFIED-WITH:
-"FROM:
-"ALIAS:
-"! POSTPONE: "
"#\ "
-syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline
-syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline
+syn region factorString start=/\<"/ skip=/\\"/ end=/"/
+syn region factorTriString start=/\<"""/ skip=/\\"/ end=/"""/
+syn region factorSbuf start=/\<SBUF"\>/ skip=/\\"/ end=/"/
syn region factorMultiString matchgroup=factorMultiStringDelims start=/\<STRING:\s\+\S\+\>/ end=/^;$/ contains=factorMultiStringContents
syn match factorMultiStringContents /.*/ contained
"adapted from lisp.vim
if exists("g:factor_norainbow")
- syn region factorQuotation matchgroup=factorDelimiter start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
+ syn region factorQuotation matchgroup=factorDelimiter start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
else
- syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
- syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
- syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
- syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
- syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
- syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
- syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
- syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
- syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
- syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
+ syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
+ syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
+ syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
+ syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
+ syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
+ syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
+ syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
+ syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
+ syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
+ syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
endif
if exists("g:factor_norainbow")
- syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL
+ syn region factorArray matchgroup=factorDelimiter start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL
else
- syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1
- syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2
- syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3
- syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4
- syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5
- syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6
- syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7
- syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8
- syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9
- syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
+ syn region factorArray0 matchgroup=hlLevel0 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1
+ syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2
+ syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3
+ syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4
+ syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5
+ syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6
+ syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7
+ syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8
+ syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9
+ syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
endif
syn match factorBracketErr /\<\]\>/
HiLink factorPGenericDelims Special
HiLink factorPGenericNDelims Special
HiLink factorString String
+ HiLink factorTriString String
HiLink factorSbuf String
HiLink factorMultiStringContents String
HiLink factorMultiStringDelims Typedef
HiLink factorBinErr Error
HiLink factorHex Number
HiLink factorHexErr Error
+ HiLink factorNan Number
HiLink factorOctal Number
HiLink factorOctErr Error
HiLink factorFloat Float
HiLink factorInt Number
HiLink factorUsing Include
+ HiLink factorQualified Include
+ HiLink factorQualifiedWith Include
+ HiLink factorFrom Include
HiLink factorUse Include
HiLink factorUnuse Include
HiLink factorIn Define
HiLink factorForget Define
HiLink factorAlien Define
HiLink factorTuple Typedef
+ HiLink factorStruct Typedef
if &bg == "dark"
hi hlLevel0 ctermfg=red guifg=red1
--- /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 ;
TYPEDEF: char SQLCHAR
TYPEDEF: char* SQLCHAR*
TYPEDEF: void* SQLHANDLE
-TYPEDEF: void* SQLHANDLE*
+C-TYPE: SQLHANDLE
TYPEDEF: void* SQLHENV
TYPEDEF: void* SQLHDBC
TYPEDEF: void* SQLHSTMT
+++ /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
inline void primitive_tuple_boa();
//words
- word *allot_word(cell vocab_, cell name_);
+ word *allot_word(cell name_, cell vocab_, cell hashcode_);
inline void primitive_word();
inline void primitive_word_xt();
void update_word_xt(cell w_);
namespace factor
{
-word *factor_vm::allot_word(cell vocab_, cell name_)
+word *factor_vm::allot_word(cell name_, cell vocab_, cell hashcode_)
{
gc_root<object> vocab(vocab_,this);
gc_root<object> name(name_,this);
gc_root<word> new_word(allot<word>(sizeof(word)),this);
- new_word->hashcode = tag_fixnum((rand() << 16) ^ rand());
+ new_word->hashcode = hashcode_;
new_word->vocabulary = vocab.value();
new_word->name = name.value();
new_word->def = userenv[UNDEFINED_ENV];
return new_word.untagged();
}
-/* <word> ( name vocabulary -- word ) */
+/* (word) ( name vocabulary hashcode -- word ) */
inline void factor_vm::primitive_word()
{
+ cell hashcode = dpop();
cell vocab = dpop();
cell name = dpop();
- dpush(tag<word>(allot_word(vocab,name)));
+ dpush(tag<word>(allot_word(name,vocab,hashcode)));
}
PRIMITIVE_FORWARD(word)
projects / factor.git / commitdiff
