Merge branch 'master' of git://factorcode.org/git/factor into bags
commit
a3c168cb5e
|
@ -31,8 +31,10 @@
|
||||||
<string>Factor</string>
|
<string>Factor</string>
|
||||||
<key>CFBundlePackageType</key>
|
<key>CFBundlePackageType</key>
|
||||||
<string>APPL</string>
|
<string>APPL</string>
|
||||||
|
<key>CFBundleVersion</key>
|
||||||
|
<string>0.93</string>
|
||||||
<key>NSHumanReadableCopyright</key>
|
<key>NSHumanReadableCopyright</key>
|
||||||
<string>Copyright © 2003-2009, Slava Pestov and friends</string>
|
<string>Copyright © 2003-2010 Factor developers</string>
|
||||||
<key>NSServices</key>
|
<key>NSServices</key>
|
||||||
<array>
|
<array>
|
||||||
<dict>
|
<dict>
|
||||||
|
|
|
@ -4,7 +4,7 @@ ifdef CONFIG
|
||||||
AR = ar
|
AR = ar
|
||||||
LD = ld
|
LD = ld
|
||||||
|
|
||||||
VERSION = 0.92
|
VERSION = 0.93
|
||||||
|
|
||||||
BUNDLE = Factor.app
|
BUNDLE = Factor.app
|
||||||
LIBPATH = -L/usr/X11R6/lib
|
LIBPATH = -L/usr/X11R6/lib
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.strings alien.c-types alien.data alien.accessors
|
USING: alien alien.strings alien.c-types alien.data alien.accessors
|
||||||
arrays words sequences math kernel namespaces fry cpu.architecture
|
arrays words sequences math kernel namespaces fry cpu.architecture
|
||||||
io.encodings.utf8 accessors ;
|
io.encodings.binary io.encodings.utf8 accessors ;
|
||||||
IN: alien.arrays
|
IN: alien.arrays
|
||||||
|
|
||||||
INSTANCE: array value-type
|
INSTANCE: array value-type
|
||||||
|
@ -35,15 +35,12 @@ M: array box-return drop void* box-return ;
|
||||||
M: array stack-size drop void* stack-size ;
|
M: array stack-size drop void* stack-size ;
|
||||||
|
|
||||||
M: array c-type-boxer-quot
|
M: array c-type-boxer-quot
|
||||||
unclip
|
unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;
|
||||||
[ array-length ]
|
|
||||||
[ [ require-c-array ] keep ] bi*
|
|
||||||
[ <c-direct-array> ] 2curry ;
|
|
||||||
|
|
||||||
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
|
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
|
||||||
|
|
||||||
PREDICATE: string-type < pair
|
PREDICATE: string-type < pair
|
||||||
first2 [ char* = ] [ word? ] bi* and ;
|
first2 [ c-string = ] [ word? ] bi* and ;
|
||||||
|
|
||||||
M: string-type c-type ;
|
M: string-type c-type ;
|
||||||
|
|
||||||
|
@ -88,10 +85,14 @@ M: string-type c-type-unboxer
|
||||||
drop void* c-type-unboxer ;
|
drop void* c-type-unboxer ;
|
||||||
|
|
||||||
M: string-type c-type-boxer-quot
|
M: string-type c-type-boxer-quot
|
||||||
second '[ _ alien>string ] ;
|
second dup binary =
|
||||||
|
[ drop void* c-type-boxer-quot ]
|
||||||
|
[ '[ _ alien>string ] ] if ;
|
||||||
|
|
||||||
M: string-type c-type-unboxer-quot
|
M: string-type c-type-unboxer-quot
|
||||||
second '[ _ string>alien ] ;
|
second dup binary =
|
||||||
|
[ drop void* c-type-unboxer-quot ]
|
||||||
|
[ '[ _ string>alien ] ] if ;
|
||||||
|
|
||||||
M: string-type c-type-getter
|
M: string-type c-type-getter
|
||||||
drop [ alien-cell ] ;
|
drop [ alien-cell ] ;
|
||||||
|
@ -99,8 +100,5 @@ M: string-type c-type-getter
|
||||||
M: string-type c-type-setter
|
M: string-type c-type-setter
|
||||||
drop [ set-alien-cell ] ;
|
drop [ set-alien-cell ] ;
|
||||||
|
|
||||||
{ char* utf8 } char* typedef
|
{ c-string utf8 } c-string typedef
|
||||||
char* uchar* typedef
|
|
||||||
|
|
||||||
char char* "pointer-c-type" set-word-prop
|
|
||||||
uchar uchar* "pointer-c-type" set-word-prop
|
|
||||||
|
|
|
@ -6,10 +6,6 @@ QUALIFIED: math
|
||||||
QUALIFIED: sequences
|
QUALIFIED: sequences
|
||||||
IN: alien.c-types
|
IN: alien.c-types
|
||||||
|
|
||||||
HELP: byte-length
|
|
||||||
{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } }
|
|
||||||
{ $contract "Outputs the size of the byte array, struct, or specialized array data in bytes." } ;
|
|
||||||
|
|
||||||
HELP: heap-size
|
HELP: heap-size
|
||||||
{ $values { "name" "a C type name" } { "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." }
|
{ $description "Outputs the number of bytes needed for a heap-allocated value of this C type." }
|
||||||
|
@ -32,13 +28,10 @@ HELP: no-c-type
|
||||||
{ $description "Throws a " { $link no-c-type } " error." }
|
{ $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." } ;
|
{ $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." } ;
|
||||||
|
|
||||||
HELP: c-types
|
|
||||||
{ $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
|
HELP: c-type
|
||||||
{ $values { "name" "a C type" } { "c-type" c-type } }
|
{ $values { "name" "a C type" } { "c-type" c-type } }
|
||||||
{ $description "Looks up a C type by name." }
|
{ $description "Looks up a C type by name." }
|
||||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist, or the word is not a C type." } ;
|
||||||
|
|
||||||
HELP: c-getter
|
HELP: c-getter
|
||||||
{ $values { "name" "a C type" } { "quot" { $quotation "( c-ptr n -- obj )" } } }
|
{ $values { "name" "a C type" } { "quot" { $quotation "( c-ptr n -- obj )" } } }
|
||||||
|
@ -106,8 +99,8 @@ HELP: ulonglong
|
||||||
HELP: void
|
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 for 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*
|
HELP: void*
|
||||||
{ $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." } ;
|
{ $description "This C type represents a generic pointer to C memory. See " { $link pointer } " for information on pointer C types." } ;
|
||||||
HELP: char*
|
HELP: c-string
|
||||||
{ $description "This C type represents a pointer to a C string. See " { $link "c-strings" } " for details about using strings with the FFI." } ;
|
{ $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
|
HELP: float
|
||||||
{ $description "This C type represents a single-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s and demoted to single-precision; output values will be returned as Factor " { $link math:float } "s." } ;
|
{ $description "This C type represents a single-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s and demoted to single-precision; output values will be returned as Factor " { $link math:float } "s." } ;
|
||||||
|
@ -118,6 +111,19 @@ HELP: complex-float
|
||||||
HELP: complex-double
|
HELP: complex-double
|
||||||
{ $description "This C type represents a double-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link math:complex } " objects into a double-precision complex float type; output values will be returned as Factor " { $link math:complex } " objects." } ;
|
{ $description "This C type represents a double-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link math:complex } " objects into a double-precision complex float type; output values will be returned as Factor " { $link math:complex } " objects." } ;
|
||||||
|
|
||||||
|
HELP: pointer:
|
||||||
|
{ $syntax "pointer: c-type" }
|
||||||
|
{ $description "Constructs a " { $link pointer } " C type." } ;
|
||||||
|
|
||||||
|
HELP: pointer
|
||||||
|
{ $class-description "Represents a pointer C type. The " { $snippet "to" } " slot contains the C type being pointed to." { $link byte-array } " and " { $link alien } " values can be provided as pointer function inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. Objects with methods on " { $link >c-ptr } ", such as structs and specialized arrays, may also be used as pointer inputs."
|
||||||
|
$nl
|
||||||
|
"Pointer output values are represented in Factor as " { $link alien } "s. If the pointed-to type is a struct, the alien will automatically be wrapped in a struct object if it is not null."
|
||||||
|
$nl
|
||||||
|
"In " { $link POSTPONE: TYPEDEF: } ", " { $link POSTPONE: FUNCTION: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: STRUCT: } " definitions, pointer types can be created by suffixing " { $snippet "*" } " to a C type name. Outside of FFI definitions, a pointer C type can be created using the " { $link POSTPONE: pointer: } " syntax word:"
|
||||||
|
{ $unchecked-example "FUNCTION: int* foo ( char* bar ) ;" }
|
||||||
|
{ $unchecked-example """: foo ( bar -- int* )
|
||||||
|
pointer: int f \"foo\" { pointer: char } alien-invoke ;""" } } ;
|
||||||
|
|
||||||
ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
|
ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
|
||||||
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
|
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
|
||||||
|
@ -194,11 +200,11 @@ ARTICLE: "c-types.primitives" "Primitive C types"
|
||||||
"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." ;
|
"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"
|
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."
|
"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. This syntax constructs a " { $link pointer } " object to represent the C type."
|
||||||
$nl
|
$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:"
|
"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]" }
|
{ $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." ;
|
"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 with the dimensions only serving as documentation." ;
|
||||||
|
|
||||||
ARTICLE: "c-types.ambiguity" "Word name clashes with C types"
|
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:"
|
"Note that some of the C type word names clash with commonly-used Factor words:"
|
||||||
|
@ -231,7 +237,7 @@ ARTICLE: "c-types.structs" "Struct and union types"
|
||||||
"Struct and union types are identified by their class word. See " { $link "classes.struct" } "." ;
|
"Struct and union types are identified by their class word. See " { $link "classes.struct" } "." ;
|
||||||
|
|
||||||
ARTICLE: "c-types-specs" "C type specifiers"
|
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."
|
"C types are identified by special words. Type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words."
|
||||||
$nl
|
$nl
|
||||||
"Defining new C types:"
|
"Defining new C types:"
|
||||||
{ $subsections
|
{ $subsections
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: alien alien.syntax alien.c-types alien.parser
|
USING: alien alien.syntax alien.c-types alien.parser
|
||||||
eval kernel tools.test sequences system libc alien.strings
|
eval kernel tools.test sequences system libc alien.strings
|
||||||
io.encodings.utf8 math.constants classes.struct classes
|
io.encodings.ascii io.encodings.utf8 math.constants classes.struct classes
|
||||||
accessors compiler.units ;
|
accessors compiler.units ;
|
||||||
IN: alien.c-types.tests
|
IN: alien.c-types.tests
|
||||||
|
|
||||||
|
@ -16,36 +16,39 @@ UNION-STRUCT: foo
|
||||||
{ a int }
|
{ a int }
|
||||||
{ b int } ;
|
{ b int } ;
|
||||||
|
|
||||||
[ f ] [ char resolve-pointer-type c-type void* c-type eq? ] unit-test
|
[ t ] [ pointer: void c-type void* c-type = ] unit-test
|
||||||
[ t ] [ char* resolve-pointer-type c-type void* c-type eq? ] unit-test
|
[ t ] [ pointer: int c-type void* c-type = ] unit-test
|
||||||
|
[ t ] [ pointer: int* c-type void* c-type = ] unit-test
|
||||||
|
[ f ] [ pointer: foo c-type void* c-type = ] unit-test
|
||||||
|
[ t ] [ pointer: foo* c-type void* c-type = ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ c-string c-type c-string c-type = ] unit-test
|
||||||
|
|
||||||
[ t ] [ foo heap-size int heap-size = ] unit-test
|
[ t ] [ foo heap-size int heap-size = ] unit-test
|
||||||
|
|
||||||
TYPEDEF: int MyInt
|
TYPEDEF: int MyInt
|
||||||
|
|
||||||
[ t ] [ int c-type MyInt c-type eq? ] unit-test
|
[ t ] [ int c-type MyInt c-type = ] unit-test
|
||||||
[ t ] [ void* c-type MyInt resolve-pointer-type c-type eq? ] unit-test
|
[ t ] [ void* c-type pointer: MyInt c-type = ] unit-test
|
||||||
|
|
||||||
TYPEDEF: char MyChar
|
|
||||||
|
|
||||||
[ 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
|
TYPEDEF: char MyChar
|
||||||
|
|
||||||
[ t ] [ char* c-type MyString c-type eq? ] unit-test
|
[ t ] [ pointer: void c-type pointer: MyChar c-type = ] unit-test
|
||||||
[ t ] [ void* c-type MyString resolve-pointer-type c-type eq? ] unit-test
|
|
||||||
|
TYPEDEF: { c-string ascii } MyFunkyString
|
||||||
|
|
||||||
|
[ { c-string ascii } ] [ MyFunkyString c-type ] unit-test
|
||||||
|
|
||||||
|
TYPEDEF: c-string MyString
|
||||||
|
|
||||||
|
[ t ] [ c-string c-type MyString c-type = ] unit-test
|
||||||
|
[ t ] [ void* c-type pointer: MyString c-type = ] unit-test
|
||||||
|
|
||||||
TYPEDEF: int* MyIntArray
|
TYPEDEF: int* MyIntArray
|
||||||
|
|
||||||
[ t ] [ void* c-type MyIntArray c-type eq? ] unit-test
|
[ t ] [ void* c-type MyIntArray c-type = ] unit-test
|
||||||
|
|
||||||
TYPEDEF: uchar* MyLPBYTE
|
|
||||||
|
|
||||||
[ t ] [ { char* utf8 } c-type MyLPBYTE c-type = ] unit-test
|
|
||||||
|
|
||||||
[
|
[
|
||||||
0 B{ 1 2 3 4 } <displaced-alien> <void*>
|
0 B{ 1 2 3 4 } <displaced-alien> <void*>
|
||||||
|
@ -63,7 +66,7 @@ os windows? cpu x86.64? and [
|
||||||
|
|
||||||
C-TYPE: opaque
|
C-TYPE: opaque
|
||||||
|
|
||||||
[ t ] [ void* c-type opaque resolve-pointer-type c-type eq? ] unit-test
|
[ t ] [ void* c-type pointer: opaque c-type = ] unit-test
|
||||||
[ opaque c-type ] [ no-c-type? ] must-fail-with
|
[ opaque c-type ] [ no-c-type? ] must-fail-with
|
||||||
|
|
||||||
[ """
|
[ """
|
||||||
|
|
|
@ -17,8 +17,9 @@ SYMBOLS:
|
||||||
long ulong
|
long ulong
|
||||||
longlong ulonglong
|
longlong ulonglong
|
||||||
float double
|
float double
|
||||||
void* bool
|
void* bool ;
|
||||||
void ;
|
|
||||||
|
SINGLETON: void
|
||||||
|
|
||||||
DEFER: <int>
|
DEFER: <int>
|
||||||
DEFER: *char
|
DEFER: *char
|
||||||
|
@ -43,65 +44,24 @@ stack-align? ;
|
||||||
: <c-type> ( -- c-type )
|
: <c-type> ( -- c-type )
|
||||||
\ c-type new ; inline
|
\ c-type new ; inline
|
||||||
|
|
||||||
SYMBOL: c-types
|
|
||||||
|
|
||||||
global [
|
|
||||||
c-types [ H{ } assoc-like ] change
|
|
||||||
] bind
|
|
||||||
|
|
||||||
ERROR: no-c-type name ;
|
ERROR: no-c-type name ;
|
||||||
|
|
||||||
PREDICATE: c-type-word < word
|
|
||||||
"c-type" word-prop ;
|
|
||||||
|
|
||||||
UNION: c-type-name string c-type-word ;
|
|
||||||
|
|
||||||
! C type protocol
|
! C type protocol
|
||||||
GENERIC: c-type ( name -- c-type ) foldable
|
GENERIC: c-type ( name -- c-type ) foldable
|
||||||
|
|
||||||
GENERIC: resolve-pointer-type ( name -- c-type )
|
PREDICATE: c-type-word < word
|
||||||
|
"c-type" word-prop ;
|
||||||
|
|
||||||
<< \ void \ void* "pointer-c-type" set-word-prop >>
|
TUPLE: pointer { to initial: void read-only } ;
|
||||||
|
C: <pointer> pointer
|
||||||
|
|
||||||
: void? ( c-type -- ? )
|
UNION: c-type-name
|
||||||
{ void "void" } member? ;
|
c-type-word pointer ;
|
||||||
|
|
||||||
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 ] [
|
|
||||||
drop
|
|
||||||
c-types get at dup c-type-name?
|
|
||||||
[ resolve-pointer-type ] [ drop void* ] if
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
M: array resolve-pointer-type
|
|
||||||
first resolve-pointer-type ;
|
|
||||||
|
|
||||||
: resolve-typedef ( name -- c-type )
|
: resolve-typedef ( name -- c-type )
|
||||||
dup void? [ no-c-type ] when
|
dup void? [ no-c-type ] when
|
||||||
dup c-type-name? [ c-type ] when ;
|
dup c-type-name? [ c-type ] when ;
|
||||||
|
|
||||||
<PRIVATE
|
|
||||||
|
|
||||||
: parse-array-type ( name -- dims c-type )
|
|
||||||
"[" split unclip
|
|
||||||
[ [ "]" ?tail drop string>number ] map ] dip ;
|
|
||||||
|
|
||||||
PRIVATE>
|
|
||||||
|
|
||||||
M: string c-type ( name -- c-type )
|
|
||||||
CHAR: ] over member? [
|
|
||||||
parse-array-type prefix
|
|
||||||
] [
|
|
||||||
dup c-types get at [ ] [
|
|
||||||
"*" ?tail [ resolve-pointer-type ] [ no-c-type ] if
|
|
||||||
] ?if resolve-typedef
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
M: word c-type
|
M: word c-type
|
||||||
dup "c-type" word-prop resolve-typedef
|
dup "c-type" word-prop resolve-typedef
|
||||||
[ ] [ no-c-type ] ?if ;
|
[ ] [ no-c-type ] ?if ;
|
||||||
|
@ -233,12 +193,6 @@ M: c-type-name stack-size c-type stack-size ;
|
||||||
|
|
||||||
M: c-type stack-size size>> cell align ;
|
M: c-type stack-size size>> cell align ;
|
||||||
|
|
||||||
GENERIC: byte-length ( seq -- n ) flushable
|
|
||||||
|
|
||||||
M: byte-array byte-length length ; inline
|
|
||||||
|
|
||||||
M: f byte-length drop 0 ; inline
|
|
||||||
|
|
||||||
: >c-bool ( ? -- int ) 1 0 ? ; inline
|
: >c-bool ( ? -- int ) 1 0 ? ; inline
|
||||||
|
|
||||||
: c-bool> ( int -- ? ) 0 = not ; inline
|
: c-bool> ( int -- ? ) 0 = not ; inline
|
||||||
|
@ -263,24 +217,13 @@ MIXIN: value-type
|
||||||
\ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
|
\ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
|
||||||
] [ ] make ;
|
] [ ] make ;
|
||||||
|
|
||||||
GENERIC: typedef ( old new -- )
|
|
||||||
|
|
||||||
PREDICATE: typedef-word < c-type-word
|
PREDICATE: typedef-word < c-type-word
|
||||||
"c-type" word-prop c-type-name? ;
|
"c-type" word-prop c-type-name? ;
|
||||||
|
|
||||||
M: string typedef ( old new -- ) c-types get set-at ;
|
: typedef ( old new -- )
|
||||||
|
|
||||||
M: word typedef ( old new -- )
|
|
||||||
{
|
{
|
||||||
[ nip define-symbol ]
|
[ nip define-symbol ]
|
||||||
[ name>> typedef ]
|
|
||||||
[ swap "c-type" set-word-prop ]
|
[ swap "c-type" set-word-prop ]
|
||||||
[
|
|
||||||
swap dup c-type-name? [
|
|
||||||
resolve-pointer-type
|
|
||||||
"pointer-c-type" set-word-prop
|
|
||||||
] [ 2drop ] if
|
|
||||||
]
|
|
||||||
} 2cleave ;
|
} 2cleave ;
|
||||||
|
|
||||||
TUPLE: long-long-type < c-type ;
|
TUPLE: long-long-type < c-type ;
|
||||||
|
@ -315,6 +258,10 @@ M: long-long-type box-return ( c-type -- )
|
||||||
: if-void ( c-type true false -- )
|
: if-void ( c-type true false -- )
|
||||||
pick void? [ drop nip call ] [ nip call ] if ; inline
|
pick void? [ drop nip call ] [ nip call ] if ; inline
|
||||||
|
|
||||||
|
SYMBOLS:
|
||||||
|
ptrdiff_t intptr_t uintptr_t size_t
|
||||||
|
c-string ;
|
||||||
|
|
||||||
CONSTANT: primitive-types
|
CONSTANT: primitive-types
|
||||||
{
|
{
|
||||||
char uchar
|
char uchar
|
||||||
|
@ -324,11 +271,30 @@ CONSTANT: primitive-types
|
||||||
longlong ulonglong
|
longlong ulonglong
|
||||||
float double
|
float double
|
||||||
void* bool
|
void* bool
|
||||||
|
c-string
|
||||||
}
|
}
|
||||||
|
|
||||||
SYMBOLS:
|
: (pointer-c-type) ( void* type -- void*' )
|
||||||
ptrdiff_t intptr_t uintptr_t size_t
|
[ clone ] dip c-type-boxer-quot '[ _ [ f ] if* ] >>boxer-quot ;
|
||||||
char* uchar* ;
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: resolve-pointer-typedef ( type -- base-type )
|
||||||
|
dup "c-type" word-prop dup word?
|
||||||
|
[ nip resolve-pointer-typedef ] [
|
||||||
|
pointer? [ drop void* ] when
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: primitive-pointer-type? ( type -- ? )
|
||||||
|
dup c-type-word? [
|
||||||
|
resolve-pointer-typedef [ void? ] [ primitive-types member? ] bi or
|
||||||
|
] [ drop t ] if ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
M: pointer c-type
|
||||||
|
[ \ void* c-type ] dip
|
||||||
|
to>> dup primitive-pointer-type? [ drop ] [ (pointer-c-type) ] if ;
|
||||||
|
|
||||||
: 8-byte-alignment ( c-type -- c-type )
|
: 8-byte-alignment ( c-type -- c-type )
|
||||||
{
|
{
|
||||||
|
@ -541,6 +507,7 @@ SYMBOLS:
|
||||||
\ uint c-type \ uintptr_t typedef
|
\ uint c-type \ uintptr_t typedef
|
||||||
\ uint c-type \ size_t typedef
|
\ uint c-type \ size_t typedef
|
||||||
] if
|
] if
|
||||||
|
|
||||||
] with-compilation-unit
|
] with-compilation-unit
|
||||||
|
|
||||||
M: char-16-rep rep-component-type drop char ;
|
M: char-16-rep rep-component-type drop char ;
|
||||||
|
|
|
@ -16,6 +16,6 @@ STRUCT: complex-holder
|
||||||
|
|
||||||
[ C{ 1.0 2.0 } ] [ "h" get z>> ] unit-test
|
[ C{ 1.0 2.0 } ] [ "h" get z>> ] unit-test
|
||||||
|
|
||||||
[ complex ] [ "complex-float" c-type-boxed-class ] unit-test
|
[ complex ] [ complex-float c-type-boxed-class ] unit-test
|
||||||
|
|
||||||
[ complex ] [ "complex-double" c-type-boxed-class ] unit-test
|
[ complex ] [ complex-double c-type-boxed-class ] unit-test
|
||||||
|
|
|
@ -6,8 +6,10 @@ IN: alien.complex
|
||||||
|
|
||||||
<<
|
<<
|
||||||
{ "float" "double" } [ dup "complex-" prepend define-complex-type ] each
|
{ "float" "double" } [ dup "complex-" prepend define-complex-type ] each
|
||||||
|
>>
|
||||||
|
|
||||||
|
<<
|
||||||
! This overrides the fact that small structures are never returned
|
! This overrides the fact that small structures are never returned
|
||||||
! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
|
! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
|
||||||
"complex-float" c-type t >>return-in-registers? drop
|
\ complex-float c-type t >>return-in-registers? drop
|
||||||
>>
|
>>
|
||||||
|
|
|
@ -7,6 +7,8 @@ IN: alien.complex.functor
|
||||||
|
|
||||||
FUNCTOR: define-complex-type ( N T -- )
|
FUNCTOR: define-complex-type ( N T -- )
|
||||||
|
|
||||||
|
N-type IS ${N}
|
||||||
|
|
||||||
T-class DEFINES-CLASS ${T}
|
T-class DEFINES-CLASS ${T}
|
||||||
|
|
||||||
<T> DEFINES <${T}>
|
<T> DEFINES <${T}>
|
||||||
|
@ -14,7 +16,7 @@ T-class DEFINES-CLASS ${T}
|
||||||
|
|
||||||
WHERE
|
WHERE
|
||||||
|
|
||||||
STRUCT: T-class { real N } { imaginary N } ;
|
STRUCT: T-class { real N-type } { imaginary N-type } ;
|
||||||
|
|
||||||
: <T> ( z -- alien )
|
: <T> ( z -- alien )
|
||||||
>rect T-class <struct-boa> >c-ptr ;
|
>rect T-class <struct-boa> >c-ptr ;
|
||||||
|
|
|
@ -21,11 +21,6 @@ HELP: memory>byte-array
|
||||||
{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
|
{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
|
||||||
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
|
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
|
||||||
|
|
||||||
HELP: byte-array>memory
|
|
||||||
{ $values { "byte-array" byte-array } { "base" c-ptr } }
|
|
||||||
{ $description "Writes a byte array to memory starting from the " { $snippet "base" } " address." }
|
|
||||||
{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
|
|
||||||
|
|
||||||
HELP: malloc-array
|
HELP: malloc-array
|
||||||
{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" "a specialized array" } }
|
{ $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> } "." }
|
{ $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> } "." }
|
||||||
|
@ -75,9 +70,7 @@ $nl
|
||||||
"You can unsafely copy a range of bytes from one memory location to another:"
|
"You can unsafely copy a range of bytes from one memory location to another:"
|
||||||
{ $subsections memcpy }
|
{ $subsections memcpy }
|
||||||
"You can copy a range of bytes from memory into a byte array:"
|
"You can copy a range of bytes from memory into a byte array:"
|
||||||
{ $subsections memory>byte-array }
|
{ $subsections memory>byte-array } ;
|
||||||
"You can copy a byte array to memory unsafely:"
|
|
||||||
{ $subsections byte-array>memory } ;
|
|
||||||
|
|
||||||
ARTICLE: "c-pointers" "Passing pointers to C functions"
|
ARTICLE: "c-pointers" "Passing pointers to C functions"
|
||||||
"The following Factor objects may be passed to C function parameters with pointer types:"
|
"The following Factor objects may be passed to C function parameters with pointer types:"
|
||||||
|
@ -85,7 +78,7 @@ ARTICLE: "c-pointers" "Passing pointers to C functions"
|
||||||
{ "Instances of " { $link alien } "." }
|
{ "Instances of " { $link alien } "." }
|
||||||
{ "Instances of " { $link f } "; this is interpreted as a null pointer." }
|
{ "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." }
|
{ "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" } "." }
|
{ "Any data type which defines a method on " { $link >c-ptr } ". This includes " { $link "classes.struct" } " and " { $link "specialized-arrays" } "." }
|
||||||
}
|
}
|
||||||
"The class of primitive C pointer types:"
|
"The class of primitive C pointer types:"
|
||||||
{ $subsections c-ptr }
|
{ $subsections c-ptr }
|
||||||
|
@ -111,7 +104,7 @@ $nl
|
||||||
{ $subsections "byte-arrays-gc" }
|
{ $subsections "byte-arrays-gc" }
|
||||||
"C-style enumerated types are supported:"
|
"C-style enumerated types are supported:"
|
||||||
{ $subsections POSTPONE: C-ENUM: }
|
{ $subsections POSTPONE: C-ENUM: }
|
||||||
"C types can be aliased for convenience and consitency with native library documentation:"
|
"C types can be aliased for convenience and consistency with native library documentation:"
|
||||||
{ $subsections POSTPONE: TYPEDEF: }
|
{ $subsections POSTPONE: TYPEDEF: }
|
||||||
"A utility for defining " { $link "destructors" } " for deallocating memory:"
|
"A utility for defining " { $link "destructors" } " for deallocating memory:"
|
||||||
{ $subsections "alien.destructors" }
|
{ $subsections "alien.destructors" }
|
||||||
|
@ -140,13 +133,13 @@ HELP: <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." } ;
|
{ $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." } ;
|
||||||
|
|
||||||
ARTICLE: "c-strings" "C strings"
|
ARTICLE: "c-strings" "C strings"
|
||||||
"C string types are arrays with shape " { $snippet "{ char* encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $link char* } " is an alias for " { $snippet "{ char* utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
|
"C string types are arrays with shape " { $snippet "{ c-string encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $link c-string } " is an alias for " { $snippet "{ c-string utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors. In " { $link POSTPONE: TYPEDEF: } ", " { $link POSTPONE: FUNCTION: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: STRUCT: } " definitions, the shorthand syntax " { $snippet "c-string[encoding]" } " can be used to specify the string encoding."
|
||||||
$nl
|
$nl
|
||||||
"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
|
"Passing a Factor string to a C function expecting a " { $link c-string } " allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
|
||||||
$nl
|
$nl
|
||||||
"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
|
"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
|
||||||
$nl
|
$nl
|
||||||
"Care must be taken if the C function expects a " { $link char* } " with a length in bytes, rather than a null-terminated " { $link char* } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
|
"Care must be taken if the C function expects a pointer to a string with its length represented by another parameter rather than a null terminator. Passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
|
||||||
$nl
|
$nl
|
||||||
"Sometimes a C function has a parameter type of " { $link void* } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
|
"Sometimes a C function has a parameter type of " { $link void* } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
|
||||||
{ $subsections
|
{ $subsections
|
||||||
|
@ -155,7 +148,9 @@ $nl
|
||||||
}
|
}
|
||||||
"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
|
"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
|
||||||
$nl
|
$nl
|
||||||
|
"The C type " { $link char } { $snippet "*" } " represents a generic pointer to " { $snippet "char" } "; arguments with this type will expect and return " { $link alien } "s, and won't perform any implicit string conversion."
|
||||||
|
$nl
|
||||||
"A word to read strings from arbitrary addresses:"
|
"A word to read strings from arbitrary addresses:"
|
||||||
{ $subsections alien>string }
|
{ $subsections alien>string }
|
||||||
"For example, if a C function returns a " { $link char* } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $link void* } ", and call one of the above words before passing the pointer to " { $link free } "." ;
|
"For example, if a C function returns a " { $link c-string } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "char*" } " and call one of the above words before passing the pointer to " { $link free } "." ;
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
! (c)2009 Slava Pestov, Joe Groff bsd license
|
! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
|
||||||
USING: accessors alien alien.c-types alien.strings arrays
|
USING: accessors alien alien.c-types alien.strings arrays
|
||||||
byte-arrays cpu.architecture fry io io.encodings.binary
|
byte-arrays cpu.architecture fry io io.encodings.binary
|
||||||
io.files io.streams.memory kernel libc math sequences words ;
|
io.files io.streams.memory kernel libc math sequences words
|
||||||
|
byte-vectors ;
|
||||||
IN: alien.data
|
IN: alien.data
|
||||||
|
|
||||||
GENERIC: require-c-array ( c-type -- )
|
GENERIC: require-c-array ( c-type -- )
|
||||||
|
@ -48,7 +49,7 @@ M: word <c-direct-array>
|
||||||
heap-size malloc ; inline
|
heap-size malloc ; inline
|
||||||
|
|
||||||
: malloc-byte-array ( byte-array -- alien )
|
: malloc-byte-array ( byte-array -- alien )
|
||||||
dup byte-length [ nip malloc dup ] 2keep memcpy ;
|
binary-object [ nip malloc dup ] 2keep memcpy ;
|
||||||
|
|
||||||
: memory>byte-array ( alien len -- byte-array )
|
: memory>byte-array ( alien len -- byte-array )
|
||||||
[ nip (byte-array) dup ] 2keep memcpy ;
|
[ nip (byte-array) dup ] 2keep memcpy ;
|
||||||
|
@ -62,8 +63,12 @@ M: memory-stream stream-read
|
||||||
swap memory>byte-array
|
swap memory>byte-array
|
||||||
] [ [ + ] change-index drop ] 2bi ;
|
] [ [ + ] change-index drop ] 2bi ;
|
||||||
|
|
||||||
: byte-array>memory ( byte-array base -- )
|
M: byte-vector stream-write
|
||||||
swap dup byte-length memcpy ; inline
|
[ dup byte-length tail-slice ]
|
||||||
|
[ [ [ byte-length ] bi@ + ] keep lengthen ]
|
||||||
|
[ drop byte-length ]
|
||||||
|
2tri
|
||||||
|
[ >c-ptr swap >c-ptr ] dip memcpy ;
|
||||||
|
|
||||||
M: value-type c-type-rep drop int-rep ;
|
M: value-type c-type-rep drop int-rep ;
|
||||||
|
|
||||||
|
|
|
@ -4,6 +4,7 @@ alien.data alien.fortran alien.fortran.private alien.strings
|
||||||
classes.struct arrays assocs byte-arrays combinators fry
|
classes.struct arrays assocs byte-arrays combinators fry
|
||||||
generalizations io.encodings.ascii kernel macros
|
generalizations io.encodings.ascii kernel macros
|
||||||
macros.expander namespaces sequences shuffle tools.test vocabs.parser ;
|
macros.expander namespaces sequences shuffle tools.test vocabs.parser ;
|
||||||
|
FROM: alien.syntax => pointer: ;
|
||||||
QUALIFIED-WITH: alien.c-types c
|
QUALIFIED-WITH: alien.c-types c
|
||||||
IN: alien.fortran.tests
|
IN: alien.fortran.tests
|
||||||
|
|
||||||
|
@ -100,16 +101,16 @@ intel-unix-abi fortran-abi [
|
||||||
|
|
||||||
! fortran-arg-type>c-type
|
! fortran-arg-type>c-type
|
||||||
|
|
||||||
[ c:void* { } ]
|
[ pointer: c:int { } ]
|
||||||
[ "integer" fortran-arg-type>c-type ] unit-test
|
[ "integer" fortran-arg-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:void* { } ]
|
[ pointer: { c:int 3 } { } ]
|
||||||
[ "integer(3)" fortran-arg-type>c-type ] unit-test
|
[ "integer(3)" fortran-arg-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:void* { } ]
|
[ pointer: { c:int 0 } { } ]
|
||||||
[ "integer(*)" fortran-arg-type>c-type ] unit-test
|
[ "integer(*)" fortran-arg-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:void* { } ]
|
[ pointer: fortran_test_record { } ]
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
"alien.fortran.tests" use-vocab
|
"alien.fortran.tests" use-vocab
|
||||||
|
@ -117,13 +118,13 @@ intel-unix-abi fortran-abi [
|
||||||
] with-manifest
|
] with-manifest
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ c:char* { } ]
|
[ pointer: c:char { } ]
|
||||||
[ "character" fortran-arg-type>c-type ] unit-test
|
[ "character" fortran-arg-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:char* { } ]
|
[ pointer: c:char { } ]
|
||||||
[ "character(1)" fortran-arg-type>c-type ] unit-test
|
[ "character(1)" fortran-arg-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:char* { long } ]
|
[ pointer: { c:char 17 } { long } ]
|
||||||
[ "character(17)" fortran-arg-type>c-type ] unit-test
|
[ "character(17)" fortran-arg-type>c-type ] unit-test
|
||||||
|
|
||||||
! fortran-ret-type>c-type
|
! fortran-ret-type>c-type
|
||||||
|
@ -131,7 +132,7 @@ intel-unix-abi fortran-abi [
|
||||||
[ c:char { } ]
|
[ c:char { } ]
|
||||||
[ "character(1)" fortran-ret-type>c-type ] unit-test
|
[ "character(1)" fortran-ret-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:void { c:char* long } ]
|
[ c:void { pointer: { c:char 17 } long } ]
|
||||||
[ "character(17)" fortran-ret-type>c-type ] unit-test
|
[ "character(17)" fortran-ret-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:int { } ]
|
[ c:int { } ]
|
||||||
|
@ -143,22 +144,22 @@ intel-unix-abi fortran-abi [
|
||||||
[ c:float { } ]
|
[ c:float { } ]
|
||||||
[ "real" fortran-ret-type>c-type ] unit-test
|
[ "real" fortran-ret-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:void { c:void* } ]
|
[ c:void { pointer: { c:float 0 } } ]
|
||||||
[ "real(*)" fortran-ret-type>c-type ] unit-test
|
[ "real(*)" fortran-ret-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:double { } ]
|
[ c:double { } ]
|
||||||
[ "double-precision" fortran-ret-type>c-type ] unit-test
|
[ "double-precision" fortran-ret-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:void { c:void* } ]
|
[ c:void { pointer: complex-float } ]
|
||||||
[ "complex" fortran-ret-type>c-type ] unit-test
|
[ "complex" fortran-ret-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:void { c:void* } ]
|
[ c:void { pointer: complex-double } ]
|
||||||
[ "double-complex" fortran-ret-type>c-type ] unit-test
|
[ "double-complex" fortran-ret-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:void { c:void* } ]
|
[ c:void { pointer: { c:int 0 } } ]
|
||||||
[ "integer(*)" fortran-ret-type>c-type ] unit-test
|
[ "integer(*)" fortran-ret-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:void { c:void* } ]
|
[ c:void { pointer: fortran_test_record } ]
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
"alien.fortran.tests" use-vocab
|
"alien.fortran.tests" use-vocab
|
||||||
|
@ -168,19 +169,19 @@ intel-unix-abi fortran-abi [
|
||||||
|
|
||||||
! fortran-sig>c-sig
|
! fortran-sig>c-sig
|
||||||
|
|
||||||
[ c:float { c:void* c:char* c:void* c:void* c:long } ]
|
[ c:float { pointer: c:int pointer: { c:char 17 } pointer: c:float pointer: c:double c:long } ]
|
||||||
[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
|
[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
|
||||||
unit-test
|
unit-test
|
||||||
|
|
||||||
[ c:char { c:char* c:char* c:void* c:long } ]
|
[ c:char { pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
|
||||||
[ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ]
|
[ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ]
|
||||||
unit-test
|
unit-test
|
||||||
|
|
||||||
[ c:void { c:char* c:long c:char* c:char* c:void* c:long } ]
|
[ c:void { pointer: { c:char 18 } c:long pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
|
||||||
[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
|
[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
|
||||||
unit-test
|
unit-test
|
||||||
|
|
||||||
[ c:void { c:void* c:char* c:char* c:void* c:long } ]
|
[ c:void { pointer: complex-float pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
|
||||||
[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
|
[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
|
||||||
unit-test
|
unit-test
|
||||||
|
|
||||||
|
@ -201,7 +202,7 @@ intel-unix-abi fortran-abi [
|
||||||
! [fortran-invoke]
|
! [fortran-invoke]
|
||||||
[
|
[
|
||||||
c:void "funpack" "funtimes_"
|
c:void "funpack" "funtimes_"
|
||||||
{ c:char* c:void* c:void* c:void* c:void* c:long }
|
{ pointer: { c:char 12 } pointer: c:longlong pointer: c:float pointer: complex-float pointer: c:short c:long }
|
||||||
alien-invoke
|
alien-invoke
|
||||||
] 6 nkeep
|
] 6 nkeep
|
||||||
! [fortran-results>]
|
! [fortran-results>]
|
||||||
|
@ -226,7 +227,7 @@ intel-unix-abi fortran-abi [
|
||||||
[ { [ drop ] } spread ]
|
[ { [ drop ] } spread ]
|
||||||
} 1 ncleave
|
} 1 ncleave
|
||||||
! [fortran-invoke]
|
! [fortran-invoke]
|
||||||
[ c:float "funpack" "fun_times_" { void* } alien-invoke ]
|
[ c:float "funpack" "fun_times_" { pointer: { c:float 0 } } alien-invoke ]
|
||||||
1 nkeep
|
1 nkeep
|
||||||
! [fortran-results>]
|
! [fortran-results>]
|
||||||
shuffle( reta aa -- reta aa )
|
shuffle( reta aa -- reta aa )
|
||||||
|
@ -244,7 +245,7 @@ intel-unix-abi fortran-abi [
|
||||||
! [fortran-invoke]
|
! [fortran-invoke]
|
||||||
[
|
[
|
||||||
c:void "funpack" "fun_times_"
|
c:void "funpack" "fun_times_"
|
||||||
{ void* void* }
|
{ pointer: complex-float pointer: { c:float 0 } }
|
||||||
alien-invoke
|
alien-invoke
|
||||||
] 2 nkeep
|
] 2 nkeep
|
||||||
! [fortran-results>]
|
! [fortran-results>]
|
||||||
|
@ -261,7 +262,7 @@ intel-unix-abi fortran-abi [
|
||||||
! [fortran-invoke]
|
! [fortran-invoke]
|
||||||
[
|
[
|
||||||
c:void "funpack" "fun_times_"
|
c:void "funpack" "fun_times_"
|
||||||
{ c:char* long }
|
{ pointer: { c:char 20 } long }
|
||||||
alien-invoke
|
alien-invoke
|
||||||
] 2 nkeep
|
] 2 nkeep
|
||||||
! [fortran-results>]
|
! [fortran-results>]
|
||||||
|
@ -287,7 +288,7 @@ intel-unix-abi fortran-abi [
|
||||||
! [fortran-invoke]
|
! [fortran-invoke]
|
||||||
[
|
[
|
||||||
c:void "funpack" "fun_times_"
|
c:void "funpack" "fun_times_"
|
||||||
{ c:char* long c:char* c:void* c:char* c:long c:long }
|
{ pointer: { c:char 10 } long pointer: { c:char 20 } pointer: c:float pointer: { c:char 30 } c:long c:long }
|
||||||
alien-invoke
|
alien-invoke
|
||||||
] 7 nkeep
|
] 7 nkeep
|
||||||
! [fortran-results>]
|
! [fortran-results>]
|
||||||
|
@ -321,16 +322,16 @@ f2c-abi fortran-abi [
|
||||||
[ { c:char 1 } ]
|
[ { c:char 1 } ]
|
||||||
[ "character(1)" fortran-type>c-type ] unit-test
|
[ "character(1)" fortran-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:char* { c:long } ]
|
[ pointer: c:char { c:long } ]
|
||||||
[ "character" fortran-arg-type>c-type ] unit-test
|
[ "character" fortran-arg-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:void { c:char* c:long } ]
|
[ c:void { pointer: c:char c:long } ]
|
||||||
[ "character" fortran-ret-type>c-type ] unit-test
|
[ "character" fortran-ret-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:double { } ]
|
[ c:double { } ]
|
||||||
[ "real" fortran-ret-type>c-type ] unit-test
|
[ "real" fortran-ret-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:void { void* } ]
|
[ c:void { pointer: { c:float 0 } } ]
|
||||||
[ "real(*)" fortran-ret-type>c-type ] unit-test
|
[ "real(*)" fortran-ret-type>c-type ] unit-test
|
||||||
|
|
||||||
[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
|
[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
|
||||||
|
@ -344,7 +345,7 @@ gfortran-abi fortran-abi [
|
||||||
[ c:float { } ]
|
[ c:float { } ]
|
||||||
[ "real" fortran-ret-type>c-type ] unit-test
|
[ "real" fortran-ret-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:void { void* } ]
|
[ c:void { pointer: { c:float 0 } } ]
|
||||||
[ "real(*)" fortran-ret-type>c-type ] unit-test
|
[ "real(*)" fortran-ret-type>c-type ] unit-test
|
||||||
|
|
||||||
[ complex-float { } ]
|
[ complex-float { } ]
|
||||||
|
@ -356,10 +357,10 @@ gfortran-abi fortran-abi [
|
||||||
[ { char 1 } ]
|
[ { char 1 } ]
|
||||||
[ "character(1)" fortran-type>c-type ] unit-test
|
[ "character(1)" fortran-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:char* { c:long } ]
|
[ pointer: c:char { c:long } ]
|
||||||
[ "character" fortran-arg-type>c-type ] unit-test
|
[ "character" fortran-arg-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:void { c:char* c:long } ]
|
[ c:void { pointer: c:char c:long } ]
|
||||||
[ "character" fortran-ret-type>c-type ] unit-test
|
[ "character" fortran-ret-type>c-type ] unit-test
|
||||||
|
|
||||||
[ complex-float { } ]
|
[ complex-float { } ]
|
||||||
|
@ -368,7 +369,7 @@ gfortran-abi fortran-abi [
|
||||||
[ complex-double { } ]
|
[ complex-double { } ]
|
||||||
[ "double-complex" fortran-ret-type>c-type ] unit-test
|
[ "double-complex" fortran-ret-type>c-type ] unit-test
|
||||||
|
|
||||||
[ c:void { c:void* } ]
|
[ c:void { pointer: { complex-double 3 } } ]
|
||||||
[ "double-complex(3)" fortran-ret-type>c-type ] unit-test
|
[ "double-complex(3)" fortran-ret-type>c-type ] unit-test
|
||||||
|
|
||||||
] with-variable
|
] with-variable
|
||||||
|
|
|
@ -392,13 +392,13 @@ PRIVATE>
|
||||||
|
|
||||||
: fortran-arg-type>c-type ( fortran-type -- c-type added-args )
|
: fortran-arg-type>c-type ( fortran-type -- c-type added-args )
|
||||||
parse-fortran-type
|
parse-fortran-type
|
||||||
[ (fortran-type>c-type) resolve-pointer-type ]
|
[ (fortran-type>c-type) <pointer> ]
|
||||||
[ added-c-args ] bi ;
|
[ added-c-args ] bi ;
|
||||||
: fortran-ret-type>c-type ( fortran-type -- c-type added-args )
|
: fortran-ret-type>c-type ( fortran-type -- c-type added-args )
|
||||||
parse-fortran-type dup returns-by-value?
|
parse-fortran-type dup returns-by-value?
|
||||||
[ (fortran-ret-type>c-type) { } ] [
|
[ (fortran-ret-type>c-type) { } ] [
|
||||||
c:void swap
|
c:void swap
|
||||||
[ added-c-args ] [ (fortran-type>c-type) resolve-pointer-type ] bi prefix
|
[ added-c-args ] [ (fortran-type>c-type) <pointer> ] bi prefix
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: fortran-arg-types>c-types ( fortran-types -- c-types )
|
: fortran-arg-types>c-types ( fortran-types -- c-types )
|
||||||
|
|
|
@ -1 +1,2 @@
|
||||||
Slava Pestov
|
Slava Pestov
|
||||||
|
Joe Groff
|
||||||
|
|
|
@ -60,6 +60,10 @@ $nl
|
||||||
}
|
}
|
||||||
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
|
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
|
||||||
|
|
||||||
|
HELP: deploy-library
|
||||||
|
{ $values { "name" string } }
|
||||||
|
{ $description "Specifies that the logical library named " { $snippet "name" } " should be included during " { $link "tools.deploy" } ". " { $snippet "name" } " must be the name of a library previously loaded with " { $link add-library } "." } ;
|
||||||
|
|
||||||
HELP: remove-library
|
HELP: remove-library
|
||||||
{ $values { "name" string } }
|
{ $values { "name" string } }
|
||||||
{ $description "Unloads a library and removes it from the internal list of libraries. The " { $snippet "name" } " parameter should be a name that was previously passed to " { $link add-library } ". If no library with that name exists, this word does nothing." } ;
|
{ $description "Unloads a library and removes it from the internal list of libraries. The " { $snippet "name" } " parameter should be a name that was previously passed to " { $link add-library } ". If no library with that name exists, this word does nothing." } ;
|
||||||
|
@ -72,4 +76,9 @@ ARTICLE: "loading-libs" "Loading native libraries"
|
||||||
}
|
}
|
||||||
"Once a library has been defined, you can try loading it to see if the path name is correct:"
|
"Once a library has been defined, you can try loading it to see if the path name is correct:"
|
||||||
{ $subsections load-library }
|
{ $subsections load-library }
|
||||||
"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again." ;
|
"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again."
|
||||||
|
$nl
|
||||||
|
"Libraries that do not come standard with the operating system need to be included with deployed applications that use them. A word is provided to instruct " { $link "tools.deploy" } " that a library must be so deployed:"
|
||||||
|
{ $subsections
|
||||||
|
deploy-library
|
||||||
|
} ;
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2009 Slava Pestov.
|
! Copyright (C) 2009, 2010 Slava Pestov, Joe Groff.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors alien alien.strings assocs io.backend
|
USING: accessors alien alien.strings assocs io.backend
|
||||||
kernel namespaces destructors ;
|
kernel namespaces destructors sequences system io.pathnames ;
|
||||||
IN: alien.libraries
|
IN: alien.libraries
|
||||||
|
|
||||||
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
|
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
|
||||||
|
@ -14,6 +14,8 @@ libraries [ H{ } clone ] initialize
|
||||||
|
|
||||||
TUPLE: library path abi dll ;
|
TUPLE: library path abi dll ;
|
||||||
|
|
||||||
|
ERROR: no-library name ;
|
||||||
|
|
||||||
: library ( name -- library ) libraries get at ;
|
: library ( name -- library ) libraries get at ;
|
||||||
|
|
||||||
: <library> ( path abi -- library )
|
: <library> ( path abi -- library )
|
||||||
|
@ -32,3 +34,30 @@ M: library dispose dll>> [ dispose ] when* ;
|
||||||
: add-library ( name path abi -- )
|
: add-library ( name path abi -- )
|
||||||
[ 2drop remove-library ]
|
[ 2drop remove-library ]
|
||||||
[ <library> swap libraries get set-at ] 3bi ;
|
[ <library> swap libraries get set-at ] 3bi ;
|
||||||
|
|
||||||
|
: library-abi ( library -- abi )
|
||||||
|
library [ abi>> ] [ "cdecl" ] if* ;
|
||||||
|
|
||||||
|
SYMBOL: deploy-libraries
|
||||||
|
|
||||||
|
deploy-libraries [ V{ } clone ] initialize
|
||||||
|
|
||||||
|
: deploy-library ( name -- )
|
||||||
|
dup libraries get key?
|
||||||
|
[ deploy-libraries get 2dup member? [ 2drop ] [ push ] if ]
|
||||||
|
[ no-library ] if ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
HOOK: >deployed-library-path os ( path -- path' )
|
||||||
|
|
||||||
|
M: windows >deployed-library-path
|
||||||
|
file-name ;
|
||||||
|
|
||||||
|
M: unix >deployed-library-path
|
||||||
|
file-name "$ORIGIN" prepend-path ;
|
||||||
|
|
||||||
|
M: macosx >deployed-library-path
|
||||||
|
file-name "@executable_path/../Frameworks" prepend-path ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! (c)2009 Joe Groff bsd license
|
! (c)2009 Joe Groff bsd license
|
||||||
USING: accessors alien.c-types alien.parser alien.syntax
|
USING: accessors alien.c-types alien.parser alien.syntax
|
||||||
tools.test vocabs.parser parser eval vocabs.parser debugger
|
tools.test vocabs.parser parser eval debugger kernel
|
||||||
continuations ;
|
continuations words ;
|
||||||
IN: alien.parser.tests
|
IN: alien.parser.tests
|
||||||
|
|
||||||
TYPEDEF: char char2
|
TYPEDEF: char char2
|
||||||
|
@ -18,22 +18,28 @@ CONSTANT: eleven 11
|
||||||
[ { int 5 } ] [ "int[5]" 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
|
[ { int 5 10 11 } ] [ "int[5][10][11]" parse-c-type ] unit-test
|
||||||
[ { int 5 10 eleven } ] [ "int[5][10][eleven]" parse-c-type ] unit-test
|
[ { int 5 10 eleven } ] [ "int[5][10][eleven]" parse-c-type ] unit-test
|
||||||
[ void* ] [ "int*" parse-c-type ] unit-test
|
[ pointer: void ] [ "void*" parse-c-type ] unit-test
|
||||||
[ void* ] [ "int**" parse-c-type ] unit-test
|
[ pointer: int ] [ "int*" parse-c-type ] unit-test
|
||||||
[ void* ] [ "int***" parse-c-type ] unit-test
|
[ pointer: int* ] [ "int**" parse-c-type ] unit-test
|
||||||
[ void* ] [ "int****" parse-c-type ] unit-test
|
[ pointer: int** ] [ "int***" parse-c-type ] unit-test
|
||||||
[ char* ] [ "char*" parse-c-type ] unit-test
|
[ pointer: int*** ] [ "int****" parse-c-type ] unit-test
|
||||||
[ void* ] [ "char**" parse-c-type ] unit-test
|
[ c-string ] [ "c-string" 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
|
[ char2 ] [ "char2" parse-c-type ] unit-test
|
||||||
[ char* ] [ "char2*" parse-c-type ] unit-test
|
[ pointer: char2 ] [ "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
|
[ "not-word" parse-c-type ] [ error>> no-word-error? ] must-fail-with
|
||||||
|
|
||||||
] with-file-vocabs
|
] with-file-vocabs
|
||||||
|
|
||||||
|
FUNCTION: void* alien-parser-function-effect-test ( int *arg1 float arg2 ) ;
|
||||||
|
[ (( arg1 arg2 -- void* )) ] [
|
||||||
|
\ alien-parser-function-effect-test "declared-effect" word-prop
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
CALLBACK: void* alien-parser-callback-effect-test ( int *arg1 float arg2 ) ;
|
||||||
|
[ (( arg1 arg2 -- void* )) ] [
|
||||||
|
\ alien-parser-callback-effect-test "callback-effect" word-prop
|
||||||
|
] unit-test
|
||||||
|
|
||||||
! Reported by mnestic
|
! Reported by mnestic
|
||||||
TYPEDEF: int alien-parser-test-int ! reasonably unique name...
|
TYPEDEF: int alien-parser-test-int ! reasonably unique name...
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
|
! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors alien alien.c-types alien.parser
|
USING: accessors alien alien.c-types alien.parser
|
||||||
alien.libraries arrays assocs classes combinators
|
alien.libraries arrays assocs classes combinators
|
||||||
|
@ -18,35 +18,41 @@ IN: alien.parser
|
||||||
{
|
{
|
||||||
{ [ dup "void" = ] [ drop void ] }
|
{ [ dup "void" = ] [ drop void ] }
|
||||||
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
|
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
|
||||||
|
{ [ "*" ?tail ] [ (parse-c-type) <pointer> ] }
|
||||||
{ [ dup search ] [ parse-c-type-name ] }
|
{ [ dup search ] [ parse-c-type-name ] }
|
||||||
{ [ "**" ?tail ] [ drop void* ] }
|
|
||||||
{ [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] }
|
|
||||||
[ dup search [ ] [ no-word ] ?if ]
|
[ dup search [ ] [ no-word ] ?if ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: valid-c-type? ( c-type -- ? )
|
: valid-c-type? ( c-type -- ? )
|
||||||
{ [ array? ] [ c-type-name? ] [ void? ] } 1|| ;
|
{ [ array? ] [ c-type-word? ] [ pointer? ] [ void? ] } 1|| ;
|
||||||
|
|
||||||
: parse-c-type ( string -- type )
|
: parse-c-type ( string -- type )
|
||||||
(parse-c-type) dup valid-c-type? [ no-c-type ] unless ;
|
(parse-c-type) dup valid-c-type? [ no-c-type ] unless ;
|
||||||
|
|
||||||
: scan-c-type ( -- c-type )
|
: scan-c-type ( -- c-type )
|
||||||
scan dup "{" =
|
scan {
|
||||||
[ drop \ } parse-until >array ]
|
{ [ dup "{" = ] [ drop \ } parse-until >array ] }
|
||||||
[ parse-c-type ] if ;
|
{ [ dup "pointer:" = ] [ drop scan-c-type <pointer> ] }
|
||||||
|
[ parse-c-type ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
: reset-c-type ( word -- )
|
: reset-c-type ( word -- )
|
||||||
dup "struct-size" word-prop
|
dup "struct-size" word-prop
|
||||||
[ dup [ forget-class ] [ { "struct-size" } reset-props ] bi ] when
|
[ dup [ forget-class ] [ { "struct-size" } reset-props ] bi ] when
|
||||||
{
|
{
|
||||||
"c-type"
|
"c-type"
|
||||||
"pointer-c-type"
|
|
||||||
"callback-effect"
|
"callback-effect"
|
||||||
"callback-library"
|
"callback-library"
|
||||||
} reset-props ;
|
} reset-props ;
|
||||||
|
|
||||||
|
ERROR: *-in-c-type-name name ;
|
||||||
|
|
||||||
|
: validate-c-type-name ( name -- name )
|
||||||
|
dup "*" tail?
|
||||||
|
[ *-in-c-type-name ] when ;
|
||||||
|
|
||||||
: CREATE-C-TYPE ( -- word )
|
: CREATE-C-TYPE ( -- word )
|
||||||
scan current-vocab create {
|
scan validate-c-type-name current-vocab create {
|
||||||
[ fake-definition ]
|
[ fake-definition ]
|
||||||
[ set-word ]
|
[ set-word ]
|
||||||
[ reset-c-type ]
|
[ reset-c-type ]
|
||||||
|
@ -61,19 +67,27 @@ IN: alien.parser
|
||||||
] bi
|
] bi
|
||||||
[ parse-c-type ] dip ;
|
[ parse-c-type ] dip ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
GENERIC: return-type-name ( type -- name )
|
||||||
|
|
||||||
|
M: object return-type-name drop "void" ;
|
||||||
|
M: word return-type-name name>> ;
|
||||||
|
M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: parse-arglist ( parameters return -- types effect )
|
: parse-arglist ( parameters return -- types effect )
|
||||||
[
|
[
|
||||||
2 group [ first2 normalize-c-arg 2array ] map
|
2 group [ first2 normalize-c-arg 2array ] map
|
||||||
unzip [ "," ?tail drop ] map
|
unzip [ "," ?tail drop ] map
|
||||||
]
|
]
|
||||||
[ [ { } ] [ 1array ] if-void ]
|
[ [ { } ] [ return-type-name 1array ] if-void ]
|
||||||
bi* <effect> ;
|
bi* <effect> ;
|
||||||
|
|
||||||
: function-quot ( return library function types -- quot )
|
: function-quot ( return library function types -- quot )
|
||||||
'[ _ _ _ _ alien-invoke ] ;
|
'[ _ _ _ _ alien-invoke ] ;
|
||||||
|
|
||||||
:: make-function ( return! library function! parameters -- word quot effect )
|
:: make-function ( return library function parameters -- word quot effect )
|
||||||
return function normalize-c-arg function! return!
|
return function normalize-c-arg :> ( return function )
|
||||||
function create-in dup reset-generic
|
function create-in dup reset-generic
|
||||||
return library function
|
return library function
|
||||||
parameters return parse-arglist [ function-quot ] dip ;
|
parameters return parse-arglist [ function-quot ] dip ;
|
||||||
|
@ -88,13 +102,10 @@ IN: alien.parser
|
||||||
make-function define-declared ;
|
make-function define-declared ;
|
||||||
|
|
||||||
: callback-quot ( return types abi -- quot )
|
: callback-quot ( return types abi -- quot )
|
||||||
[ [ ] 3curry dip alien-callback ] 3curry ;
|
'[ [ _ _ _ ] dip alien-callback ] ;
|
||||||
|
|
||||||
: library-abi ( lib -- abi )
|
:: make-callback-type ( lib return type-name parameters -- word quot effect )
|
||||||
library [ abi>> ] [ "cdecl" ] if* ;
|
return type-name normalize-c-arg :> ( return type-name )
|
||||||
|
|
||||||
:: 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-name current-vocab create :> type-word
|
||||||
type-word [ reset-generic ] [ reset-c-type ] bi
|
type-word [ reset-generic ] [ reset-c-type ] bi
|
||||||
void* type-word typedef
|
void* type-word typedef
|
||||||
|
@ -115,4 +126,3 @@ PREDICATE: alien-function-word < word
|
||||||
|
|
||||||
PREDICATE: alien-callback-type-word < typedef-word
|
PREDICATE: alien-callback-type-word < typedef-word
|
||||||
"callback-effect" word-prop ;
|
"callback-effect" word-prop ;
|
||||||
|
|
||||||
|
|
|
@ -19,12 +19,25 @@ M: c-type-word definer drop \ C-TYPE: f ;
|
||||||
M: c-type-word definition drop f ;
|
M: c-type-word definition drop f ;
|
||||||
M: c-type-word declarations. drop ;
|
M: c-type-word declarations. drop ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
GENERIC: pointer-string ( pointer -- string/f )
|
||||||
|
M: object pointer-string drop f ;
|
||||||
|
M: word pointer-string name>> ;
|
||||||
|
M: pointer pointer-string to>> pointer-string [ CHAR: * suffix ] [ f ] if* ;
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
GENERIC: pprint-c-type ( c-type -- )
|
GENERIC: pprint-c-type ( c-type -- )
|
||||||
M: word pprint-c-type pprint-word ;
|
M: word pprint-c-type pprint-word ;
|
||||||
|
M: pointer pprint-c-type
|
||||||
|
dup pointer-string
|
||||||
|
[ swap present-text ]
|
||||||
|
[ pprint* ] if* ;
|
||||||
M: wrapper pprint-c-type wrapped>> pprint-word ;
|
M: wrapper pprint-c-type wrapped>> pprint-word ;
|
||||||
M: string pprint-c-type text ;
|
M: string pprint-c-type text ;
|
||||||
M: array pprint-c-type pprint* ;
|
M: array pprint-c-type pprint* ;
|
||||||
|
|
||||||
|
M: pointer pprint* \ pointer: pprint-word to>> pprint-c-type ;
|
||||||
|
|
||||||
M: typedef-word definer drop \ TYPEDEF: f ;
|
M: typedef-word definer drop \ TYPEDEF: f ;
|
||||||
|
|
||||||
M: typedef-word synopsis*
|
M: typedef-word synopsis*
|
||||||
|
|
|
@ -6,7 +6,7 @@ eval ;
|
||||||
IN: alien.remote-control
|
IN: alien.remote-control
|
||||||
|
|
||||||
: eval-callback ( -- callback )
|
: eval-callback ( -- callback )
|
||||||
void* { char* } "cdecl"
|
void* { c-string } "cdecl"
|
||||||
[ eval>string utf8 malloc-string ] alien-callback ;
|
[ eval>string utf8 malloc-string ] alien-callback ;
|
||||||
|
|
||||||
: yield-callback ( -- callback )
|
: yield-callback ( -- callback )
|
||||||
|
|
|
@ -40,11 +40,11 @@ $nl
|
||||||
}
|
}
|
||||||
"You can define a word for invoking it:"
|
"You can define a word for invoking it:"
|
||||||
{ $unchecked-example
|
{ $unchecked-example
|
||||||
"LIBRARY: foo\nFUNCTION: void the_answer ( char* question, int value ) ;"
|
"LIBRARY: foo\nFUNCTION: void the_answer ( c-string question, int value ) ;"
|
||||||
"USE: compiler"
|
|
||||||
"\"the question\" 42 the_answer"
|
"\"the question\" 42 the_answer"
|
||||||
"The answer to the question is 42."
|
"The answer to the question is 42."
|
||||||
} }
|
} }
|
||||||
|
"Using the " { $link c-string } " type instead of " { $snippet "char*" } " causes the FFI to automatically convert Factor strings to C strings. See " { $link "c-strings" } " for more information on using strings with the FFI."
|
||||||
{ $notes "Note that the parentheses and commas are only syntax sugar and can be omitted; they serve no purpose other than to make the declaration slightly easier to read:"
|
{ $notes "Note that the parentheses and commas are only syntax sugar and can be omitted; they serve no purpose other than to make the declaration slightly easier to read:"
|
||||||
{ $code
|
{ $code
|
||||||
"FUNCTION: void glHint ( GLenum target, GLenum mode ) ;"
|
"FUNCTION: void glHint ( GLenum target, GLenum mode ) ;"
|
||||||
|
@ -54,7 +54,7 @@ $nl
|
||||||
HELP: TYPEDEF:
|
HELP: TYPEDEF:
|
||||||
{ $syntax "TYPEDEF: old new" }
|
{ $syntax "TYPEDEF: old new" }
|
||||||
{ $values { "old" "a C type" } { "new" "a C type" } }
|
{ $values { "old" "a C type" } { "new" "a C type" } }
|
||||||
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." }
|
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
|
||||||
{ $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." } ;
|
{ $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-ENUM:
|
HELP: C-ENUM:
|
||||||
|
@ -72,12 +72,12 @@ HELP: C-ENUM:
|
||||||
HELP: C-TYPE:
|
HELP: C-TYPE:
|
||||||
{ $syntax "C-TYPE: type" }
|
{ $syntax "C-TYPE: type" }
|
||||||
{ $values { "type" "a new C 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
|
{ $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 " { $link pointer } "."
|
||||||
{ $snippet "C-TYPE:" } " can also be used to forward-declare C types to enable circular dependencies. For example:"
|
{ $snippet "C-TYPE:" } " can also be used to forward declare C types, allowing circular dependencies to occur between types. For example:"
|
||||||
{ $code """C-TYPE: forward
|
{ $code """C-TYPE: forward
|
||||||
STRUCT: backward { x forward* } ;
|
STRUCT: backward { x forward* } ;
|
||||||
STRUCT: forward { x backward* } ; """ } }
|
STRUCT: forward { x backward* } ; """ } }
|
||||||
{ $notes "Primitive C types are also displayed using " { $snippet "C-TYPE:" } " syntax when they are displayed by " { $link see } "." } ;
|
{ $notes "Primitive C types are displayed using " { $snippet "C-TYPE:" } " syntax when they are " { $link see } "n." } ;
|
||||||
|
|
||||||
HELP: CALLBACK:
|
HELP: CALLBACK:
|
||||||
{ $syntax "CALLBACK: return type ( parameters ) ;" }
|
{ $syntax "CALLBACK: return type ( parameters ) ;" }
|
||||||
|
|
|
@ -47,3 +47,6 @@ SYNTAX: &:
|
||||||
[ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;
|
[ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;
|
||||||
|
|
||||||
SYNTAX: C-GLOBAL: scan-c-type CREATE-WORD define-global ;
|
SYNTAX: C-GLOBAL: scan-c-type CREATE-WORD define-global ;
|
||||||
|
|
||||||
|
SYNTAX: pointer:
|
||||||
|
scan-c-type <pointer> suffix! ;
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: combinators io io.binary io.encodings.binary
|
USING: combinators io io.binary io.encodings.binary
|
||||||
io.streams.byte-array kernel math namespaces
|
io.streams.byte-array kernel math namespaces
|
||||||
sequences strings io.crlf ;
|
sequences strings ;
|
||||||
IN: base64
|
IN: base64
|
||||||
|
|
||||||
ERROR: malformed-base64 ;
|
ERROR: malformed-base64 ;
|
||||||
|
@ -35,7 +35,7 @@ SYMBOL: column
|
||||||
: write1-lines ( ch -- )
|
: write1-lines ( ch -- )
|
||||||
write1
|
write1
|
||||||
column get [
|
column get [
|
||||||
1 + [ 76 = [ crlf ] when ]
|
1 + [ 76 = [ B{ CHAR: \r CHAR: \n } write ] when ]
|
||||||
[ 76 mod column set ] bi
|
[ 76 mod column set ] bi
|
||||||
] when* ;
|
] when* ;
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2007, 2010 Slava Pestov.
|
! Copyright (C) 2007, 2010 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien.c-types alien.data accessors math alien.accessors kernel
|
USING: alien alien.data accessors math alien.accessors kernel
|
||||||
kernel.private sequences sequences.private byte-arrays
|
kernel.private sequences sequences.private byte-arrays
|
||||||
parser prettyprint.custom fry ;
|
parser prettyprint.custom fry ;
|
||||||
IN: bit-arrays
|
IN: bit-arrays
|
||||||
|
|
|
@ -1 +1 @@
|
||||||
unportable
|
untested
|
||||||
|
|
|
@ -18,7 +18,7 @@ IN: cairo.ffi
|
||||||
LIBRARY: cairo
|
LIBRARY: cairo
|
||||||
|
|
||||||
FUNCTION: int cairo_version ( ) ;
|
FUNCTION: int cairo_version ( ) ;
|
||||||
FUNCTION: char* cairo_version_string ( ) ;
|
FUNCTION: c-string cairo_version_string ( ) ;
|
||||||
|
|
||||||
TYPEDEF: int cairo_bool_t
|
TYPEDEF: int cairo_bool_t
|
||||||
|
|
||||||
|
@ -38,7 +38,7 @@ TYPEDEF: void* cairo_pattern_t
|
||||||
|
|
||||||
TYPEDEF: void* cairo_destroy_func_t
|
TYPEDEF: void* cairo_destroy_func_t
|
||||||
: cairo-destroy-func ( quot -- callback )
|
: cairo-destroy-func ( quot -- callback )
|
||||||
[ void { void* } "cdecl" ] dip alien-callback ; inline
|
[ void { pointer: void } "cdecl" ] dip alien-callback ; inline
|
||||||
|
|
||||||
! See cairo.h for details
|
! See cairo.h for details
|
||||||
STRUCT: cairo_user_data_key_t
|
STRUCT: cairo_user_data_key_t
|
||||||
|
@ -79,11 +79,11 @@ CONSTANT: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000
|
||||||
|
|
||||||
TYPEDEF: void* cairo_write_func_t
|
TYPEDEF: void* cairo_write_func_t
|
||||||
: cairo-write-func ( quot -- callback )
|
: cairo-write-func ( quot -- callback )
|
||||||
[ cairo_status_t { void* uchar* int } "cdecl" ] dip alien-callback ; inline
|
[ cairo_status_t { pointer: void c-string int } "cdecl" ] dip alien-callback ; inline
|
||||||
|
|
||||||
TYPEDEF: void* cairo_read_func_t
|
TYPEDEF: void* cairo_read_func_t
|
||||||
: cairo-read-func ( quot -- callback )
|
: cairo-read-func ( quot -- callback )
|
||||||
[ cairo_status_t { void* uchar* int } "cdecl" ] dip alien-callback ; inline
|
[ cairo_status_t { pointer: void c-string int } "cdecl" ] dip alien-callback ; inline
|
||||||
|
|
||||||
! Functions for manipulating state objects
|
! Functions for manipulating state objects
|
||||||
FUNCTION: cairo_t*
|
FUNCTION: cairo_t*
|
||||||
|
@ -463,7 +463,7 @@ cairo_font_options_get_hint_metrics ( cairo_font_options_t* options ) ;
|
||||||
! font object inside the the cairo_t.
|
! font object inside the the cairo_t.
|
||||||
|
|
||||||
FUNCTION: void
|
FUNCTION: void
|
||||||
cairo_select_font_face ( cairo_t* cr, char* family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ;
|
cairo_select_font_face ( cairo_t* cr, c-string family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ;
|
||||||
|
|
||||||
FUNCTION: void
|
FUNCTION: void
|
||||||
cairo_set_font_size ( cairo_t* cr, double size ) ;
|
cairo_set_font_size ( cairo_t* cr, double size ) ;
|
||||||
|
@ -493,19 +493,19 @@ FUNCTION: cairo_scaled_font_t*
|
||||||
cairo_get_scaled_font ( cairo_t* cr ) ;
|
cairo_get_scaled_font ( cairo_t* cr ) ;
|
||||||
|
|
||||||
FUNCTION: void
|
FUNCTION: void
|
||||||
cairo_show_text ( cairo_t* cr, char* utf8 ) ;
|
cairo_show_text ( cairo_t* cr, c-string utf8 ) ;
|
||||||
|
|
||||||
FUNCTION: void
|
FUNCTION: void
|
||||||
cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
|
cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
|
||||||
|
|
||||||
FUNCTION: void
|
FUNCTION: void
|
||||||
cairo_text_path ( cairo_t* cr, char* utf8 ) ;
|
cairo_text_path ( cairo_t* cr, c-string utf8 ) ;
|
||||||
|
|
||||||
FUNCTION: void
|
FUNCTION: void
|
||||||
cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
|
cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
|
||||||
|
|
||||||
FUNCTION: void
|
FUNCTION: void
|
||||||
cairo_text_extents ( cairo_t* cr, char* utf8, cairo_text_extents_t* extents ) ;
|
cairo_text_extents ( cairo_t* cr, c-string utf8, cairo_text_extents_t* extents ) ;
|
||||||
|
|
||||||
FUNCTION: void
|
FUNCTION: void
|
||||||
cairo_glyph_extents ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
|
cairo_glyph_extents ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
|
||||||
|
@ -573,7 +573,7 @@ FUNCTION: void
|
||||||
cairo_scaled_font_extents ( cairo_scaled_font_t* scaled_font, cairo_font_extents_t* extents ) ;
|
cairo_scaled_font_extents ( cairo_scaled_font_t* scaled_font, cairo_font_extents_t* extents ) ;
|
||||||
|
|
||||||
FUNCTION: void
|
FUNCTION: void
|
||||||
cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, char* utf8, cairo_text_extents_t* extents ) ;
|
cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, c-string utf8, cairo_text_extents_t* extents ) ;
|
||||||
|
|
||||||
FUNCTION: void
|
FUNCTION: void
|
||||||
cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
|
cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
|
||||||
|
@ -682,7 +682,7 @@ cairo_path_destroy ( cairo_path_t* path ) ;
|
||||||
FUNCTION: cairo_status_t
|
FUNCTION: cairo_status_t
|
||||||
cairo_status ( cairo_t* cr ) ;
|
cairo_status ( cairo_t* cr ) ;
|
||||||
|
|
||||||
FUNCTION: char*
|
FUNCTION: c-string
|
||||||
cairo_status_to_string ( cairo_status_t status ) ;
|
cairo_status_to_string ( cairo_status_t status ) ;
|
||||||
|
|
||||||
! Surface manipulation
|
! Surface manipulation
|
||||||
|
@ -731,7 +731,7 @@ FUNCTION: cairo_content_t
|
||||||
cairo_surface_get_content ( cairo_surface_t* surface ) ;
|
cairo_surface_get_content ( cairo_surface_t* surface ) ;
|
||||||
|
|
||||||
FUNCTION: cairo_status_t
|
FUNCTION: cairo_status_t
|
||||||
cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ;
|
cairo_surface_write_to_png ( cairo_surface_t* surface, c-string filename ) ;
|
||||||
|
|
||||||
FUNCTION: cairo_status_t
|
FUNCTION: cairo_status_t
|
||||||
cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ;
|
cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ;
|
||||||
|
@ -786,7 +786,7 @@ FUNCTION: int
|
||||||
cairo_format_stride_for_width ( cairo_format_t format, int width ) ;
|
cairo_format_stride_for_width ( cairo_format_t format, int width ) ;
|
||||||
|
|
||||||
FUNCTION: cairo_surface_t*
|
FUNCTION: cairo_surface_t*
|
||||||
cairo_image_surface_create_for_data ( uchar* data, cairo_format_t format, int width, int height, int stride ) ;
|
cairo_image_surface_create_for_data ( char* data, cairo_format_t format, int width, int height, int stride ) ;
|
||||||
|
|
||||||
FUNCTION: uchar*
|
FUNCTION: uchar*
|
||||||
cairo_image_surface_get_data ( cairo_surface_t* surface ) ;
|
cairo_image_surface_get_data ( cairo_surface_t* surface ) ;
|
||||||
|
@ -804,7 +804,7 @@ FUNCTION: int
|
||||||
cairo_image_surface_get_stride ( cairo_surface_t* surface ) ;
|
cairo_image_surface_get_stride ( cairo_surface_t* surface ) ;
|
||||||
|
|
||||||
FUNCTION: cairo_surface_t*
|
FUNCTION: cairo_surface_t*
|
||||||
cairo_image_surface_create_from_png ( char* filename ) ;
|
cairo_image_surface_create_from_png ( c-string filename ) ;
|
||||||
|
|
||||||
FUNCTION: cairo_surface_t*
|
FUNCTION: cairo_surface_t*
|
||||||
cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ;
|
cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ;
|
||||||
|
|
|
@ -309,7 +309,7 @@ HELP: time-
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: convert-timezone
|
HELP: convert-timezone
|
||||||
{ $values { "timestamp" timestamp } { "duration" duration } { "timestamp" timestamp } }
|
{ $values { "timestamp" timestamp } { "duration" duration } { "timestamp'" timestamp } }
|
||||||
{ $description "Converts the " { $snippet "timestamp" } "'s " { $snippet "gmt-offset" } " to the GMT offset represented by the " { $snippet "duration" } "." }
|
{ $description "Converts the " { $snippet "timestamp" } "'s " { $snippet "gmt-offset" } " to the GMT offset represented by the " { $snippet "duration" } "." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $example "USING: accessors calendar prettyprint ;"
|
{ $example "USING: accessors calendar prettyprint ;"
|
||||||
|
@ -319,7 +319,7 @@ HELP: convert-timezone
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: >local-time
|
HELP: >local-time
|
||||||
{ $values { "timestamp" timestamp } { "timestamp" timestamp } }
|
{ $values { "timestamp" timestamp } { "timestamp'" timestamp } }
|
||||||
{ $description "Converts the " { $snippet "timestamp" } " to the timezone of your computer." }
|
{ $description "Converts the " { $snippet "timestamp" } " to the timezone of your computer." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $example "USING: accessors calendar kernel prettyprint ;"
|
{ $example "USING: accessors calendar kernel prettyprint ;"
|
||||||
|
@ -329,7 +329,7 @@ HELP: >local-time
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: >gmt
|
HELP: >gmt
|
||||||
{ $values { "timestamp" timestamp } { "timestamp" timestamp } }
|
{ $values { "timestamp" timestamp } { "timestamp'" timestamp } }
|
||||||
{ $description "Converts the " { $snippet "timestamp" } " to the GMT timezone." }
|
{ $description "Converts the " { $snippet "timestamp" } " to the GMT timezone." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $example "USING: accessors calendar kernel prettyprint ;"
|
{ $example "USING: accessors calendar kernel prettyprint ;"
|
||||||
|
|
|
@ -316,15 +316,15 @@ M: duration <=> [ duration>years ] compare ;
|
||||||
|
|
||||||
GENERIC: time- ( time1 time2 -- time3 )
|
GENERIC: time- ( time1 time2 -- time3 )
|
||||||
|
|
||||||
: convert-timezone ( timestamp duration -- timestamp )
|
: convert-timezone ( timestamp duration -- timestamp' )
|
||||||
over gmt-offset>> over = [ drop ] [
|
over gmt-offset>> over = [ drop ] [
|
||||||
[ over gmt-offset>> time- time+ ] keep >>gmt-offset
|
[ over gmt-offset>> time- time+ ] keep >>gmt-offset
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: >local-time ( timestamp -- timestamp )
|
: >local-time ( timestamp -- timestamp' )
|
||||||
gmt-offset-duration convert-timezone ;
|
gmt-offset-duration convert-timezone ;
|
||||||
|
|
||||||
: >gmt ( timestamp -- timestamp )
|
: >gmt ( timestamp -- timestamp' )
|
||||||
instant convert-timezone ;
|
instant convert-timezone ;
|
||||||
|
|
||||||
M: timestamp <=> ( ts1 ts2 -- n )
|
M: timestamp <=> ( ts1 ts2 -- n )
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
unix
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
|
@ -21,7 +21,7 @@ IN: calendar.unix
|
||||||
timespec>seconds since-1970 ;
|
timespec>seconds since-1970 ;
|
||||||
|
|
||||||
: get-time ( -- alien )
|
: get-time ( -- alien )
|
||||||
f time <time_t> localtime tm memory>struct ;
|
f time <time_t> localtime ;
|
||||||
|
|
||||||
: timezone-name ( -- string )
|
: timezone-name ( -- string )
|
||||||
get-time zone>> ;
|
get-time zone>> ;
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
windows
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
|
@ -159,7 +159,7 @@ $nl
|
||||||
"A C function which returns a struct by value:"
|
"A C function which returns a struct by value:"
|
||||||
{ $code
|
{ $code
|
||||||
"USING: alien.syntax ;"
|
"USING: alien.syntax ;"
|
||||||
"FUNCTION: Point give_me_a_point ( char* description ) ;"
|
"FUNCTION: Point give_me_a_point ( c-string description ) ;"
|
||||||
}
|
}
|
||||||
"A C function which takes a struct parameter by reference:"
|
"A C function which takes a struct parameter by reference:"
|
||||||
{ $code
|
{ $code
|
||||||
|
|
|
@ -1,11 +1,11 @@
|
||||||
! (c)Joe Groff bsd license
|
! (c)Joe Groff bsd license
|
||||||
USING: accessors alien alien.c-types alien.data ascii
|
USING: accessors alien alien.c-types alien.data alien.syntax ascii
|
||||||
assocs byte-arrays classes.struct classes.tuple.private
|
assocs byte-arrays classes.struct classes.tuple.parser
|
||||||
combinators compiler.tree.debugger compiler.units destructors
|
classes.tuple.private classes.tuple combinators compiler.tree.debugger
|
||||||
io.encodings.utf8 io.pathnames io.streams.string kernel libc
|
compiler.units destructors io.encodings.utf8 io.pathnames
|
||||||
literals math mirrors namespaces prettyprint
|
io.streams.string kernel libc literals math mirrors namespaces
|
||||||
prettyprint.config see sequences specialized-arrays system
|
prettyprint prettyprint.config see sequences specialized-arrays system
|
||||||
tools.test parser lexer eval layouts ;
|
tools.test parser lexer eval layouts generic.single classes ;
|
||||||
FROM: math => float ;
|
FROM: math => float ;
|
||||||
QUALIFIED-WITH: alien.c-types c
|
QUALIFIED-WITH: alien.c-types c
|
||||||
SPECIALIZED-ARRAY: char
|
SPECIALIZED-ARRAY: char
|
||||||
|
@ -139,7 +139,7 @@ UNION-STRUCT: struct-test-float-and-bits
|
||||||
[ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
|
[ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
|
||||||
|
|
||||||
STRUCT: struct-test-string-ptr
|
STRUCT: struct-test-string-ptr
|
||||||
{ x char* } ;
|
{ x c-string } ;
|
||||||
|
|
||||||
[ "hello world" ] [
|
[ "hello world" ] [
|
||||||
[
|
[
|
||||||
|
@ -219,7 +219,7 @@ UNION-STRUCT: struct-test-float-and-bits
|
||||||
{ type bool }
|
{ type bool }
|
||||||
{ class object }
|
{ class object }
|
||||||
}
|
}
|
||||||
} ] [ "struct-test-foo" c-type fields>> ] unit-test
|
} ] [ struct-test-foo c-type fields>> ] unit-test
|
||||||
|
|
||||||
[ {
|
[ {
|
||||||
T{ struct-slot-spec
|
T{ struct-slot-spec
|
||||||
|
@ -236,7 +236,7 @@ UNION-STRUCT: struct-test-float-and-bits
|
||||||
{ class integer }
|
{ class integer }
|
||||||
{ initial 0 }
|
{ initial 0 }
|
||||||
}
|
}
|
||||||
} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
|
} ] [ struct-test-float-and-bits c-type fields>> ] unit-test
|
||||||
|
|
||||||
STRUCT: struct-test-equality-1
|
STRUCT: struct-test-equality-1
|
||||||
{ x int } ;
|
{ x int } ;
|
||||||
|
@ -334,24 +334,40 @@ STRUCT: struct-that's-a-word { x int } ;
|
||||||
"struct-class-test-1" parse-stream
|
"struct-class-test-1" parse-stream
|
||||||
] [ error>> error>> unexpected-eof? ] must-fail-with
|
] [ error>> error>> unexpected-eof? ] must-fail-with
|
||||||
|
|
||||||
|
[
|
||||||
|
"USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x uint } ;" eval( -- )
|
||||||
|
] [ error>> duplicate-slot-names? ] must-fail-with
|
||||||
|
|
||||||
|
[
|
||||||
|
"USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x float } ;" eval( -- )
|
||||||
|
] [ error>> duplicate-slot-names? ] must-fail-with
|
||||||
|
|
||||||
! S{ with non-struct type
|
! S{ with non-struct type
|
||||||
[
|
[
|
||||||
"USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
|
"USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
|
||||||
eval( -- value )
|
eval( -- value )
|
||||||
] must-fail
|
] [ error>> no-method? ] must-fail-with
|
||||||
|
|
||||||
! Subclassing a struct class should not be allowed
|
! Subclassing a struct class should not be allowed
|
||||||
[
|
[
|
||||||
"USE: classes.struct IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
|
"USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
|
||||||
eval( -- )
|
eval( -- )
|
||||||
] must-fail
|
] [ error>> bad-superclass? ] must-fail-with
|
||||||
|
|
||||||
! Remove c-type when struct class is forgotten
|
! Changing a superclass into a struct should reset the subclass
|
||||||
[ ] [
|
TUPLE: will-become-struct ;
|
||||||
"USE: classes.struct IN: classes.struct.tests TUPLE: a-struct ;" eval( -- )
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ f ] [ "a-struct" c-types get key? ] unit-test
|
TUPLE: a-subclass < will-become-struct ;
|
||||||
|
|
||||||
|
[ f ] [ will-become-struct struct-class? ] unit-test
|
||||||
|
|
||||||
|
[ will-become-struct ] [ a-subclass superclass ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "IN: classes.struct.tests USING: classes.struct alien.c-types ; STRUCT: will-become-struct { x int } ;" eval( -- ) ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ will-become-struct struct-class? ] unit-test
|
||||||
|
|
||||||
|
[ tuple ] [ a-subclass superclass ] unit-test
|
||||||
|
|
||||||
STRUCT: bit-field-test
|
STRUCT: bit-field-test
|
||||||
{ a uint bits: 12 }
|
{ a uint bits: 12 }
|
||||||
|
@ -366,6 +382,63 @@ STRUCT: bit-field-test
|
||||||
[ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
|
[ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
|
||||||
[ 3 ] [ bit-field-test heap-size ] unit-test
|
[ 3 ] [ bit-field-test heap-size ] unit-test
|
||||||
|
|
||||||
|
STRUCT: referent
|
||||||
|
{ y int } ;
|
||||||
|
STRUCT: referrer
|
||||||
|
{ x referent* } ;
|
||||||
|
|
||||||
|
[ 57 ] [
|
||||||
|
[
|
||||||
|
referrer <struct>
|
||||||
|
referent malloc-struct &free
|
||||||
|
57 >>y
|
||||||
|
>>x
|
||||||
|
x>> y>>
|
||||||
|
] with-destructors
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
STRUCT: self-referent
|
||||||
|
{ x self-referent* }
|
||||||
|
{ y int } ;
|
||||||
|
|
||||||
|
[ 75 ] [
|
||||||
|
[
|
||||||
|
self-referent <struct>
|
||||||
|
self-referent malloc-struct &free
|
||||||
|
75 >>y
|
||||||
|
>>x
|
||||||
|
x>> y>>
|
||||||
|
] with-destructors
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
C-TYPE: forward-referent
|
||||||
|
STRUCT: backward-referent
|
||||||
|
{ x forward-referent* }
|
||||||
|
{ y int } ;
|
||||||
|
STRUCT: forward-referent
|
||||||
|
{ x backward-referent* }
|
||||||
|
{ y int } ;
|
||||||
|
|
||||||
|
[ 41 ] [
|
||||||
|
[
|
||||||
|
forward-referent <struct>
|
||||||
|
backward-referent malloc-struct &free
|
||||||
|
41 >>y
|
||||||
|
>>x
|
||||||
|
x>> y>>
|
||||||
|
] with-destructors
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ 14 ] [
|
||||||
|
[
|
||||||
|
backward-referent <struct>
|
||||||
|
forward-referent malloc-struct &free
|
||||||
|
14 >>y
|
||||||
|
>>x
|
||||||
|
x>> y>>
|
||||||
|
] with-destructors
|
||||||
|
] unit-test
|
||||||
|
|
||||||
cpu ppc? [
|
cpu ppc? [
|
||||||
STRUCT: ppc-align-test-1
|
STRUCT: ppc-align-test-1
|
||||||
{ x longlong }
|
{ x longlong }
|
||||||
|
|
|
@ -8,7 +8,8 @@ generalizations generic.parser kernel kernel.private lexer libc
|
||||||
locals macros make math math.order parser quotations sequences
|
locals macros make math math.order parser quotations sequences
|
||||||
slots slots.private specialized-arrays vectors words summary
|
slots slots.private specialized-arrays vectors words summary
|
||||||
namespaces assocs vocabs.parser math.functions
|
namespaces assocs vocabs.parser math.functions
|
||||||
classes.struct.bit-accessors bit-arrays ;
|
classes.struct.bit-accessors bit-arrays
|
||||||
|
stack-checker.dependencies ;
|
||||||
QUALIFIED: math
|
QUALIFIED: math
|
||||||
IN: classes.struct
|
IN: classes.struct
|
||||||
|
|
||||||
|
@ -32,8 +33,6 @@ TUPLE: struct-bit-slot-spec < struct-slot-spec
|
||||||
PREDICATE: struct-class < tuple-class
|
PREDICATE: struct-class < tuple-class
|
||||||
superclass \ struct eq? ;
|
superclass \ struct eq? ;
|
||||||
|
|
||||||
M: struct-class valid-superclass? drop f ;
|
|
||||||
|
|
||||||
SLOT: fields
|
SLOT: fields
|
||||||
|
|
||||||
: struct-slots ( struct-class -- slots )
|
: struct-slots ( struct-class -- slots )
|
||||||
|
@ -47,11 +46,11 @@ M: struct >c-ptr
|
||||||
M: struct equal?
|
M: struct equal?
|
||||||
{
|
{
|
||||||
[ [ class ] bi@ = ]
|
[ [ class ] bi@ = ]
|
||||||
[ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
|
[ [ >c-ptr ] [ binary-object ] bi* memory= ]
|
||||||
} 2&& ; inline
|
} 2&& ; inline
|
||||||
|
|
||||||
M: struct hashcode*
|
M: struct hashcode*
|
||||||
[ >c-ptr ] [ byte-length ] bi <direct-uchar-array> hashcode* ; inline
|
binary-object <direct-uchar-array> hashcode* ; inline
|
||||||
|
|
||||||
: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
|
: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
|
||||||
|
|
||||||
|
@ -126,6 +125,14 @@ M: struct-bit-slot-spec (writer-quot)
|
||||||
|
|
||||||
: (unboxer-quot) ( class -- quot )
|
: (unboxer-quot) ( class -- quot )
|
||||||
drop [ >c-ptr ] ;
|
drop [ >c-ptr ] ;
|
||||||
|
|
||||||
|
MACRO: read-struct-slot ( slot -- )
|
||||||
|
dup type>> depends-on-c-type
|
||||||
|
(reader-quot) ;
|
||||||
|
|
||||||
|
MACRO: write-struct-slot ( slot -- )
|
||||||
|
dup type>> depends-on-c-type
|
||||||
|
(writer-quot) ;
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
M: struct-class boa>object
|
M: struct-class boa>object
|
||||||
|
@ -140,10 +147,11 @@ M: struct-class initial-value* <struct> ; inline
|
||||||
GENERIC: struct-slot-values ( struct -- sequence )
|
GENERIC: struct-slot-values ( struct -- sequence )
|
||||||
|
|
||||||
M: struct-class reader-quot
|
M: struct-class reader-quot
|
||||||
nip (reader-quot) ;
|
dup type>> array? [ dup type>> first define-array-vocab drop ] when
|
||||||
|
nip '[ _ read-struct-slot ] ;
|
||||||
|
|
||||||
M: struct-class writer-quot
|
M: struct-class writer-quot
|
||||||
nip (writer-quot) ;
|
nip '[ _ write-struct-slot ] ;
|
||||||
|
|
||||||
: offset-of ( field struct -- offset )
|
: offset-of ( field struct -- offset )
|
||||||
struct-slots slot-named offset>> ; inline
|
struct-slots slot-named offset>> ; inline
|
||||||
|
@ -195,7 +203,7 @@ M: struct-c-type c-struct? drop t ;
|
||||||
define-inline-method ;
|
define-inline-method ;
|
||||||
|
|
||||||
: clone-underlying ( struct -- byte-array )
|
: clone-underlying ( struct -- byte-array )
|
||||||
[ >c-ptr ] [ byte-length ] bi memory>byte-array ; inline
|
binary-object memory>byte-array ; inline
|
||||||
|
|
||||||
: (define-clone-method) ( class -- )
|
: (define-clone-method) ( class -- )
|
||||||
[ \ clone ]
|
[ \ clone ]
|
||||||
|
@ -273,7 +281,7 @@ M: struct binary-zero? >c-ptr [ 0 = ] all? ;
|
||||||
[ type>> c-type drop ] each ;
|
[ type>> c-type drop ] each ;
|
||||||
|
|
||||||
: redefine-struct-tuple-class ( class -- )
|
: redefine-struct-tuple-class ( class -- )
|
||||||
[ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ;
|
[ struct f define-tuple-class ] [ make-final ] bi ;
|
||||||
|
|
||||||
:: (define-struct-class) ( class slots offsets-quot -- )
|
:: (define-struct-class) ( class slots offsets-quot -- )
|
||||||
slots empty? [ struct-must-have-slots ] when
|
slots empty? [ struct-must-have-slots ] when
|
||||||
|
@ -298,9 +306,6 @@ PRIVATE>
|
||||||
: define-union-struct-class ( class slots -- )
|
: define-union-struct-class ( class slots -- )
|
||||||
[ compute-union-offsets ] (define-struct-class) ;
|
[ compute-union-offsets ] (define-struct-class) ;
|
||||||
|
|
||||||
M: struct-class reset-class
|
|
||||||
[ call-next-method ] [ name>> c-types get delete-at ] bi ;
|
|
||||||
|
|
||||||
ERROR: invalid-struct-slot token ;
|
ERROR: invalid-struct-slot token ;
|
||||||
|
|
||||||
: struct-slot-class ( c-type -- class' )
|
: struct-slot-class ( c-type -- class' )
|
||||||
|
@ -358,7 +363,8 @@ PRIVATE>
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
: parse-struct-definition ( -- class slots )
|
: parse-struct-definition ( -- class slots )
|
||||||
CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
|
CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array
|
||||||
|
dup [ name>> ] map check-duplicate-slots ;
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
SYNTAX: STRUCT:
|
SYNTAX: STRUCT:
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2005, 2006 Kevin Reid.
|
! Copyright (C) 2005, 2006 Kevin Reid.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: assocs kernel namespaces cocoa cocoa.classes
|
USING: alien.c-types assocs kernel namespaces cocoa
|
||||||
cocoa.subclassing debugger ;
|
cocoa.classes cocoa.runtime cocoa.subclassing debugger ;
|
||||||
IN: cocoa.callbacks
|
IN: cocoa.callbacks
|
||||||
|
|
||||||
SYMBOL: callbacks
|
SYMBOL: callbacks
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
|
@ -39,6 +39,7 @@ SYNTAX: IMPORT: scan [ ] import-objc-class ;
|
||||||
|
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
|
"NSAlert"
|
||||||
"NSApplication"
|
"NSApplication"
|
||||||
"NSArray"
|
"NSArray"
|
||||||
"NSAutoreleasePool"
|
"NSAutoreleasePool"
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
|
@ -76,13 +76,13 @@ MACRO: (send) ( selector super? -- quot )
|
||||||
: super-send ( receiver args... selector -- return... ) t (send) ; inline
|
: super-send ( receiver args... selector -- return... ) t (send) ; inline
|
||||||
|
|
||||||
! Runtime introspection
|
! Runtime introspection
|
||||||
SYMBOL: class-startup-hooks
|
SYMBOL: class-init-hooks
|
||||||
|
|
||||||
class-startup-hooks [ H{ } clone ] initialize
|
class-init-hooks [ H{ } clone ] initialize
|
||||||
|
|
||||||
: (objc-class) ( name word -- class )
|
: (objc-class) ( name word -- class )
|
||||||
2dup execute dup [ 2nip ] [
|
2dup execute dup [ 2nip ] [
|
||||||
drop over class-startup-hooks get at [ call( -- ) ] when*
|
drop over class-init-hooks get at [ call( -- ) ] when*
|
||||||
2dup execute dup [ 2nip ] [
|
2dup execute dup [ 2nip ] [
|
||||||
2drop "No such class: " prepend throw
|
2drop "No such class: " prepend throw
|
||||||
] if
|
] if
|
||||||
|
@ -110,7 +110,7 @@ H{
|
||||||
{ "d" c:double }
|
{ "d" c:double }
|
||||||
{ "B" c:bool }
|
{ "B" c:bool }
|
||||||
{ "v" c:void }
|
{ "v" c:void }
|
||||||
{ "*" c:char* }
|
{ "*" c:c-string }
|
||||||
{ "?" unknown_type }
|
{ "?" unknown_type }
|
||||||
{ "@" id }
|
{ "@" id }
|
||||||
{ "#" Class }
|
{ "#" Class }
|
||||||
|
@ -229,16 +229,19 @@ ERROR: no-objc-type name ;
|
||||||
: class-exists? ( string -- class ) objc_getClass >boolean ;
|
: class-exists? ( string -- class ) objc_getClass >boolean ;
|
||||||
|
|
||||||
: define-objc-class-word ( quot name -- )
|
: define-objc-class-word ( quot name -- )
|
||||||
[ class-startup-hooks get set-at ]
|
[ class-init-hooks get set-at ]
|
||||||
[
|
[
|
||||||
[ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
|
[ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
|
||||||
(( -- class )) define-declared
|
(( -- class )) define-declared
|
||||||
] bi ;
|
] bi ;
|
||||||
|
|
||||||
: import-objc-class ( name quot -- )
|
: import-objc-class ( name quot -- )
|
||||||
over define-objc-class-word
|
2dup swap define-objc-class-word
|
||||||
[ objc-class register-objc-methods ]
|
over class-exists? [ drop ] [ call( -- ) ] if
|
||||||
[ objc-meta-class register-objc-methods ] bi ;
|
dup class-exists? [
|
||||||
|
[ objc_getClass register-objc-methods ]
|
||||||
|
[ objc_getMetaClass register-objc-methods ] bi
|
||||||
|
] [ drop ] if ;
|
||||||
|
|
||||||
: root-class ( class -- root )
|
: root-class ( class -- root )
|
||||||
dup class_getSuperclass [ root-class ] [ ] ?if ;
|
dup class_getSuperclass [ root-class ] [ ] ?if ;
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -7,11 +7,11 @@ TYPEDEF: void* SEL
|
||||||
|
|
||||||
TYPEDEF: void* id
|
TYPEDEF: void* id
|
||||||
|
|
||||||
FUNCTION: char* sel_getName ( SEL aSelector ) ;
|
FUNCTION: c-string sel_getName ( SEL aSelector ) ;
|
||||||
|
|
||||||
FUNCTION: char sel_isMapped ( SEL aSelector ) ;
|
FUNCTION: char sel_isMapped ( SEL aSelector ) ;
|
||||||
|
|
||||||
FUNCTION: SEL sel_registerName ( char* str ) ;
|
FUNCTION: SEL sel_registerName ( c-string str ) ;
|
||||||
|
|
||||||
TYPEDEF: void* Class
|
TYPEDEF: void* Class
|
||||||
TYPEDEF: void* Method
|
TYPEDEF: void* Method
|
||||||
|
@ -33,13 +33,13 @@ CONSTANT: CLS_METHOD_ARRAY HEX: 100
|
||||||
|
|
||||||
FUNCTION: int objc_getClassList ( void* buffer, int bufferLen ) ;
|
FUNCTION: int objc_getClassList ( void* buffer, int bufferLen ) ;
|
||||||
|
|
||||||
FUNCTION: Class objc_getClass ( char* class ) ;
|
FUNCTION: Class objc_getClass ( c-string class ) ;
|
||||||
|
|
||||||
FUNCTION: Class objc_getMetaClass ( char* class ) ;
|
FUNCTION: Class objc_getMetaClass ( c-string class ) ;
|
||||||
|
|
||||||
FUNCTION: Protocol objc_getProtocol ( char* class ) ;
|
FUNCTION: Protocol objc_getProtocol ( c-string class ) ;
|
||||||
|
|
||||||
FUNCTION: Class objc_allocateClassPair ( Class superclass, char* name, size_t extraBytes ) ;
|
FUNCTION: Class objc_allocateClassPair ( Class superclass, c-string name, size_t extraBytes ) ;
|
||||||
FUNCTION: void objc_registerClassPair ( Class cls ) ;
|
FUNCTION: void objc_registerClassPair ( Class cls ) ;
|
||||||
|
|
||||||
FUNCTION: id class_createInstance ( Class class, uint additionalByteCount ) ;
|
FUNCTION: id class_createInstance ( Class class, uint additionalByteCount ) ;
|
||||||
|
@ -54,7 +54,7 @@ FUNCTION: Method* class_copyMethodList ( Class class, uint* outCount ) ;
|
||||||
|
|
||||||
FUNCTION: Class class_getSuperclass ( Class cls ) ;
|
FUNCTION: Class class_getSuperclass ( Class cls ) ;
|
||||||
|
|
||||||
FUNCTION: char* class_getName ( Class cls ) ;
|
FUNCTION: c-string class_getName ( Class cls ) ;
|
||||||
|
|
||||||
FUNCTION: char class_addMethod ( Class class, SEL name, void* imp, void* types ) ;
|
FUNCTION: char class_addMethod ( Class class, SEL name, void* imp, void* types ) ;
|
||||||
|
|
||||||
|
@ -64,7 +64,7 @@ FUNCTION: uint method_getNumberOfArguments ( Method method ) ;
|
||||||
|
|
||||||
FUNCTION: uint method_getSizeOfArguments ( Method method ) ;
|
FUNCTION: uint method_getSizeOfArguments ( Method method ) ;
|
||||||
|
|
||||||
FUNCTION: uint method_getArgumentInfo ( Method method, int argIndex, char** type, int* offset ) ;
|
FUNCTION: uint method_getArgumentInfo ( Method method, int argIndex, c-string* type, int* offset ) ;
|
||||||
|
|
||||||
FUNCTION: void* method_copyReturnType ( Method method ) ;
|
FUNCTION: void* method_copyReturnType ( Method method ) ;
|
||||||
|
|
||||||
|
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
|
@ -1,2 +1,2 @@
|
||||||
unportable
|
|
||||||
bindings
|
bindings
|
||||||
|
ffi
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
|
@ -0,0 +1,9 @@
|
||||||
|
USING: compiler.crossref fry kernel sequences tools.test vocabs words ;
|
||||||
|
IN: compiler.crossref.tests
|
||||||
|
|
||||||
|
! Dependencies of all words should always be satisfied unless we're
|
||||||
|
! in the middle of recompiling something
|
||||||
|
[ { } ] [
|
||||||
|
all-words dup [ subwords ] map concat append
|
||||||
|
H{ } clone '[ _ dependencies-satisfied? not ] filter
|
||||||
|
] unit-test
|
|
@ -67,7 +67,7 @@ FUNCTION: FOO ffi_test_14 int x int y ;
|
||||||
|
|
||||||
[ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test
|
[ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test
|
||||||
|
|
||||||
FUNCTION: char* ffi_test_15 char* x char* y ;
|
FUNCTION: c-string ffi_test_15 c-string x c-string y ;
|
||||||
|
|
||||||
[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
|
[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
|
||||||
[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
|
[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
|
||||||
|
@ -576,7 +576,7 @@ FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
|
||||||
|
|
||||||
! Reported by jedahu
|
! Reported by jedahu
|
||||||
STRUCT: bool-field-test
|
STRUCT: bool-field-test
|
||||||
{ name char* }
|
{ name c-string }
|
||||||
{ on bool }
|
{ on bool }
|
||||||
{ parents short } ;
|
{ parents short } ;
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,11 @@
|
||||||
|
IN: compiler.tests.redefine22
|
||||||
|
USING: kernel sequences compiler.units vocabs tools.test definitions ;
|
||||||
|
|
||||||
|
TUPLE: ttt ;
|
||||||
|
INSTANCE: ttt sequence
|
||||||
|
M: ttt new-sequence 2drop ttt new ;
|
||||||
|
|
||||||
|
: www-1 ( a -- b ) T{ ttt } new-sequence ;
|
||||||
|
|
||||||
|
! This used to break with a compiler error in the above word
|
||||||
|
[ ] [ [ \ ttt forget ] with-compilation-unit ] unit-test
|
|
@ -0,0 +1,13 @@
|
||||||
|
IN: compiler.tests.redefine23
|
||||||
|
USING: classes.struct specialized-arrays alien.c-types sequences
|
||||||
|
compiler.units vocabs tools.test ;
|
||||||
|
|
||||||
|
STRUCT: my-struct { x int } ;
|
||||||
|
SPECIALIZED-ARRAY: my-struct
|
||||||
|
: my-word ( a -- b ) iota [ my-struct <struct-boa> ] my-struct-array{ } map-as ;
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
[
|
||||||
|
"specialized-arrays.instances.compiler.tests.redefine23" forget-vocab
|
||||||
|
] with-compilation-unit
|
||||||
|
] unit-test
|
|
@ -0,0 +1,39 @@
|
||||||
|
USING: alien alien.syntax eval math tools.test ;
|
||||||
|
QUALIFIED: alien.c-types
|
||||||
|
IN: compiler.tests.redefine24
|
||||||
|
|
||||||
|
TYPEDEF: alien.c-types:int type-1
|
||||||
|
|
||||||
|
TYPEDEF: alien.c-types:int type-3
|
||||||
|
|
||||||
|
: callback ( -- ptr )
|
||||||
|
type-3 { type-1 type-1 } "cdecl" [ + >integer ] alien-callback ;
|
||||||
|
|
||||||
|
TYPEDEF: alien.c-types:float type-2
|
||||||
|
|
||||||
|
: indirect ( x y ptr -- z )
|
||||||
|
type-3 { type-2 type-2 } "cdecl" alien-indirect ;
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
"USING: alien.c-types alien.syntax ;
|
||||||
|
IN: compiler.tests.redefine24 TYPEDEF: int type-2" eval( -- )
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ 3 ] [ 1 2 callback indirect ] unit-test
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
"USING: alien.c-types alien.syntax ;
|
||||||
|
IN: compiler.tests.redefine24
|
||||||
|
TYPEDEF: float type-1
|
||||||
|
TYPEDEF: float type-2" eval( -- )
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ 3 ] [ 1.0 2.0 callback indirect ] unit-test
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
"USING: alien.c-types alien.syntax ;
|
||||||
|
IN: compiler.tests.redefine24
|
||||||
|
TYPEDEF: float type-3" eval( -- )
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ 3.0 ] [ 1.0 2.0 callback indirect ] unit-test
|
|
@ -51,11 +51,16 @@ GENERIC: cleanup* ( node -- node/nodes )
|
||||||
[ in-d>> #drop ]
|
[ in-d>> #drop ]
|
||||||
bi prefix ;
|
bi prefix ;
|
||||||
|
|
||||||
: record-predicate-folding ( #call -- )
|
: >predicate-folding< ( #call -- value-info class result )
|
||||||
[ node-input-infos first class>> ]
|
[ node-input-infos first ]
|
||||||
[ word>> "predicating" word-prop ]
|
[ word>> "predicating" word-prop ]
|
||||||
[ node-output-infos first literal>> ] tri
|
[ node-output-infos first literal>> ] tri ;
|
||||||
[ depends-on-class<= ] [ depends-on-classes-disjoint ] if ;
|
|
||||||
|
: record-predicate-folding ( #call -- )
|
||||||
|
>predicate-folding< pick literal?>>
|
||||||
|
[ [ literal>> ] 2dip depends-on-instance-predicate ]
|
||||||
|
[ [ class>> ] 2dip depends-on-class-predicate ]
|
||||||
|
if ;
|
||||||
|
|
||||||
: record-folding ( #call -- )
|
: record-folding ( #call -- )
|
||||||
dup word>> predicate?
|
dup word>> predicate?
|
||||||
|
|
|
@ -1,10 +1,11 @@
|
||||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: assocs classes classes.algebra classes.tuple
|
USING: assocs classes classes.algebra classes.tuple
|
||||||
classes.tuple.private kernel accessors math math.intervals namespaces
|
classes.tuple.private classes.singleton kernel accessors math
|
||||||
sequences sequences.private words combinators memoize
|
math.intervals namespaces sequences sequences.private words
|
||||||
combinators.short-circuit byte-arrays strings arrays layouts
|
combinators memoize combinators.short-circuit byte-arrays
|
||||||
cpu.architecture compiler.tree.propagation.copy ;
|
strings arrays layouts cpu.architecture
|
||||||
|
compiler.tree.propagation.copy ;
|
||||||
IN: compiler.tree.propagation.info
|
IN: compiler.tree.propagation.info
|
||||||
|
|
||||||
: false-class? ( class -- ? ) \ f class<= ;
|
: false-class? ( class -- ? ) \ f class<= ;
|
||||||
|
@ -65,9 +66,17 @@ DEFER: <literal-info>
|
||||||
|
|
||||||
UNION: fixed-length array byte-array string ;
|
UNION: fixed-length array byte-array string ;
|
||||||
|
|
||||||
|
: literal-class ( obj -- class )
|
||||||
|
#! Handle forgotten tuples and singleton classes properly
|
||||||
|
dup singleton-class? [
|
||||||
|
class dup class? [
|
||||||
|
drop tuple
|
||||||
|
] unless
|
||||||
|
] unless ;
|
||||||
|
|
||||||
: init-literal-info ( info -- info )
|
: init-literal-info ( info -- info )
|
||||||
empty-interval >>interval
|
empty-interval >>interval
|
||||||
dup literal>> class >>class
|
dup literal>> literal-class >>class
|
||||||
dup literal>> {
|
dup literal>> {
|
||||||
{ [ dup real? ] [ [a,a] >>interval ] }
|
{ [ dup real? ] [ [a,a] >>interval ] }
|
||||||
{ [ dup tuple? ] [ tuple-slot-infos >>slots ] }
|
{ [ dup tuple? ] [ tuple-slot-infos >>slots ] }
|
||||||
|
|
|
@ -648,7 +648,7 @@ M: array iterate first t ; inline
|
||||||
] final-info drop
|
] final-info drop
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ V{ word } ] [
|
[ V{ t } ] [
|
||||||
[ { hashtable } declare hashtable instance? ] final-classes
|
[ { hashtable } declare hashtable instance? ] final-classes
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -660,7 +660,7 @@ M: array iterate first t ; inline
|
||||||
[ { assoc } declare hashtable instance? ] final-classes
|
[ { assoc } declare hashtable instance? ] final-classes
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ V{ word } ] [
|
[ V{ t } ] [
|
||||||
[ { string } declare string? ] final-classes
|
[ { string } declare string? ] final-classes
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -774,7 +774,7 @@ MIXIN: empty-mixin
|
||||||
[ { fixnum } declare log2 ] final-classes
|
[ { fixnum } declare log2 ] final-classes
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ V{ word } ] [
|
[ V{ t } ] [
|
||||||
[ { fixnum } declare log2 0 >= ] final-classes
|
[ { fixnum } declare log2 0 >= ] final-classes
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: fry accessors kernel sequences sequences.private assocs
|
USING: fry accessors kernel sequences sequences.private assocs
|
||||||
words namespaces classes.algebra combinators
|
words namespaces classes.algebra combinators
|
||||||
|
@ -72,7 +72,7 @@ M: #declare propagate-before
|
||||||
|
|
||||||
: foldable-call? ( #call word -- ? )
|
: foldable-call? ( #call word -- ? )
|
||||||
{
|
{
|
||||||
[ nip "foldable" word-prop ]
|
[ nip foldable? ]
|
||||||
[ drop literal-inputs? ]
|
[ drop literal-inputs? ]
|
||||||
[ input-classes-match? ]
|
[ input-classes-match? ]
|
||||||
} 2&& ;
|
} 2&& ;
|
||||||
|
@ -93,11 +93,8 @@ M: #declare propagate-before
|
||||||
recover ;
|
recover ;
|
||||||
|
|
||||||
: predicate-output-infos/class ( info class -- info )
|
: predicate-output-infos/class ( info class -- info )
|
||||||
[ class>> ] dip {
|
[ class>> ] dip compare-classes
|
||||||
{ [ 2dup class<= ] [ t <literal-info> ] }
|
dup +incomparable+ eq? [ drop object-info ] [ <literal-info> ] if ;
|
||||||
{ [ 2dup classes-intersect? not ] [ f <literal-info> ] }
|
|
||||||
[ object-info ]
|
|
||||||
} cond 2nip ;
|
|
||||||
|
|
||||||
: predicate-output-infos ( info class -- info )
|
: predicate-output-infos ( info class -- info )
|
||||||
over literal?>>
|
over literal?>>
|
||||||
|
|
|
@ -20,7 +20,6 @@ HELP: tiff-lzw-uncompress
|
||||||
|
|
||||||
HELP: lzw-read
|
HELP: lzw-read
|
||||||
{ $values
|
{ $values
|
||||||
{ "lzw" lzw }
|
|
||||||
{ "lzw" lzw } { "n" integer }
|
{ "lzw" lzw } { "n" integer }
|
||||||
}
|
}
|
||||||
{ $description "Read the next LZW code." } ;
|
{ $description "Read the next LZW code." } ;
|
||||||
|
@ -48,7 +47,6 @@ HELP: code-space-full?
|
||||||
HELP: reset-lzw-uncompress
|
HELP: reset-lzw-uncompress
|
||||||
{ $values
|
{ $values
|
||||||
{ "lzw" lzw }
|
{ "lzw" lzw }
|
||||||
{ "lzw" lzw }
|
|
||||||
}
|
}
|
||||||
{ $description "Reset the LZW uncompressor state (either at initialization time or immediately after receiving a Clear Code). " } ;
|
{ $description "Reset the LZW uncompressor state (either at initialization time or immediately after receiving a Clear Code). " } ;
|
||||||
|
|
||||||
|
|
|
@ -42,40 +42,6 @@ IN: concurrency.mailboxes.tests
|
||||||
mailbox-get
|
mailbox-get
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
<mailbox> "m" set
|
|
||||||
|
|
||||||
1 <count-down> "c" set
|
|
||||||
1 <count-down> "d" set
|
|
||||||
|
|
||||||
[
|
|
||||||
"c" get await
|
|
||||||
[ "m" get mailbox-get drop ]
|
|
||||||
[ drop "d" get count-down ] recover
|
|
||||||
] "Mailbox close test" spawn drop
|
|
||||||
|
|
||||||
[ ] [ "c" get count-down ] unit-test
|
|
||||||
[ ] [ "m" get dispose ] unit-test
|
|
||||||
[ ] [ "d" get 5 seconds await-timeout ] unit-test
|
|
||||||
|
|
||||||
[ ] [ "m" get dispose ] unit-test
|
|
||||||
|
|
||||||
<mailbox> "m" set
|
|
||||||
|
|
||||||
1 <count-down> "c" set
|
|
||||||
1 <count-down> "d" set
|
|
||||||
|
|
||||||
[
|
|
||||||
"c" get await
|
|
||||||
"m" get wait-for-close
|
|
||||||
"d" get count-down
|
|
||||||
] "Mailbox close test" spawn drop
|
|
||||||
|
|
||||||
[ ] [ "c" get count-down ] unit-test
|
|
||||||
[ ] [ "m" get dispose ] unit-test
|
|
||||||
[ ] [ "d" get 5 seconds await-timeout ] unit-test
|
|
||||||
|
|
||||||
[ ] [ "m" get dispose ] unit-test
|
|
||||||
|
|
||||||
[ { "foo" "bar" } ] [
|
[ { "foo" "bar" } ] [
|
||||||
<mailbox>
|
<mailbox>
|
||||||
"foo" over mailbox-put
|
"foo" over mailbox-put
|
||||||
|
@ -86,4 +52,3 @@ IN: concurrency.mailboxes.tests
|
||||||
[
|
[
|
||||||
<mailbox> 1 seconds mailbox-get-timeout
|
<mailbox> 1 seconds mailbox-get-timeout
|
||||||
] [ wait-timeout? ] must-fail-with
|
] [ wait-timeout? ] must-fail-with
|
||||||
|
|
||||||
|
|
|
@ -1,17 +1,17 @@
|
||||||
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
|
! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: dlists deques threads sequences continuations
|
USING: dlists deques threads sequences continuations namespaces
|
||||||
destructors namespaces math quotations words kernel
|
math quotations words kernel arrays assocs init system
|
||||||
arrays assocs init system concurrency.conditions accessors
|
concurrency.conditions accessors debugger debugger.threads
|
||||||
debugger debugger.threads locals fry ;
|
locals fry ;
|
||||||
IN: concurrency.mailboxes
|
IN: concurrency.mailboxes
|
||||||
|
|
||||||
TUPLE: mailbox < disposable threads data ;
|
TUPLE: mailbox threads data ;
|
||||||
|
|
||||||
M: mailbox dispose* threads>> notify-all ;
|
|
||||||
|
|
||||||
: <mailbox> ( -- mailbox )
|
: <mailbox> ( -- mailbox )
|
||||||
mailbox new-disposable <dlist> >>threads <dlist> >>data ;
|
mailbox new
|
||||||
|
<dlist> >>threads
|
||||||
|
<dlist> >>data ;
|
||||||
|
|
||||||
: mailbox-empty? ( mailbox -- bool )
|
: mailbox-empty? ( mailbox -- bool )
|
||||||
data>> deque-empty? ;
|
data>> deque-empty? ;
|
||||||
|
@ -24,14 +24,12 @@ M: mailbox dispose* threads>> notify-all ;
|
||||||
[ threads>> ] dip "mailbox" wait ;
|
[ threads>> ] dip "mailbox" wait ;
|
||||||
|
|
||||||
:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
|
:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
|
||||||
mailbox check-disposed
|
|
||||||
mailbox data>> pred dlist-any? [
|
mailbox data>> pred dlist-any? [
|
||||||
mailbox timeout wait-for-mailbox
|
mailbox timeout wait-for-mailbox
|
||||||
mailbox timeout pred block-unless-pred
|
mailbox timeout pred block-unless-pred
|
||||||
] unless ; inline recursive
|
] unless ; inline recursive
|
||||||
|
|
||||||
: block-if-empty ( mailbox timeout -- mailbox )
|
: block-if-empty ( mailbox timeout -- mailbox )
|
||||||
over check-disposed
|
|
||||||
over mailbox-empty? [
|
over mailbox-empty? [
|
||||||
2dup wait-for-mailbox block-if-empty
|
2dup wait-for-mailbox block-if-empty
|
||||||
] [
|
] [
|
||||||
|
|
|
@ -12,6 +12,7 @@ TUPLE: promise mailbox ;
|
||||||
mailbox>> mailbox-empty? not ;
|
mailbox>> mailbox-empty? not ;
|
||||||
|
|
||||||
ERROR: promise-already-fulfilled promise ;
|
ERROR: promise-already-fulfilled promise ;
|
||||||
|
|
||||||
: fulfill ( value promise -- )
|
: fulfill ( value promise -- )
|
||||||
dup promise-fulfilled? [
|
dup promise-fulfilled? [
|
||||||
promise-already-fulfilled
|
promise-already-fulfilled
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1,2 +1 @@
|
||||||
unportable
|
|
||||||
bindings
|
bindings
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1,2 +1 @@
|
||||||
unportable
|
|
||||||
bindings
|
bindings
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1,2 +1 @@
|
||||||
unportable
|
|
||||||
bindings
|
bindings
|
||||||
|
|
|
@ -12,7 +12,7 @@ CONSTANT: kCFPropertyListImmutable 0
|
||||||
CONSTANT: kCFPropertyListMutableContainers 1
|
CONSTANT: kCFPropertyListMutableContainers 1
|
||||||
CONSTANT: kCFPropertyListMutableContainersAndLeaves 2
|
CONSTANT: kCFPropertyListMutableContainersAndLeaves 2
|
||||||
|
|
||||||
FUNCTION: CFDataRef CFDataCreate ( CFAllocatorRef allocator, uchar* bytes, CFIndex length ) ;
|
FUNCTION: CFDataRef CFDataCreate ( CFAllocatorRef allocator, UInt8* bytes, CFIndex length ) ;
|
||||||
|
|
||||||
FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
|
FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1,2 +1 @@
|
||||||
unportable
|
|
||||||
bindings
|
bindings
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1,2 +1 @@
|
||||||
unportable
|
|
||||||
bindings
|
bindings
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1,2 +1 @@
|
||||||
unportable
|
|
||||||
bindings
|
bindings
|
||||||
|
|
|
@ -36,7 +36,6 @@ STRUCT: FSEventStreamContext
|
||||||
{ release void* }
|
{ release void* }
|
||||||
{ copyDescription void* } ;
|
{ copyDescription void* } ;
|
||||||
|
|
||||||
! callback(
|
|
||||||
CALLBACK: void FSEventStreamCallback ( FSEventStreamRef streamRef, void* clientCallBackInfo, size_t numEvents, void* eventPaths, FSEventStreamEventFlags* eventFlags, FSEventStreamEventId* eventIds ) ;
|
CALLBACK: void FSEventStreamCallback ( FSEventStreamRef streamRef, void* clientCallBackInfo, size_t numEvents, void* eventPaths, FSEventStreamEventFlags* eventFlags, FSEventStreamEventId* eventIds ) ;
|
||||||
|
|
||||||
CONSTANT: FSEventStreamEventIdSinceNow HEX: FFFFFFFFFFFFFFFF
|
CONSTANT: FSEventStreamEventIdSinceNow HEX: FFFFFFFFFFFFFFFF
|
||||||
|
@ -173,16 +172,7 @@ SYMBOL: event-stream-callbacks
|
||||||
info event-stream-callbacks get at [ drop ] or call( changes -- ) ;
|
info event-stream-callbacks get at [ drop ] or call( changes -- ) ;
|
||||||
|
|
||||||
: master-event-source-callback ( -- alien )
|
: master-event-source-callback ( -- alien )
|
||||||
"void"
|
[ (master-event-source-callback) ] FSEventStreamCallback ;
|
||||||
{
|
|
||||||
"FSEventStreamRef"
|
|
||||||
"void*" ! info
|
|
||||||
"size_t" ! numEvents
|
|
||||||
"void*" ! eventPaths
|
|
||||||
"FSEventStreamEventFlags*"
|
|
||||||
"FSEventStreamEventId*"
|
|
||||||
}
|
|
||||||
"cdecl" [ (master-event-source-callback) ] alien-callback ;
|
|
||||||
|
|
||||||
TUPLE: event-stream < disposable info handle ;
|
TUPLE: event-stream < disposable info handle ;
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
|
@ -0,0 +1 @@
|
||||||
|
macosx
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue