steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Daniel Ehrenberg 2010-02-26 10:00:57 -05:00
parent 22edb2ea0d 49768413fe
commit a3c168cb5e
1111 changed files with 9195 additions and 3316 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Factor.app/Contents/Info.plist
View File

@ -31,8 +31,10 @@
<string>Factor</string>
<key>CFBundlePackageType</key>
<string>APPL</string>
<key>CFBundleVersion</key>
<string>0.93</string>
<key>NSHumanReadableCopyright</key>
<string>Copyright © 2003-2009, Slava Pestov and friends</string>
<string>Copyright © 2003-2010 Factor developers</string>
<key>NSServices</key>
<array>
<dict>

2
GNUmakefile
View File

@ -4,7 +4,7 @@ ifdef CONFIG
AR = ar
LD = ld
VERSION = 0.92
VERSION = 0.93
BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib

22
basis/alien/arrays/arrays.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.strings alien.c-types alien.data alien.accessors
arrays words sequences math kernel namespaces fry cpu.architecture
io.encodings.utf8 accessors ;
io.encodings.binary io.encodings.utf8 accessors ;
IN: alien.arrays
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 c-type-boxer-quot
unclip
[ array-length ]
[ [ require-c-array ] keep ] bi*
[ <c-direct-array> ] 2curry ;
unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
PREDICATE: string-type < pair
first2 [ char* = ] [ word? ] bi* and ;
first2 [ c-string = ] [ word? ] bi* and ;
M: string-type c-type ;
@ -88,10 +85,14 @@ M: string-type c-type-unboxer
drop void* c-type-unboxer ;
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
second '[ _ string>alien ] ;
second dup binary =
[ drop void* c-type-unboxer-quot ]
[ '[ _ string>alien ] ] if ;
M: string-type c-type-getter
drop [ alien-cell ] ;
@ -99,8 +100,5 @@ M: string-type c-type-getter
M: string-type c-type-setter
drop [ set-alien-cell ] ;
{ char* utf8 } char* typedef
char* uchar* typedef
{ c-string utf8 } c-string typedef
char char* "pointer-c-type" set-word-prop
uchar uchar* "pointer-c-type" set-word-prop

32
basis/alien/c-types/c-types-docs.factor
View File

@ -6,10 +6,6 @@ QUALIFIED: math
QUALIFIED: sequences
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
{ $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." }
@ -32,13 +28,10 @@ HELP: no-c-type
{ $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." } ;
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
{ $values { "name" "a C type" } { "c-type" c-type } }
{ $description "Looks up a C type by name." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
{ $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
{ $values { "name" "a C type" } { "quot" { $quotation "( c-ptr n -- obj )" } } }
@ -106,8 +99,8 @@ HELP: ulonglong
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." } ;
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." } ;
HELP: char*
{ $description "This C type represents a generic pointer to C memory. See " { $link pointer } " for information on pointer C types." } ;
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." } ;
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." } ;
@ -118,6 +111,19 @@ HELP: complex-float
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." } ;
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"
"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." ;
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
"Fixed-size array types are supported; the syntax consists of a C type name followed by dimension sizes in brackets; the following denotes a 3 by 4 array of integers:"
{ $code "int[3][4]" }
"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however when used as function parameters they behave exactly like pointers and thus the dimensions only serve as documentation." ;
"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"
"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" } "." ;
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
"Defining new C types:"
{ $subsections

43
basis/alien/c-types/c-types-tests.factor
View File

@ -1,6 +1,6 @@
USING: alien alien.syntax alien.c-types alien.parser
eval kernel tools.test sequences system libc alien.strings
io.encodings.utf8 math.constants classes.struct classes
io.encodings.ascii io.encodings.utf8 math.constants classes.struct classes
accessors compiler.units ;
IN: alien.c-types.tests
@ -16,36 +16,39 @@ UNION-STRUCT: foo
{ a int }
{ b int } ;
[ f ] [ char resolve-pointer-type c-type void* c-type eq? ] unit-test
[ t ] [ char* resolve-pointer-type c-type void* c-type eq? ] unit-test
[ t ] [ pointer: void c-type void* c-type = ] 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
TYPEDEF: int MyInt
[ t ] [ int c-type MyInt c-type eq? ] unit-test
[ t ] [ void* c-type MyInt resolve-pointer-type c-type eq? ] unit-test
TYPEDEF: char MyChar
[ t ] [ char c-type MyChar c-type eq? ] unit-test
[ f ] [ void* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
[ t ] [ char* c-type MyChar resolve-pointer-type c-type eq? ] unit-test
[ t ] [ int c-type MyInt c-type = ] unit-test
[ t ] [ void* c-type pointer: MyInt c-type = ] 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 ] [ void* c-type MyString resolve-pointer-type c-type eq? ] unit-test
[ t ] [ pointer: void c-type pointer: MyChar c-type = ] 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
[ t ] [ void* c-type MyIntArray c-type eq? ] unit-test
TYPEDEF: uchar* MyLPBYTE
[ t ] [ { char* utf8 } c-type MyLPBYTE c-type = ] unit-test
[ t ] [ void* c-type MyIntArray c-type = ] unit-test
[
0 B{ 1 2 3 4 } <displaced-alien> <void*>
@ -63,7 +66,7 @@ os windows? cpu x86.64? and [
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
[ """

107
basis/alien/c-types/c-types.factor
View File

@ -17,8 +17,9 @@ SYMBOLS:
long ulong
longlong ulonglong
float double
void* bool
void ;
void* bool ;
SINGLETON: void
DEFER: <int>
DEFER: *char
@ -43,65 +44,24 @@ stack-align? ;
: <c-type> ( -- c-type )
\ c-type new ; inline
SYMBOL: c-types
global [
c-types [ H{ } assoc-like ] change
] bind
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
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 -- ? )
{ void "void" } member? ;
M: word resolve-pointer-type
dup "pointer-c-type" word-prop
[ ] [ drop void* ] ?if ;
M: string resolve-pointer-type
dup "*" append dup c-types get at
[ nip ] [
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 ;
UNION: c-type-name
c-type-word pointer ;
: resolve-typedef ( name -- c-type )
dup void? [ no-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
dup "c-type" word-prop resolve-typedef
[ ] [ 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 ;
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 -- ? ) 0 = not ; inline
@ -263,24 +217,13 @@ MIXIN: value-type
\ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
] [ ] make ;
GENERIC: typedef ( old new -- )
PREDICATE: typedef-word < c-type-word
"c-type" word-prop c-type-name? ;
M: string typedef ( old new -- ) c-types get set-at ;
M: word typedef ( old new -- )
: typedef ( old new -- )
{
[ nip define-symbol ]
[ name>> typedef ]
[ swap "c-type" set-word-prop ]
[
swap dup c-type-name? [
resolve-pointer-type
"pointer-c-type" set-word-prop
] [ 2drop ] if
]
} 2cleave ;
TUPLE: long-long-type < c-type ;
@ -315,6 +258,10 @@ M: long-long-type box-return ( c-type -- )
: if-void ( c-type true false -- )
pick void? [ drop nip call ] [ nip call ] if ; inline
SYMBOLS:
ptrdiff_t intptr_t uintptr_t size_t
c-string ;
CONSTANT: primitive-types
{
char uchar
@ -324,11 +271,30 @@ CONSTANT: primitive-types
longlong ulonglong
float double
void* bool
c-string
}
SYMBOLS:
ptrdiff_t intptr_t uintptr_t size_t
char* uchar* ;
: (pointer-c-type) ( void* type -- void*' )
[ clone ] dip c-type-boxer-quot '[ _ [ f ] if* ] >>boxer-quot ;
<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 )
{
@ -541,6 +507,7 @@ SYMBOLS:
\ uint c-type \ uintptr_t typedef
\ uint c-type \ size_t typedef
] if
] with-compilation-unit
M: char-16-rep rep-component-type drop char ;

4
basis/alien/complex/complex-tests.factor
View File

@ -16,6 +16,6 @@ STRUCT: complex-holder
[ 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

4
basis/alien/complex/complex.factor
View File

@ -6,8 +6,10 @@ IN: alien.complex
<<
{ "float" "double" } [ dup "complex-" prepend define-complex-type ] each
>>
<<
! This overrides the fact that small structures are never returned
! 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
>>

4
basis/alien/complex/functor/functor.factor
View File

@ -7,6 +7,8 @@ IN: alien.complex.functor
FUNCTOR: define-complex-type ( N T -- )
N-type IS ${N}
T-class DEFINES-CLASS ${T}
<T> DEFINES <${T}>
@ -14,7 +16,7 @@ T-class DEFINES-CLASS ${T}
WHERE
STRUCT: T-class { real N } { imaginary N } ;
STRUCT: T-class { real N-type } { imaginary N-type } ;
: <T> ( z -- alien )
>rect T-class <struct-boa> >c-ptr ;

23
basis/alien/data/data-docs.factor
View File

@ -21,11 +21,6 @@ HELP: memory>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." } ;
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
{ $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> } "." }
@ -75,9 +70,7 @@ $nl
"You can unsafely copy a range of bytes from one memory location to another:"
{ $subsections memcpy }
"You can copy a range of bytes from memory into a byte array:"
{ $subsections memory>byte-array }
"You can copy a byte array to memory unsafely:"
{ $subsections byte-array>memory } ;
{ $subsections memory>byte-array } ;
ARTICLE: "c-pointers" "Passing pointers to C functions"
"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 f } "; this is interpreted as a null pointer." }
{ "Instances of " { $link byte-array } "; the C function receives a pointer to the first element of the array." }
{ "Any data type which defines a method on " { $link >c-ptr } " that returns an instance of one of the above. This includes " { $link "classes.struct" } " and " { $link "specialized-arrays" } "." }
{ "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:"
{ $subsections c-ptr }
@ -111,7 +104,7 @@ $nl
{ $subsections "byte-arrays-gc" }
"C-style enumerated types are supported:"
{ $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: }
"A utility for defining " { $link "destructors" } " for deallocating memory:"
{ $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." } ;
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
"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
"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
"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
"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
@ -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."
$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:"
{ $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 } "." ;

15
basis/alien/data/data.factor
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
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
GENERIC: require-c-array ( c-type -- )
@ -48,7 +49,7 @@ M: word <c-direct-array>
heap-size malloc ; inline
: 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 )
[ nip (byte-array) dup ] 2keep memcpy ;
@ -62,8 +63,12 @@ M: memory-stream stream-read
swap memory>byte-array
] [ [ + ] change-index drop ] 2bi ;
: byte-array>memory ( byte-array base -- )
swap dup byte-length memcpy ; inline
M: byte-vector stream-write
[ 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 ;

59
basis/alien/fortran/fortran-tests.factor
View File

@ -4,6 +4,7 @@ alien.data alien.fortran alien.fortran.private alien.strings
classes.struct arrays assocs byte-arrays combinators fry
generalizations io.encodings.ascii kernel macros
macros.expander namespaces sequences shuffle tools.test vocabs.parser ;
FROM: alien.syntax => pointer: ;
QUALIFIED-WITH: alien.c-types c
IN: alien.fortran.tests
@ -100,16 +101,16 @@ intel-unix-abi fortran-abi [
! fortran-arg-type>c-type
[ c:void* { } ]
[ pointer: c:int { } ]
[ "integer" fortran-arg-type>c-type ] unit-test
[ c:void* { } ]
[ pointer: { c:int 3 } { } ]
[ "integer(3)" fortran-arg-type>c-type ] unit-test
[ c:void* { } ]
[ pointer: { c:int 0 } { } ]
[ "integer(*)" fortran-arg-type>c-type ] unit-test
[ c:void* { } ]
[ pointer: fortran_test_record { } ]
[
[
"alien.fortran.tests" use-vocab
@ -117,13 +118,13 @@ intel-unix-abi fortran-abi [
] with-manifest
] unit-test
[ c:char* { } ]
[ pointer: c:char { } ]
[ "character" fortran-arg-type>c-type ] unit-test
[ c:char* { } ]
[ pointer: c:char { } ]
[ "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
! fortran-ret-type>c-type
@ -131,7 +132,7 @@ intel-unix-abi fortran-abi [
[ c:char { } ]
[ "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
[ c:int { } ]
@ -143,22 +144,22 @@ intel-unix-abi fortran-abi [
[ c:float { } ]
[ "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
[ c:double { } ]
[ "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
[ c:void { c:void* } ]
[ c:void { pointer: complex-double } ]
[ "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
[ c:void { c:void* } ]
[ c:void { pointer: fortran_test_record } ]
[
[
"alien.fortran.tests" use-vocab
@ -168,19 +169,19 @@ intel-unix-abi fortran-abi [
! 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 ]
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 ]
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 ]
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 ]
unit-test
@ -201,7 +202,7 @@ intel-unix-abi fortran-abi [
! [fortran-invoke]
[
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
] 6 nkeep
! [fortran-results>]
@ -226,7 +227,7 @@ intel-unix-abi fortran-abi [
[ { [ drop ] } spread ]
} 1 ncleave
! [fortran-invoke]
[ c:float "funpack" "fun_times_" { void* } alien-invoke ]
[ c:float "funpack" "fun_times_" { pointer: { c:float 0 } } alien-invoke ]
1 nkeep
! [fortran-results>]
shuffle( reta aa -- reta aa )
@ -244,7 +245,7 @@ intel-unix-abi fortran-abi [
! [fortran-invoke]
[
c:void "funpack" "fun_times_"
{ void* void* }
{ pointer: complex-float pointer: { c:float 0 } }
alien-invoke
] 2 nkeep
! [fortran-results>]
@ -261,7 +262,7 @@ intel-unix-abi fortran-abi [
! [fortran-invoke]
[
c:void "funpack" "fun_times_"
{ c:char* long }
{ pointer: { c:char 20 } long }
alien-invoke
] 2 nkeep
! [fortran-results>]
@ -287,7 +288,7 @@ intel-unix-abi fortran-abi [
! [fortran-invoke]
[
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
] 7 nkeep
! [fortran-results>]
@ -321,16 +322,16 @@ f2c-abi fortran-abi [
[ { c:char 1 } ]
[ "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
[ c:void { c:char* c:long } ]
[ c:void { pointer: c:char c:long } ]
[ "character" fortran-ret-type>c-type ] unit-test
[ c:double { } ]
[ "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
[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
@ -344,7 +345,7 @@ gfortran-abi fortran-abi [
[ c:float { } ]
[ "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
[ complex-float { } ]
@ -356,10 +357,10 @@ gfortran-abi fortran-abi [
[ { char 1 } ]
[ "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
[ c:void { c:char* c:long } ]
[ c:void { pointer: c:char c:long } ]
[ "character" fortran-ret-type>c-type ] unit-test
[ complex-float { } ]
@ -368,7 +369,7 @@ gfortran-abi fortran-abi [
[ complex-double { } ]
[ "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
] with-variable

4
basis/alien/fortran/fortran.factor
View File

@ -392,13 +392,13 @@ PRIVATE>
: fortran-arg-type>c-type ( fortran-type -- c-type added-args )
parse-fortran-type
[ (fortran-type>c-type) resolve-pointer-type ]
[ (fortran-type>c-type) <pointer> ]
[ added-c-args ] bi ;
: fortran-ret-type>c-type ( fortran-type -- c-type added-args )
parse-fortran-type dup returns-by-value?
[ (fortran-ret-type>c-type) { } ] [
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 ;
: fortran-arg-types>c-types ( fortran-types -- c-types )

1
basis/alien/libraries/authors.txt
View File

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

11
basis/alien/libraries/libraries-docs.factor
View File

@ -60,6 +60,10 @@ $nl
}
"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
{ $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." } ;
@ -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:"
{ $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
} ;

35
basis/alien/libraries/libraries.factor
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.
USING: accessors alien alien.strings assocs io.backend
kernel namespaces destructors ;
kernel namespaces destructors sequences system io.pathnames ;
IN: alien.libraries
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
@ -14,6 +14,8 @@ libraries [ H{ } clone ] initialize
TUPLE: library path abi dll ;
ERROR: no-library name ;
: library ( name -- library ) libraries get at ;
: <library> ( path abi -- library )
@ -31,4 +33,31 @@ M: library dispose dll>> [ dispose ] when* ;
: add-library ( name path abi -- )
[ 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>

32
basis/alien/parser/parser-tests.factor
View File

@ -1,7 +1,7 @@
! (c)2009 Joe Groff bsd license
USING: accessors alien.c-types alien.parser alien.syntax
tools.test vocabs.parser parser eval vocabs.parser debugger
continuations ;
tools.test vocabs.parser parser eval debugger kernel
continuations words ;
IN: alien.parser.tests
TYPEDEF: char char2
@ -18,22 +18,28 @@ CONSTANT: eleven 11
[ { 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 eleven } ] [ "int[5][10][eleven]" parse-c-type ] unit-test
[ void* ] [ "int*" parse-c-type ] unit-test
[ void* ] [ "int**" parse-c-type ] unit-test
[ void* ] [ "int***" parse-c-type ] unit-test
[ void* ] [ "int****" parse-c-type ] unit-test
[ char* ] [ "char*" parse-c-type ] unit-test
[ void* ] [ "char**" parse-c-type ] unit-test
[ void* ] [ "char***" parse-c-type ] unit-test
[ void* ] [ "char****" parse-c-type ] unit-test
[ pointer: void ] [ "void*" parse-c-type ] unit-test
[ pointer: int ] [ "int*" parse-c-type ] unit-test
[ pointer: int* ] [ "int**" parse-c-type ] unit-test
[ pointer: int** ] [ "int***" parse-c-type ] unit-test
[ pointer: int*** ] [ "int****" parse-c-type ] unit-test
[ c-string ] [ "c-string" 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
] 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
TYPEDEF: int alien-parser-test-int ! reasonably unique name...

48
basis/alien/parser/parser.factor
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.
USING: accessors alien alien.c-types alien.parser
alien.libraries arrays assocs classes combinators
@ -18,35 +18,41 @@ IN: alien.parser
{
{ [ dup "void" = ] [ drop void ] }
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
{ [ "*" ?tail ] [ (parse-c-type) <pointer> ] }
{ [ dup search ] [ parse-c-type-name ] }
{ [ "**" ?tail ] [ drop void* ] }
{ [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] }
[ dup search [ ] [ no-word ] ?if ]
} cond ;
: 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) dup valid-c-type? [ no-c-type ] unless ;
: scan-c-type ( -- c-type )
scan dup "{" =
[ drop \ } parse-until >array ]
[ parse-c-type ] if ;
scan {
{ [ dup "{" = ] [ drop \ } parse-until >array ] }
{ [ dup "pointer:" = ] [ drop scan-c-type <pointer> ] }
[ parse-c-type ]
} cond ;
: reset-c-type ( word -- )
dup "struct-size" word-prop
[ dup [ forget-class ] [ { "struct-size" } reset-props ] bi ] when
{
"c-type"
"pointer-c-type"
"callback-effect"
"callback-library"
} reset-props ;
ERROR: *-in-c-type-name name ;
: validate-c-type-name ( name -- name )
dup "*" tail?
[ *-in-c-type-name ] when ;
: CREATE-C-TYPE ( -- word )
scan current-vocab create {
scan validate-c-type-name current-vocab create {
[ fake-definition ]
[ set-word ]
[ reset-c-type ]
@ -61,19 +67,27 @@ IN: alien.parser
] bi
[ 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 )
[
2 group [ first2 normalize-c-arg 2array ] map
unzip [ "," ?tail drop ] map
]
[ [ { } ] [ 1array ] if-void ]
[ [ { } ] [ return-type-name 1array ] if-void ]
bi* <effect> ;
: function-quot ( return library function types -- quot )
'[ _ _ _ _ alien-invoke ] ;
:: make-function ( return! library function! parameters -- word quot effect )
return function normalize-c-arg function! return!
:: make-function ( return library function parameters -- word quot effect )
return function normalize-c-arg :> ( return function )
function create-in dup reset-generic
return library function
parameters return parse-arglist [ function-quot ] dip ;
@ -88,13 +102,10 @@ IN: alien.parser
make-function define-declared ;
: callback-quot ( return types abi -- quot )
[ [ ] 3curry dip alien-callback ] 3curry ;
'[ [ _ _ _ ] dip alien-callback ] ;
: library-abi ( lib -- abi )
library [ abi>> ] [ "cdecl" ] if* ;
:: make-callback-type ( lib return! type-name! parameters -- word quot effect )
return type-name normalize-c-arg type-name! return!
:: make-callback-type ( lib return type-name parameters -- word quot effect )
return type-name normalize-c-arg :> ( return type-name )
type-name current-vocab create :> type-word
type-word [ reset-generic ] [ reset-c-type ] bi
void* type-word typedef
@ -115,4 +126,3 @@ PREDICATE: alien-function-word < word
PREDICATE: alien-callback-type-word < typedef-word
"callback-effect" word-prop ;

13
basis/alien/prettyprint/prettyprint.factor
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 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 -- )
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: string pprint-c-type text ;
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 synopsis*

2
basis/alien/remote-control/remote-control.factor
View File

@ -6,7 +6,7 @@ eval ;
IN: alien.remote-control
: eval-callback ( -- callback )
void* { char* } "cdecl"
void* { c-string } "cdecl"
[ eval>string utf8 malloc-string ] alien-callback ;
: yield-callback ( -- callback )

12
basis/alien/syntax/syntax-docs.factor
View File

@ -40,11 +40,11 @@ $nl
}
"You can define a word for invoking it:"
{ $unchecked-example
"LIBRARY: foo\nFUNCTION: void the_answer ( char* question, int value ) ;"
"USE: compiler"
"LIBRARY: foo\nFUNCTION: void the_answer ( c-string question, int value ) ;"
"\"the question\" 42 the_answer"
"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:"
{ $code
"FUNCTION: void glHint ( GLenum target, GLenum mode ) ;"
@ -54,7 +54,7 @@ $nl
HELP: TYPEDEF:
{ $syntax "TYPEDEF: old new" }
{ $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." } ;
HELP: C-ENUM:
@ -72,12 +72,12 @@ HELP: C-ENUM:
HELP: C-TYPE:
{ $syntax "C-TYPE: type" }
{ $values { "type" "a new C type" } }
{ $description "Defines a new, opaque C type. Since it is opaque, " { $snippet "type" } " will not be directly usable as a parameter or return type of a " { $link POSTPONE: FUNCTION: } " or as a slot of a " { $link POSTPONE: STRUCT: } ". However, it can be used as the type of a pointer (that is, as " { $snippet "type*" } ")." $nl
{ $snippet "C-TYPE:" } " can also be used to forward-declare C types to enable circular dependencies. For example:"
{ $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, allowing circular dependencies to occur between types. For example:"
{ $code """C-TYPE: forward
STRUCT: backward { x forward* } ;
STRUCT: forward { x backward* } ; """ } }
{ $notes "Primitive C types are also displayed using " { $snippet "C-TYPE:" } " syntax when they are displayed by " { $link see } "." } ;
{ $notes "Primitive C types are displayed using " { $snippet "C-TYPE:" } " syntax when they are " { $link see } "n." } ;
HELP: CALLBACK:
{ $syntax "CALLBACK: return type ( parameters ) ;" }

3
basis/alien/syntax/syntax.factor
View File

@ -47,3 +47,6 @@ SYNTAX: &:
[ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;
SYNTAX: C-GLOBAL: scan-c-type CREATE-WORD define-global ;
SYNTAX: pointer:
scan-c-type <pointer> suffix! ;

4
basis/base64/base64.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: combinators io io.binary io.encodings.binary
io.streams.byte-array kernel math namespaces
sequences strings io.crlf ;
sequences strings ;
IN: base64
ERROR: malformed-base64 ;
@ -35,7 +35,7 @@ SYMBOL: column
: write1-lines ( ch -- )
write1
column get [
1 + [ 76 = [ crlf ] when ]
1 + [ 76 = [ B{ CHAR: \r CHAR: \n } write ] when ]
[ 76 mod column set ] bi
] when* ;

2
basis/bit-arrays/bit-arrays.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007, 2010 Slava Pestov.
! 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
parser prettyprint.custom fry ;
IN: bit-arrays

2
basis/bootstrap/compiler/timing/tags.txt
View File

@ -1 +1 @@
unportable
untested

26
basis/cairo/ffi/ffi.factor
View File

@ -18,7 +18,7 @@ IN: cairo.ffi
LIBRARY: cairo
FUNCTION: int cairo_version ( ) ;
FUNCTION: char* cairo_version_string ( ) ;
FUNCTION: c-string cairo_version_string ( ) ;
TYPEDEF: int cairo_bool_t
@ -38,7 +38,7 @@ TYPEDEF: void* cairo_pattern_t
TYPEDEF: void* cairo_destroy_func_t
: 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
STRUCT: cairo_user_data_key_t
@ -79,11 +79,11 @@ CONSTANT: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000
TYPEDEF: void* cairo_write_func_t
: 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
: 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
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.
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
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 ) ;
FUNCTION: void
cairo_show_text ( cairo_t* cr, char* utf8 ) ;
cairo_show_text ( cairo_t* cr, c-string utf8 ) ;
FUNCTION: void
cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
FUNCTION: void
cairo_text_path ( cairo_t* cr, char* utf8 ) ;
cairo_text_path ( cairo_t* cr, c-string utf8 ) ;
FUNCTION: void
cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
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
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 ) ;
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
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
cairo_status ( cairo_t* cr ) ;
FUNCTION: char*
FUNCTION: c-string
cairo_status_to_string ( cairo_status_t status ) ;
! Surface manipulation
@ -731,7 +731,7 @@ FUNCTION: cairo_content_t
cairo_surface_get_content ( cairo_surface_t* surface ) ;
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
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 ) ;
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*
cairo_image_surface_get_data ( cairo_surface_t* surface ) ;
@ -804,7 +804,7 @@ FUNCTION: int
cairo_image_surface_get_stride ( cairo_surface_t* surface ) ;
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*
cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ;

6
basis/calendar/calendar-docs.factor
View File

@ -309,7 +309,7 @@ HELP: time-
} ;
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" } "." }
{ $examples
{ $example "USING: accessors calendar prettyprint ;"
@ -319,7 +319,7 @@ HELP: convert-timezone
} ;
HELP: >local-time
{ $values { "timestamp" timestamp } { "timestamp" timestamp } }
{ $values { "timestamp" timestamp } { "timestamp'" timestamp } }
{ $description "Converts the " { $snippet "timestamp" } " to the timezone of your computer." }
{ $examples
{ $example "USING: accessors calendar kernel prettyprint ;"
@ -329,7 +329,7 @@ HELP: >local-time
} ;
HELP: >gmt
{ $values { "timestamp" timestamp } { "timestamp" timestamp } }
{ $values { "timestamp" timestamp } { "timestamp'" timestamp } }
{ $description "Converts the " { $snippet "timestamp" } " to the GMT timezone." }
{ $examples
{ $example "USING: accessors calendar kernel prettyprint ;"

6
basis/calendar/calendar.factor
View File

@ -316,15 +316,15 @@ M: duration <=> [ duration>years ] compare ;
GENERIC: time- ( time1 time2 -- time3 )
: convert-timezone ( timestamp duration -- timestamp )
: convert-timezone ( timestamp duration -- timestamp' )
over gmt-offset>> over = [ drop ] [
[ over gmt-offset>> time- time+ ] keep >>gmt-offset
] if ;
: >local-time ( timestamp -- timestamp )
: >local-time ( timestamp -- timestamp' )
gmt-offset-duration convert-timezone ;
: >gmt ( timestamp -- timestamp )
: >gmt ( timestamp -- timestamp' )
instant convert-timezone ;
M: timestamp <=> ( ts1 ts2 -- n )

1
basis/calendar/unix/platforms.txt Normal file
View File

@ -0,0 +1 @@
unix

1
basis/calendar/unix/tags.txt
View File

@ -1 +0,0 @@
unportable

2
basis/calendar/unix/unix.factor
View File

@ -21,7 +21,7 @@ IN: calendar.unix
timespec>seconds since-1970 ;
: get-time ( -- alien )
f time <time_t> localtime tm memory>struct ;
f time <time_t> localtime ;
: timezone-name ( -- string )
get-time zone>> ;

1
basis/calendar/windows/platforms.txt Normal file
View File

@ -0,0 +1 @@
windows

1
basis/calendar/windows/tags.txt
View File

@ -1 +0,0 @@
unportable

2
basis/classes/struct/struct-docs.factor
View File

@ -159,7 +159,7 @@ $nl
"A C function which returns a struct by value:"
{ $code
"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:"
{ $code

109
basis/classes/struct/struct-tests.factor
View File

@ -1,11 +1,11 @@
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.data ascii
assocs byte-arrays classes.struct classes.tuple.private
combinators compiler.tree.debugger compiler.units destructors
io.encodings.utf8 io.pathnames io.streams.string kernel libc
literals math mirrors namespaces prettyprint
prettyprint.config see sequences specialized-arrays system
tools.test parser lexer eval layouts ;
USING: accessors alien alien.c-types alien.data alien.syntax ascii
assocs byte-arrays classes.struct classes.tuple.parser
classes.tuple.private classes.tuple combinators compiler.tree.debugger
compiler.units destructors io.encodings.utf8 io.pathnames
io.streams.string kernel libc literals math mirrors namespaces
prettyprint prettyprint.config see sequences specialized-arrays system
tools.test parser lexer eval layouts generic.single classes ;
FROM: math => float ;
QUALIFIED-WITH: alien.c-types c
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
STRUCT: struct-test-string-ptr
{ x char* } ;
{ x c-string } ;
[ "hello world" ] [
[
@ -219,7 +219,7 @@ UNION-STRUCT: struct-test-float-and-bits
{ type bool }
{ class object }
}
} ] [ "struct-test-foo" c-type fields>> ] unit-test
} ] [ struct-test-foo c-type fields>> ] unit-test
[ {
T{ struct-slot-spec
@ -236,7 +236,7 @@ UNION-STRUCT: struct-test-float-and-bits
{ class integer }
{ 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
{ x int } ;
@ -334,24 +334,40 @@ STRUCT: struct-that's-a-word { x int } ;
"struct-class-test-1" parse-stream
] [ 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
[
"USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
eval( -- value )
] must-fail
] [ error>> no-method? ] must-fail-with
! 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( -- )
] must-fail
] [ error>> bad-superclass? ] must-fail-with
! Remove c-type when struct class is forgotten
[ ] [
"USE: classes.struct IN: classes.struct.tests TUPLE: a-struct ;" eval( -- )
] unit-test
! Changing a superclass into a struct should reset the subclass
TUPLE: will-become-struct ;
[ 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
{ a uint bits: 12 }
@ -366,6 +382,63 @@ STRUCT: bit-field-test
[ 1 ] [ bit-field-test <struct> 257 >>c c>> ] 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? [
STRUCT: ppc-align-test-1
{ x longlong }

36
basis/classes/struct/struct.factor
View File

@ -8,7 +8,8 @@ generalizations generic.parser kernel kernel.private lexer libc
locals macros make math math.order parser quotations sequences
slots slots.private specialized-arrays vectors words summary
namespaces assocs vocabs.parser math.functions
classes.struct.bit-accessors bit-arrays ;
classes.struct.bit-accessors bit-arrays
stack-checker.dependencies ;
QUALIFIED: math
IN: classes.struct
@ -32,8 +33,6 @@ TUPLE: struct-bit-slot-spec < struct-slot-spec
PREDICATE: struct-class < tuple-class
superclass \ struct eq? ;
M: struct-class valid-superclass? drop f ;
SLOT: fields
: struct-slots ( struct-class -- slots )
@ -47,11 +46,11 @@ M: struct >c-ptr
M: struct equal?
{
[ [ class ] bi@ = ]
[ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
[ [ >c-ptr ] [ binary-object ] bi* memory= ]
} 2&& ; inline
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
@ -126,11 +125,19 @@ M: struct-bit-slot-spec (writer-quot)
: (unboxer-quot) ( class -- quot )
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>
M: struct-class boa>object
swap pad-struct-slots
[ <struct> ] [ struct-slots ] bi
[ <struct> ] [ struct-slots ] bi
[ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
M: struct-class initial-value* <struct> ; inline
@ -140,10 +147,11 @@ M: struct-class initial-value* <struct> ; inline
GENERIC: struct-slot-values ( struct -- sequence )
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
nip (writer-quot) ;
nip '[ _ write-struct-slot ] ;
: offset-of ( field struct -- offset )
struct-slots slot-named offset>> ; inline
@ -195,7 +203,7 @@ M: struct-c-type c-struct? drop t ;
define-inline-method ;
: clone-underlying ( struct -- byte-array )
[ >c-ptr ] [ byte-length ] bi memory>byte-array ; inline
binary-object memory>byte-array ; inline
: (define-clone-method) ( class -- )
[ \ clone ]
@ -273,7 +281,7 @@ M: struct binary-zero? >c-ptr [ 0 = ] all? ;
[ type>> c-type drop ] each ;
: 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 -- )
slots empty? [ struct-must-have-slots ] when
@ -298,9 +306,6 @@ PRIVATE>
: define-union-struct-class ( class slots -- )
[ 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 ;
: struct-slot-class ( c-type -- class' )
@ -348,7 +353,7 @@ PRIVATE>
<PRIVATE
: parse-struct-slot ( -- slot )
scan scan-c-type \ } parse-until <struct-slot-spec> ;
: parse-struct-slots ( slots -- slots' more? )
scan {
{ ";" [ f ] }
@ -358,7 +363,8 @@ PRIVATE>
} case ;
: 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>
SYNTAX: STRUCT:

1
basis/cocoa/application/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/application/tags.txt
View File

@ -1 +0,0 @@
unportable

4
basis/cocoa/callbacks/callbacks.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Kevin Reid.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces cocoa cocoa.classes
cocoa.subclassing debugger ;
USING: alien.c-types assocs kernel namespaces cocoa
cocoa.classes cocoa.runtime cocoa.subclassing debugger ;
IN: cocoa.callbacks
SYMBOL: callbacks

1
basis/cocoa/callbacks/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/callbacks/tags.txt
View File

@ -1 +0,0 @@
unportable

1
basis/cocoa/cocoa.factor
View File

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

1
basis/cocoa/dialogs/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/dialogs/tags.txt
View File

@ -1 +0,0 @@
unportable

1
basis/cocoa/enumeration/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/enumeration/tags.txt
View File

@ -1 +0,0 @@
unportable

19
basis/cocoa/messages/messages.factor
View File

@ -76,13 +76,13 @@ MACRO: (send) ( selector super? -- quot )
: super-send ( receiver args... selector -- return... ) t (send) ; inline
! 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 )
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 ] [
2drop "No such class: " prepend throw
] if
@ -110,7 +110,7 @@ H{
{ "d" c:double }
{ "B" c:bool }
{ "v" c:void }
{ "*" c:char* }
{ "*" c:c-string }
{ "?" unknown_type }
{ "@" id }
{ "#" Class }
@ -229,16 +229,19 @@ ERROR: no-objc-type name ;
: class-exists? ( string -- class ) objc_getClass >boolean ;
: define-objc-class-word ( quot name -- )
[ class-startup-hooks get set-at ]
[ class-init-hooks get set-at ]
[
[ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
(( -- class )) define-declared
] bi ;
: import-objc-class ( name quot -- )
over define-objc-class-word
[ objc-class register-objc-methods ]
[ objc-meta-class register-objc-methods ] bi ;
2dup swap define-objc-class-word
over class-exists? [ drop ] [ call( -- ) ] if
dup class-exists? [
[ objc_getClass register-objc-methods ]
[ objc_getMetaClass register-objc-methods ] bi
] [ drop ] if ;
: root-class ( class -- root )
dup class_getSuperclass [ root-class ] [ ] ?if ;

1
basis/cocoa/messages/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/messages/tags.txt
View File

@ -1 +0,0 @@
unportable

1
basis/cocoa/nibs/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/nibs/tags.txt
View File

@ -1 +0,0 @@
unportable

1
basis/cocoa/pasteboard/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/pasteboard/tags.txt
View File

@ -1 +0,0 @@
unportable

1
basis/cocoa/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/plists/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/plists/tags.txt
View File

@ -1 +0,0 @@
unportable

1
basis/cocoa/runtime/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

16
basis/cocoa/runtime/runtime.factor
View File

@ -7,11 +7,11 @@ TYPEDEF: void* SEL
TYPEDEF: void* id
FUNCTION: char* sel_getName ( SEL aSelector ) ;
FUNCTION: c-string sel_getName ( 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* Method
@ -33,13 +33,13 @@ CONSTANT: CLS_METHOD_ARRAY HEX: 100
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: 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: char* class_getName ( Class cls ) ;
FUNCTION: c-string class_getName ( Class cls ) ;
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_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 ) ;

1
basis/cocoa/runtime/tags.txt
View File

@ -1 +0,0 @@
unportable

1
basis/cocoa/subclassing/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/subclassing/tags.txt
View File

@ -1 +0,0 @@
unportable

2
basis/cocoa/tags.txt
View File

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

1
basis/cocoa/types/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/types/tags.txt
View File

@ -1 +0,0 @@
unportable

1
basis/cocoa/views/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/views/tags.txt
View File

@ -1 +0,0 @@
unportable

1
basis/cocoa/windows/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/cocoa/windows/tags.txt
View File

@ -1 +0,0 @@
unportable

9
basis/compiler/crossref/crossref-tests.factor Normal file
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

4
basis/compiler/tests/alien.factor
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
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
[ "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
STRUCT: bool-field-test
{ name char* }
{ name c-string }
{ on bool }
{ parents short } ;

11
basis/compiler/tests/redefine22.factor Normal file
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

13
basis/compiler/tests/redefine23.factor Normal file
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

39
basis/compiler/tests/redefine24.factor Normal file
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

13
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -51,11 +51,16 @@ GENERIC: cleanup* ( node -- node/nodes )
[ in-d>> #drop ]
bi prefix ;
: record-predicate-folding ( #call -- )
[ node-input-infos first class>> ]
: >predicate-folding< ( #call -- value-info class result )
[ node-input-infos first ]
[ word>> "predicating" word-prop ]
[ node-output-infos first literal>> ] tri
[ depends-on-class<= ] [ depends-on-classes-disjoint ] if ;
[ node-output-infos first literal>> ] tri ;
: record-predicate-folding ( #call -- )
>predicate-folding< pick literal?>>
[ [ literal>> ] 2dip depends-on-instance-predicate ]
[ [ class>> ] 2dip depends-on-class-predicate ]
if ;
: record-folding ( #call -- )
dup word>> predicate?

21
basis/compiler/tree/propagation/info/info.factor
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.
USING: assocs classes classes.algebra classes.tuple
classes.tuple.private kernel accessors math math.intervals namespaces
sequences sequences.private words combinators memoize
combinators.short-circuit byte-arrays strings arrays layouts
cpu.architecture compiler.tree.propagation.copy ;
classes.tuple.private classes.singleton kernel accessors math
math.intervals namespaces sequences sequences.private words
combinators memoize combinators.short-circuit byte-arrays
strings arrays layouts cpu.architecture
compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
: false-class? ( class -- ? ) \ f class<= ;
@ -65,9 +66,17 @@ DEFER: <literal-info>
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 )
empty-interval >>interval
dup literal>> class >>class
dup literal>> literal-class >>class
dup literal>> {
{ [ dup real? ] [ [a,a] >>interval ] }
{ [ dup tuple? ] [ tuple-slot-infos >>slots ] }

6
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -648,7 +648,7 @@ M: array iterate first t ; inline
] final-info drop
] unit-test
[ V{ word } ] [
[ V{ t } ] [
[ { hashtable } declare hashtable instance? ] final-classes
] unit-test
@ -660,7 +660,7 @@ M: array iterate first t ; inline
[ { assoc } declare hashtable instance? ] final-classes
] unit-test
[ V{ word } ] [
[ V{ t } ] [
[ { string } declare string? ] final-classes
] unit-test
@ -774,7 +774,7 @@ MIXIN: empty-mixin
[ { fixnum } declare log2 ] final-classes
] unit-test
[ V{ word } ] [
[ V{ t } ] [
[ { fixnum } declare log2 0 >= ] final-classes
] unit-test

11
basis/compiler/tree/propagation/simple/simple.factor
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.
USING: fry accessors kernel sequences sequences.private assocs
words namespaces classes.algebra combinators
@ -72,7 +72,7 @@ M: #declare propagate-before
: foldable-call? ( #call word -- ? )
{
[ nip "foldable" word-prop ]
[ nip foldable? ]
[ drop literal-inputs? ]
[ input-classes-match? ]
} 2&& ;
@ -93,11 +93,8 @@ M: #declare propagate-before
recover ;
: predicate-output-infos/class ( info class -- info )
[ class>> ] dip {
{ [ 2dup class<= ] [ t <literal-info> ] }
{ [ 2dup classes-intersect? not ] [ f <literal-info> ] }
[ object-info ]
} cond 2nip ;
[ class>> ] dip compare-classes
dup +incomparable+ eq? [ drop object-info ] [ <literal-info> ] if ;
: predicate-output-infos ( info class -- info )
over literal?>>

2
basis/compression/lzw/lzw-docs.factor
View File

@ -20,7 +20,6 @@ HELP: tiff-lzw-uncompress
HELP: lzw-read
{ $values
{ "lzw" lzw }
{ "lzw" lzw } { "n" integer }
}
{ $description "Read the next LZW code." } ;
@ -48,7 +47,6 @@ HELP: code-space-full?
HELP: reset-lzw-uncompress
{ $values
{ "lzw" lzw }
{ "lzw" lzw }
}
{ $description "Reset the LZW uncompressor state (either at initialization time or immediately after receiving a Clear Code). " } ;

143
basis/concurrency/mailboxes/mailboxes-tests.factor
View File

@ -1,89 +1,54 @@
USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions
vectors sequences threads tools.test math kernel strings namespaces
continuations calendar destructors ;
IN: concurrency.mailboxes.tests
{ 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as
[ V{ 1 2 3 } ] [
0 <vector>
<mailbox>
[ mailbox-get swap push ] in-thread
[ mailbox-get swap push ] in-thread
[ mailbox-get swap push ] in-thread
1 over mailbox-put
2 over mailbox-put
3 swap mailbox-put
] unit-test
[ V{ 1 2 3 } ] [
0 <vector>
<mailbox>
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
1 over mailbox-put
2 over mailbox-put
3 swap mailbox-put
] unit-test
[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
0 <vector>
<mailbox>
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ string? ] mailbox-get? swap push ] in-thread
[ [ string? ] mailbox-get? swap push ] in-thread
1 over mailbox-put
"junk" over mailbox-put
[ 456 ] over mailbox-put
3 over mailbox-put
"junk2" over mailbox-put
mailbox-get
] 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" } ] [
<mailbox>
"foo" over mailbox-put
"bar" over mailbox-put
mailbox-get-all
] unit-test
[
<mailbox> 1 seconds mailbox-get-timeout
] [ wait-timeout? ] must-fail-with
USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions
vectors sequences threads tools.test math kernel strings namespaces
continuations calendar destructors ;
IN: concurrency.mailboxes.tests
{ 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as
[ V{ 1 2 3 } ] [
0 <vector>
<mailbox>
[ mailbox-get swap push ] in-thread
[ mailbox-get swap push ] in-thread
[ mailbox-get swap push ] in-thread
1 over mailbox-put
2 over mailbox-put
3 swap mailbox-put
] unit-test
[ V{ 1 2 3 } ] [
0 <vector>
<mailbox>
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
1 over mailbox-put
2 over mailbox-put
3 swap mailbox-put
] unit-test
[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
0 <vector>
<mailbox>
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ string? ] mailbox-get? swap push ] in-thread
[ [ string? ] mailbox-get? swap push ] in-thread
1 over mailbox-put
"junk" over mailbox-put
[ 456 ] over mailbox-put
3 over mailbox-put
"junk2" over mailbox-put
mailbox-get
] unit-test
[ { "foo" "bar" } ] [
<mailbox>
"foo" over mailbox-put
"bar" over mailbox-put
mailbox-get-all
] unit-test
[
<mailbox> 1 seconds mailbox-get-timeout
] [ wait-timeout? ] must-fail-with

190
basis/concurrency/mailboxes/mailboxes.factor
View File

@ -1,96 +1,94 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: dlists deques threads sequences continuations
destructors namespaces math quotations words kernel
arrays assocs init system concurrency.conditions accessors
debugger debugger.threads locals fry ;
IN: concurrency.mailboxes
TUPLE: mailbox < disposable threads data ;
M: mailbox dispose* threads>> notify-all ;
: <mailbox> ( -- mailbox )
mailbox new-disposable <dlist> >>threads <dlist> >>data ;
: mailbox-empty? ( mailbox -- bool )
data>> deque-empty? ;
: mailbox-put ( obj mailbox -- )
[ data>> push-front ]
[ threads>> notify-all ] bi yield ;
: wait-for-mailbox ( mailbox timeout -- )
[ threads>> ] dip "mailbox" wait ;
:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
mailbox check-disposed
mailbox data>> pred dlist-any? [
mailbox timeout wait-for-mailbox
mailbox timeout pred block-unless-pred
] unless ; inline recursive
: block-if-empty ( mailbox timeout -- mailbox )
over check-disposed
over mailbox-empty? [
2dup wait-for-mailbox block-if-empty
] [
drop
] if ;
: mailbox-peek ( mailbox -- obj )
data>> peek-back ;
: mailbox-get-timeout ( mailbox timeout -- obj )
block-if-empty data>> pop-back ;
: mailbox-get ( mailbox -- obj )
f mailbox-get-timeout ;
: mailbox-get-all-timeout ( mailbox timeout -- array )
block-if-empty
[ dup mailbox-empty? not ]
[ dup data>> pop-back ]
produce nip ;
: mailbox-get-all ( mailbox -- array )
f mailbox-get-all-timeout ;
: while-mailbox-empty ( mailbox quot -- )
[ '[ _ mailbox-empty? ] ] dip while ; inline
: mailbox-get-timeout? ( mailbox timeout pred -- obj )
[ block-unless-pred ]
[ [ drop data>> ] dip delete-node-if ]
3bi ; inline
: mailbox-get? ( mailbox pred -- obj )
f swap mailbox-get-timeout? ; inline
: wait-for-close-timeout ( mailbox timeout -- )
over disposed>>
[ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ;
: wait-for-close ( mailbox -- )
f wait-for-close-timeout ;
TUPLE: linked-error error thread ;
M: linked-error error.
[ thread>> error-in-thread. ] [ error>> error. ] bi ;
C: <linked-error> linked-error
: ?linked ( message -- message )
dup linked-error? [ rethrow ] when ;
TUPLE: linked-thread < thread supervisor ;
M: linked-thread error-in-thread
[ <linked-error> ] [ supervisor>> ] bi mailbox-put ;
: <linked-thread> ( quot name mailbox -- thread' )
[ linked-thread new-thread ] dip >>supervisor ;
: spawn-linked-to ( quot name mailbox -- thread )
<linked-thread> [ (spawn) ] keep ;
! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: dlists deques threads sequences continuations namespaces
math quotations words kernel arrays assocs init system
concurrency.conditions accessors debugger debugger.threads
locals fry ;
IN: concurrency.mailboxes
TUPLE: mailbox threads data ;
: <mailbox> ( -- mailbox )
mailbox new
<dlist> >>threads
<dlist> >>data ;
: mailbox-empty? ( mailbox -- bool )
data>> deque-empty? ;
: mailbox-put ( obj mailbox -- )
[ data>> push-front ]
[ threads>> notify-all ] bi yield ;
: wait-for-mailbox ( mailbox timeout -- )
[ threads>> ] dip "mailbox" wait ;
:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
mailbox data>> pred dlist-any? [
mailbox timeout wait-for-mailbox
mailbox timeout pred block-unless-pred
] unless ; inline recursive
: block-if-empty ( mailbox timeout -- mailbox )
over mailbox-empty? [
2dup wait-for-mailbox block-if-empty
] [
drop
] if ;
: mailbox-peek ( mailbox -- obj )
data>> peek-back ;
: mailbox-get-timeout ( mailbox timeout -- obj )
block-if-empty data>> pop-back ;
: mailbox-get ( mailbox -- obj )
f mailbox-get-timeout ;
: mailbox-get-all-timeout ( mailbox timeout -- array )
block-if-empty
[ dup mailbox-empty? not ]
[ dup data>> pop-back ]
produce nip ;
: mailbox-get-all ( mailbox -- array )
f mailbox-get-all-timeout ;
: while-mailbox-empty ( mailbox quot -- )
[ '[ _ mailbox-empty? ] ] dip while ; inline
: mailbox-get-timeout? ( mailbox timeout pred -- obj )
[ block-unless-pred ]
[ [ drop data>> ] dip delete-node-if ]
3bi ; inline
: mailbox-get? ( mailbox pred -- obj )
f swap mailbox-get-timeout? ; inline
: wait-for-close-timeout ( mailbox timeout -- )
over disposed>>
[ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ;
: wait-for-close ( mailbox -- )
f wait-for-close-timeout ;
TUPLE: linked-error error thread ;
M: linked-error error.
[ thread>> error-in-thread. ] [ error>> error. ] bi ;
C: <linked-error> linked-error
: ?linked ( message -- message )
dup linked-error? [ rethrow ] when ;
TUPLE: linked-thread < thread supervisor ;
M: linked-thread error-in-thread
[ <linked-error> ] [ supervisor>> ] bi mailbox-put ;
: <linked-thread> ( quot name mailbox -- thread' )
[ linked-thread new-thread ] dip >>supervisor ;
: spawn-linked-to ( quot name mailbox -- thread )
<linked-thread> [ (spawn) ] keep ;

53
basis/concurrency/promises/promises.factor
View File

@ -1,26 +1,27 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors concurrency.mailboxes kernel continuations ;
IN: concurrency.promises
TUPLE: promise mailbox ;
: <promise> ( -- promise )
<mailbox> promise boa ;
: promise-fulfilled? ( promise -- ? )
mailbox>> mailbox-empty? not ;
ERROR: promise-already-fulfilled promise ;
: fulfill ( value promise -- )
dup promise-fulfilled? [
promise-already-fulfilled
] [
mailbox>> mailbox-put
] if ;
: ?promise-timeout ( promise timeout -- result )
[ mailbox>> ] dip block-if-empty mailbox-peek ;
: ?promise ( promise -- result )
f ?promise-timeout ;
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors concurrency.mailboxes kernel continuations ;
IN: concurrency.promises
TUPLE: promise mailbox ;
: <promise> ( -- promise )
<mailbox> promise boa ;
: promise-fulfilled? ( promise -- ? )
mailbox>> mailbox-empty? not ;
ERROR: promise-already-fulfilled promise ;
: fulfill ( value promise -- )
dup promise-fulfilled? [
promise-already-fulfilled
] [
mailbox>> mailbox-put
] if ;
: ?promise-timeout ( promise timeout -- result )
[ mailbox>> ] dip block-if-empty mailbox-peek ;
: ?promise ( promise -- result )
f ?promise-timeout ;

1
basis/core-foundation/arrays/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/core-foundation/arrays/tags.txt
View File

@ -1,2 +1 @@
unportable
bindings

1
basis/core-foundation/attributed-strings/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/core-foundation/attributed-strings/tags.txt
View File

@ -1,2 +1 @@
unportable
bindings

1
basis/core-foundation/bundles/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/core-foundation/bundles/tags.txt
View File

@ -1,2 +1 @@
unportable
bindings

2
basis/core-foundation/data/data.factor
View File

@ -12,7 +12,7 @@ CONSTANT: kCFPropertyListImmutable 0
CONSTANT: kCFPropertyListMutableContainers 1
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 ) ;

1
basis/core-foundation/data/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/core-foundation/data/tags.txt
View File

@ -1,2 +1 @@
unportable
bindings

1
basis/core-foundation/dictionaries/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/core-foundation/dictionaries/tags.txt
View File

@ -1,2 +1 @@
unportable
bindings

1
basis/core-foundation/file-descriptors/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/core-foundation/file-descriptors/tags.txt
View File

@ -1,2 +1 @@
unportable
bindings

12
basis/core-foundation/fsevents/fsevents.factor
View File

@ -36,7 +36,6 @@ STRUCT: FSEventStreamContext
{ release void* }
{ copyDescription void* } ;
! callback(
CALLBACK: void FSEventStreamCallback ( FSEventStreamRef streamRef, void* clientCallBackInfo, size_t numEvents, void* eventPaths, FSEventStreamEventFlags* eventFlags, FSEventStreamEventId* eventIds ) ;
CONSTANT: FSEventStreamEventIdSinceNow HEX: FFFFFFFFFFFFFFFF
@ -173,16 +172,7 @@ SYMBOL: event-stream-callbacks
info event-stream-callbacks get at [ drop ] or call( changes -- ) ;
: master-event-source-callback ( -- alien )
"void"
{
"FSEventStreamRef"
"void*" ! info
"size_t" ! numEvents
"void*" ! eventPaths
"FSEventStreamEventFlags*"
"FSEventStreamEventId*"
}
"cdecl" [ (master-event-source-callback) ] alien-callback ;
[ (master-event-source-callback) ] FSEventStreamCallback ;
TUPLE: event-stream < disposable info handle ;

1
basis/core-foundation/fsevents/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/core-foundation/fsevents/tags.txt
View File

@ -1 +0,0 @@
unportable

1
basis/core-foundation/numbers/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

1
basis/core-foundation/numbers/tags.txt
View File

@ -1 +0,0 @@
unportable

1
basis/core-foundation/platforms.txt Normal file
View File

@ -0,0 +1 @@
macosx

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