Merge branch 'master' of git://factorcode.org/git/factor into bags

db4
Daniel Ehrenberg 2010-02-26 10:00:57 -05:00
commit a3c168cb5e
1111 changed files with 9195 additions and 3316 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -1 +1,2 @@
Slava Pestov Slava Pestov
Joe Groff

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -1 +1 @@
unportable untested

View File

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

View File

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

View File

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

View File

@ -0,0 +1 @@
unix

View File

@ -1 +0,0 @@
unportable

View File

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

View File

@ -0,0 +1 @@
windows

View File

@ -1 +0,0 @@
unportable

View File

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

View File

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

View File

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

View File

@ -0,0 +1 @@
macosx

View File

@ -1 +0,0 @@
unportable

View File

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

View File

@ -0,0 +1 @@
macosx

View File

@ -1 +0,0 @@
unportable

View File

@ -39,6 +39,7 @@ SYNTAX: IMPORT: scan [ ] import-objc-class ;
[ [
{ {
"NSAlert"
"NSApplication" "NSApplication"
"NSArray" "NSArray"
"NSAutoreleasePool" "NSAutoreleasePool"

View File

@ -0,0 +1 @@
macosx

View File

@ -1 +0,0 @@
unportable

View File

@ -0,0 +1 @@
macosx

View File

@ -1 +0,0 @@
unportable

View File

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

View File

@ -0,0 +1 @@
macosx

View File

@ -1 +0,0 @@
unportable

View File

@ -0,0 +1 @@
macosx

View File

@ -1 +0,0 @@
unportable

View File

@ -0,0 +1 @@
macosx

View File

@ -1 +0,0 @@
unportable

View File

@ -0,0 +1 @@
macosx

View File

@ -0,0 +1 @@
macosx

View File

@ -1 +0,0 @@
unportable

View File

@ -0,0 +1 @@
macosx

View File

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

View File

@ -1 +0,0 @@
unportable

View File

@ -0,0 +1 @@
macosx

View File

@ -1 +0,0 @@
unportable

View File

@ -1,2 +1,2 @@
unportable
bindings bindings
ffi

View File

@ -0,0 +1 @@
macosx

View File

@ -1 +0,0 @@
unportable

View File

@ -0,0 +1 @@
macosx

View File

@ -1 +0,0 @@
unportable

View File

@ -0,0 +1 @@
macosx

View File

@ -1 +0,0 @@
unportable

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -0,0 +1 @@
macosx

View File

@ -1,2 +1 @@
unportable
bindings bindings

View File

@ -0,0 +1 @@
macosx

View File

@ -1,2 +1 @@
unportable
bindings bindings

View File

@ -0,0 +1 @@
macosx

View File

@ -1,2 +1 @@
unportable
bindings bindings

View File

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

View File

@ -0,0 +1 @@
macosx

View File

@ -1,2 +1 @@
unportable
bindings bindings

View File

@ -0,0 +1 @@
macosx

View File

@ -1,2 +1 @@
unportable
bindings bindings

View File

@ -0,0 +1 @@
macosx

View File

@ -1,2 +1 @@
unportable
bindings bindings

View File

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

View File

@ -0,0 +1 @@
macosx

View File

@ -1 +0,0 @@
unportable

View File

@ -0,0 +1 @@
macosx

View File

@ -1 +0,0 @@
unportable

View File

@ -0,0 +1 @@
macosx

Some files were not shown because too many files have changed in this diff Show More