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

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

db4
Guillaume Nargeot 2009-09-22 11:16:49 +09:00
parent 941fc66a43 962d039852
commit 0b01117e90
302 changed files with 7045 additions and 4682 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
Makefile
View File

@ -18,6 +18,10 @@ else
CFLAGS += -O3
endif
ifdef REENTRANT
CFLAGS += -DFACTOR_REENTRANT
endif
CFLAGS += $(SITE_CFLAGS)
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
@ -164,17 +168,17 @@ macosx.app: factor
Factor.app/Contents/MacOS/factor
$(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
$(LINKER) $(ENGINE) $(DLL_OBJS)
$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
$(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
$(LINKER) $(ENGINE) $(DLL_OBJS)
$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
$(TEST_LIBRARY): vm/ffi_test.o
$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
$(TOOLCHAIN_PREFIX)$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
clean:
rm -f vm/*.o
@ -187,22 +191,22 @@ tags:
etags vm/*.{cpp,hpp,mm,S,c}
vm/resources.o:
$(WINDRES) vm/factor.rs vm/resources.o
$(TOOLCHAIN_PREFIX)$(WINDRES) vm/factor.rs vm/resources.o
vm/ffi_test.o: vm/ffi_test.c
$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $<
$(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $<
.c.o:
$(CC) -c $(CFLAGS) -o $@ $<
$(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) -o $@ $<
.cpp.o:
$(CPP) -c $(CFLAGS) -o $@ $<
$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
.S.o:
$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
$(TOOLCHAIN_PREFIX)$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
.mm.o:
$(CPP) -c $(CFLAGS) -o $@ $<
$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
.PHONY: factor tags clean

2
basis/alien/arrays/arrays-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.syntax help.markup byte-arrays alien.c-types alien.data ;
IN: alien.arrays
USING: help.syntax help.markup byte-arrays alien.c-types ;
ARTICLE: "c-arrays" "C arrays"
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."

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

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.strings alien.c-types alien.accessors
arrays words sequences math kernel namespaces fry libc cpu.architecture
USING: alien alien.strings alien.c-types alien.data alien.accessors
arrays words sequences math kernel namespaces fry cpu.architecture
io.encodings.utf8 accessors ;
IN: alien.arrays
@ -22,15 +22,15 @@ M: array c-type-align first c-type-align ;
M: array c-type-stack-align? drop f ;
M: array unbox-parameter drop "void*" unbox-parameter ;
M: array unbox-parameter drop void* unbox-parameter ;
M: array unbox-return drop "void*" unbox-return ;
M: array unbox-return drop void* unbox-return ;
M: array box-parameter drop "void*" box-parameter ;
M: array box-parameter drop void* box-parameter ;
M: array box-return drop "void*" box-return ;
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
unclip
@ -41,7 +41,7 @@ M: array c-type-boxer-quot
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
PREDICATE: string-type < pair
first2 [ "char*" = ] [ word? ] bi* and ;
first2 [ char* = ] [ word? ] bi* and ;
M: string-type c-type ;
@ -50,37 +50,37 @@ M: string-type c-type-class drop object ;
M: string-type c-type-boxed-class drop object ;
M: string-type heap-size
drop "void*" heap-size ;
drop void* heap-size ;
M: string-type c-type-align
drop "void*" c-type-align ;
drop void* c-type-align ;
M: string-type c-type-stack-align?
drop "void*" c-type-stack-align? ;
drop void* c-type-stack-align? ;
M: string-type unbox-parameter
drop "void*" unbox-parameter ;
drop void* unbox-parameter ;
M: string-type unbox-return
drop "void*" unbox-return ;
drop void* unbox-return ;
M: string-type box-parameter
drop "void*" box-parameter ;
drop void* box-parameter ;
M: string-type box-return
drop "void*" box-return ;
drop void* box-return ;
M: string-type stack-size
drop "void*" stack-size ;
drop void* stack-size ;
M: string-type c-type-rep
drop int-rep ;
M: string-type c-type-boxer
drop "void*" c-type-boxer ;
drop void* c-type-boxer ;
M: string-type c-type-unboxer
drop "void*" c-type-unboxer ;
drop void* c-type-unboxer ;
M: string-type c-type-boxer-quot
second '[ _ alien>string ] ;
@ -94,6 +94,8 @@ M: string-type c-type-getter
M: string-type c-type-setter
drop [ set-alien-cell ] ;
{ "char*" utf8 } "char*" typedef
"char*" "uchar*" typedef
{ char* utf8 } char* typedef
char* uchar* typedef
char char* "pointer-c-type" set-word-prop
uchar uchar* "pointer-c-type" set-word-prop

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

@ -1,7 +1,27 @@
USING: alien alien.complex help.syntax help.markup libc kernel.private
byte-arrays strings hashtables alien.syntax alien.strings sequences
io.encodings.string debugger destructors vocabs.loader
classes.struct ;
QUALIFIED: math
IN: alien.c-types
USING: alien help.syntax help.markup libc kernel.private
byte-arrays math strings hashtables alien.syntax alien.strings sequences
io.encodings.string debugger destructors vocabs.loader ;
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 { "type" string } { "size" math:integer } }
{ $description "Outputs the number of bytes needed for a heap-allocated value of this C type." }
{ $examples
"On a 32-bit system, you will get the following output:"
{ $unchecked-example "USE: alien\n\"void*\" heap-size ." "4" }
}
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: stack-size
{ $values { "type" string } { "size" math:integer } }
{ $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: <c-type>
{ $values { "type" hashtable } }
@ -20,24 +40,6 @@ HELP: c-type
{ $description "Looks up a C type by name." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: heap-size
{ $values { "type" string } { "size" integer } }
{ $description "Outputs the number of bytes needed for a heap-allocated value of this C type." }
{ $examples
"On a 32-bit system, you will get the following output:"
{ $unchecked-example "USE: alien\n\"void*\" heap-size ." "4" }
}
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: stack-size
{ $values { "type" string } { "size" integer } }
{ $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: byte-length
{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } }
{ $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ;
HELP: c-getter
{ $values { "name" string } { "quot" { $quotation "( c-ptr n -- obj )" } } }
{ $description "Outputs a quotation which reads values of this C type from a C structure." }
@ -48,51 +50,8 @@ HELP: c-setter
{ $description "Outputs a quotation which writes values of this C type to a C structure." }
{ $errors "Throws an error if the type does not exist." } ;
HELP: <c-array>
{ $values { "len" "a non-negative integer" } { "c-type" "a C type" } { "array" byte-array } }
{ $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
{ $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." }
{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
HELP: <c-object>
{ $values { "type" "a C type" } { "array" byte-array } }
{ $description "Creates a byte array suitable for holding a value with the given C type." }
{ $errors "Throws an " { $link no-c-type } " error if the type does not exist." } ;
{ <c-object> malloc-object } related-words
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" } { "alien" alien } }
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-direct-array> } "." }
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
HELP: malloc-object
{ $values { "type" "a C type" } { "alien" alien } }
{ $description "Allocates an unmanaged memory block large enough to hold a value of a C type." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if the type does not exist or if memory allocation fails." } ;
HELP: malloc-byte-array
{ $values { "byte-array" byte-array } { "alien" alien } }
{ $description "Allocates an unmanaged memory block of the same size as the byte array, and copies the contents of the byte array there." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if memory allocation fails." } ;
{ <c-array> <c-direct-array> malloc-array } related-words
HELP: box-parameter
{ $values { "n" integer } { "ctype" string } }
{ $values { "n" math:integer } { "ctype" string } }
{ $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." }
{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
@ -116,47 +75,41 @@ HELP: define-out
{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
{ string>alien alien>string malloc-string } related-words
HELP: char
{ $description "This C type represents a one-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ;
HELP: uchar
{ $description "This C type represents a one-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ;
HELP: short
{ $description "This C type represents a two-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to sixteen bits; output values will be returned as " { $link math:fixnum } "s." } ;
HELP: ushort
{ $description "This C type represents a two-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to sixteen bits; output values will be returned as " { $link math:fixnum } "s." } ;
HELP: int
{ $description "This C type represents a four-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to 32 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: uint
{ $description "This C type represents a four-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 32 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: long
{ $description "This C type represents a four- or eight-byte signed integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: ulong
{ $description "This C type represents a four- or eight-byte unsigned integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: longlong
{ $description "This C type represents an eight-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: ulonglong
{ $description "This C type represents an eight-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ;
HELP: void
{ $description "This symbol is not a valid C type, but it can be used as the return type for a " { $link POSTPONE: FUNCTION: } " or " { $link POSTPONE: CALLBACK: } " definition, or an " { $link alien-invoke } " or " { $link alien-callback } " call." } ;
HELP: void*
{ $description "This C type represents a pointer to C memory. " { $link byte-array } " and " { $link alien } " values can be passed as inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. Output values are returned as " { $link alien } "s." } ;
HELP: char*
{ $description "This C type represents a pointer to a C string. See " { $link "c-strings" } " for details about using strings with the FFI." } ;
HELP: float
{ $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." } ;
HELP: double
{ $description "This C type represents a double-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s; output values will be returned as Factor " { $link math:float } "s." } ;
HELP: complex-float
{ $description "This C type represents a single-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link math:complex } " objects into a single-precision complex float type; output values will be returned as Factor " { $link math:complex } " objects." } ;
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: malloc-string
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if one of the following conditions occurs:"
{ $list
"the string contains null code points"
"the string contains characters not representable using the encoding specified"
"memory allocation fails"
}
} ;
HELP: require-c-array
{ $values { "c-type" "a C type" } }
{ $description "Generates a specialized array of " { $snippet "c-type" } " using the " { $link <c-array> } " or " { $link <c-direct-array> } " vocabularies." }
{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence types loaded." } ;
HELP: <c-direct-array>
{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } }
{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." }
{ $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 " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
$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."
$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 " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "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."
$nl
"Sometimes a C function has a parameter type of " { $snippet "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:"
{ $subsection string>alien }
{ $subsection malloc-string }
"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
"A word to read strings from arbitrary addresses:"
{ $subsection alien>string }
"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
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."
@ -205,90 +158,32 @@ $nl
"Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link <void*> } " and " { $link *void* } " may be used." ;
ARTICLE: "c-types-specs" "C type specifiers"
"C types are identified by strings, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words, as well as " { $link POSTPONE: C-STRUCT: } ", " { $link POSTPONE: C-UNION: } " and " { $link POSTPONE: TYPEDEF: } "."
"C types are identified by special words, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words. New C types can be defined by the words " { $link POSTPONE: STRUCT: } ", " { $link POSTPONE: UNION-STRUCT: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: TYPEDEF: } "."
$nl
"The following numerical types are available; a " { $snippet "u" } " prefix denotes an unsigned type:"
{ $table
{ "C type" "Notes" }
{ { $snippet "char" } "always 1 byte" }
{ { $snippet "uchar" } { } }
{ { $snippet "short" } "always 2 bytes" }
{ { $snippet "ushort" } { } }
{ { $snippet "int" } "always 4 bytes" }
{ { $snippet "uint" } { } }
{ { $snippet "long" } { "same size as CPU word size and " { $snippet "void*" } ", except on 64-bit Windows, where it is 4 bytes" } }
{ { $snippet "ulong" } { } }
{ { $snippet "longlong" } "always 8 bytes" }
{ { $snippet "ulonglong" } { } }
{ { $snippet "float" } { } }
{ { $snippet "double" } { "same format as " { $link float } " objects" } }
{ { $snippet "complex-float" } { "C99 " { $snippet "complex float" } " type, converted to and from " { $link complex } " values" } }
{ { $snippet "complex-double" } { "C99 " { $snippet "complex double" } " type, converted to and from " { $link complex } " values" } }
{ { $link char } "always 1 byte" }
{ { $link uchar } { } }
{ { $link short } "always 2 bytes" }
{ { $link ushort } { } }
{ { $link int } "always 4 bytes" }
{ { $link uint } { } }
{ { $link long } { "same size as CPU word size and " { $link void* } ", except on 64-bit Windows, where it is 4 bytes" } }
{ { $link ulong } { } }
{ { $link longlong } "always 8 bytes" }
{ { $link ulonglong } { } }
{ { $link float } { "single-precision float (not the same as Factor's " { $link math:float } " class!)" } }
{ { $link double } { "double-precision float (the same format as Factor's " { $link math:float } " objects)" } }
{ { $link complex-float } { "C99 or Fortran " { $snippet "complex float" } " type, converted to and from Factor " { $link math:complex } " values" } }
{ { $link complex-double } { "C99 or Fortran " { $snippet "complex double" } " type, converted to and from Factor " { $link math:complex } " values" } }
}
"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision."
$nl
"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $snippet "void*" } ", which denotes a generic pointer; " { $snippet "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. With the exception of strings (see " { $link "c-strings" } "), all pointer types are identical to " { $snippet "void*" } " as far as the C library interface is concerned."
$nl
"Fixed-size array types are supported; the syntax consists of a C type name followed by dimension sizes in brackets; the following denotes a 3 by 4 array of integers:"
{ $code "int[3][4]" }
"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however when used as function parameters they behave exactly like pointers and thus the dimensions only serve as documentation."
$nl
"Structure and union types are specified by the name of the structure or union." ;
ARTICLE: "c-byte-arrays" "Passing data in byte arrays"
"Instances of the " { $link byte-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array."
$nl
"Byte arrays can be allocated directly with a byte count using the " { $link <byte-array> } " word. However in most cases, instead of computing a size in bytes directly, it is easier to use a higher-level word which expects C type and outputs a byte array large enough to hold that type:"
{ $subsection <c-object> }
{ $subsection <c-array> }
{ $warning
"The Factor garbage collector can move byte arrays around, and code passing byte arrays to C must obey important guidelines. See " { $link "byte-arrays-gc" } "." }
{ $see-also "c-arrays" } ;
ARTICLE: "malloc" "Manual memory management"
"Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case."
$nl
"Allocating a C datum with a fixed address:"
{ $subsection malloc-object }
{ $subsection malloc-array }
{ $subsection malloc-byte-array }
"There is a set of words in the " { $vocab-link "libc" } " vocabulary which directly call C standard library memory management functions:"
{ $subsection malloc }
{ $subsection calloc }
{ $subsection realloc }
"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
{ $subsection free }
"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
{ $subsection &free }
{ $subsection |free }
"The " { $link &free } " and " { $link |free } " words are generated using " { $link "alien.destructors" } "."
$nl
"You can unsafely copy a range of bytes from one memory location to another:"
{ $subsection memcpy }
"You can copy a range of bytes from memory into a byte array:"
{ $subsection memory>byte-array }
"You can copy a byte array to memory unsafely:"
{ $subsection byte-array>memory } ;
ARTICLE: "c-data" "Passing data between Factor and C"
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."
$nl
"Furthermore, Factor's garbage collector can move objects in memory; for a discussion of the consequences, see " { $link "byte-arrays-gc" } "."
{ $subsection "c-types-specs" }
{ $subsection "c-byte-arrays" }
{ $subsection "malloc" }
{ $subsection "c-strings" }
{ $subsection "c-arrays" }
{ $subsection "c-out-params" }
"Important guidelines for passing data in byte arrays:"
{ $subsection "byte-arrays-gc" }
"C-style enumerated types are supported:"
{ $subsection POSTPONE: C-ENUM: }
"C types can be aliased for convenience and consitency with native library documentation:"
{ $subsection POSTPONE: TYPEDEF: }
"New C types can be defined:"
{ $subsection "c-structs" }
{ $subsection "c-unions" }
"A utility for defining " { $link "destructors" } " for deallocating memory:"
{ $subsection "alien.destructors" }
{ $see-also "aliens" } ;

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

@ -43,7 +43,7 @@ TYPEDEF: int* MyIntArray
TYPEDEF: uchar* MyLPBYTE
[ t ] [ { "char*" utf8 } c-type "MyLPBYTE" c-type = ] unit-test
[ t ] [ { char* utf8 } c-type "MyLPBYTE" c-type = ] unit-test
[
0 B{ 1 2 3 4 } <displaced-alien> <void*>

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

@ -1,18 +1,27 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays arrays assocs kernel kernel.private libc math
USING: byte-arrays arrays assocs kernel kernel.private math
namespaces make parser sequences strings words splitting math.parser
cpu.architecture alien alien.accessors alien.strings quotations
layouts system compiler.units io io.files io.encodings.binary
io.streams.memory accessors combinators effects continuations fry
classes vocabs vocabs.loader ;
classes vocabs vocabs.loader words.symbol ;
QUALIFIED: math
IN: alien.c-types
SYMBOLS:
char uchar
short ushort
int uint
long ulong
longlong ulonglong
float double
void* bool
void ;
DEFER: <int>
DEFER: *char
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
TUPLE: abstract-c-type
{ class class initial: object }
{ boxed-class class initial: object }
@ -40,149 +49,124 @@ global [
ERROR: no-c-type name ;
: (c-type) ( name -- type/f )
c-types get-global at dup [
dup string? [ (c-type) ] when
] when ;
PREDICATE: c-type-word < word
"c-type" word-prop ;
UNION: c-type-name string c-type-word ;
! C type protocol
GENERIC: c-type ( name -- type ) foldable
: resolve-pointer-type ( name -- name )
c-types get at dup string?
[ "*" append ] [ drop "void*" ] if
c-type ;
GENERIC: resolve-pointer-type ( name -- c-type )
M: word resolve-pointer-type
dup "pointer-c-type" word-prop
[ ] [ drop void* ] ?if ;
M: string resolve-pointer-type
dup "*" append dup c-types get at
[ nip ] [
drop
c-types get at dup c-type-name?
[ resolve-pointer-type ] [ drop void* ] if
] if ;
: resolve-typedef ( name -- type )
dup string? [ c-type ] when ;
dup c-type-name? [ c-type ] when ;
: parse-array-type ( name -- array )
: parse-array-type ( name -- dims type )
"[" split unclip
[ [ "]" ?tail drop string>number ] map ] dip prefix ;
[ [ "]" ?tail drop string>number ] map ] dip ;
M: string c-type ( name -- type )
CHAR: ] over member? [
parse-array-type
parse-array-type prefix
] [
dup c-types get at [
resolve-typedef
] [
dup c-types get at [ ] [
"*" ?tail [ resolve-pointer-type ] [ no-c-type ] if
] ?if
] ?if resolve-typedef
] if ;
M: word c-type
"c-type" word-prop resolve-typedef ;
: void? ( c-type -- ? )
{ void "void" } member? ;
GENERIC: c-struct? ( type -- ? )
M: object c-struct?
drop f ;
M: string c-struct?
dup "void" = [ drop f ] [ c-type c-struct? ] if ;
M: c-type-name c-struct?
dup void? [ drop f ] [ c-type c-struct? ] if ;
! These words being foldable means that words need to be
! recompiled if a C type is redefined. Even so, folding the
! size facilitates some optimizations.
GENERIC: heap-size ( type -- size ) foldable
M: string heap-size c-type heap-size ;
M: abstract-c-type heap-size size>> ;
GENERIC: require-c-array ( c-type -- )
M: array require-c-array first require-c-array ;
GENERIC: c-array-constructor ( c-type -- word )
GENERIC: c-(array)-constructor ( c-type -- word )
GENERIC: c-direct-array-constructor ( c-type -- word )
GENERIC: <c-array> ( len c-type -- array )
M: string <c-array>
c-array-constructor execute( len -- array ) ; inline
GENERIC: (c-array) ( len c-type -- array )
M: string (c-array)
c-(array)-constructor execute( len -- array ) ; inline
GENERIC: <c-direct-array> ( alien len c-type -- array )
M: string <c-direct-array>
c-direct-array-constructor execute( alien len -- array ) ; inline
: malloc-array ( n type -- alien )
[ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
: (malloc-array) ( n type -- alien )
[ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
GENERIC: c-type-class ( name -- class )
M: abstract-c-type c-type-class class>> ;
M: string c-type-class c-type c-type-class ;
M: c-type-name c-type-class c-type c-type-class ;
GENERIC: c-type-boxed-class ( name -- class )
M: abstract-c-type c-type-boxed-class boxed-class>> ;
M: string c-type-boxed-class c-type c-type-boxed-class ;
M: c-type-name c-type-boxed-class c-type c-type-boxed-class ;
GENERIC: c-type-boxer ( name -- boxer )
M: c-type c-type-boxer boxer>> ;
M: string c-type-boxer c-type c-type-boxer ;
M: c-type-name c-type-boxer c-type c-type-boxer ;
GENERIC: c-type-boxer-quot ( name -- quot )
M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
M: string c-type-boxer-quot c-type c-type-boxer-quot ;
M: c-type-name c-type-boxer-quot c-type c-type-boxer-quot ;
GENERIC: c-type-unboxer ( name -- boxer )
M: c-type c-type-unboxer unboxer>> ;
M: string c-type-unboxer c-type c-type-unboxer ;
M: c-type-name c-type-unboxer c-type c-type-unboxer ;
GENERIC: c-type-unboxer-quot ( name -- quot )
M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
M: string c-type-unboxer-quot c-type c-type-unboxer-quot ;
M: c-type-name c-type-unboxer-quot c-type c-type-unboxer-quot ;
GENERIC: c-type-rep ( name -- rep )
M: c-type c-type-rep rep>> ;
M: string c-type-rep c-type c-type-rep ;
M: c-type-name c-type-rep c-type c-type-rep ;
GENERIC: c-type-getter ( name -- quot )
M: c-type c-type-getter getter>> ;
M: string c-type-getter c-type c-type-getter ;
M: c-type-name c-type-getter c-type c-type-getter ;
GENERIC: c-type-setter ( name -- quot )
M: c-type c-type-setter setter>> ;
M: string c-type-setter c-type c-type-setter ;
M: c-type-name c-type-setter c-type c-type-setter ;
GENERIC: c-type-align ( name -- n )
M: abstract-c-type c-type-align align>> ;
M: string c-type-align c-type c-type-align ;
M: c-type-name c-type-align c-type c-type-align ;
GENERIC: c-type-stack-align? ( name -- ? )
M: c-type c-type-stack-align? stack-align?>> ;
M: string c-type-stack-align? c-type c-type-stack-align? ;
M: c-type-name c-type-stack-align? c-type c-type-stack-align? ;
: c-type-box ( n type -- )
[ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
@ -196,49 +180,48 @@ GENERIC: box-parameter ( n ctype -- )
M: c-type box-parameter c-type-box ;
M: string box-parameter c-type box-parameter ;
M: c-type-name box-parameter c-type box-parameter ;
GENERIC: box-return ( ctype -- )
M: c-type box-return f swap c-type-box ;
M: string box-return c-type box-return ;
M: c-type-name box-return c-type box-return ;
GENERIC: unbox-parameter ( n ctype -- )
M: c-type unbox-parameter c-type-unbox ;
M: string unbox-parameter c-type unbox-parameter ;
M: c-type-name unbox-parameter c-type unbox-parameter ;
GENERIC: unbox-return ( ctype -- )
M: c-type unbox-return f swap c-type-unbox ;
M: string unbox-return c-type unbox-return ;
M: c-type-name unbox-return c-type unbox-return ;
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
GENERIC: heap-size ( type -- size ) foldable
M: c-type-name heap-size c-type heap-size ;
M: abstract-c-type heap-size size>> ;
GENERIC: stack-size ( type -- size ) foldable
M: string stack-size c-type stack-size ;
M: c-type-name stack-size c-type stack-size ;
M: c-type stack-size size>> cell align ;
MIXIN: value-type
M: value-type c-type-rep drop int-rep ;
M: value-type c-type-getter
drop [ swap <displaced-alien> ] ;
M: value-type c-type-setter ( type -- quot )
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
'[ @ swap @ _ memcpy ] ;
GENERIC: byte-length ( seq -- n ) flushable
M: byte-array byte-length length ; inline
M: f byte-length drop 0 ; inline
MIXIN: value-type
: c-getter ( name -- quot )
c-type-getter [
[ "Cannot read struct fields with this type" throw ]
@ -252,42 +235,29 @@ M: f byte-length drop 0 ; inline
[ "Cannot write struct fields with this type" throw ]
] unless* ;
: <c-object> ( type -- array )
heap-size <byte-array> ; inline
: (c-object) ( type -- array )
heap-size (byte-array) ; inline
: malloc-object ( type -- alien )
1 swap heap-size calloc ; inline
: (malloc-object) ( type -- alien )
heap-size malloc ; inline
: malloc-byte-array ( byte-array -- alien )
dup byte-length [ nip malloc dup ] 2keep memcpy ;
: memory>byte-array ( alien len -- byte-array )
[ nip (byte-array) dup ] 2keep memcpy ;
: malloc-string ( string encoding -- alien )
string>alien malloc-byte-array ;
M: memory-stream stream-read
[
[ index>> ] [ alien>> ] bi <displaced-alien>
swap memory>byte-array
] [ [ + ] change-index drop ] 2bi ;
: byte-array>memory ( byte-array base -- )
swap dup byte-length memcpy ; inline
: array-accessor ( type quot -- def )
[
\ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
] [ ] make ;
: typedef ( old new -- ) c-types get set-at ;
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 -- )
{
[ 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 ;
@ -312,36 +282,33 @@ M: long-long-type box-return ( type -- )
: define-out ( name -- )
[ "alien.c-types" constructor-word ]
[ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ] bi
[ dup c-setter '[ _ heap-size <byte-array> [ 0 @ ] keep ] ] bi
(( value -- c-ptr )) define-inline ;
: >c-bool ( ? -- int ) 1 0 ? ; inline
: c-bool> ( int -- ? ) 0 = not ; inline
: define-primitive-type ( type name -- )
[ typedef ]
[ define-deref ]
[ define-out ]
[ name>> define-deref ]
[ name>> define-out ]
tri ;
: malloc-file-contents ( path -- alien len )
binary file-contents [ malloc-byte-array ] [ length ] bi ;
: if-void ( type true false -- )
pick "void" = [ drop nip call ] [ nip call ] if ; inline
pick void? [ drop nip call ] [ nip call ] if ; inline
CONSTANT: primitive-types
{
"char" "uchar"
"short" "ushort"
"int" "uint"
"long" "ulong"
"longlong" "ulonglong"
"float" "double"
"void*" "bool"
char uchar
short ushort
int uint
long ulong
longlong ulonglong
float double
void* bool
}
SYMBOLS:
ptrdiff_t intptr_t size_t
char* uchar* ;
[
<c-type>
c-ptr >>class
@ -353,7 +320,7 @@ CONSTANT: primitive-types
[ >c-ptr ] >>unboxer-quot
"box_alien" >>boxer
"alien_offset" >>unboxer
"void*" define-primitive-type
\ void* define-primitive-type
<long-long-type>
integer >>class
@ -364,7 +331,7 @@ CONSTANT: primitive-types
8 >>align
"box_signed_8" >>boxer
"to_signed_8" >>unboxer
"longlong" define-primitive-type
\ longlong define-primitive-type
<long-long-type>
integer >>class
@ -375,7 +342,7 @@ CONSTANT: primitive-types
8 >>align
"box_unsigned_8" >>boxer
"to_unsigned_8" >>unboxer
"ulonglong" define-primitive-type
\ ulonglong define-primitive-type
<c-type>
integer >>class
@ -386,7 +353,7 @@ CONSTANT: primitive-types
bootstrap-cell >>align
"box_signed_cell" >>boxer
"to_fixnum" >>unboxer
"long" define-primitive-type
\ long define-primitive-type
<c-type>
integer >>class
@ -397,7 +364,7 @@ CONSTANT: primitive-types
bootstrap-cell >>align
"box_unsigned_cell" >>boxer
"to_cell" >>unboxer
"ulong" define-primitive-type
\ ulong define-primitive-type
<c-type>
integer >>class
@ -408,7 +375,7 @@ CONSTANT: primitive-types
4 >>align
"box_signed_4" >>boxer
"to_fixnum" >>unboxer
"int" define-primitive-type
\ int define-primitive-type
<c-type>
integer >>class
@ -419,7 +386,7 @@ CONSTANT: primitive-types
4 >>align
"box_unsigned_4" >>boxer
"to_cell" >>unboxer
"uint" define-primitive-type
\ uint define-primitive-type
<c-type>
fixnum >>class
@ -430,7 +397,7 @@ CONSTANT: primitive-types
2 >>align
"box_signed_2" >>boxer
"to_fixnum" >>unboxer
"short" define-primitive-type
\ short define-primitive-type
<c-type>
fixnum >>class
@ -441,7 +408,7 @@ CONSTANT: primitive-types
2 >>align
"box_unsigned_2" >>boxer
"to_cell" >>unboxer
"ushort" define-primitive-type
\ ushort define-primitive-type
<c-type>
fixnum >>class
@ -452,7 +419,7 @@ CONSTANT: primitive-types
1 >>align
"box_signed_1" >>boxer
"to_fixnum" >>unboxer
"char" define-primitive-type
\ char define-primitive-type
<c-type>
fixnum >>class
@ -463,20 +430,20 @@ CONSTANT: primitive-types
1 >>align
"box_unsigned_1" >>boxer
"to_cell" >>unboxer
"uchar" define-primitive-type
\ uchar define-primitive-type
<c-type>
[ alien-unsigned-1 c-bool> ] >>getter
[ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
[ alien-unsigned-1 0 = not ] >>getter
[ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
1 >>size
1 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
"bool" define-primitive-type
\ bool define-primitive-type
<c-type>
float >>class
float >>boxed-class
math:float >>class
math:float >>boxed-class
[ alien-float ] >>getter
[ [ >float ] 2dip set-alien-float ] >>setter
4 >>size
@ -485,11 +452,11 @@ CONSTANT: primitive-types
"to_float" >>unboxer
float-rep >>rep
[ >float ] >>unboxer-quot
"float" define-primitive-type
\ float define-primitive-type
<c-type>
float >>class
float >>boxed-class
math:float >>class
math:float >>boxed-class
[ alien-double ] >>getter
[ [ >float ] 2dip set-alien-double ] >>setter
8 >>size
@ -498,10 +465,10 @@ CONSTANT: primitive-types
"to_double" >>unboxer
double-rep >>rep
[ >float ] >>unboxer-quot
"double" define-primitive-type
\ double define-primitive-type
"long" "ptrdiff_t" typedef
"long" "intptr_t" typedef
"ulong" "size_t" typedef
\ long \ ptrdiff_t typedef
\ long \ intptr_t typedef
\ ulong \ size_t typedef
] with-compilation-unit

1
basis/alien/data/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

148
basis/alien/data/data-docs.factor Normal file
View File

@ -0,0 +1,148 @@
USING: alien alien.c-types help.syntax help.markup libc kernel.private
byte-arrays math strings hashtables alien.syntax alien.strings sequences
io.encodings.string debugger destructors vocabs.loader ;
IN: alien.data
HELP: <c-array>
{ $values { "len" "a non-negative integer" } { "c-type" "a C type" } { "array" byte-array } }
{ $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
{ $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." }
{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
HELP: <c-object>
{ $values { "type" "a C type" } { "array" byte-array } }
{ $description "Creates a byte array suitable for holding a value with the given C type." }
{ $errors "Throws an " { $link no-c-type } " error if the type does not exist." } ;
{ <c-object> malloc-object } related-words
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" } { "alien" alien } }
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-direct-array> } "." }
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
HELP: malloc-object
{ $values { "type" "a C type" } { "alien" alien } }
{ $description "Allocates an unmanaged memory block large enough to hold a value of a C type." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if the type does not exist or if memory allocation fails." } ;
HELP: malloc-byte-array
{ $values { "byte-array" byte-array } { "alien" alien } }
{ $description "Allocates an unmanaged memory block of the same size as the byte array, and copies the contents of the byte array there." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if memory allocation fails." } ;
{ <c-array> <c-direct-array> malloc-array } related-words
{ string>alien alien>string malloc-string } related-words
ARTICLE: "malloc" "Manual memory management"
"Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case."
$nl
"Allocating a C datum with a fixed address:"
{ $subsection malloc-object }
{ $subsection malloc-array }
{ $subsection malloc-byte-array }
"There is a set of words in the " { $vocab-link "libc" } " vocabulary which directly call C standard library memory management functions:"
{ $subsection malloc }
{ $subsection calloc }
{ $subsection realloc }
"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
{ $subsection free }
"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
{ $subsection &free }
{ $subsection |free }
"The " { $link &free } " and " { $link |free } " words are generated using " { $link "alien.destructors" } "."
$nl
"You can unsafely copy a range of bytes from one memory location to another:"
{ $subsection memcpy }
"You can copy a range of bytes from memory into a byte array:"
{ $subsection memory>byte-array }
"You can copy a byte array to memory unsafely:"
{ $subsection byte-array>memory } ;
ARTICLE: "c-byte-arrays" "Passing data in byte arrays"
"Instances of the " { $link byte-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array."
$nl
"Byte arrays can be allocated directly with a byte count using the " { $link <byte-array> } " word. However in most cases, instead of computing a size in bytes directly, it is easier to use a higher-level word which expects C type and outputs a byte array large enough to hold that type:"
{ $subsection <c-object> }
{ $subsection <c-array> }
{ $warning
"The Factor garbage collector can move byte arrays around, and code passing byte arrays to C must obey important guidelines. See " { $link "byte-arrays-gc" } "." }
{ $see-also "c-arrays" } ;
ARTICLE: "c-data" "Passing data between Factor and C"
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."
$nl
"Furthermore, Factor's garbage collector can move objects in memory; for a discussion of the consequences, see " { $link "byte-arrays-gc" } "."
{ $subsection "c-types-specs" }
{ $subsection "c-byte-arrays" }
{ $subsection "malloc" }
{ $subsection "c-strings" }
{ $subsection "c-arrays" }
{ $subsection "c-out-params" }
"Important guidelines for passing data in byte arrays:"
{ $subsection "byte-arrays-gc" }
"C-style enumerated types are supported:"
{ $subsection POSTPONE: C-ENUM: }
"C types can be aliased for convenience and consitency with native library documentation:"
{ $subsection POSTPONE: TYPEDEF: }
"New C types can be defined:"
{ $subsection "c-structs" }
{ $subsection "c-unions" }
"A utility for defining " { $link "destructors" } " for deallocating memory:"
{ $subsection "alien.destructors" }
{ $see-also "aliens" } ;
HELP: malloc-string
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if one of the following conditions occurs:"
{ $list
"the string contains null code points"
"the string contains characters not representable using the encoding specified"
"memory allocation fails"
}
} ;
HELP: require-c-array
{ $values { "c-type" "a C type" } }
{ $description "Generates a specialized array of " { $snippet "c-type" } " using the " { $link <c-array> } " or " { $link <c-direct-array> } " vocabularies." }
{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence types loaded." } ;
HELP: <c-direct-array>
{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } }
{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." }
{ $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."
$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."
$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."
$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:"
{ $subsection string>alien }
{ $subsection malloc-string }
"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
"A word to read strings from arbitrary addresses:"
{ $subsection 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 } "." ;

83
basis/alien/data/data.factor Normal file
View File

@ -0,0 +1,83 @@
! (c)2009 Slava Pestov, Joe Groff bsd license
USING: accessors alien alien.c-types alien.strings arrays
byte-arrays cpu.architecture fry io io.encodings.binary
io.files io.streams.memory kernel libc math sequences ;
IN: alien.data
GENERIC: require-c-array ( c-type -- )
M: array require-c-array first require-c-array ;
GENERIC: c-array-constructor ( c-type -- word )
GENERIC: c-(array)-constructor ( c-type -- word )
GENERIC: c-direct-array-constructor ( c-type -- word )
GENERIC: <c-array> ( len c-type -- array )
M: c-type-name <c-array>
c-array-constructor execute( len -- array ) ; inline
GENERIC: (c-array) ( len c-type -- array )
M: c-type-name (c-array)
c-(array)-constructor execute( len -- array ) ; inline
GENERIC: <c-direct-array> ( alien len c-type -- array )
M: c-type-name <c-direct-array>
c-direct-array-constructor execute( alien len -- array ) ; inline
: malloc-array ( n type -- alien )
[ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
: (malloc-array) ( n type -- alien )
[ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
: <c-object> ( type -- array )
heap-size <byte-array> ; inline
: (c-object) ( type -- array )
heap-size (byte-array) ; inline
: malloc-object ( type -- alien )
1 swap heap-size calloc ; inline
: (malloc-object) ( type -- alien )
heap-size malloc ; inline
: malloc-byte-array ( byte-array -- alien )
dup byte-length [ nip malloc dup ] 2keep memcpy ;
: memory>byte-array ( alien len -- byte-array )
[ nip (byte-array) dup ] 2keep memcpy ;
: malloc-string ( string encoding -- alien )
string>alien malloc-byte-array ;
: malloc-file-contents ( path -- alien len )
binary file-contents [ malloc-byte-array ] [ length ] bi ;
M: memory-stream stream-read
[
[ index>> ] [ alien>> ] bi <displaced-alien>
swap memory>byte-array
] [ [ + ] change-index drop ] 2bi ;
: byte-array>memory ( byte-array base -- )
swap dup byte-length memcpy ; inline
: >c-bool ( ? -- int ) 1 0 ? ; inline
: c-bool> ( int -- ? ) 0 = not ; inline
M: value-type c-type-rep drop int-rep ;
M: value-type c-type-getter
drop [ swap <displaced-alien> ] ;
M: value-type c-type-setter ( type -- quot )
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
'[ @ swap @ _ memcpy ] ;

1
basis/alien/data/summary.txt Normal file
View File

@ -0,0 +1 @@
Words for allocating objects and arrays of C types

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

@ -1,7 +1,7 @@
! (c) 2009 Joe Groff, see BSD license
USING: accessors alien alien.c-types alien.complex
alien.fortran alien.fortran.private alien.strings classes.struct
arrays assocs byte-arrays combinators fry
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 ;
IN: alien.fortran.tests

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

@ -1,5 +1,5 @@
! (c) 2009 Joe Groff, see BSD license
USING: accessors alien alien.c-types alien.complex alien.parser
USING: accessors alien alien.c-types alien.complex alien.data grouping
alien.strings alien.syntax arrays ascii assocs
byte-arrays combinators combinators.short-circuit fry generalizations
kernel lexer macros math math.parser namespaces parser sequences
@ -429,6 +429,11 @@ PRIVATE>
MACRO: fortran-invoke ( return library function parameters -- )
{ [ 2drop nip set-fortran-abi ] [ (fortran-invoke) ] } 4 ncleave ;
: parse-arglist ( parameters return -- types effect )
[ 2 group unzip [ "," ?tail drop ] map ]
[ [ { } ] [ 1array ] if-void ]
bi* <effect> ;
:: define-fortran-function ( return library function parameters -- )
function create-in dup reset-generic
return library function parameters return [ "void" ] unless* parse-arglist

67
basis/alien/parser/parser.factor
View File

@ -1,16 +1,42 @@
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays assocs effects grouping kernel
parser sequences splitting words fry locals lexer namespaces
summary math ;
USING: accessors alien alien.c-types arrays assocs
combinators combinators.short-circuit effects grouping
kernel parser sequences splitting words fry locals lexer
namespaces summary math vocabs.parser ;
IN: alien.parser
: parse-c-type-name ( name -- word/string )
[ search ] keep or ;
: parse-c-type ( string -- array )
{
{ [ dup "void" = ] [ drop void ] }
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
{ [ dup search c-type-word? ] [ parse-c-type-name ] }
{ [ dup c-types get at ] [ ] }
{ [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] }
[ no-c-type ]
} cond ;
: scan-c-type ( -- c-type )
scan dup "{" =
[ drop \ } parse-until >array ]
[ parse-c-type ] if ;
: reset-c-type ( word -- )
{ "c-type" "pointer-c-type" "callback-effect" "callback-abi" } reset-props ;
: CREATE-C-TYPE ( -- word )
scan current-vocab create dup reset-c-type ;
: normalize-c-arg ( type name -- type' name' )
[ length ]
[
[ CHAR: * = ] trim-head
[ length - CHAR: * <array> append ] keep
] bi ;
] bi
[ parse-c-type ] dip ;
: parse-arglist ( parameters return -- types effect )
[
@ -29,10 +55,37 @@ IN: alien.parser
return library function
parameters return parse-arglist [ function-quot ] dip ;
: parse-arg-tokens ( -- tokens )
";" parse-tokens [ "()" subseq? not ] filter ;
: (FUNCTION:) ( -- word quot effect )
scan "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] filter
make-function ;
scan "c-library" get scan parse-arg-tokens make-function ;
: define-function ( return library function parameters -- )
make-function define-declared ;
: callback-quot ( return types abi -- quot )
[ [ ] 3curry dip alien-callback ] 3curry ;
:: make-callback-type ( abi return! type-name! parameters -- word quot effect )
return type-name normalize-c-arg type-name! return!
type-name current-vocab create :> type-word
type-word [ reset-generic ] [ reset-c-type ] bi
void* type-word typedef
parameters return parse-arglist :> callback-effect :> types
type-word callback-effect "callback-effect" set-word-prop
type-word abi "callback-abi" set-word-prop
type-word return types abi callback-quot (( quot -- alien )) ;
: (CALLBACK:) ( abi -- word quot effect )
scan scan parse-arg-tokens make-callback-type ;
PREDICATE: alien-function-word < word
def>> {
[ length 5 = ]
[ last \ alien-invoke eq? ]
} 1&& ;
PREDICATE: alien-callback-type-word < typedef-word
"callback-effect" word-prop ;

74
basis/alien/prettyprint/prettyprint.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators alien alien.strings alien.syntax
math.parser prettyprint.backend prettyprint.custom
prettyprint.sections ;
USING: accessors kernel combinators alien alien.strings alien.c-types
alien.parser alien.syntax arrays assocs effects math.parser
prettyprint.backend prettyprint.custom prettyprint.sections
definitions see see.private sequences strings words ;
IN: alien.prettyprint
M: alien pprint*
@ -13,3 +14,70 @@ M: alien pprint*
} cond ;
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;
M: c-type-word definer drop \ C-TYPE: f ;
M: c-type-word definition drop f ;
M: c-type-word declarations. drop ;
GENERIC: pprint-c-type ( c-type -- )
M: word pprint-c-type pprint-word ;
M: wrapper pprint-c-type wrapped>> pprint-word ;
M: string pprint-c-type text ;
M: array pprint-c-type pprint* ;
M: typedef-word definer drop \ TYPEDEF: f ;
M: typedef-word synopsis*
{
[ seeing-word ]
[ definer. ]
[ "c-type" word-prop pprint-c-type ]
[ pprint-word ]
} cleave ;
: pprint-function-arg ( type name -- )
[ pprint-c-type ] [ text ] bi* ;
: pprint-function-args ( types names -- )
zip [ ] [
unclip-last
[ [ first2 "," append pprint-function-arg ] each ] dip
first2 pprint-function-arg
] if-empty ;
M: alien-function-word definer
drop \ FUNCTION: \ ; ;
M: alien-function-word definition drop f ;
M: alien-function-word synopsis*
{
[ seeing-word ]
[ def>> second [ \ LIBRARY: [ text ] pprint-prefix ] when* ]
[ definer. ]
[ def>> first pprint-c-type ]
[ pprint-word ]
[
<block "(" text
[ def>> fourth ] [ stack-effect in>> ] bi
pprint-function-args
")" text block>
]
} cleave ;
M: alien-callback-type-word definer
"callback-abi" word-prop "stdcall" =
\ STDCALL-CALLBACK: \ CALLBACK: ?
f ;
M: alien-callback-type-word definition drop f ;
M: alien-callback-type-word synopsis*
{
[ seeing-word ]
[ definer. ]
[ def>> first pprint-c-type ]
[ pprint-word ]
[
<block "(" text
[ def>> second ] [ "callback-effect" word-prop in>> ] bi
pprint-function-args
")" text block>
]
} cleave ;

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

@ -1,6 +1,6 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings parser
USING: accessors alien alien.data alien.strings parser
threads words kernel.private kernel io.encodings.utf8 eval ;
IN: alien.remote-control

2
basis/alien/structs/structs-docs.factor
View File

@ -1,4 +1,4 @@
USING: alien.c-types strings help.markup help.syntax alien.syntax
USING: alien.c-types alien.data strings help.markup help.syntax alien.syntax
sequences io arrays kernel words assocs namespaces ;
IN: alien.structs

2
basis/alien/structs/structs-tests.factor
View File

@ -1,4 +1,4 @@
USING: alien alien.syntax alien.c-types kernel tools.test
USING: alien alien.syntax alien.c-types alien.data kernel tools.test
sequences system libc words vocabs namespaces layouts ;
IN: alien.structs.tests

2
basis/alien/structs/structs.factor
View File

@ -15,7 +15,7 @@ M: struct-type c-type ;
M: struct-type c-type-stack-align? drop f ;
: if-value-struct ( ctype true false -- )
[ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
[ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
M: struct-type unbox-parameter
[ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;

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

@ -81,6 +81,42 @@ HELP: C-ENUM:
{ $code "CONSTANT: red 0" "CONSTANT: green 1" "CONSTANT: blue 2" }
} ;
HELP: CALLBACK:
{ $syntax "CALLBACK: return type ( parameters ) ;" }
{ $values { "return" "a C return type" } { "type" "a type name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters with the " { $snippet "\"cdecl\"" } " ABI." }
{ $examples
{ $code
"CALLBACK: bool FakeCallback ( int message, void* payload ) ;"
": MyFakeCallback ( -- alien )"
" [| message payload |"
" \"message #\" write"
" message number>string write"
" \" received\" write nl"
" t"
" ] FakeCallback ;"
}
} ;
HELP: STDCALL-CALLBACK:
{ $syntax "STDCALL-CALLBACK: return type ( parameters ) ;" }
{ $values { "return" "a C return type" } { "type" "a type name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } }
{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters with the " { $snippet "\"stdcall\"" } " ABI." }
{ $examples
{ $code
"STDCALL-CALLBACK: bool FakeCallback ( int message, void* payload ) ;"
": MyFakeCallback ( -- alien )"
" [| message payload |"
" \"message #\" write"
" message number>string write"
" \" received\" write nl"
" t"
" ] FakeCallback ;"
}
} ;
{ POSTPONE: CALLBACK: POSTPONE: STDCALL-CALLBACK: } related-words
HELP: &:
{ $syntax "&: symbol" }
{ $values { "symbol" "A C library symbol name" } }
@ -88,7 +124,7 @@ HELP: &:
HELP: typedef
{ $values { "old" "a string" } { "new" "a string" } }
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
{ $notes "Using this word in the same source file which defines C bindings can cause problems, because words are compiled before top-level forms are run. Use the " { $link POSTPONE: TYPEDEF: } " word instead." } ;
{ POSTPONE: TYPEDEF: typedef } related-words

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

@ -18,8 +18,14 @@ SYNTAX: LIBRARY: scan "c-library" set ;
SYNTAX: FUNCTION:
(FUNCTION:) define-declared ;
SYNTAX: CALLBACK:
"cdecl" (CALLBACK:) define-inline ;
SYNTAX: STDCALL-CALLBACK:
"stdcall" (CALLBACK:) define-inline ;
SYNTAX: TYPEDEF:
scan scan typedef ;
scan-c-type CREATE-C-TYPE typedef ;
SYNTAX: C-STRUCT:
scan current-vocab parse-definition define-struct ; deprecated
@ -31,6 +37,9 @@ SYNTAX: C-ENUM:
";" parse-tokens
[ [ create-in ] dip define-constant ] each-index ;
SYNTAX: C-TYPE:
"Primitive C type definition not supported" throw ;
ERROR: no-such-symbol name library ;
: address-of ( name library -- value )

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

@ -1,6 +1,6 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types accessors math alien.accessors kernel
USING: alien.c-types alien.data accessors math alien.accessors kernel
kernel.private sequences sequences.private byte-arrays
parser prettyprint.custom fry ;
IN: bit-arrays

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

@ -6,7 +6,7 @@
USING: system combinators alien alien.syntax alien.c-types
alien.destructors kernel accessors sequences arrays ui.gadgets
alien.libraries ;
alien.libraries classes.struct ;
IN: cairo.ffi
<< {
@ -26,23 +26,23 @@ TYPEDEF: int cairo_bool_t
TYPEDEF: void* cairo_t
TYPEDEF: void* cairo_surface_t
C-STRUCT: cairo_matrix_t
{ "double" "xx" }
{ "double" "yx" }
{ "double" "xy" }
{ "double" "yy" }
{ "double" "x0" }
{ "double" "y0" } ;
STRUCT: cairo_matrix_t
{ xx double }
{ yx double }
{ xy double }
{ yy double }
{ x0 double }
{ y0 double } ;
TYPEDEF: void* cairo_pattern_t
TYPEDEF: void* cairo_destroy_func_t
: cairo-destroy-func ( quot -- callback )
[ "void" { "void*" } "cdecl" ] dip alien-callback ; inline
[ void { void* } "cdecl" ] dip alien-callback ; inline
! See cairo.h for details
C-STRUCT: cairo_user_data_key_t
{ "int" "unused" } ;
STRUCT: cairo_user_data_key_t
{ unused int } ;
TYPEDEF: int cairo_status_t
C-ENUM:
@ -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 { void* uchar* 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 { void* uchar* int } "cdecl" ] dip alien-callback ; inline
! Functions for manipulating state objects
FUNCTION: cairo_t*
@ -336,16 +336,16 @@ cairo_clip_preserve ( cairo_t* cr ) ;
FUNCTION: void
cairo_clip_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
C-STRUCT: cairo_rectangle_t
{ "double" "x" }
{ "double" "y" }
{ "double" "width" }
{ "double" "height" } ;
STRUCT: cairo_rectangle_t
{ x double }
{ y double }
{ width double }
{ height double } ;
C-STRUCT: cairo_rectangle_list_t
{ "cairo_status_t" "status" }
{ "cairo_rectangle_t*" "rectangles" }
{ "int" "num_rectangles" } ;
STRUCT: cairo_rectangle_list_t
{ status cairo_status_t }
{ rectangles cairo_rectangle_t* }
{ num_rectangles int } ;
FUNCTION: cairo_rectangle_list_t*
cairo_copy_clip_rectangle_list ( cairo_t* cr ) ;
@ -359,25 +359,25 @@ TYPEDEF: void* cairo_scaled_font_t
TYPEDEF: void* cairo_font_face_t
C-STRUCT: cairo_glyph_t
{ "ulong" "index" }
{ "double" "x" }
{ "double" "y" } ;
STRUCT: cairo_glyph_t
{ index ulong }
{ x double }
{ y double } ;
C-STRUCT: cairo_text_extents_t
{ "double" "x_bearing" }
{ "double" "y_bearing" }
{ "double" "width" }
{ "double" "height" }
{ "double" "x_advance" }
{ "double" "y_advance" } ;
STRUCT: cairo_text_extents_t
{ x_bearing double }
{ y_bearing double }
{ width double }
{ height double }
{ x_advance double }
{ y_advance double } ;
C-STRUCT: cairo_font_extents_t
{ "double" "ascent" }
{ "double" "descent" }
{ "double" "height" }
{ "double" "max_x_advance" }
{ "double" "max_y_advance" } ;
STRUCT: cairo_font_extents_t
{ ascent double }
{ descent double }
{ height double }
{ max_x_advance double }
{ max_y_advance double } ;
TYPEDEF: int cairo_font_slant_t
C-ENUM:
@ -648,20 +648,22 @@ C-ENUM:
CAIRO_PATH_CLOSE_PATH ;
! NEED TO DO UNION HERE
C-STRUCT: cairo_path_data_t-point
{ "double" "x" }
{ "double" "y" } ;
STRUCT: cairo_path_data_t-point
{ x double }
{ y double } ;
C-STRUCT: cairo_path_data_t-header
{ "cairo_path_data_type_t" "type" }
{ "int" "length" } ;
STRUCT: cairo_path_data_t-header
{ type cairo_path_data_type_t }
{ length int } ;
C-UNION: cairo_path_data_t "cairo_path_data_t-point" "cairo_path_data_t-header" ;
UNION-STRUCT: cairo_path_data_t
{ point cairo_path_data_t-point }
{ header cairo_path_data_t-header } ;
C-STRUCT: cairo_path_t
{ "cairo_status_t" "status" }
{ "cairo_path_data_t*" "data" }
{ "int" "num_data" } ;
STRUCT: cairo_path_t
{ status cairo_status_t }
{ data cairo_path_data_t* }
{ num_data int } ;
FUNCTION: cairo_path_t*
cairo_copy_path ( cairo_t* cr ) ;

8
basis/checksums/openssl/openssl.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays alien.c-types kernel continuations
destructors sequences io openssl openssl.libcrypto checksums
checksums.stream ;
USING: accessors byte-arrays alien.c-types alien.data kernel
continuations destructors sequences io openssl openssl.libcrypto
checksums checksums.stream classes.struct ;
IN: checksums.openssl
ERROR: unknown-digest name ;
@ -23,7 +23,7 @@ TUPLE: evp-md-context < disposable handle ;
: <evp-md-context> ( -- ctx )
evp-md-context new-disposable
"EVP_MD_CTX" <c-object> dup EVP_MD_CTX_init >>handle ;
EVP_MD_CTX <struct> dup EVP_MD_CTX_init >>handle ;
M: evp-md-context dispose*
handle>> EVP_MD_CTX_cleanup drop ;

12
basis/classes/struct/prettyprint/prettyprint.factor
View File

@ -1,9 +1,9 @@
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types arrays assocs classes
classes.struct combinators combinators.short-circuit continuations
fry kernel libc make math math.parser mirrors prettyprint.backend
prettyprint.custom prettyprint.sections see.private sequences
slots strings summary words ;
USING: accessors alien alien.c-types alien.data alien.prettyprint arrays
assocs classes classes.struct combinators combinators.short-circuit
continuations fry kernel libc make math math.parser mirrors
prettyprint.backend prettyprint.custom prettyprint.sections
see.private sequences slots strings summary words ;
IN: classes.struct.prettyprint
<PRIVATE
@ -20,7 +20,7 @@ IN: classes.struct.prettyprint
<flow \ { pprint-word
f <inset {
[ name>> text ]
[ type>> dup string? [ text ] [ pprint* ] if ]
[ type>> pprint-c-type ]
[ read-only>> [ \ read-only pprint-word ] when ]
[ initial>> [ \ initial: pprint-word pprint* ] when* ]
} cleave block>

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

@ -1,11 +1,13 @@
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types ascii
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 multiline namespaces prettyprint
prettyprint.config see sequences specialized-arrays system
tools.test parser lexer eval layouts ;
FROM: math => float ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: char
SPECIALIZED-ARRAY: int
SPECIALIZED-ARRAY: ushort
@ -46,9 +48,9 @@ STRUCT: struct-test-bar
[ {
{ "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } }
{ { "x" "char" } 98 }
{ { "y" "int" } HEX: 7F00007F }
{ { "z" "bool" } f }
{ { "x" char } 98 }
{ { "y" int } HEX: 7F00007F }
{ { "z" bool } f }
} ] [
B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct
make-mirror >alist
@ -128,7 +130,7 @@ STRUCT: struct-test-bar
] unit-test
UNION-STRUCT: struct-test-float-and-bits
{ f float }
{ f c:float }
{ bits uint } ;
[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
@ -181,14 +183,14 @@ STRUCT: struct-test-string-ptr
] with-scope
] unit-test
[ <" USING: classes.struct ;
[ <" USING: alien.c-types classes.struct ;
IN: classes.struct.tests
STRUCT: struct-test-foo
{ x char initial: 0 } { y int initial: 123 } { z bool } ;
"> ]
[ [ struct-test-foo see ] with-string-writer ] unit-test
[ <" USING: classes.struct ;
[ <" USING: alien.c-types classes.struct ;
IN: classes.struct.tests
UNION-STRUCT: struct-test-float-and-bits
{ f float initial: 0.0 } { bits uint initial: 0 } ;
@ -201,20 +203,20 @@ UNION-STRUCT: struct-test-float-and-bits
{ offset 0 }
{ initial 0 }
{ class fixnum }
{ type "char" }
{ type char }
}
T{ struct-slot-spec
{ name "y" }
{ offset 4 }
{ initial 123 }
{ class integer }
{ type "int" }
{ type int }
}
T{ struct-slot-spec
{ name "z" }
{ offset 8 }
{ initial f }
{ type "bool" }
{ type bool }
{ class object }
}
} ] [ "struct-test-foo" c-type fields>> ] unit-test
@ -223,14 +225,14 @@ UNION-STRUCT: struct-test-float-and-bits
T{ struct-slot-spec
{ name "f" }
{ offset 0 }
{ type "float" }
{ type c:float }
{ class float }
{ initial 0.0 }
}
T{ struct-slot-spec
{ name "bits" }
{ offset 0 }
{ type "uint" }
{ type uint }
{ class integer }
{ initial 0 }
}
@ -277,7 +279,7 @@ STRUCT: struct-test-array-slots
] unit-test
STRUCT: struct-test-optimization
{ x { "int" 3 } } { y int } ;
{ x { int 3 } } { y int } ;
SPECIALIZED-ARRAY: struct-test-optimization

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

@ -1,12 +1,12 @@
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types arrays byte-arrays classes
classes.parser classes.tuple classes.tuple.parser
USING: accessors alien alien.c-types alien.data alien.parser arrays
byte-arrays classes classes.parser classes.tuple classes.tuple.parser
classes.tuple.private combinators combinators.short-circuit
combinators.smart cpu.architecture definitions functors.backend
fry 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 ;
summary namespaces assocs vocabs.parser ;
IN: classes.struct
SPECIALIZED-ARRAY: uchar
@ -126,7 +126,7 @@ M: struct-c-type c-type ;
M: struct-c-type c-type-stack-align? drop f ;
: if-value-struct ( ctype true false -- )
[ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
[ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
M: struct-c-type unbox-parameter
[ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
@ -197,20 +197,6 @@ M: struct-c-type c-struct? drop t ;
[ type>> c-type-align ] [ max ] map-reduce ;
PRIVATE>
M: struct-class c-type name>> c-type ;
M: struct-class c-type-align c-type c-type-align ;
M: struct-class c-type-getter c-type c-type-getter ;
M: struct-class c-type-setter c-type c-type-setter ;
M: struct-class c-type-boxer-quot c-type c-type-boxer-quot ;
M: struct-class c-type-unboxer-quot c-type c-type-boxer-quot ;
M: struct-class heap-size c-type heap-size ;
M: struct byte-length class "struct-size" word-prop ; foldable
! class definition
@ -259,7 +245,7 @@ M: struct byte-length class "struct-size" word-prop ; foldable
[ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
(struct-word-props)
]
[ drop [ c-type-for-class ] [ name>> ] bi typedef ] 2tri ; inline
[ drop [ c-type-for-class ] keep typedef ] 2tri ; inline
PRIVATE>
: define-struct-class ( class slots -- )
@ -284,9 +270,6 @@ ERROR: invalid-struct-slot token ;
[ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ;
<PRIVATE
: scan-c-type ( -- c-type )
scan dup "{" = [ drop \ } parse-until >array ] when ;
: parse-struct-slot ( -- slot )
scan scan-c-type \ } parse-until <struct-slot-spec> ;
@ -317,7 +300,7 @@ SYNTAX: S@
<PRIVATE
: scan-c-type` ( -- c-type/param )
scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
scan dup "{" = [ drop \ } parse-until >array ] [ search ] if ;
: parse-struct-slot` ( accum -- accum )
scan-string-param scan-c-type` \ } parse-until

11
basis/cocoa/enumeration/enumeration.factor
View File

@ -1,17 +1,16 @@
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel classes.struct cocoa cocoa.types alien.c-types
locals math sequences vectors fry libc destructors ;
USING: accessors kernel classes.struct cocoa cocoa.runtime cocoa.types alien.data
locals math sequences vectors fry libc destructors specialized-arrays ;
SPECIALIZED-ARRAY: id
IN: cocoa.enumeration
<< "id" require-c-array >>
CONSTANT: NS-EACH-BUFFER-SIZE 16
: with-enumeration-buffers ( quot -- )
'[
NSFastEnumerationState malloc-struct &free
NS-EACH-BUFFER-SIZE "id" malloc-array &free
NS-EACH-BUFFER-SIZE id malloc-array &free
NS-EACH-BUFFER-SIZE
@
] with-destructors ; inline
@ -19,7 +18,7 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16
:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count
items-count 0 = [
state itemsPtr>> [ items-count "id" <c-direct-array> ] [ stackbuf ] if* :> items
state itemsPtr>> [ items-count id <c-direct-array> ] [ stackbuf ] if* :> items
items-count iota [ items nth quot call ] each
object quot state stackbuf count (NSFastEnumeration-each)
] unless ; inline recursive

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

@ -4,8 +4,8 @@
USING: strings arrays hashtables assocs sequences fry macros
cocoa.messages cocoa.classes cocoa.application cocoa kernel
namespaces io.backend math cocoa.enumeration byte-arrays
combinators alien.c-types words core-foundation quotations
core-foundation.data core-foundation.utilities ;
combinators alien.c-types alien.data words core-foundation
quotations core-foundation.data core-foundation.utilities ;
IN: cocoa.plists
: >plist ( value -- plist ) >cf -> autorelease ;

2
basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -190,12 +190,14 @@ M: ##slot-imm insn-slot# slot>> ;
M: ##set-slot insn-slot# slot>> constant ;
M: ##set-slot-imm insn-slot# slot>> ;
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
M: ##vm-field-ptr insn-slot# fieldname>> 1array ; ! is this right?
M: ##slot insn-object obj>> resolve ;
M: ##slot-imm insn-object obj>> resolve ;
M: ##set-slot insn-object obj>> resolve ;
M: ##set-slot-imm insn-object obj>> resolve ;
M: ##alien-global insn-object drop \ ##alien-global ;
M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
: init-alias-analysis ( insns -- insns' )
H{ } clone histories set

2
basis/compiler/cfg/hats/hats.factor
View File

@ -57,4 +57,4 @@ insn-classes get [
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ; inline
: ^^tag-fixnum ( src -- dst ) tag-bits get ^^shl-imm ; inline
: ^^untag-fixnum ( src -- dst ) tag-bits get ^^sar-imm ; inline
: ^^untag-fixnum ( src -- dst ) tag-bits get ^^sar-imm ; inline

4
basis/compiler/cfg/instructions/instructions.factor
View File

@ -450,6 +450,10 @@ INSN: ##alien-global
def: dst/int-rep
literal: symbol library ;
INSN: ##vm-field-ptr
def: dst/int-rep
literal: fieldname ;
! FFI
INSN: ##alien-invoke
literal: params stack-frame ;

2
basis/compiler/cfg/intrinsics/misc/misc.factor
View File

@ -10,7 +10,7 @@ IN: compiler.cfg.intrinsics.misc
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
: emit-getenv ( node -- )
"userenv" f ^^alien-global
"userenv" ^^vm-field-ptr
swap node-input-infos first literal>>
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if*
ds-push ;

9
basis/compiler/codegen/codegen.factor
View File

@ -270,6 +270,9 @@ M: ##alien-global generate-insn
[ dst>> ] [ symbol>> ] [ library>> ] tri
%alien-global ;
M: ##vm-field-ptr generate-insn
[ dst>> ] [ fieldname>> ] bi %vm-field-ptr ;
! ##alien-invoke
GENERIC: next-fastcall-param ( rep -- )
@ -434,7 +437,7 @@ M: ##alien-indirect generate-insn
! Generate code for boxing input parameters in a callback.
[
dup \ %save-param-reg move-parameters
"nest_stacks" f %alien-invoke
"nest_stacks" %vm-invoke-1st-arg
box-parameters
] with-param-regs ;
@ -456,7 +459,7 @@ TUPLE: callback-context ;
: callback-return-quot ( ctype -- quot )
return>> {
{ [ dup "void" = ] [ drop [ ] ] }
{ [ dup void? ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
[ c-type c-type-unboxer-quot ]
} cond ;
@ -472,7 +475,7 @@ TUPLE: callback-context ;
[ callback-context new do-callback ] %
] [ ] make ;
: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
: %unnest-stacks ( -- ) "unnest_stacks" %vm-invoke-1st-arg ;
M: ##callback-return generate-insn
#! All the extra book-keeping for %unwind is only for x86.

1
basis/compiler/constants/constants.factor
View File

@ -50,6 +50,7 @@ CONSTANT: rt-immediate 8
CONSTANT: rt-stack-chain 9
CONSTANT: rt-untagged 10
CONSTANT: rt-megamorphic-cache-hits 11
CONSTANT: rt-vm 12
: rc-absolute? ( n -- ? )
${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;

1
basis/compiler/tests/alien.factor
View File

@ -5,6 +5,7 @@ io.streams.string kernel math memory namespaces
namespaces.private parser quotations sequences
specialized-arrays stack-checker stack-checker.errors
system threads tools.test words ;
FROM: alien.c-types => float short ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: char
IN: compiler.tests.alien

3
basis/compiler/tests/codegen.factor
View File

@ -4,6 +4,7 @@ namespaces.private slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors grouping make alien.c-types combinators.short-circuit
math.order math.libm math.parser ;
FROM: math => float ;
QUALIFIED: namespaces.private
IN: compiler.tests.codegen
@ -414,4 +415,4 @@ cell 4 = [
[ "0.169967142900241" "0.9854497299884601" ] [ 1.4 [ [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
[ 1 "0.169967142900241" "0.9854497299884601" ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
[ 6.0 ] [ 1.0 [ >float 3.0 + [ B{ 0 0 0 0 } 0 set-alien-float ] [ 2.0 + ] bi ] compile-call ] unit-test
[ 6.0 ] [ 1.0 [ >float 3.0 + [ B{ 0 0 0 0 } 0 set-alien-float ] [ 2.0 + ] bi ] compile-call ] unit-test

3
basis/compiler/tests/intrinsics.factor
View File

@ -3,8 +3,9 @@ math math.constants math.private math.integers.private sequences
strings tools.test words continuations sequences.private
hashtables.private byte-arrays system random layouts vectors
sbufs strings.private slots.private alien math.order
alien.accessors alien.c-types alien.syntax alien.strings
alien.accessors alien.c-types alien.data alien.syntax alien.strings
namespaces libc io.encodings.ascii classes compiler ;
FROM: math => float ;
IN: compiler.tests.intrinsics
! Make sure that intrinsic ops compile to correct code.

11
basis/compiler/tests/optimizer.factor
View File

@ -122,17 +122,6 @@ GENERIC: void-generic ( obj -- * )
[ t ] [ \ <tuple>-regression optimized? ] unit-test
GENERIC: foozul ( a -- b )
M: reversed foozul ;
M: integer foozul ;
M: slice foozul ;
[ t ] [
reversed \ foozul specific-method
reversed \ foozul method
eq?
] unit-test
! regression
: constant-fold-2 ( -- value ) f ; foldable
: constant-fold-3 ( -- value ) 4 ; foldable

1
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -16,6 +16,7 @@ compiler.tree.propagation
compiler.tree.propagation.info
compiler.tree.checker
compiler.tree.debugger ;
FROM: math => float ;
IN: compiler.tree.cleanup.tests
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test

2
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -52,7 +52,7 @@ M: callable splicing-nodes splicing-body ;
2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
[ swap nth value-info class>> dup ] dip
specific-method
method-for-class
] if
] if ;

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

@ -10,6 +10,7 @@ compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
specialized-arrays system sorting math.libm
math.intervals quotations effects alien ;
FROM: math => float ;
SPECIALIZED-ARRAY: double
IN: compiler.tree.propagation.tests

2
basis/compiler/tree/propagation/transforms/transforms.factor
View File

@ -14,7 +14,7 @@ IN: compiler.tree.propagation.transforms
! If first input has a known type and second input is an
! object, we convert this to [ swap equal? ].
in-d>> first2 value-info class>> object class= [
value-info class>> \ equal? specific-method
value-info class>> \ equal? method-for-class
[ swap equal? ] f ?
] [ drop f ] if
] "custom-inlining" set-word-prop

1
basis/core-foundation/numbers/numbers.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax kernel math core-foundation ;
FROM: math => float ;
IN: core-foundation.numbers
TYPEDEF: void* CFNumberRef

4
basis/cpu/architecture/architecture.factor
View File

@ -202,6 +202,7 @@ HOOK: %set-alien-double cpu ( ptr value -- )
HOOK: %set-alien-vector cpu ( ptr value rep -- )
HOOK: %alien-global cpu ( dst symbol library -- )
HOOK: %vm-field-ptr cpu ( dst fieldname -- )
HOOK: %allot cpu ( dst size class temp -- )
HOOK: %write-barrier cpu ( src card# table -- )
@ -297,6 +298,9 @@ M: object %prepare-var-args ;
HOOK: %alien-invoke cpu ( function library -- )
HOOK: %vm-invoke-1st-arg cpu ( function -- )
HOOK: %vm-invoke-3rd-arg cpu ( function -- )
HOOK: %cleanup cpu ( params -- )
M: object %cleanup ( params -- ) drop ;

27
basis/cpu/ppc/ppc.factor
View File

@ -2,13 +2,14 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences kernel combinators make math
math.order math.ranges system namespaces locals layouts words
alien alien.accessors alien.c-types literals cpu.architecture
alien alien.accessors alien.c-types alien.data literals cpu.architecture
cpu.ppc.assembler cpu.ppc.assembler.backend compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.comparisons
compiler.codegen.fixup compiler.cfg.intrinsics
compiler.cfg.stack-frame compiler.cfg.build-stack-frame
compiler.units compiler.constants compiler.codegen ;
compiler.units compiler.constants compiler.codegen vm ;
FROM: cpu.ppc.assembler => B ;
FROM: math => float ;
IN: cpu.ppc
! PowerPC register assignments:
@ -29,6 +30,18 @@ enable-float-intrinsics
\ ##float>integer t frame-required? set-word-prop
>>
: %load-vm-addr ( reg -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rt-vm rel-fixup ;
: %load-vm-field-addr ( reg symbol -- )
[ drop %load-vm-addr ]
[ [ dup ] dip vm-field-offset ADDI ] 2bi ;
M: ppc %vm-field-ptr ( dst field -- ) %load-vm-field-addr ;
M: ppc %vm-invoke-1st-arg ( function -- ) f %alien-invoke ;
M: ppc %vm-invoke-3rd-arg ( function -- ) f %alien-invoke ;
M: ppc machine-registers
{
{ int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
@ -418,7 +431,7 @@ M: ppc %set-alien-float swap 0 STFS ;
M: ppc %set-alien-double swap 0 STFD ;
: load-zone-ptr ( reg -- )
"nursery" f %alien-global ;
"nursery" %load-vm-field-addr ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ;
@ -441,10 +454,10 @@ M:: ppc %allot ( dst size class nursery-ptr -- )
dst class store-tagged ;
: load-cards-offset ( dst -- )
[ "cards_offset" f %alien-global ] [ dup 0 LWZ ] bi ;
[ "cards_offset" %load-vm-field-addr ] [ dup 0 LWZ ] bi ;
: load-decks-offset ( dst -- )
[ "decks_offset" f %alien-global ] [ dup 0 LWZ ] bi ;
[ "decks_offset" %load-vm-field-addr ] [ dup 0 LWZ ] bi ;
M:: ppc %write-barrier ( src card# table -- )
card-mark scratch-reg LI
@ -682,7 +695,7 @@ M:: ppc %save-context ( temp1 temp2 callback-allowed? -- )
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
temp1 "stack_chain" f %alien-global
temp1 "stack_chain" %load-vm-field-addr
temp1 temp1 0 LWZ
1 temp1 0 STW
callback-allowed? [
@ -770,5 +783,5 @@ USE: vocabs.loader
4 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
"bool" define-primitive-type
bool define-primitive-type
] with-compilation-unit

53
basis/cpu/x86/32/32.factor
View File

@ -47,6 +47,18 @@ M: x86.32 reserved-area-size 0 ;
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
: push-vm-ptr ( -- )
temp-reg 0 MOV rc-absolute-cell rt-vm rel-fixup ! push the vm ptr as an argument
temp-reg PUSH ;
M: x86.32 %vm-invoke-1st-arg ( function -- )
push-vm-ptr
f %alien-invoke
temp-reg POP ;
M: x86.32 %vm-invoke-3rd-arg ( function -- )
%vm-invoke-1st-arg ; ! first 2 args are regs, 3rd is stack so vm-invoke-1st-arg works here
M: x86.32 return-struct-in-registers? ( c-type -- ? )
c-type
[ return-in-registers?>> ]
@ -103,9 +115,12 @@ M: x86.32 %save-param-reg 3drop ;
#! parameter being passed to a callback from C.
over [ load-return-reg ] [ 2drop ] if ;
CONSTANT: vm-ptr-size 4
M:: x86.32 %box ( n rep func -- )
n rep (%box)
rep rep-size [
rep rep-size vm-ptr-size + [
push-vm-ptr
rep push-return-reg
func f %alien-invoke
] with-aligned-stack ;
@ -118,7 +133,8 @@ M:: x86.32 %box ( n rep func -- )
M: x86.32 %box-long-long ( n func -- )
[ (%box-long-long) ] dip
8 [
8 vm-ptr-size + [
push-vm-ptr
EDX PUSH
EAX PUSH
f %alien-invoke
@ -126,12 +142,13 @@ M: x86.32 %box-long-long ( n func -- )
M:: x86.32 %box-large-struct ( n c-type -- )
! Compute destination address
ECX n struct-return@ LEA
8 [
EDX n struct-return@ LEA
8 vm-ptr-size + [
push-vm-ptr
! Push struct size
c-type heap-size PUSH
! Push destination address
ECX PUSH
EDX PUSH
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke
] with-aligned-stack ;
@ -144,7 +161,8 @@ M: x86.32 %prepare-box-struct ( -- )
M: x86.32 %box-small-struct ( c-type -- )
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
12 [
12 vm-ptr-size + [
push-vm-ptr
heap-size PUSH
EDX PUSH
EAX PUSH
@ -157,7 +175,9 @@ M: x86.32 %prepare-unbox ( -- )
ESI 4 SUB ;
: call-unbox-func ( func -- )
4 [
8 [
! push the vm ptr as an argument
push-vm-ptr
! Push parameter
EAX PUSH
! Call the unboxer
@ -183,7 +203,8 @@ M: x86.32 %unbox-long-long ( n func -- )
: %unbox-struct-1 ( -- )
#! Alien must be in EAX.
4 [
4 vm-ptr-size + [
push-vm-ptr
EAX PUSH
"alien_offset" f %alien-invoke
! Load first cell
@ -192,7 +213,8 @@ M: x86.32 %unbox-long-long ( n func -- )
: %unbox-struct-2 ( -- )
#! Alien must be in EAX.
4 [
4 vm-ptr-size + [
push-vm-ptr
EAX PUSH
"alien_offset" f %alien-invoke
! Load second cell
@ -211,12 +233,13 @@ M: x86 %unbox-small-struct ( size -- )
M:: x86.32 %unbox-large-struct ( n c-type -- )
! Alien must be in EAX.
! Compute destination address
ECX n stack@ LEA
12 [
EDX n stack@ LEA
12 vm-ptr-size + [
push-vm-ptr
! Push struct size
c-type heap-size PUSH
! Push destination address
ECX PUSH
EDX PUSH
! Push source address
EAX PUSH
! Copy the struct to the stack
@ -224,7 +247,8 @@ M:: x86.32 %unbox-large-struct ( n c-type -- )
] with-aligned-stack ;
M: x86.32 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
push-vm-ptr "unbox_alien" f %alien-invoke
temp-reg POP
EBP EAX MOV ;
M: x86.32 %alien-indirect ( -- )
@ -234,6 +258,7 @@ M: x86.32 %alien-callback ( quot -- )
4 [
EAX swap %load-reference
EAX PUSH
param-reg-2 0 MOV rc-absolute-cell rt-vm rel-fixup
"c_to_factor" f %alien-invoke
] with-aligned-stack ;
@ -243,9 +268,11 @@ M: x86.32 %callback-value ( ctype -- )
! Save top of data stack in non-volatile register
%prepare-unbox
EAX PUSH
push-vm-ptr
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Place top of data stack in EAX
temp-reg POP
EAX POP
! Restore C stack
ESP 12 ADD

3
basis/cpu/x86/32/bootstrap.factor
View File

@ -12,6 +12,7 @@ IN: bootstrap.x86
: div-arg ( -- reg ) EAX ;
: mod-arg ( -- reg ) EDX ;
: arg ( -- reg ) EAX ;
: arg2 ( -- reg ) EDX ;
: temp0 ( -- reg ) EAX ;
: temp1 ( -- reg ) EDX ;
: temp2 ( -- reg ) ECX ;
@ -27,6 +28,8 @@ IN: bootstrap.x86
temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
! save stack pointer
temp0 [] stack-reg MOV
! pass vm ptr to primitive
arg 0 MOV rc-absolute-cell rt-vm jit-rel
! call the primitive
0 JMP rc-relative rt-primitive jit-rel
] jit-primitive jit-define

39
basis/cpu/x86/64/64.factor
View File

@ -74,9 +74,26 @@ M: x86.64 %prepare-unbox ( -- )
param-reg-1 R14 [] MOV
R14 cell SUB ;
M: x86.64 %vm-invoke-1st-arg ( function -- )
param-reg-1 0 MOV rc-absolute-cell rt-vm rel-fixup
f %alien-invoke ;
: %vm-invoke-2nd-arg ( function -- )
param-reg-2 0 MOV rc-absolute-cell rt-vm rel-fixup
f %alien-invoke ;
M: x86.64 %vm-invoke-3rd-arg ( function -- )
param-reg-3 0 MOV rc-absolute-cell rt-vm rel-fixup
f %alien-invoke ;
: %vm-invoke-4th-arg ( function -- )
int-regs param-regs fourth 0 MOV rc-absolute-cell rt-vm rel-fixup
f %alien-invoke ;
M:: x86.64 %unbox ( n rep func -- )
! Call the unboxer
func f %alien-invoke
func %vm-invoke-2nd-arg
! Store the return value on the C stack if this is an
! alien-invoke, otherwise leave it the return register if
! this is the end of alien-callback
@ -92,9 +109,10 @@ M: x86.64 %unbox-long-long ( n func -- )
{ float-regs [ float-regs get pop swap MOVSD ] }
} case ;
M: x86.64 %unbox-small-struct ( c-type -- )
! Alien must be in param-reg-1.
"alien_offset" f %alien-invoke
"alien_offset" %vm-invoke-2nd-arg
! Move alien_offset() return value to R11 so that we don't
! clobber it.
R11 RAX MOV
@ -109,7 +127,7 @@ M:: x86.64 %unbox-large-struct ( n c-type -- )
! Load structure size into param-reg-3
param-reg-3 c-type heap-size MOV
! Copy the struct to the C stack
"to_value_struct" f %alien-invoke ;
"to_value_struct" %vm-invoke-4th-arg ;
: load-return-value ( rep -- )
[ [ 0 ] dip reg-class-of param-reg ]
@ -117,6 +135,8 @@ M:: x86.64 %unbox-large-struct ( n c-type -- )
[ ]
tri copy-register ;
M:: x86.64 %box ( n rep func -- )
n [
n
@ -125,7 +145,7 @@ M:: x86.64 %box ( n rep func -- )
] [
rep load-return-value
] if
func f %alien-invoke ;
rep int-rep? [ func %vm-invoke-2nd-arg ] [ func %vm-invoke-1st-arg ] if ;
M: x86.64 %box-long-long ( n func -- )
[ int-rep ] dip %box ;
@ -145,7 +165,7 @@ M: x86.64 %box-small-struct ( c-type -- )
[ param-reg-3 swap heap-size MOV ] bi
param-reg-1 0 box-struct-field@ MOV
param-reg-2 1 box-struct-field@ MOV
"box_small_struct" f %alien-invoke
"box_small_struct" %vm-invoke-4th-arg
] with-return-regs ;
: struct-return@ ( n -- operand )
@ -157,7 +177,7 @@ M: x86.64 %box-large-struct ( n c-type -- )
! Compute destination address
param-reg-1 swap struct-return@ LEA
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke ;
"box_value_struct" %vm-invoke-3rd-arg ;
M: x86.64 %prepare-box-struct ( -- )
! Compute target address for value struct return
@ -172,8 +192,9 @@ M: x86.64 %alien-invoke
rc-absolute-cell rel-dlsym
R11 CALL ;
M: x86.64 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
"unbox_alien" %vm-invoke-1st-arg
RBP RAX MOV ;
M: x86.64 %alien-indirect ( -- )
@ -181,7 +202,7 @@ M: x86.64 %alien-indirect ( -- )
M: x86.64 %alien-callback ( quot -- )
param-reg-1 swap %load-reference
"c_to_factor" f %alien-invoke ;
"c_to_factor" %vm-invoke-2nd-arg ;
M: x86.64 %callback-value ( ctype -- )
! Save top of data stack
@ -190,7 +211,7 @@ M: x86.64 %callback-value ( ctype -- )
RSP 8 SUB
param-reg-1 PUSH
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
"unnest_stacks" %vm-invoke-1st-arg
! Put former top of data stack in param-reg-1
param-reg-1 POP
RSP 8 ADD

3
basis/cpu/x86/64/bootstrap.factor
View File

@ -21,6 +21,7 @@ IN: bootstrap.x86
: rex-length ( -- n ) 1 ;
[
! load stack_chain
temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel
temp0 temp0 [] MOV
@ -28,6 +29,8 @@ IN: bootstrap.x86
temp0 [] stack-reg MOV
! load XT
temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
! load vm ptr
arg 0 MOV rc-absolute-cell rt-vm jit-rel
! go
temp1 JMP
] jit-primitive jit-define

1
basis/cpu/x86/64/unix/bootstrap.factor
View File

@ -6,6 +6,7 @@ IN: bootstrap.x86
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
: arg ( -- reg ) RDI ;
: arg2 ( -- reg ) RSI ;
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >>
call

11
basis/cpu/x86/64/unix/unix.factor
View File

@ -16,9 +16,10 @@ M: float-regs param-regs
M: x86.64 reserved-area-size 0 ;
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
stack-params "__stack_value" c-type (>>rep) >>
SYMBOL: (stack-value)
! The ABI for passing structs by value is pretty great
<< void* c-type clone \ (stack-value) define-primitive-type
stack-params \ (stack-value) c-type (>>rep) >>
: struct-types&offset ( struct-type -- pairs )
fields>> [
@ -33,12 +34,12 @@ stack-params "__stack_value" c-type (>>rep) >>
: flatten-small-struct ( c-type -- seq )
struct-types&offset split-struct [
[ c-type c-type-rep reg-class-of ] map
int-regs swap member? "void*" "double" ? c-type
int-regs swap member? void* double ? c-type
] map ;
: flatten-large-struct ( c-type -- seq )
heap-size cell align
cell /i "__stack_value" c-type <repetition> ;
cell /i \ (stack-value) c-type <repetition> ;
: flatten-struct ( c-type -- seq )
dup heap-size 16 > [

1
basis/cpu/x86/64/winnt/bootstrap.factor
View File

@ -7,6 +7,7 @@ IN: bootstrap.x86
: stack-frame-size ( -- n ) 8 bootstrap-cells ;
: arg ( -- reg ) RCX ;
: arg2 ( -- reg ) RDX ;
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >>
call

8
basis/cpu/x86/64/winnt/winnt.factor
View File

@ -25,8 +25,8 @@ M: x86.64 dummy-fp-params? t ;
M: x86.64 temp-reg RAX ;
<<
"longlong" "ptrdiff_t" typedef
"longlong" "intptr_t" typedef
"int" c-type "long" define-primitive-type
"uint" c-type "ulong" define-primitive-type
longlong ptrdiff_t typedef
longlong intptr_t typedef
int c-type long define-primitive-type
uint c-type ulong define-primitive-type
>>

2
basis/cpu/x86/bootstrap.factor
View File

@ -251,6 +251,8 @@ big-endian off
arg ds-reg [] MOV
! pop stack
ds-reg bootstrap-cell SUB
! pass vm pointer
arg2 0 MOV rc-absolute-cell rt-vm jit-rel
! call quotation
arg quot-xt-offset [+] JMP
] \ (call) define-sub-primitive

4
basis/cpu/x86/features/features.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: system kernel math math.order math.parser namespaces
alien.syntax combinators locals init io cpu.x86 compiler
compiler.units accessors ;
alien.c-types alien.syntax combinators locals init io cpu.x86
compiler compiler.units accessors ;
IN: cpu.x86.features
<PRIVATE

29
basis/cpu/x86/x86.factor
View File

@ -4,18 +4,17 @@ USING: accessors assocs alien alien.c-types arrays strings
cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
cpu.architecture kernel kernel.private math memory namespaces make
sequences words system layouts combinators math.order fry locals
compiler.constants byte-arrays
compiler.constants vm byte-arrays
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.intrinsics
compiler.cfg.comparisons
compiler.cfg.stack-frame
compiler.codegen
compiler.codegen.fixup ;
FROM: layouts => cell ;
FROM: math => float ;
IN: cpu.x86
<< enable-fixnum-log2 >>
! Add some methods to the assembler to be more useful to the backend
M: label JMP 0 JMP rc-relative label-fixup ;
M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
@ -555,9 +554,13 @@ M: x86 %shl [ SHL ] emit-shift ;
M: x86 %shr [ SHR ] emit-shift ;
M: x86 %sar [ SAR ] emit-shift ;
M: x86 %vm-field-ptr ( dst field -- )
[ drop 0 MOV rc-absolute-cell rt-vm rel-fixup ]
[ vm-field-offset ADD ] 2bi ;
: load-zone-ptr ( reg -- )
#! Load pointer to start of zone array
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
"nursery" %vm-field-ptr ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
@ -577,18 +580,19 @@ M:: x86 %allot ( dst size class nursery-ptr -- )
dst class store-tagged
nursery-ptr size inc-allot-ptr ;
M:: x86 %write-barrier ( src card# table -- )
#! Mark the card pointed to by vreg.
! Mark the card
card# src MOV
card# card-bits SHR
table "cards_offset" f %alien-global
table "cards_offset" %vm-field-ptr
table table [] MOV
table card# [+] card-mark <byte> MOV
! Mark the card deck
card# deck-bits card-bits - SHR
table "decks_offset" f %alien-global
table "decks_offset" %vm-field-ptr
table table [] MOV
table card# [+] card-mark <byte> MOV ;
@ -610,10 +614,10 @@ M:: x86 %call-gc ( gc-root-count -- )
! Pass number of roots as second parameter
param-reg-2 gc-root-count MOV
! Call GC
"inline_gc" f %alien-invoke ;
"inline_gc" %vm-invoke-3rd-arg ;
M: x86 %alien-global
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
M: x86 %alien-global ( dst symbol library -- )
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
@ -742,8 +746,8 @@ M:: x86 %save-context ( temp1 temp2 callback-allowed? -- )
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
temp1 "stack_chain" f %alien-global
temp1 temp1 [] MOV
temp1 0 MOV rc-absolute-cell rt-vm rel-fixup
temp1 temp1 "stack_chain" vm-field-offset [+] MOV
temp2 stack-reg cell neg [+] LEA
temp1 [] temp2 MOV
callback-allowed? [
@ -774,3 +778,4 @@ M: x86 small-enough? ( n -- ? )
enable-sse3-simd ;
enable-min/max
enable-fixnum-log2

10
basis/db/postgresql/lib/lib.factor
View File

@ -2,11 +2,11 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays continuations db io kernel math namespaces
quotations sequences db.postgresql.ffi alien alien.c-types
db.types tools.walker ascii splitting math.parser combinators
libc calendar.format byte-arrays destructors prettyprint
accessors strings serialize io.encodings.binary io.encodings.utf8
alien.strings io.streams.byte-array summary present urls
specialized-arrays db.private ;
alien.data db.types tools.walker ascii splitting math.parser
combinators libc calendar.format byte-arrays destructors
prettyprint accessors strings serialize io.encodings.binary
io.encodings.utf8 alien.strings io.streams.byte-array summary
present urls specialized-arrays db.private ;
SPECIALIZED-ARRAY: uint
SPECIALIZED-ARRAY: void*
IN: db.postgresql.lib

2
basis/db/sqlite/lib/lib.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types arrays assocs kernel math math.parser
USING: alien.c-types alien.data arrays assocs kernel math math.parser
namespaces sequences db.sqlite.ffi db combinators
continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary

2
basis/debugger/debugger.factor
View File

@ -174,6 +174,8 @@ M: no-method error.
M: bad-slot-value summary drop "Bad store to specialized slot" ;
M: bad-slot-name summary drop "Bad slot name in object literal" ;
M: no-math-method summary
drop "No suitable arithmetic method" ;

7
basis/environment/unix/unix.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax kernel
layouts sequences system unix environment io.encodings.utf8
unix.utilities vocabs.loader combinators alien.accessors ;
USING: alien alien.c-types alien.data alien.strings
alien.syntax kernel layouts sequences system unix
environment io.encodings.utf8 unix.utilities vocabs.loader
combinators alien.accessors ;
IN: environment.unix
HOOK: environ os ( -- void* )

11
basis/environment/winnt/winnt.factor
View File

@ -1,15 +1,14 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.strings fry io.encodings.utf16n kernel
splitting windows windows.kernel32 system environment
alien.c-types sequences windows.errors io.streams.memory
io.encodings io ;
splitting windows windows.kernel32 windows.types system
environment alien.data sequences windows.errors
io.streams.memory io.encodings io specialized-arrays ;
SPECIALIZED-ARRAY: TCHAR
IN: environment.winnt
<< "TCHAR" require-c-array >>
M: winnt os-env ( key -- value )
MAX_UNICODE_PATH "TCHAR" <c-array>
MAX_UNICODE_PATH TCHAR <c-array>
[ dup length GetEnvironmentVariable ] keep over 0 = [
2drop f
] [

19
basis/functors/functors-tests.factor
View File

@ -1,5 +1,6 @@
USING: classes.struct functors tools.test math words kernel
multiline parser io.streams.string generic ;
QUALIFIED-WITH: alien.c-types c
IN: functors.tests
<<
@ -160,15 +161,15 @@ T-class DEFINES-CLASS ${T}
WHERE
STRUCT: T-class
{ NAME int }
{ NAME c:int }
{ x { TYPE 4 } }
{ y { "short" N } }
{ y { c:short N } }
{ z TYPE initial: 5 }
{ float { "float" 2 } } ;
{ float { c:float 2 } } ;
;FUNCTOR
"a-struct" "nemo" "char" 2 define-a-struct
"a-struct" "nemo" c:char 2 define-a-struct
>>
@ -179,35 +180,35 @@ STRUCT: T-class
{ offset 0 }
{ class integer }
{ initial 0 }
{ c-type "int" }
{ type c:int }
}
T{ struct-slot-spec
{ name "x" }
{ offset 4 }
{ class object }
{ initial f }
{ c-type { "char" 4 } }
{ type { c:char 4 } }
}
T{ struct-slot-spec
{ name "y" }
{ offset 8 }
{ class object }
{ initial f }
{ c-type { "short" 2 } }
{ type { c:short 2 } }
}
T{ struct-slot-spec
{ name "z" }
{ offset 12 }
{ class fixnum }
{ initial 5 }
{ c-type "char" }
{ type c:char }
}
T{ struct-slot-spec
{ name "float" }
{ offset 16 }
{ class object }
{ initial f }
{ c-type { "float" 2 } }
{ type { c:float 2 } }
}
}
] [ a-struct struct-slots ] unit-test

0
extra/system-info/authors.txt → basis/furnace/recaptcha/authors.txt
View File

1
basis/furnace/recaptcha/example/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

31
basis/furnace/recaptcha/example/example.factor Normal file
View File

@ -0,0 +1,31 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors db.sqlite furnace.actions furnace.alloy
furnace.conversations furnace.recaptcha furnace.redirection
html.templates.chloe.compiler http.server
http.server.dispatchers http.server.responses io.streams.string
kernel urls xml.syntax ;
IN: furnace.recaptcha.example
TUPLE: recaptcha-app < dispatcher recaptcha ;
: recaptcha-db ( -- obj ) "recaptcha-example" <sqlite-db> ;
: <recaptcha-challenge> ( -- obj )
<page-action>
[
begin-conversation
validate-recaptcha
recaptcha-valid? cget
"?good" "?bad" ? >url <continue-conversation>
] >>submit
{ recaptcha-app "example" } >>template ;
: <recaptcha-app> ( -- obj )
\ recaptcha-app new-dispatcher
<recaptcha-challenge> "" add-responder
<recaptcha>
"concatenative.org" >>domain
"6LeJWQgAAAAAAFlYV7SuBClE9uSpGtV_ZS-qVON7" >>public-key
"6LeJWQgAAAAAALh-XJgSSQ6xKygRgJ8-029Ip2Xv" >>private-key
recaptcha-db <alloy> ;

4
basis/furnace/recaptcha/example/example.xml Normal file
View File

@ -0,0 +1,4 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<html><body><form submit="" method="post"><t:recaptcha/></form></body></html>
</t:chloe>

55
basis/furnace/recaptcha/recaptcha-docs.factor Normal file
View File

@ -0,0 +1,55 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax http.server.filters kernel
multiline furnace.actions furnace.alloy furnace.conversations ;
IN: furnace.recaptcha
HELP: <recaptcha>
{ $values
{ "responder" "a responder" }
{ "obj" object }
}
{ $description "A " { $link filter-responder } " wrapping another responder. Set the domain, public, and private keys using the key you get by registering with Recaptcha." } ;
HELP: recaptcha-error
{ $var-description "Set to the error string returned by the Recaptcha server." } ;
HELP: recaptcha-valid?
{ $var-description "Set to " { $link t } " if the user solved the last Recaptcha correctly." } ;
HELP: validate-recaptcha
{ $description "Validates a Recaptcha using the Recaptcha web service API." } ;
ARTICLE: "recaptcha-example" "Recaptcha example"
"There are several steps to using the Recaptcha library."
{ $list
{ "Wrap the responder in a " { $link <recaptcha> } }
{ "Wrap the responder in a " { $link <conversations> } " if it is not already" }
{ "Ensure that there is a database connected, with the " { $link <alloy> } " word" }
{ "Start a conversation to move values between requests" }
{ "Add a handler calling " { $link validate-recaptcha } " in the " { $slot "submit" } " of the " { $link page-action } }
{ "Pass the conversation from your submit action using " { $link <continue-conversation> } }
{ "Put the chloe tag " { $snippet "<recaptcha/>" } " inside a form tag in the template for your " { $link page-action } }
}
$nl
"Run this example vocabulary:"
{ $code
"USE: furnace.recaptcha.example"
"<recaptcha-app> main-responder set-global"
} ;
ARTICLE: "furnace.recaptcha" "Recaptcha"
"The " { $vocab-link "furnace.recaptcha" } " vocabulary implements support for the Recaptcha. Recaptcha is a web service that provides the user with a captcha, a test that is easy to solve by visual inspection, but hard to solve by writing a computer program. Use a captcha to protect forms from abusive users." $nl
"The recaptcha responder is a " { $link filter-responder } " that wraps another responder. Set the " { $slot "domain" } ", " { $slot "public-key" } ", and " { $slot "private-key" } " slots of this responder to your Recaptcha account information." $nl
"Wrapping a responder with Recaptcha:"
{ $subsection <recaptcha> }
"Validating recaptcha:"
{ $subsection validate-recaptcha }
"Symbols set after validation:"
{ $subsection recaptcha-valid? }
{ $subsection recaptcha-error }
{ $subsection "recaptcha-example" } ;
ABOUT: "furnace.recaptcha"

76
basis/furnace/recaptcha/recaptcha.factor Normal file
View File

@ -0,0 +1,76 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors furnace.actions furnace.redirection html.forms
html.templates.chloe.compiler html.templates.chloe.syntax
http.client http.server http.server.filters io.sockets kernel
locals namespaces sequences splitting urls validators
xml.syntax furnace.conversations ;
IN: furnace.recaptcha
TUPLE: recaptcha < filter-responder domain public-key private-key ;
SYMBOLS: recaptcha-valid? recaptcha-error ;
: <recaptcha> ( responder -- obj )
recaptcha new
swap >>responder ;
M: recaptcha call-responder*
dup \ recaptcha set
responder>> call-responder ;
<PRIVATE
: (render-recaptcha) ( private-key -- xml )
dup
[XML <script type="text/javascript"
src=<->>
</script>
<noscript>
<iframe src=<->
height="300" width="500" frameborder="0"></iframe><br/>
<textarea name="recaptcha_challenge_field" rows="3" cols="40">
</textarea>
<input type="hidden" name="recaptcha_response_field"
value="manual_challenge"/>
</noscript>
XML] ;
: recaptcha-url ( secure? -- ? )
[ "https://api.recaptcha.net/challenge" ]
[ "http://api.recaptcha.net/challenge" ] if
recaptcha-error cget [ "?error=" glue ] when* >url ;
: render-recaptcha ( -- xml )
secure-connection? recaptcha-url
recaptcha get public-key>> "k" set-query-param (render-recaptcha) ;
: parse-recaptcha-response ( string -- valid? error )
"\n" split first2 [ "true" = ] dip ;
:: (validate-recaptcha) ( challenge response recaptcha -- valid? error )
recaptcha private-key>> :> private-key
remote-address get host>> :> remote-ip
H{
{ "challenge" challenge }
{ "response" response }
{ "privatekey" private-key }
{ "remoteip" remote-ip }
} URL" http://api-verify.recaptcha.net/verify"
<post-request> http-request nip parse-recaptcha-response ;
CHLOE: recaptcha
drop [ render-recaptcha ] [xml-code] ;
PRIVATE>
: validate-recaptcha ( -- )
{
{ "recaptcha_challenge_field" [ v-required ] }
{ "recaptcha_response_field" [ v-required ] }
} validate-params
"recaptcha_challenge_field" value
"recaptcha_response_field" value
\ recaptcha get (validate-recaptcha)
[ recaptcha-valid? cset ] [ recaptcha-error cset ] bi* ;

7
basis/furnace/recaptcha/recaptcha.xml Normal file
View File

@ -0,0 +1,7 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<html>
<body><t:recaptcha/>
</body>
</html>
</t:chloe>

1
basis/furnace/recaptcha/summary.txt Normal file
View File

@ -0,0 +1 @@
Recaptcha library

1
basis/furnace/recaptcha/tags.txt Normal file
View File

@ -0,0 +1 @@
web

19
basis/game-input/dinput/dinput.factor
View File

@ -6,7 +6,7 @@ math.rectangles namespaces parser sequences shuffle
specialized-arrays ui.backend.windows vectors windows.com
windows.dinput windows.dinput.constants windows.errors
windows.kernel32 windows.messages windows.ole32
windows.user32 classes.struct ;
windows.user32 classes.struct alien.data ;
SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA
IN: game-input.dinput
@ -160,19 +160,24 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
[ device-attached? not ] filter
[ remove-controller ] each ;
: device-interface? ( dbt-broadcast-hdr -- ? )
dbch_devicetype>> DBT_DEVTYP_DEVICEINTERFACE = ;
: ?device-interface ( dbt-broadcast-hdr -- ? )
dup dbch_devicetype>> DBT_DEVTYP_DEVICEINTERFACE =
[ >c-ptr DEV_BROADCAST_DEVICEW memory>struct ]
[ drop f ] if ; inline
: device-arrived ( dbt-broadcast-hdr -- )
device-interface? [ find-controllers ] when ;
?device-interface [ find-controllers ] when ; inline
: device-removed ( dbt-broadcast-hdr -- )
device-interface? [ find-and-remove-detached-devices ] when ;
?device-interface [ find-and-remove-detached-devices ] when ; inline
: <DEV_BROADCAST_HDR> ( wParam -- struct )
<alien> DEV_BROADCAST_HDR memory>struct ;
: handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
[ 2drop ] 2dip swap {
{ [ dup DBT_DEVICEARRIVAL = ] [ drop <alien> device-arrived ] }
{ [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <alien> device-removed ] }
{ [ dup DBT_DEVICEARRIVAL = ] [ drop <DEV_BROADCAST_HDR> device-arrived ] }
{ [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <DEV_BROADCAST_HDR> device-removed ] }
[ 2drop ]
} cond ;

4
basis/game-input/dinput/keys-array/keys-array.factor
View File

@ -1,5 +1,5 @@
USING: sequences sequences.private math alien.c-types
accessors ;
USING: sequences sequences.private math
accessors alien.data ;
IN: game-input.dinput.keys-array
TUPLE: keys-array

3
basis/game-input/iokit/iokit.factor
View File

@ -3,7 +3,8 @@ kernel cocoa.enumeration destructors math.parser cocoa.application
sequences locals combinators.short-circuit threads
namespaces assocs arrays combinators hints alien
core-foundation.run-loop accessors sequences.private
alien.c-types math parser game-input vectors bit-arrays ;
alien.c-types alien.data math parser game-input vectors
bit-arrays ;
IN: game-input.iokit
SINGLETON: iokit-game-input-backend

2
basis/html/templates/chloe/chloe-docs.factor
View File

@ -24,7 +24,7 @@ HELP: compile-attr
{ $description "Compiles code which pushes an attribute value previously extracted by " { $link required-attr } " or " { $link optional-attr } " on the stack. If the attribute value begins with " { $snippet "@" } ", compiles into code which pushes the a form value." } ;
HELP: CHLOE:
{ $syntax "name definition... ;" }
{ $syntax "CHLOE: name definition... ;" }
{ $values { "name" "the tag name" } { "definition" { $quotation "( tag -- )" } } }
{ $description "Defines compilation semantics for the Chloe tag named " { $snippet "tag" } ". The definition body receives a " { $link tag } " on the stack." } ;

6
basis/images/memory/memory.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types destructors fry images kernel
libc math sequences ;
USING: accessors alien.c-types alien.data destructors fry images
kernel libc math sequences ;
IN: images.memory
! Some code shared by core-graphics and cairo for constructing
@ -27,4 +27,4 @@ PRIVATE>
: make-memory-bitmap ( dim quot -- image )
'[
[ malloc-bitmap-data ] keep _ [ <bitmap-image> ] 2bi
] with-destructors ; inline
] with-destructors ; inline

95
basis/io/backend/windows/nt/privileges/privileges.factor
View File

@ -1,52 +1,43 @@
USING: alien alien.c-types alien.syntax arrays continuations
destructors generic io.mmap io.ports io.backend.windows io.files.windows
kernel libc math math.bitwise namespaces quotations sequences windows
windows.advapi32 windows.kernel32 io.backend system accessors
io.backend.windows.privileges windows.errors ;
IN: io.backend.windows.nt.privileges
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
! Security tokens
! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
: (open-process-token) ( handle -- handle )
{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" <c-object>
[ OpenProcessToken win32-error=0/f ] keep *void* ;
: open-process-token ( -- handle )
#! remember to CloseHandle
GetCurrentProcess (open-process-token) ;
: with-process-token ( quot -- )
#! quot: ( token-handle -- token-handle )
[ open-process-token ] dip
[ keep ] curry
[ CloseHandle drop ] [ ] cleanup ; inline
: lookup-privilege ( string -- luid )
[ f ] dip "LUID" <c-object>
[ LookupPrivilegeValue win32-error=0/f ] keep ;
: make-token-privileges ( name ? -- obj )
"TOKEN_PRIVILEGES" <c-object>
1 over set-TOKEN_PRIVILEGES-PrivilegeCount
"LUID_AND_ATTRIBUTES" malloc-object &free
over set-TOKEN_PRIVILEGES-Privileges
swap [
SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges
set-LUID_AND_ATTRIBUTES-Attributes
] when
[ lookup-privilege ] dip
[
TOKEN_PRIVILEGES-Privileges
set-LUID_AND_ATTRIBUTES-Luid
] keep ;
M: winnt set-privilege ( name ? -- )
[
-rot 0 -rot make-token-privileges
dup length f f AdjustTokenPrivileges win32-error=0/f
] with-process-token ;
USING: alien alien.c-types alien.data alien.syntax arrays continuations
destructors generic io.mmap io.ports io.backend.windows io.files.windows
kernel libc locals math math.bitwise namespaces quotations sequences windows
windows.advapi32 windows.kernel32 windows.types io.backend system accessors
io.backend.windows.privileges classes.struct windows.errors ;
IN: io.backend.windows.nt.privileges
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
! Security tokens
! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
: (open-process-token) ( handle -- handle )
{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags PHANDLE <c-object>
[ OpenProcessToken win32-error=0/f ] keep *void* ;
: open-process-token ( -- handle )
#! remember to CloseHandle
GetCurrentProcess (open-process-token) ;
: with-process-token ( quot -- )
#! quot: ( token-handle -- token-handle )
[ open-process-token ] dip
[ keep ] curry
[ CloseHandle drop ] [ ] cleanup ; inline
: lookup-privilege ( string -- luid )
[ f ] dip LUID <struct>
[ LookupPrivilegeValue win32-error=0/f ] keep ;
:: make-token-privileges ( name enabled? -- obj )
TOKEN_PRIVILEGES <struct>
1 >>PrivilegeCount
LUID_AND_ATTRIBUTES malloc-struct &free
enabled? [ SE_PRIVILEGE_ENABLED >>Attributes ] when
name lookup-privilege >>Luid
>>Privileges ;
M: winnt set-privilege ( name ? -- )
[
-rot 0 -rot make-token-privileges
dup byte-length f f AdjustTokenPrivileges win32-error=0/f
] with-process-token ;

6
basis/io/buffers/buffers-tests.factor
View File

@ -1,7 +1,7 @@
IN: io.buffers.tests
USING: alien alien.c-types io.buffers kernel kernel.private libc
sequences tools.test namespaces byte-arrays strings accessors
destructors ;
USING: alien alien.c-types alien.data io.buffers kernel
kernel.private libc sequences tools.test namespaces byte-arrays
strings accessors destructors ;
: buffer-set ( string buffer -- )
over >byte-array over ptr>> byte-array>memory

4
basis/io/buffers/buffers.factor
View File

@ -2,8 +2,8 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.accessors alien.c-types
alien.syntax kernel libc math sequences byte-arrays strings
hints math.order destructors combinators ;
alien.data alien.syntax kernel libc math sequences byte-arrays
strings hints math.order destructors combinators ;
IN: io.buffers
TUPLE: buffer

2
basis/io/files/info/windows/windows.factor
View File

@ -6,7 +6,7 @@ windows.time windows accessors alien.c-types combinators
generalizations system alien.strings io.encodings.utf16n
sequences splitting windows.errors fry continuations destructors
calendar ascii combinators.short-circuit locals classes.struct
specialized-arrays ;
specialized-arrays alien.data ;
SPECIALIZED-ARRAY: ushort
IN: io.files.info.windows

2
basis/io/files/windows/windows.factor
View File

@ -6,7 +6,7 @@ io.backend.windows kernel math splitting fry alien.strings
windows windows.kernel32 windows.time calendar combinators
math.functions sequences namespaces make words system
destructors accessors math.bitwise continuations windows.errors
arrays byte-arrays generalizations ;
arrays byte-arrays generalizations alien.data ;
IN: io.files.windows
: open-file ( path access-mode create-mode flags -- handle )

2
basis/io/mmap/mmap.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors io.files io.files.info
io.backend kernel quotations system alien alien.accessors
accessors vocabs.loader combinators alien.c-types
accessors vocabs.loader combinators alien.c-types alien.data
math ;
IN: io.mmap

4
basis/io/monitors/windows/nt/nt.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings libc destructors locals
kernel math assocs namespaces make continuations sequences
USING: alien alien.c-types alien.data alien.strings libc destructors
locals kernel math assocs namespaces make continuations sequences
hashtables sorting arrays combinators math.bitwise strings
system accessors threads splitting io.backend io.backend.windows
io.backend.windows.nt io.files.windows.nt io.monitors io.ports

10
basis/io/sockets/secure/openssl/openssl.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays kernel sequences namespaces math
math.order combinators init alien alien.c-types alien.strings
libc continuations destructors summary splitting assocs random
math.parser locals unicode.case openssl openssl.libcrypto
openssl.libssl io.backend io.ports io.pathnames
math.order combinators init alien alien.c-types alien.data
alien.strings libc continuations destructors summary splitting
assocs random math.parser locals unicode.case openssl
openssl.libcrypto openssl.libssl io.backend io.ports io.pathnames
io.encodings.8-bit io.timeouts io.sockets.secure ;
IN: io.sockets.secure.openssl
@ -31,7 +31,7 @@ TUPLE: openssl-context < secure-context aliens sessions ;
] [ drop ] if ;
: password-callback ( -- alien )
"int" { "void*" "int" "bool" "void*" } "cdecl"
int { void* int bool void* } "cdecl"
[| buf size rwflag password! |
password [ B{ 0 } password! ] unless

2
basis/io/sockets/sockets.factor
View File

@ -6,7 +6,7 @@ arrays io.encodings io.ports io.streams.duplex io.encodings.ascii
alien.strings io.binary accessors destructors classes byte-arrays
parser alien.c-types math.parser splitting grouping math assocs
summary system vocabs.loader combinators present fry vocabs.parser
classes.struct ;
classes.struct alien.data ;
IN: io.sockets
<< {

2
basis/io/sockets/unix/unix.factor
View File

@ -5,7 +5,7 @@ threads sequences byte-arrays io.binary io.backend.unix
io.streams.duplex io.backend io.pathnames io.sockets.private
io.files.private io.encodings.utf8 math.parser continuations
libc combinators system accessors destructors unix locals init
classes.struct ;
classes.struct alien.data ;
EXCLUDE: namespaces => bind ;
EXCLUDE: io => read write ;

2
basis/io/sockets/windows/nt/nt.factor
View File

@ -1,4 +1,4 @@
USING: alien alien.accessors alien.c-types byte-arrays
USING: alien alien.accessors alien.c-types alien.data byte-arrays
continuations destructors io.ports io.timeouts io.sockets
io.sockets.private io namespaces io.streams.duplex
io.backend.windows io.sockets.windows io.backend.windows.nt

29
basis/iokit/hid/hid.factor
View File

@ -130,30 +130,11 @@ TYPEDEF: void* IOHIDTransactionRef
TYPEDEF: UInt32 IOHIDValueScaleType
TYPEDEF: UInt32 IOHIDTransactionDirectionType
TYPEDEF: void* IOHIDCallback
: IOHIDCallback ( quot -- alien )
[ "void" { "void*" "IOReturn" "void*" } "cdecl" ]
dip alien-callback ; inline
TYPEDEF: void* IOHIDReportCallback
: IOHIDReportCallback ( quot -- alien )
[ "void" { "void*" "IOReturn" "void*" "IOHIDReportType" "UInt32" "uchar*" "CFIndex" } "cdecl" ]
dip alien-callback ; inline
TYPEDEF: void* IOHIDValueCallback
: IOHIDValueCallback ( quot -- alien )
[ "void" { "void*" "IOReturn" "void*" "IOHIDValueRef" } "cdecl" ]
dip alien-callback ; inline
TYPEDEF: void* IOHIDValueMultipleCallback
: IOHIDValueMultipleCallback ( quot -- alien )
[ "void" { "void*" "IOReturn" "void*" "CFDictionaryRef" } "cdecl" ]
dip alien-callback ; inline
TYPEDEF: void* IOHIDDeviceCallback
: IOHIDDeviceCallback ( quot -- alien )
[ "void" { "void*" "IOReturn" "void*" "IOHIDDeviceRef" } "cdecl" ]
dip alien-callback ; inline
CALLBACK: void IOHIDCallback ( void* context, IOReturn result, void* sender ) ;
CALLBACK: void IOHIDReportCallback ( void* context, IOReturn result, void* sender, IOHIDReportType type, UInt32 reportID, uchar* report, CFIndex reportLength ) ;
CALLBACK: void IOHIDValueCallback ( void* context, IOReturn result, void* sender, IOHIDValueRef value ) ;
CALLBACK: void IOHIDValueMultipleCallback ( void* context, IOReturn result, void* sender, CFDictionaryRef multiple ) ;
CALLBACK: void IOHIDDeviceCallback ( void* context, IOReturn result, void* sender, IOHIDDeviceRef device ) ;
! IOHIDDevice

20
basis/libc/libc.factor
View File

@ -2,29 +2,29 @@
! Copyright (C) 2007, 2009 Slava Pestov
! Copyright (C) 2007, 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: alien assocs continuations alien.destructors kernel
USING: alien alien.c-types assocs continuations alien.destructors kernel
namespaces accessors sets summary destructors destructors.private ;
IN: libc
: errno ( -- int )
"int" "factor" "err_no" { } alien-invoke ;
int "factor" "err_no" { } alien-invoke ;
: clear-errno ( -- )
"void" "factor" "clear_err_no" { } alien-invoke ;
void "factor" "clear_err_no" { } alien-invoke ;
<PRIVATE
: (malloc) ( size -- alien )
"void*" "libc" "malloc" { "ulong" } alien-invoke ;
void* "libc" "malloc" { ulong } alien-invoke ;
: (calloc) ( count size -- alien )
"void*" "libc" "calloc" { "ulong" "ulong" } alien-invoke ;
void* "libc" "calloc" { ulong ulong } alien-invoke ;
: (free) ( alien -- )
"void" "libc" "free" { "void*" } alien-invoke ;
void "libc" "free" { void* } alien-invoke ;
: (realloc) ( alien size -- newalien )
"void*" "libc" "realloc" { "void*" "ulong" } alien-invoke ;
void* "libc" "realloc" { void* ulong } alien-invoke ;
! We stick malloc-ptr instances in the global disposables set
TUPLE: malloc-ptr value continuation ;
@ -81,15 +81,15 @@ PRIVATE>
>c-ptr [ delete-malloc ] [ (free) ] bi ;
: memcpy ( dst src size -- )
"void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ;
void "libc" "memcpy" { void* void* ulong } alien-invoke ;
: memcmp ( a b size -- cmp )
"int" "libc" "memcmp" { "void*" "void*" "ulong" } alien-invoke ;
int "libc" "memcmp" { void* void* ulong } alien-invoke ;
: memory= ( a b size -- ? )
memcmp 0 = ;
: strlen ( alien -- len )
"size_t" "libc" "strlen" { "char*" } alien-invoke ;
size_t "libc" "strlen" { char* } alien-invoke ;
DESTRUCTOR: free

15
basis/math/blas/matrices/matrices.factor
View File

@ -1,10 +1,11 @@
USING: accessors alien alien.c-types arrays byte-arrays combinators
combinators.short-circuit fry kernel locals macros
math math.blas.ffi math.blas.vectors math.blas.vectors.private
math.complex math.functions math.order functors words
sequences sequences.merged sequences.private shuffle
parser prettyprint.backend prettyprint.custom ascii
specialized-arrays ;
USING: accessors alien alien.c-types alien.data arrays
byte-arrays combinators combinators.short-circuit fry
kernel locals macros math math.blas.ffi math.blas.vectors
math.blas.vectors.private math.complex math.functions
math.order functors words sequences sequences.merged
sequences.private shuffle parser prettyprint.backend
prettyprint.custom ascii specialized-arrays ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: double
SPECIALIZED-ARRAY: complex-float

1
basis/math/blas/vectors/vectors.factor
View File

@ -3,6 +3,7 @@ combinators.short-circuit fry kernel math math.blas.ffi
math.complex math.functions math.order sequences sequences.private
functors words locals parser prettyprint.backend prettyprint.custom
specialized-arrays ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: double
SPECIALIZED-ARRAY: complex-float

40
basis/math/libm/libm.factor
View File

@ -1,62 +1,62 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien ;
USING: alien alien.c-types ;
IN: math.libm
: facos ( x -- y )
"double" "libm" "acos" { "double" } alien-invoke ;
double "libm" "acos" { double } alien-invoke ;
: fasin ( x -- y )
"double" "libm" "asin" { "double" } alien-invoke ;
double "libm" "asin" { double } alien-invoke ;
: fatan ( x -- y )
"double" "libm" "atan" { "double" } alien-invoke ;
double "libm" "atan" { double } alien-invoke ;
: fatan2 ( x y -- z )
"double" "libm" "atan2" { "double" "double" } alien-invoke ;
double "libm" "atan2" { double double } alien-invoke ;
: fcos ( x -- y )
"double" "libm" "cos" { "double" } alien-invoke ;
double "libm" "cos" { double } alien-invoke ;
: fsin ( x -- y )
"double" "libm" "sin" { "double" } alien-invoke ;
double "libm" "sin" { double } alien-invoke ;
: ftan ( x -- y )
"double" "libm" "tan" { "double" } alien-invoke ;
double "libm" "tan" { double } alien-invoke ;
: fcosh ( x -- y )
"double" "libm" "cosh" { "double" } alien-invoke ;
double "libm" "cosh" { double } alien-invoke ;
: fsinh ( x -- y )
"double" "libm" "sinh" { "double" } alien-invoke ;
double "libm" "sinh" { double } alien-invoke ;
: ftanh ( x -- y )
"double" "libm" "tanh" { "double" } alien-invoke ;
double "libm" "tanh" { double } alien-invoke ;
: fexp ( x -- y )
"double" "libm" "exp" { "double" } alien-invoke ;
double "libm" "exp" { double } alien-invoke ;
: flog ( x -- y )
"double" "libm" "log" { "double" } alien-invoke ;
double "libm" "log" { double } alien-invoke ;
: flog10 ( x -- y )
"double" "libm" "log10" { "double" } alien-invoke ;
double "libm" "log10" { double } alien-invoke ;
: fpow ( x y -- z )
"double" "libm" "pow" { "double" "double" } alien-invoke ;
double "libm" "pow" { double double } alien-invoke ;
: fsqrt ( x -- y )
"double" "libm" "sqrt" { "double" } alien-invoke ;
double "libm" "sqrt" { double } alien-invoke ;
! Windows doesn't have these...
: flog1+ ( x -- y )
"double" "libm" "log1p" { "double" } alien-invoke ;
double "libm" "log1p" { double } alien-invoke ;
: facosh ( x -- y )
"double" "libm" "acosh" { "double" } alien-invoke ;
double "libm" "acosh" { double } alien-invoke ;
: fasinh ( x -- y )
"double" "libm" "asinh" { "double" } alien-invoke ;
double "libm" "asinh" { double } alien-invoke ;
: fatanh ( x -- y )
"double" "libm" "atanh" { "double" } alien-invoke ;
double "libm" "atanh" { double } alien-invoke ;

2
basis/math/partial-dispatch/partial-dispatch.factor
View File

@ -147,7 +147,7 @@ SYMBOL: fast-math-ops
: math-both-known? ( word left right -- ? )
3dup math-op
[ 2drop 2drop t ]
[ drop math-class-max swap specific-method >boolean ] if ;
[ drop math-class-max swap method-for-class >boolean ] if ;
: (derived-ops) ( word assoc -- words )
swap '[ swap first _ eq? nip ] assoc-filter ;

12
basis/math/vectors/simd/functor/functor.factor
View File

@ -9,14 +9,16 @@ ERROR: bad-length got expected ;
FUNCTOR: define-simd-128 ( T -- )
N [ 16 T heap-size /i ]
T-TYPE IS ${T}
N [ 16 T-TYPE heap-size /i ]
A DEFINES-CLASS ${T}-${N}
>A DEFINES >${A}
A{ DEFINES ${A}{
NTH [ T dup c-type-getter-boxer array-accessor ]
SET-NTH [ T dup c-setter array-accessor ]
NTH [ T-TYPE dup c-type-getter-boxer array-accessor ]
SET-NTH [ T-TYPE dup c-setter array-accessor ]
A-rep IS ${A}-rep
A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
@ -74,7 +76,9 @@ PRIVATE>
! Synthesize 256-bit vectors from a pair of 128-bit vectors
FUNCTOR: define-simd-256 ( T -- )
N [ 32 T heap-size /i ]
T-TYPE IS ${T}
N [ 32 T-TYPE heap-size /i ]
N/2 [ N 2 / ]
A/2 IS ${T}-${N/2}

2
basis/math/vectors/simd/intrinsics/intrinsics.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel alien alien.c-types cpu.architecture libc ;
USING: kernel alien alien.data cpu.architecture libc ;
IN: math.vectors.simd.intrinsics
ERROR: bad-simd-call ;

14
basis/math/vectors/simd/simd.factor
View File

@ -5,6 +5,8 @@ kernel math math.functions math.vectors
math.vectors.simd.functor math.vectors.simd.intrinsics
math.vectors.specialization parser prettyprint.custom sequences
sequences.private locals assocs words fry ;
FROM: alien.c-types => float ;
QUALIFIED-WITH: math m
IN: math.vectors.simd
<<
@ -15,9 +17,9 @@ DEFER: float-8
DEFER: double-4
"double" define-simd-128
"float" define-simd-128
"float" define-simd-128
"double" define-simd-256
"float" define-simd-256
"float" define-simd-256
>>
@ -136,7 +138,7 @@ DEFER: double-4
PRIVATE>
\ float-4 \ float-4-with float H{
\ float-4 \ float-4-with m:float H{
{ v+ [ [ (simd-v+) ] float-4-vv->v-op ] }
{ v- [ [ (simd-v-) ] float-4-vv->v-op ] }
{ v* [ [ (simd-v*) ] float-4-vv->v-op ] }
@ -146,7 +148,7 @@ PRIVATE>
{ sum [ [ (simd-sum) ] float-4-v->n-op ] }
} simd-vector-words
\ double-2 \ double-2-with float H{
\ double-2 \ double-2-with m:float H{
{ v+ [ [ (simd-v+) ] double-2-vv->v-op ] }
{ v- [ [ (simd-v-) ] double-2-vv->v-op ] }
{ v* [ [ (simd-v*) ] double-2-vv->v-op ] }
@ -156,7 +158,7 @@ PRIVATE>
{ sum [ [ (simd-sum) ] double-2-v->n-op ] }
} simd-vector-words
\ float-8 \ float-8-with float H{
\ float-8 \ float-8-with m:float H{
{ v+ [ [ (simd-v+) ] float-8-vv->v-op ] }
{ v- [ [ (simd-v-) ] float-8-vv->v-op ] }
{ v* [ [ (simd-v*) ] float-8-vv->v-op ] }
@ -166,7 +168,7 @@ PRIVATE>
{ sum [ [ (simd-sum) ] [ + ] float-8-v->n-op ] }
} simd-vector-words
\ double-4 \ double-4-with float H{
\ double-4 \ double-4-with m:float H{
{ v+ [ [ (simd-v+) ] double-4-vv->v-op ] }
{ v- [ [ (simd-v-) ] double-4-vv->v-op ] }
{ v* [ [ (simd-v*) ] double-4-vv->v-op ] }

1
basis/opengl/opengl.factor
View File

@ -8,6 +8,7 @@ math.parser opengl.gl combinators combinators.smart arrays
sequences splitting words byte-arrays assocs vocabs
colors colors.constants accessors generalizations locals fry
specialized-arrays ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: uint
IN: opengl

2
basis/opengl/shaders/shaders.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl.gl alien.c-types continuations namespaces
assocs alien alien.strings libc opengl math sequences combinators
assocs alien alien.data alien.strings libc opengl math sequences combinators
macros arrays io.encodings.ascii fry specialized-arrays
destructors accessors ;
SPECIALIZED-ARRAY: uint

70
basis/openssl/libcrypto/libcrypto.factor
View File

@ -5,8 +5,8 @@
!
! export LD_LIBRARY_PATH=/opt/local/lib
USING: alien alien.syntax combinators kernel system
alien.libraries ;
USING: alien alien.c-types alien.syntax combinators kernel system
alien.libraries classes.struct ;
IN: openssl.libcrypto
@ -20,35 +20,35 @@ IN: openssl.libcrypto
} cond
>>
C-STRUCT: bio-method
{ "int" "type" }
{ "void*" "name" }
{ "void*" "bwrite" }
{ "void*" "bread" }
{ "void*" "bputs" }
{ "void*" "bgets" }
{ "void*" "ctrl" }
{ "void*" "create" }
{ "void*" "destroy" }
{ "void*" "callback-ctrl" } ;
STRUCT: bio-method
{ type int }
{ name void* }
{ bwrite void* }
{ bread void* }
{ bputs void* }
{ bgets void* }
{ ctrl void* }
{ create void* }
{ destroy void* }
{ callback-ctrl void* } ;
C-STRUCT: bio
{ "void*" "method" }
{ "void*" "callback" }
{ "void*" "cb-arg" }
{ "int" "init" }
{ "int" "shutdown" }
{ "int" "flags" }
{ "int" "retry-reason" }
{ "int" "num" }
{ "void*" "ptr" }
{ "void*" "next-bio" }
{ "void*" "prev-bio" }
{ "int" "references" }
{ "ulong" "num-read" }
{ "ulong" "num-write" }
{ "void*" "crypto-ex-data-stack" }
{ "int" "crypto-ex-data-dummy" } ;
STRUCT: bio
{ method void* }
{ callback void* }
{ cb-arg void* }
{ init int }
{ shutdown int }
{ flags int }
{ retry-reason int }
{ num int }
{ ptr void* }
{ next-bio void* }
{ prev-bio void* }
{ references int }
{ num-read ulong }
{ num-write ulong }
{ crypto-ex-data-stack void* }
{ crypto-ex-data-dummy int } ;
CONSTANT: BIO_NOCLOSE HEX: 00
CONSTANT: BIO_CLOSE HEX: 01
@ -103,11 +103,11 @@ FUNCTION: void* BIO_f_buffer ( ) ;
CONSTANT: EVP_MAX_MD_SIZE 64
C-STRUCT: EVP_MD_CTX
{ "EVP_MD*" "digest" }
{ "ENGINE*" "engine" }
{ "ulong" "flags" }
{ "void*" "md_data" } ;
STRUCT: EVP_MD_CTX
{ digest EVP_MD* }
{ engine ENGINE* }
{ flags ulong }
{ md_data void* } ;
TYPEDEF: void* EVP_MD*
TYPEDEF: void* ENGINE*

3
basis/prettyprint/config/config-docs.factor
View File

@ -19,6 +19,9 @@ HELP: length-limit
HELP: line-limit
{ $var-description "The maximum number of lines output by the prettyprinter before output is truncated with \"...\". The default is " { $link f } ", denoting unlimited line count." } ;
HELP: number-base
{ $var-description "The number base in which the prettyprinter will output numeric literals. A value of " { $snippet "2" } " will print integers and ratios in binary with " { $link POSTPONE: BIN: } ", and " { $snippet "8" } " will print them in octal with " { $link POSTPONE: OCT: } ". A value of " { $snippet "16" } " will print all integers, ratios, and floating-point values in hexadecimal with " { $link POSTPONE: HEX: } ". Other values of " { $snippet "number-base" } " will print numbers in decimal, which is the default." } ;
HELP: string-limit?
{ $var-description "Toggles whether printed strings are truncated to the margin." } ;

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