Merge branch 'master' of git://factorcode.org/git/factor
commit
0b01117e90
26
Makefile
26
Makefile
|
@ -18,6 +18,10 @@ else
|
||||||
CFLAGS += -O3
|
CFLAGS += -O3
|
||||||
endif
|
endif
|
||||||
|
|
||||||
|
ifdef REENTRANT
|
||||||
|
CFLAGS += -DFACTOR_REENTRANT
|
||||||
|
endif
|
||||||
|
|
||||||
CFLAGS += $(SITE_CFLAGS)
|
CFLAGS += $(SITE_CFLAGS)
|
||||||
|
|
||||||
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
|
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
|
||||||
|
@ -164,17 +168,17 @@ macosx.app: factor
|
||||||
Factor.app/Contents/MacOS/factor
|
Factor.app/Contents/MacOS/factor
|
||||||
|
|
||||||
$(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
|
$(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
|
||||||
$(LINKER) $(ENGINE) $(DLL_OBJS)
|
$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
|
||||||
$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
||||||
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
|
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
|
||||||
|
|
||||||
$(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
|
$(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
|
||||||
$(LINKER) $(ENGINE) $(DLL_OBJS)
|
$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
|
||||||
$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
||||||
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
|
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
|
||||||
|
|
||||||
$(TEST_LIBRARY): vm/ffi_test.o
|
$(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:
|
clean:
|
||||||
rm -f vm/*.o
|
rm -f vm/*.o
|
||||||
|
@ -187,22 +191,22 @@ tags:
|
||||||
etags vm/*.{cpp,hpp,mm,S,c}
|
etags vm/*.{cpp,hpp,mm,S,c}
|
||||||
|
|
||||||
vm/resources.o:
|
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
|
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:
|
.c.o:
|
||||||
$(CC) -c $(CFLAGS) -o $@ $<
|
$(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) -o $@ $<
|
||||||
|
|
||||||
.cpp.o:
|
.cpp.o:
|
||||||
$(CPP) -c $(CFLAGS) -o $@ $<
|
$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
|
||||||
|
|
||||||
.S.o:
|
.S.o:
|
||||||
$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
|
$(TOOLCHAIN_PREFIX)$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
|
||||||
|
|
||||||
.mm.o:
|
.mm.o:
|
||||||
$(CPP) -c $(CFLAGS) -o $@ $<
|
$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
|
||||||
|
|
||||||
.PHONY: factor tags clean
|
.PHONY: factor tags clean
|
||||||
|
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
|
USING: help.syntax help.markup byte-arrays alien.c-types alien.data ;
|
||||||
IN: alien.arrays
|
IN: alien.arrays
|
||||||
USING: help.syntax help.markup byte-arrays alien.c-types ;
|
|
||||||
|
|
||||||
ARTICLE: "c-arrays" "C arrays"
|
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" } "."
|
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.strings alien.c-types alien.accessors
|
USING: alien alien.strings alien.c-types alien.data alien.accessors
|
||||||
arrays words sequences math kernel namespaces fry libc cpu.architecture
|
arrays words sequences math kernel namespaces fry cpu.architecture
|
||||||
io.encodings.utf8 accessors ;
|
io.encodings.utf8 accessors ;
|
||||||
IN: alien.arrays
|
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 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
|
M: array c-type-boxer-quot
|
||||||
unclip
|
unclip
|
||||||
|
@ -41,7 +41,7 @@ M: array c-type-boxer-quot
|
||||||
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
|
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
|
||||||
|
|
||||||
PREDICATE: string-type < pair
|
PREDICATE: string-type < pair
|
||||||
first2 [ "char*" = ] [ word? ] bi* and ;
|
first2 [ char* = ] [ word? ] bi* and ;
|
||||||
|
|
||||||
M: string-type c-type ;
|
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 c-type-boxed-class drop object ;
|
||||||
|
|
||||||
M: string-type heap-size
|
M: string-type heap-size
|
||||||
drop "void*" heap-size ;
|
drop void* heap-size ;
|
||||||
|
|
||||||
M: string-type c-type-align
|
M: string-type c-type-align
|
||||||
drop "void*" c-type-align ;
|
drop void* c-type-align ;
|
||||||
|
|
||||||
M: string-type c-type-stack-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
|
M: string-type unbox-parameter
|
||||||
drop "void*" unbox-parameter ;
|
drop void* unbox-parameter ;
|
||||||
|
|
||||||
M: string-type unbox-return
|
M: string-type unbox-return
|
||||||
drop "void*" unbox-return ;
|
drop void* unbox-return ;
|
||||||
|
|
||||||
M: string-type box-parameter
|
M: string-type box-parameter
|
||||||
drop "void*" box-parameter ;
|
drop void* box-parameter ;
|
||||||
|
|
||||||
M: string-type box-return
|
M: string-type box-return
|
||||||
drop "void*" box-return ;
|
drop void* box-return ;
|
||||||
|
|
||||||
M: string-type stack-size
|
M: string-type stack-size
|
||||||
drop "void*" stack-size ;
|
drop void* stack-size ;
|
||||||
|
|
||||||
M: string-type c-type-rep
|
M: string-type c-type-rep
|
||||||
drop int-rep ;
|
drop int-rep ;
|
||||||
|
|
||||||
M: string-type c-type-boxer
|
M: string-type c-type-boxer
|
||||||
drop "void*" c-type-boxer ;
|
drop void* c-type-boxer ;
|
||||||
|
|
||||||
M: string-type c-type-unboxer
|
M: string-type c-type-unboxer
|
||||||
drop "void*" c-type-unboxer ;
|
drop void* c-type-unboxer ;
|
||||||
|
|
||||||
M: string-type c-type-boxer-quot
|
M: string-type c-type-boxer-quot
|
||||||
second '[ _ alien>string ] ;
|
second '[ _ alien>string ] ;
|
||||||
|
@ -94,6 +94,8 @@ M: string-type c-type-getter
|
||||||
M: string-type c-type-setter
|
M: string-type c-type-setter
|
||||||
drop [ set-alien-cell ] ;
|
drop [ set-alien-cell ] ;
|
||||||
|
|
||||||
{ "char*" utf8 } "char*" typedef
|
{ char* utf8 } char* typedef
|
||||||
"char*" "uchar*" typedef
|
char* uchar* typedef
|
||||||
|
|
||||||
|
char char* "pointer-c-type" set-word-prop
|
||||||
|
uchar uchar* "pointer-c-type" set-word-prop
|
||||||
|
|
|
@ -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
|
IN: alien.c-types
|
||||||
USING: alien help.syntax help.markup libc kernel.private
|
|
||||||
byte-arrays math strings hashtables alien.syntax alien.strings sequences
|
HELP: byte-length
|
||||||
io.encodings.string debugger destructors vocabs.loader ;
|
{ $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>
|
HELP: <c-type>
|
||||||
{ $values { "type" hashtable } }
|
{ $values { "type" hashtable } }
|
||||||
|
@ -20,24 +40,6 @@ HELP: c-type
|
||||||
{ $description "Looks up a C type by name." }
|
{ $description "Looks up a C type by name." }
|
||||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
||||||
|
|
||||||
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
|
HELP: c-getter
|
||||||
{ $values { "name" string } { "quot" { $quotation "( c-ptr n -- obj )" } } }
|
{ $values { "name" string } { "quot" { $quotation "( c-ptr n -- obj )" } } }
|
||||||
{ $description "Outputs a quotation which reads values of this C type from a C structure." }
|
{ $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." }
|
{ $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." } ;
|
{ $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
|
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." }
|
{ $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." } ;
|
{ $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." }
|
{ $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." } ;
|
{ $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"
|
ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
|
||||||
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
|
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
|
||||||
|
@ -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." ;
|
"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"
|
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
|
$nl
|
||||||
"The following numerical types are available; a " { $snippet "u" } " prefix denotes an unsigned type:"
|
"The following numerical types are available; a " { $snippet "u" } " prefix denotes an unsigned type:"
|
||||||
{ $table
|
{ $table
|
||||||
{ "C type" "Notes" }
|
{ "C type" "Notes" }
|
||||||
{ { $snippet "char" } "always 1 byte" }
|
{ { $link char } "always 1 byte" }
|
||||||
{ { $snippet "uchar" } { } }
|
{ { $link uchar } { } }
|
||||||
{ { $snippet "short" } "always 2 bytes" }
|
{ { $link short } "always 2 bytes" }
|
||||||
{ { $snippet "ushort" } { } }
|
{ { $link ushort } { } }
|
||||||
{ { $snippet "int" } "always 4 bytes" }
|
{ { $link int } "always 4 bytes" }
|
||||||
{ { $snippet "uint" } { } }
|
{ { $link uint } { } }
|
||||||
{ { $snippet "long" } { "same size as CPU word size and " { $snippet "void*" } ", except on 64-bit Windows, where it is 4 bytes" } }
|
{ { $link long } { "same size as CPU word size and " { $link void* } ", except on 64-bit Windows, where it is 4 bytes" } }
|
||||||
{ { $snippet "ulong" } { } }
|
{ { $link ulong } { } }
|
||||||
{ { $snippet "longlong" } "always 8 bytes" }
|
{ { $link longlong } "always 8 bytes" }
|
||||||
{ { $snippet "ulonglong" } { } }
|
{ { $link ulonglong } { } }
|
||||||
{ { $snippet "float" } { } }
|
{ { $link float } { "single-precision float (not the same as Factor's " { $link math:float } " class!)" } }
|
||||||
{ { $snippet "double" } { "same format as " { $link float } " objects" } }
|
{ { $link double } { "double-precision float (the same format as Factor's " { $link math:float } " objects)" } }
|
||||||
{ { $snippet "complex-float" } { "C99 " { $snippet "complex float" } " type, converted to and from " { $link complex } " values" } }
|
{ { $link complex-float } { "C99 or Fortran " { $snippet "complex float" } " type, converted to and from Factor " { $link math:complex } " values" } }
|
||||||
{ { $snippet "complex-double" } { "C99 " { $snippet "complex double" } " type, converted to and from " { $link 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."
|
"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
|
$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
|
$nl
|
||||||
"Fixed-size array types are supported; the syntax consists of a C type name followed by dimension sizes in brackets; the following denotes a 3 by 4 array of integers:"
|
"Fixed-size array types are supported; the syntax consists of a C type name followed by dimension sizes in brackets; the following denotes a 3 by 4 array of integers:"
|
||||||
{ $code "int[3][4]" }
|
{ $code "int[3][4]" }
|
||||||
"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however when used as function parameters they behave exactly like pointers and thus the dimensions only serve as documentation."
|
"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however when used as function parameters they behave exactly like pointers and thus the dimensions only serve as documentation."
|
||||||
$nl
|
$nl
|
||||||
"Structure and union types are specified by the name of the structure or union." ;
|
"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" } ;
|
|
||||||
|
|
|
@ -43,7 +43,7 @@ TYPEDEF: int* MyIntArray
|
||||||
|
|
||||||
TYPEDEF: uchar* MyLPBYTE
|
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*>
|
0 B{ 1 2 3 4 } <displaced-alien> <void*>
|
||||||
|
|
|
@ -1,18 +1,27 @@
|
||||||
! Copyright (C) 2004, 2009 Slava Pestov.
|
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
namespaces make parser sequences strings words splitting math.parser
|
||||||
cpu.architecture alien alien.accessors alien.strings quotations
|
cpu.architecture alien alien.accessors alien.strings quotations
|
||||||
layouts system compiler.units io io.files io.encodings.binary
|
layouts system compiler.units io io.files io.encodings.binary
|
||||||
io.streams.memory accessors combinators effects continuations fry
|
io.streams.memory accessors combinators effects continuations fry
|
||||||
classes vocabs vocabs.loader ;
|
classes vocabs vocabs.loader words.symbol ;
|
||||||
|
QUALIFIED: math
|
||||||
IN: alien.c-types
|
IN: alien.c-types
|
||||||
|
|
||||||
|
SYMBOLS:
|
||||||
|
char uchar
|
||||||
|
short ushort
|
||||||
|
int uint
|
||||||
|
long ulong
|
||||||
|
longlong ulonglong
|
||||||
|
float double
|
||||||
|
void* bool
|
||||||
|
void ;
|
||||||
|
|
||||||
DEFER: <int>
|
DEFER: <int>
|
||||||
DEFER: *char
|
DEFER: *char
|
||||||
|
|
||||||
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
|
|
||||||
|
|
||||||
TUPLE: abstract-c-type
|
TUPLE: abstract-c-type
|
||||||
{ class class initial: object }
|
{ class class initial: object }
|
||||||
{ boxed-class class initial: object }
|
{ boxed-class class initial: object }
|
||||||
|
@ -40,149 +49,124 @@ global [
|
||||||
|
|
||||||
ERROR: no-c-type name ;
|
ERROR: no-c-type name ;
|
||||||
|
|
||||||
: (c-type) ( name -- type/f )
|
PREDICATE: c-type-word < word
|
||||||
c-types get-global at dup [
|
"c-type" word-prop ;
|
||||||
dup string? [ (c-type) ] when
|
|
||||||
] when ;
|
UNION: c-type-name string c-type-word ;
|
||||||
|
|
||||||
! C type protocol
|
! C type protocol
|
||||||
GENERIC: c-type ( name -- type ) foldable
|
GENERIC: c-type ( name -- type ) foldable
|
||||||
|
|
||||||
: resolve-pointer-type ( name -- name )
|
GENERIC: resolve-pointer-type ( name -- c-type )
|
||||||
c-types get at dup string?
|
|
||||||
[ "*" append ] [ drop "void*" ] if
|
M: word resolve-pointer-type
|
||||||
c-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 )
|
: 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
|
"[" split unclip
|
||||||
[ [ "]" ?tail drop string>number ] map ] dip prefix ;
|
[ [ "]" ?tail drop string>number ] map ] dip ;
|
||||||
|
|
||||||
M: string c-type ( name -- type )
|
M: string c-type ( name -- type )
|
||||||
CHAR: ] over member? [
|
CHAR: ] over member? [
|
||||||
parse-array-type
|
parse-array-type prefix
|
||||||
] [
|
] [
|
||||||
dup c-types get at [
|
dup c-types get at [ ] [
|
||||||
resolve-typedef
|
|
||||||
] [
|
|
||||||
"*" ?tail [ resolve-pointer-type ] [ no-c-type ] if
|
"*" ?tail [ resolve-pointer-type ] [ no-c-type ] if
|
||||||
] ?if
|
] ?if resolve-typedef
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
M: word c-type
|
||||||
|
"c-type" word-prop resolve-typedef ;
|
||||||
|
|
||||||
|
: void? ( c-type -- ? )
|
||||||
|
{ void "void" } member? ;
|
||||||
|
|
||||||
GENERIC: c-struct? ( type -- ? )
|
GENERIC: c-struct? ( type -- ? )
|
||||||
|
|
||||||
M: object c-struct?
|
M: object c-struct?
|
||||||
drop f ;
|
drop f ;
|
||||||
M: string c-struct?
|
M: c-type-name c-struct?
|
||||||
dup "void" = [ drop f ] [ c-type c-struct? ] if ;
|
dup void? [ drop f ] [ c-type c-struct? ] if ;
|
||||||
|
|
||||||
! These words being foldable means that words need to be
|
! These words being foldable means that words need to be
|
||||||
! recompiled if a C type is redefined. Even so, folding the
|
! recompiled if a C type is redefined. Even so, folding the
|
||||||
! size facilitates some optimizations.
|
! 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 )
|
GENERIC: c-type-class ( name -- class )
|
||||||
|
|
||||||
M: abstract-c-type c-type-class 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 )
|
GENERIC: c-type-boxed-class ( name -- class )
|
||||||
|
|
||||||
M: abstract-c-type c-type-boxed-class boxed-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 )
|
GENERIC: c-type-boxer ( name -- boxer )
|
||||||
|
|
||||||
M: c-type c-type-boxer 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 )
|
GENERIC: c-type-boxer-quot ( name -- quot )
|
||||||
|
|
||||||
M: abstract-c-type c-type-boxer-quot boxer-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 )
|
GENERIC: c-type-unboxer ( name -- boxer )
|
||||||
|
|
||||||
M: c-type c-type-unboxer unboxer>> ;
|
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 )
|
GENERIC: c-type-unboxer-quot ( name -- quot )
|
||||||
|
|
||||||
M: abstract-c-type c-type-unboxer-quot unboxer-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 )
|
GENERIC: c-type-rep ( name -- rep )
|
||||||
|
|
||||||
M: c-type c-type-rep 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 )
|
GENERIC: c-type-getter ( name -- quot )
|
||||||
|
|
||||||
M: c-type c-type-getter getter>> ;
|
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 )
|
GENERIC: c-type-setter ( name -- quot )
|
||||||
|
|
||||||
M: c-type c-type-setter setter>> ;
|
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 )
|
GENERIC: c-type-align ( name -- n )
|
||||||
|
|
||||||
M: abstract-c-type c-type-align align>> ;
|
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 -- ? )
|
GENERIC: c-type-stack-align? ( name -- ? )
|
||||||
|
|
||||||
M: c-type c-type-stack-align? stack-align?>> ;
|
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-box ( n type -- )
|
||||||
[ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
|
[ 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: 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 -- )
|
GENERIC: box-return ( ctype -- )
|
||||||
|
|
||||||
M: c-type box-return f swap c-type-box ;
|
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 -- )
|
GENERIC: unbox-parameter ( n ctype -- )
|
||||||
|
|
||||||
M: c-type unbox-parameter c-type-unbox ;
|
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 -- )
|
GENERIC: unbox-return ( ctype -- )
|
||||||
|
|
||||||
M: c-type unbox-return f swap c-type-unbox ;
|
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
|
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 ;
|
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
|
GENERIC: byte-length ( seq -- n ) flushable
|
||||||
|
|
||||||
M: byte-array byte-length length ; inline
|
M: byte-array byte-length length ; inline
|
||||||
|
|
||||||
M: f byte-length drop 0 ; inline
|
M: f byte-length drop 0 ; inline
|
||||||
|
|
||||||
|
MIXIN: value-type
|
||||||
|
|
||||||
: c-getter ( name -- quot )
|
: c-getter ( name -- quot )
|
||||||
c-type-getter [
|
c-type-getter [
|
||||||
[ "Cannot read struct fields with this type" throw ]
|
[ "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 ]
|
[ "Cannot write struct fields with this type" throw ]
|
||||||
] unless* ;
|
] 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 )
|
: array-accessor ( type quot -- def )
|
||||||
[
|
[
|
||||||
\ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
|
\ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
|
||||||
] [ ] make ;
|
] [ ] 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 ;
|
TUPLE: long-long-type < c-type ;
|
||||||
|
|
||||||
|
@ -312,36 +282,33 @@ M: long-long-type box-return ( type -- )
|
||||||
|
|
||||||
: define-out ( name -- )
|
: define-out ( name -- )
|
||||||
[ "alien.c-types" constructor-word ]
|
[ "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 ;
|
(( value -- c-ptr )) define-inline ;
|
||||||
|
|
||||||
: >c-bool ( ? -- int ) 1 0 ? ; inline
|
|
||||||
|
|
||||||
: c-bool> ( int -- ? ) 0 = not ; inline
|
|
||||||
|
|
||||||
: define-primitive-type ( type name -- )
|
: define-primitive-type ( type name -- )
|
||||||
[ typedef ]
|
[ typedef ]
|
||||||
[ define-deref ]
|
[ name>> define-deref ]
|
||||||
[ define-out ]
|
[ name>> define-out ]
|
||||||
tri ;
|
tri ;
|
||||||
|
|
||||||
: malloc-file-contents ( path -- alien len )
|
|
||||||
binary file-contents [ malloc-byte-array ] [ length ] bi ;
|
|
||||||
|
|
||||||
: if-void ( type true false -- )
|
: 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
|
CONSTANT: primitive-types
|
||||||
{
|
{
|
||||||
"char" "uchar"
|
char uchar
|
||||||
"short" "ushort"
|
short ushort
|
||||||
"int" "uint"
|
int uint
|
||||||
"long" "ulong"
|
long ulong
|
||||||
"longlong" "ulonglong"
|
longlong ulonglong
|
||||||
"float" "double"
|
float double
|
||||||
"void*" "bool"
|
void* bool
|
||||||
}
|
}
|
||||||
|
|
||||||
|
SYMBOLS:
|
||||||
|
ptrdiff_t intptr_t size_t
|
||||||
|
char* uchar* ;
|
||||||
|
|
||||||
[
|
[
|
||||||
<c-type>
|
<c-type>
|
||||||
c-ptr >>class
|
c-ptr >>class
|
||||||
|
@ -353,7 +320,7 @@ CONSTANT: primitive-types
|
||||||
[ >c-ptr ] >>unboxer-quot
|
[ >c-ptr ] >>unboxer-quot
|
||||||
"box_alien" >>boxer
|
"box_alien" >>boxer
|
||||||
"alien_offset" >>unboxer
|
"alien_offset" >>unboxer
|
||||||
"void*" define-primitive-type
|
\ void* define-primitive-type
|
||||||
|
|
||||||
<long-long-type>
|
<long-long-type>
|
||||||
integer >>class
|
integer >>class
|
||||||
|
@ -364,7 +331,7 @@ CONSTANT: primitive-types
|
||||||
8 >>align
|
8 >>align
|
||||||
"box_signed_8" >>boxer
|
"box_signed_8" >>boxer
|
||||||
"to_signed_8" >>unboxer
|
"to_signed_8" >>unboxer
|
||||||
"longlong" define-primitive-type
|
\ longlong define-primitive-type
|
||||||
|
|
||||||
<long-long-type>
|
<long-long-type>
|
||||||
integer >>class
|
integer >>class
|
||||||
|
@ -375,7 +342,7 @@ CONSTANT: primitive-types
|
||||||
8 >>align
|
8 >>align
|
||||||
"box_unsigned_8" >>boxer
|
"box_unsigned_8" >>boxer
|
||||||
"to_unsigned_8" >>unboxer
|
"to_unsigned_8" >>unboxer
|
||||||
"ulonglong" define-primitive-type
|
\ ulonglong define-primitive-type
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
integer >>class
|
integer >>class
|
||||||
|
@ -386,7 +353,7 @@ CONSTANT: primitive-types
|
||||||
bootstrap-cell >>align
|
bootstrap-cell >>align
|
||||||
"box_signed_cell" >>boxer
|
"box_signed_cell" >>boxer
|
||||||
"to_fixnum" >>unboxer
|
"to_fixnum" >>unboxer
|
||||||
"long" define-primitive-type
|
\ long define-primitive-type
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
integer >>class
|
integer >>class
|
||||||
|
@ -397,7 +364,7 @@ CONSTANT: primitive-types
|
||||||
bootstrap-cell >>align
|
bootstrap-cell >>align
|
||||||
"box_unsigned_cell" >>boxer
|
"box_unsigned_cell" >>boxer
|
||||||
"to_cell" >>unboxer
|
"to_cell" >>unboxer
|
||||||
"ulong" define-primitive-type
|
\ ulong define-primitive-type
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
integer >>class
|
integer >>class
|
||||||
|
@ -408,7 +375,7 @@ CONSTANT: primitive-types
|
||||||
4 >>align
|
4 >>align
|
||||||
"box_signed_4" >>boxer
|
"box_signed_4" >>boxer
|
||||||
"to_fixnum" >>unboxer
|
"to_fixnum" >>unboxer
|
||||||
"int" define-primitive-type
|
\ int define-primitive-type
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
integer >>class
|
integer >>class
|
||||||
|
@ -419,7 +386,7 @@ CONSTANT: primitive-types
|
||||||
4 >>align
|
4 >>align
|
||||||
"box_unsigned_4" >>boxer
|
"box_unsigned_4" >>boxer
|
||||||
"to_cell" >>unboxer
|
"to_cell" >>unboxer
|
||||||
"uint" define-primitive-type
|
\ uint define-primitive-type
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
fixnum >>class
|
fixnum >>class
|
||||||
|
@ -430,7 +397,7 @@ CONSTANT: primitive-types
|
||||||
2 >>align
|
2 >>align
|
||||||
"box_signed_2" >>boxer
|
"box_signed_2" >>boxer
|
||||||
"to_fixnum" >>unboxer
|
"to_fixnum" >>unboxer
|
||||||
"short" define-primitive-type
|
\ short define-primitive-type
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
fixnum >>class
|
fixnum >>class
|
||||||
|
@ -441,7 +408,7 @@ CONSTANT: primitive-types
|
||||||
2 >>align
|
2 >>align
|
||||||
"box_unsigned_2" >>boxer
|
"box_unsigned_2" >>boxer
|
||||||
"to_cell" >>unboxer
|
"to_cell" >>unboxer
|
||||||
"ushort" define-primitive-type
|
\ ushort define-primitive-type
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
fixnum >>class
|
fixnum >>class
|
||||||
|
@ -452,7 +419,7 @@ CONSTANT: primitive-types
|
||||||
1 >>align
|
1 >>align
|
||||||
"box_signed_1" >>boxer
|
"box_signed_1" >>boxer
|
||||||
"to_fixnum" >>unboxer
|
"to_fixnum" >>unboxer
|
||||||
"char" define-primitive-type
|
\ char define-primitive-type
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
fixnum >>class
|
fixnum >>class
|
||||||
|
@ -463,20 +430,20 @@ CONSTANT: primitive-types
|
||||||
1 >>align
|
1 >>align
|
||||||
"box_unsigned_1" >>boxer
|
"box_unsigned_1" >>boxer
|
||||||
"to_cell" >>unboxer
|
"to_cell" >>unboxer
|
||||||
"uchar" define-primitive-type
|
\ uchar define-primitive-type
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
[ alien-unsigned-1 c-bool> ] >>getter
|
[ alien-unsigned-1 0 = not ] >>getter
|
||||||
[ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
|
[ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
|
||||||
1 >>size
|
1 >>size
|
||||||
1 >>align
|
1 >>align
|
||||||
"box_boolean" >>boxer
|
"box_boolean" >>boxer
|
||||||
"to_boolean" >>unboxer
|
"to_boolean" >>unboxer
|
||||||
"bool" define-primitive-type
|
\ bool define-primitive-type
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
float >>class
|
math:float >>class
|
||||||
float >>boxed-class
|
math:float >>boxed-class
|
||||||
[ alien-float ] >>getter
|
[ alien-float ] >>getter
|
||||||
[ [ >float ] 2dip set-alien-float ] >>setter
|
[ [ >float ] 2dip set-alien-float ] >>setter
|
||||||
4 >>size
|
4 >>size
|
||||||
|
@ -485,11 +452,11 @@ CONSTANT: primitive-types
|
||||||
"to_float" >>unboxer
|
"to_float" >>unboxer
|
||||||
float-rep >>rep
|
float-rep >>rep
|
||||||
[ >float ] >>unboxer-quot
|
[ >float ] >>unboxer-quot
|
||||||
"float" define-primitive-type
|
\ float define-primitive-type
|
||||||
|
|
||||||
<c-type>
|
<c-type>
|
||||||
float >>class
|
math:float >>class
|
||||||
float >>boxed-class
|
math:float >>boxed-class
|
||||||
[ alien-double ] >>getter
|
[ alien-double ] >>getter
|
||||||
[ [ >float ] 2dip set-alien-double ] >>setter
|
[ [ >float ] 2dip set-alien-double ] >>setter
|
||||||
8 >>size
|
8 >>size
|
||||||
|
@ -498,10 +465,10 @@ CONSTANT: primitive-types
|
||||||
"to_double" >>unboxer
|
"to_double" >>unboxer
|
||||||
double-rep >>rep
|
double-rep >>rep
|
||||||
[ >float ] >>unboxer-quot
|
[ >float ] >>unboxer-quot
|
||||||
"double" define-primitive-type
|
\ double define-primitive-type
|
||||||
|
|
||||||
"long" "ptrdiff_t" typedef
|
\ long \ ptrdiff_t typedef
|
||||||
"long" "intptr_t" typedef
|
\ long \ intptr_t typedef
|
||||||
"ulong" "size_t" typedef
|
\ ulong \ size_t typedef
|
||||||
] with-compilation-unit
|
] with-compilation-unit
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
|
@ -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 } "." ;
|
||||||
|
|
|
@ -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 ] ;
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Words for allocating objects and arrays of C types
|
|
@ -1,7 +1,7 @@
|
||||||
! (c) 2009 Joe Groff, see BSD license
|
! (c) 2009 Joe Groff, see BSD license
|
||||||
USING: accessors alien alien.c-types alien.complex
|
USING: accessors alien alien.c-types alien.complex
|
||||||
alien.fortran alien.fortran.private alien.strings classes.struct
|
alien.data alien.fortran alien.fortran.private alien.strings
|
||||||
arrays assocs byte-arrays combinators fry
|
classes.struct arrays assocs byte-arrays combinators fry
|
||||||
generalizations io.encodings.ascii kernel macros
|
generalizations io.encodings.ascii kernel macros
|
||||||
macros.expander namespaces sequences shuffle tools.test ;
|
macros.expander namespaces sequences shuffle tools.test ;
|
||||||
IN: alien.fortran.tests
|
IN: alien.fortran.tests
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
! (c) 2009 Joe Groff, see BSD license
|
! (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
|
alien.strings alien.syntax arrays ascii assocs
|
||||||
byte-arrays combinators combinators.short-circuit fry generalizations
|
byte-arrays combinators combinators.short-circuit fry generalizations
|
||||||
kernel lexer macros math math.parser namespaces parser sequences
|
kernel lexer macros math math.parser namespaces parser sequences
|
||||||
|
@ -429,6 +429,11 @@ PRIVATE>
|
||||||
MACRO: fortran-invoke ( return library function parameters -- )
|
MACRO: fortran-invoke ( return library function parameters -- )
|
||||||
{ [ 2drop nip set-fortran-abi ] [ (fortran-invoke) ] } 4 ncleave ;
|
{ [ 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 -- )
|
:: define-fortran-function ( return library function parameters -- )
|
||||||
function create-in dup reset-generic
|
function create-in dup reset-generic
|
||||||
return library function parameters return [ "void" ] unless* parse-arglist
|
return library function parameters return [ "void" ] unless* parse-arglist
|
||||||
|
|
|
@ -1,16 +1,42 @@
|
||||||
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
|
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.c-types arrays assocs effects grouping kernel
|
USING: accessors alien alien.c-types arrays assocs
|
||||||
parser sequences splitting words fry locals lexer namespaces
|
combinators combinators.short-circuit effects grouping
|
||||||
summary math ;
|
kernel parser sequences splitting words fry locals lexer
|
||||||
|
namespaces summary math vocabs.parser ;
|
||||||
IN: alien.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' )
|
: normalize-c-arg ( type name -- type' name' )
|
||||||
[ length ]
|
[ length ]
|
||||||
[
|
[
|
||||||
[ CHAR: * = ] trim-head
|
[ CHAR: * = ] trim-head
|
||||||
[ length - CHAR: * <array> append ] keep
|
[ length - CHAR: * <array> append ] keep
|
||||||
] bi ;
|
] bi
|
||||||
|
[ parse-c-type ] dip ;
|
||||||
|
|
||||||
: parse-arglist ( parameters return -- types effect )
|
: parse-arglist ( parameters return -- types effect )
|
||||||
[
|
[
|
||||||
|
@ -29,10 +55,37 @@ IN: alien.parser
|
||||||
return library function
|
return library function
|
||||||
parameters return parse-arglist [ function-quot ] dip ;
|
parameters return parse-arglist [ function-quot ] dip ;
|
||||||
|
|
||||||
|
: parse-arg-tokens ( -- tokens )
|
||||||
|
";" parse-tokens [ "()" subseq? not ] filter ;
|
||||||
|
|
||||||
: (FUNCTION:) ( -- word quot effect )
|
: (FUNCTION:) ( -- word quot effect )
|
||||||
scan "c-library" get scan ";" parse-tokens
|
scan "c-library" get scan parse-arg-tokens make-function ;
|
||||||
[ "()" subseq? not ] filter
|
|
||||||
make-function ;
|
|
||||||
|
|
||||||
: define-function ( return library function parameters -- )
|
: define-function ( return library function parameters -- )
|
||||||
make-function define-declared ;
|
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 ;
|
||||||
|
|
||||||
|
|
|
@ -1,8 +1,9 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel combinators alien alien.strings alien.syntax
|
USING: accessors kernel combinators alien alien.strings alien.c-types
|
||||||
math.parser prettyprint.backend prettyprint.custom
|
alien.parser alien.syntax arrays assocs effects math.parser
|
||||||
prettyprint.sections ;
|
prettyprint.backend prettyprint.custom prettyprint.sections
|
||||||
|
definitions see see.private sequences strings words ;
|
||||||
IN: alien.prettyprint
|
IN: alien.prettyprint
|
||||||
|
|
||||||
M: alien pprint*
|
M: alien pprint*
|
||||||
|
@ -13,3 +14,70 @@ M: alien pprint*
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;
|
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 ;
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors alien alien.c-types alien.strings parser
|
USING: accessors alien alien.data alien.strings parser
|
||||||
threads words kernel.private kernel io.encodings.utf8 eval ;
|
threads words kernel.private kernel io.encodings.utf8 eval ;
|
||||||
IN: alien.remote-control
|
IN: alien.remote-control
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
sequences io arrays kernel words assocs namespaces ;
|
||||||
IN: alien.structs
|
IN: alien.structs
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
sequences system libc words vocabs namespaces layouts ;
|
||||||
IN: alien.structs.tests
|
IN: alien.structs.tests
|
||||||
|
|
||||||
|
|
|
@ -15,7 +15,7 @@ M: struct-type c-type ;
|
||||||
M: struct-type c-type-stack-align? drop f ;
|
M: struct-type c-type-stack-align? drop f ;
|
||||||
|
|
||||||
: if-value-struct ( ctype true false -- )
|
: 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
|
M: struct-type unbox-parameter
|
||||||
[ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
|
[ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
|
||||||
|
|
|
@ -81,6 +81,42 @@ HELP: C-ENUM:
|
||||||
{ $code "CONSTANT: red 0" "CONSTANT: green 1" "CONSTANT: blue 2" }
|
{ $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: &:
|
HELP: &:
|
||||||
{ $syntax "&: symbol" }
|
{ $syntax "&: symbol" }
|
||||||
{ $values { "symbol" "A C library symbol name" } }
|
{ $values { "symbol" "A C library symbol name" } }
|
||||||
|
@ -88,7 +124,7 @@ HELP: &:
|
||||||
|
|
||||||
HELP: typedef
|
HELP: typedef
|
||||||
{ $values { "old" "a string" } { "new" "a string" } }
|
{ $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." } ;
|
{ $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
|
{ POSTPONE: TYPEDEF: typedef } related-words
|
||||||
|
|
|
@ -18,8 +18,14 @@ SYNTAX: LIBRARY: scan "c-library" set ;
|
||||||
SYNTAX: FUNCTION:
|
SYNTAX: FUNCTION:
|
||||||
(FUNCTION:) define-declared ;
|
(FUNCTION:) define-declared ;
|
||||||
|
|
||||||
|
SYNTAX: CALLBACK:
|
||||||
|
"cdecl" (CALLBACK:) define-inline ;
|
||||||
|
|
||||||
|
SYNTAX: STDCALL-CALLBACK:
|
||||||
|
"stdcall" (CALLBACK:) define-inline ;
|
||||||
|
|
||||||
SYNTAX: TYPEDEF:
|
SYNTAX: TYPEDEF:
|
||||||
scan scan typedef ;
|
scan-c-type CREATE-C-TYPE typedef ;
|
||||||
|
|
||||||
SYNTAX: C-STRUCT:
|
SYNTAX: C-STRUCT:
|
||||||
scan current-vocab parse-definition define-struct ; deprecated
|
scan current-vocab parse-definition define-struct ; deprecated
|
||||||
|
@ -31,6 +37,9 @@ SYNTAX: C-ENUM:
|
||||||
";" parse-tokens
|
";" parse-tokens
|
||||||
[ [ create-in ] dip define-constant ] each-index ;
|
[ [ create-in ] dip define-constant ] each-index ;
|
||||||
|
|
||||||
|
SYNTAX: C-TYPE:
|
||||||
|
"Primitive C type definition not supported" throw ;
|
||||||
|
|
||||||
ERROR: no-such-symbol name library ;
|
ERROR: no-such-symbol name library ;
|
||||||
|
|
||||||
: address-of ( name library -- value )
|
: address-of ( name library -- value )
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
kernel.private sequences sequences.private byte-arrays
|
||||||
parser prettyprint.custom fry ;
|
parser prettyprint.custom fry ;
|
||||||
IN: bit-arrays
|
IN: bit-arrays
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
|
|
||||||
USING: system combinators alien alien.syntax alien.c-types
|
USING: system combinators alien alien.syntax alien.c-types
|
||||||
alien.destructors kernel accessors sequences arrays ui.gadgets
|
alien.destructors kernel accessors sequences arrays ui.gadgets
|
||||||
alien.libraries ;
|
alien.libraries classes.struct ;
|
||||||
|
|
||||||
IN: cairo.ffi
|
IN: cairo.ffi
|
||||||
<< {
|
<< {
|
||||||
|
@ -26,23 +26,23 @@ TYPEDEF: int cairo_bool_t
|
||||||
TYPEDEF: void* cairo_t
|
TYPEDEF: void* cairo_t
|
||||||
TYPEDEF: void* cairo_surface_t
|
TYPEDEF: void* cairo_surface_t
|
||||||
|
|
||||||
C-STRUCT: cairo_matrix_t
|
STRUCT: cairo_matrix_t
|
||||||
{ "double" "xx" }
|
{ xx double }
|
||||||
{ "double" "yx" }
|
{ yx double }
|
||||||
{ "double" "xy" }
|
{ xy double }
|
||||||
{ "double" "yy" }
|
{ yy double }
|
||||||
{ "double" "x0" }
|
{ x0 double }
|
||||||
{ "double" "y0" } ;
|
{ y0 double } ;
|
||||||
|
|
||||||
TYPEDEF: void* cairo_pattern_t
|
TYPEDEF: void* cairo_pattern_t
|
||||||
|
|
||||||
TYPEDEF: void* cairo_destroy_func_t
|
TYPEDEF: void* cairo_destroy_func_t
|
||||||
: cairo-destroy-func ( quot -- callback )
|
: cairo-destroy-func ( quot -- callback )
|
||||||
[ "void" { "void*" } "cdecl" ] dip alien-callback ; inline
|
[ void { void* } "cdecl" ] dip alien-callback ; inline
|
||||||
|
|
||||||
! See cairo.h for details
|
! See cairo.h for details
|
||||||
C-STRUCT: cairo_user_data_key_t
|
STRUCT: cairo_user_data_key_t
|
||||||
{ "int" "unused" } ;
|
{ unused int } ;
|
||||||
|
|
||||||
TYPEDEF: int cairo_status_t
|
TYPEDEF: int cairo_status_t
|
||||||
C-ENUM:
|
C-ENUM:
|
||||||
|
@ -79,11 +79,11 @@ CONSTANT: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000
|
||||||
|
|
||||||
TYPEDEF: void* cairo_write_func_t
|
TYPEDEF: void* cairo_write_func_t
|
||||||
: cairo-write-func ( quot -- callback )
|
: cairo-write-func ( quot -- callback )
|
||||||
[ "cairo_status_t" { "void*" "uchar*" "int" } "cdecl" ] dip alien-callback ; inline
|
[ cairo_status_t { void* uchar* int } "cdecl" ] dip alien-callback ; inline
|
||||||
|
|
||||||
TYPEDEF: void* cairo_read_func_t
|
TYPEDEF: void* cairo_read_func_t
|
||||||
: cairo-read-func ( quot -- callback )
|
: cairo-read-func ( quot -- callback )
|
||||||
[ "cairo_status_t" { "void*" "uchar*" "int" } "cdecl" ] dip alien-callback ; inline
|
[ cairo_status_t { void* uchar* int } "cdecl" ] dip alien-callback ; inline
|
||||||
|
|
||||||
! Functions for manipulating state objects
|
! Functions for manipulating state objects
|
||||||
FUNCTION: cairo_t*
|
FUNCTION: cairo_t*
|
||||||
|
@ -336,16 +336,16 @@ cairo_clip_preserve ( cairo_t* cr ) ;
|
||||||
FUNCTION: void
|
FUNCTION: void
|
||||||
cairo_clip_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
|
cairo_clip_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
|
||||||
|
|
||||||
C-STRUCT: cairo_rectangle_t
|
STRUCT: cairo_rectangle_t
|
||||||
{ "double" "x" }
|
{ x double }
|
||||||
{ "double" "y" }
|
{ y double }
|
||||||
{ "double" "width" }
|
{ width double }
|
||||||
{ "double" "height" } ;
|
{ height double } ;
|
||||||
|
|
||||||
C-STRUCT: cairo_rectangle_list_t
|
STRUCT: cairo_rectangle_list_t
|
||||||
{ "cairo_status_t" "status" }
|
{ status cairo_status_t }
|
||||||
{ "cairo_rectangle_t*" "rectangles" }
|
{ rectangles cairo_rectangle_t* }
|
||||||
{ "int" "num_rectangles" } ;
|
{ num_rectangles int } ;
|
||||||
|
|
||||||
FUNCTION: cairo_rectangle_list_t*
|
FUNCTION: cairo_rectangle_list_t*
|
||||||
cairo_copy_clip_rectangle_list ( cairo_t* cr ) ;
|
cairo_copy_clip_rectangle_list ( cairo_t* cr ) ;
|
||||||
|
@ -359,25 +359,25 @@ TYPEDEF: void* cairo_scaled_font_t
|
||||||
|
|
||||||
TYPEDEF: void* cairo_font_face_t
|
TYPEDEF: void* cairo_font_face_t
|
||||||
|
|
||||||
C-STRUCT: cairo_glyph_t
|
STRUCT: cairo_glyph_t
|
||||||
{ "ulong" "index" }
|
{ index ulong }
|
||||||
{ "double" "x" }
|
{ x double }
|
||||||
{ "double" "y" } ;
|
{ y double } ;
|
||||||
|
|
||||||
C-STRUCT: cairo_text_extents_t
|
STRUCT: cairo_text_extents_t
|
||||||
{ "double" "x_bearing" }
|
{ x_bearing double }
|
||||||
{ "double" "y_bearing" }
|
{ y_bearing double }
|
||||||
{ "double" "width" }
|
{ width double }
|
||||||
{ "double" "height" }
|
{ height double }
|
||||||
{ "double" "x_advance" }
|
{ x_advance double }
|
||||||
{ "double" "y_advance" } ;
|
{ y_advance double } ;
|
||||||
|
|
||||||
C-STRUCT: cairo_font_extents_t
|
STRUCT: cairo_font_extents_t
|
||||||
{ "double" "ascent" }
|
{ ascent double }
|
||||||
{ "double" "descent" }
|
{ descent double }
|
||||||
{ "double" "height" }
|
{ height double }
|
||||||
{ "double" "max_x_advance" }
|
{ max_x_advance double }
|
||||||
{ "double" "max_y_advance" } ;
|
{ max_y_advance double } ;
|
||||||
|
|
||||||
TYPEDEF: int cairo_font_slant_t
|
TYPEDEF: int cairo_font_slant_t
|
||||||
C-ENUM:
|
C-ENUM:
|
||||||
|
@ -648,20 +648,22 @@ C-ENUM:
|
||||||
CAIRO_PATH_CLOSE_PATH ;
|
CAIRO_PATH_CLOSE_PATH ;
|
||||||
|
|
||||||
! NEED TO DO UNION HERE
|
! NEED TO DO UNION HERE
|
||||||
C-STRUCT: cairo_path_data_t-point
|
STRUCT: cairo_path_data_t-point
|
||||||
{ "double" "x" }
|
{ x double }
|
||||||
{ "double" "y" } ;
|
{ y double } ;
|
||||||
|
|
||||||
C-STRUCT: cairo_path_data_t-header
|
STRUCT: cairo_path_data_t-header
|
||||||
{ "cairo_path_data_type_t" "type" }
|
{ type cairo_path_data_type_t }
|
||||||
{ "int" "length" } ;
|
{ 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
|
STRUCT: cairo_path_t
|
||||||
{ "cairo_status_t" "status" }
|
{ status cairo_status_t }
|
||||||
{ "cairo_path_data_t*" "data" }
|
{ data cairo_path_data_t* }
|
||||||
{ "int" "num_data" } ;
|
{ num_data int } ;
|
||||||
|
|
||||||
FUNCTION: cairo_path_t*
|
FUNCTION: cairo_path_t*
|
||||||
cairo_copy_path ( cairo_t* cr ) ;
|
cairo_copy_path ( cairo_t* cr ) ;
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2008 Slava Pestov
|
! Copyright (C) 2008 Slava Pestov
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors byte-arrays alien.c-types kernel continuations
|
USING: accessors byte-arrays alien.c-types alien.data kernel
|
||||||
destructors sequences io openssl openssl.libcrypto checksums
|
continuations destructors sequences io openssl openssl.libcrypto
|
||||||
checksums.stream ;
|
checksums checksums.stream classes.struct ;
|
||||||
IN: checksums.openssl
|
IN: checksums.openssl
|
||||||
|
|
||||||
ERROR: unknown-digest name ;
|
ERROR: unknown-digest name ;
|
||||||
|
@ -23,7 +23,7 @@ TUPLE: evp-md-context < disposable handle ;
|
||||||
|
|
||||||
: <evp-md-context> ( -- ctx )
|
: <evp-md-context> ( -- ctx )
|
||||||
evp-md-context new-disposable
|
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*
|
M: evp-md-context dispose*
|
||||||
handle>> EVP_MD_CTX_cleanup drop ;
|
handle>> EVP_MD_CTX_cleanup drop ;
|
||||||
|
|
|
@ -1,9 +1,9 @@
|
||||||
! (c)Joe Groff bsd license
|
! (c)Joe Groff bsd license
|
||||||
USING: accessors alien alien.c-types arrays assocs classes
|
USING: accessors alien alien.c-types alien.data alien.prettyprint arrays
|
||||||
classes.struct combinators combinators.short-circuit continuations
|
assocs classes classes.struct combinators combinators.short-circuit
|
||||||
fry kernel libc make math math.parser mirrors prettyprint.backend
|
continuations fry kernel libc make math math.parser mirrors
|
||||||
prettyprint.custom prettyprint.sections see.private sequences
|
prettyprint.backend prettyprint.custom prettyprint.sections
|
||||||
slots strings summary words ;
|
see.private sequences slots strings summary words ;
|
||||||
IN: classes.struct.prettyprint
|
IN: classes.struct.prettyprint
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
@ -20,7 +20,7 @@ IN: classes.struct.prettyprint
|
||||||
<flow \ { pprint-word
|
<flow \ { pprint-word
|
||||||
f <inset {
|
f <inset {
|
||||||
[ name>> text ]
|
[ name>> text ]
|
||||||
[ type>> dup string? [ text ] [ pprint* ] if ]
|
[ type>> pprint-c-type ]
|
||||||
[ read-only>> [ \ read-only pprint-word ] when ]
|
[ read-only>> [ \ read-only pprint-word ] when ]
|
||||||
[ initial>> [ \ initial: pprint-word pprint* ] when* ]
|
[ initial>> [ \ initial: pprint-word pprint* ] when* ]
|
||||||
} cleave block>
|
} cleave block>
|
||||||
|
|
|
@ -1,11 +1,13 @@
|
||||||
! (c)Joe Groff bsd license
|
! (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
|
assocs byte-arrays classes.struct classes.tuple.private
|
||||||
combinators compiler.tree.debugger compiler.units destructors
|
combinators compiler.tree.debugger compiler.units destructors
|
||||||
io.encodings.utf8 io.pathnames io.streams.string kernel libc
|
io.encodings.utf8 io.pathnames io.streams.string kernel libc
|
||||||
literals math mirrors multiline namespaces prettyprint
|
literals math mirrors multiline namespaces prettyprint
|
||||||
prettyprint.config see sequences specialized-arrays system
|
prettyprint.config see sequences specialized-arrays system
|
||||||
tools.test parser lexer eval layouts ;
|
tools.test parser lexer eval layouts ;
|
||||||
|
FROM: math => float ;
|
||||||
|
QUALIFIED-WITH: alien.c-types c
|
||||||
SPECIALIZED-ARRAY: char
|
SPECIALIZED-ARRAY: char
|
||||||
SPECIALIZED-ARRAY: int
|
SPECIALIZED-ARRAY: int
|
||||||
SPECIALIZED-ARRAY: ushort
|
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 } }
|
{ "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } }
|
||||||
{ { "x" "char" } 98 }
|
{ { "x" char } 98 }
|
||||||
{ { "y" "int" } HEX: 7F00007F }
|
{ { "y" int } HEX: 7F00007F }
|
||||||
{ { "z" "bool" } f }
|
{ { "z" bool } f }
|
||||||
} ] [
|
} ] [
|
||||||
B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct
|
B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct
|
||||||
make-mirror >alist
|
make-mirror >alist
|
||||||
|
@ -128,7 +130,7 @@ STRUCT: struct-test-bar
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
UNION-STRUCT: struct-test-float-and-bits
|
UNION-STRUCT: struct-test-float-and-bits
|
||||||
{ f float }
|
{ f c:float }
|
||||||
{ bits uint } ;
|
{ bits uint } ;
|
||||||
|
|
||||||
[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
|
[ 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
|
] with-scope
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ <" USING: classes.struct ;
|
[ <" USING: alien.c-types classes.struct ;
|
||||||
IN: classes.struct.tests
|
IN: classes.struct.tests
|
||||||
STRUCT: struct-test-foo
|
STRUCT: struct-test-foo
|
||||||
{ x char initial: 0 } { y int initial: 123 } { z bool } ;
|
{ x char initial: 0 } { y int initial: 123 } { z bool } ;
|
||||||
"> ]
|
"> ]
|
||||||
[ [ struct-test-foo see ] with-string-writer ] unit-test
|
[ [ struct-test-foo see ] with-string-writer ] unit-test
|
||||||
|
|
||||||
[ <" USING: classes.struct ;
|
[ <" USING: alien.c-types classes.struct ;
|
||||||
IN: classes.struct.tests
|
IN: classes.struct.tests
|
||||||
UNION-STRUCT: struct-test-float-and-bits
|
UNION-STRUCT: struct-test-float-and-bits
|
||||||
{ f float initial: 0.0 } { bits uint initial: 0 } ;
|
{ f float initial: 0.0 } { bits uint initial: 0 } ;
|
||||||
|
@ -201,20 +203,20 @@ UNION-STRUCT: struct-test-float-and-bits
|
||||||
{ offset 0 }
|
{ offset 0 }
|
||||||
{ initial 0 }
|
{ initial 0 }
|
||||||
{ class fixnum }
|
{ class fixnum }
|
||||||
{ type "char" }
|
{ type char }
|
||||||
}
|
}
|
||||||
T{ struct-slot-spec
|
T{ struct-slot-spec
|
||||||
{ name "y" }
|
{ name "y" }
|
||||||
{ offset 4 }
|
{ offset 4 }
|
||||||
{ initial 123 }
|
{ initial 123 }
|
||||||
{ class integer }
|
{ class integer }
|
||||||
{ type "int" }
|
{ type int }
|
||||||
}
|
}
|
||||||
T{ struct-slot-spec
|
T{ struct-slot-spec
|
||||||
{ name "z" }
|
{ name "z" }
|
||||||
{ offset 8 }
|
{ offset 8 }
|
||||||
{ initial f }
|
{ initial f }
|
||||||
{ type "bool" }
|
{ type bool }
|
||||||
{ class object }
|
{ class object }
|
||||||
}
|
}
|
||||||
} ] [ "struct-test-foo" c-type fields>> ] unit-test
|
} ] [ "struct-test-foo" c-type fields>> ] unit-test
|
||||||
|
@ -223,14 +225,14 @@ UNION-STRUCT: struct-test-float-and-bits
|
||||||
T{ struct-slot-spec
|
T{ struct-slot-spec
|
||||||
{ name "f" }
|
{ name "f" }
|
||||||
{ offset 0 }
|
{ offset 0 }
|
||||||
{ type "float" }
|
{ type c:float }
|
||||||
{ class float }
|
{ class float }
|
||||||
{ initial 0.0 }
|
{ initial 0.0 }
|
||||||
}
|
}
|
||||||
T{ struct-slot-spec
|
T{ struct-slot-spec
|
||||||
{ name "bits" }
|
{ name "bits" }
|
||||||
{ offset 0 }
|
{ offset 0 }
|
||||||
{ type "uint" }
|
{ type uint }
|
||||||
{ class integer }
|
{ class integer }
|
||||||
{ initial 0 }
|
{ initial 0 }
|
||||||
}
|
}
|
||||||
|
@ -277,7 +279,7 @@ STRUCT: struct-test-array-slots
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
STRUCT: struct-test-optimization
|
STRUCT: struct-test-optimization
|
||||||
{ x { "int" 3 } } { y int } ;
|
{ x { int 3 } } { y int } ;
|
||||||
|
|
||||||
SPECIALIZED-ARRAY: struct-test-optimization
|
SPECIALIZED-ARRAY: struct-test-optimization
|
||||||
|
|
||||||
|
|
|
@ -1,12 +1,12 @@
|
||||||
! (c)Joe Groff bsd license
|
! (c)Joe Groff bsd license
|
||||||
USING: accessors alien alien.c-types arrays byte-arrays classes
|
USING: accessors alien alien.c-types alien.data alien.parser arrays
|
||||||
classes.parser classes.tuple classes.tuple.parser
|
byte-arrays classes classes.parser classes.tuple classes.tuple.parser
|
||||||
classes.tuple.private combinators combinators.short-circuit
|
classes.tuple.private combinators combinators.short-circuit
|
||||||
combinators.smart cpu.architecture definitions functors.backend
|
combinators.smart cpu.architecture definitions functors.backend
|
||||||
fry generalizations generic.parser kernel kernel.private lexer
|
fry generalizations generic.parser kernel kernel.private lexer
|
||||||
libc locals macros make math math.order parser quotations
|
libc locals macros make math math.order parser quotations
|
||||||
sequences slots slots.private specialized-arrays vectors words
|
sequences slots slots.private specialized-arrays vectors words
|
||||||
summary namespaces assocs ;
|
summary namespaces assocs vocabs.parser ;
|
||||||
IN: classes.struct
|
IN: classes.struct
|
||||||
|
|
||||||
SPECIALIZED-ARRAY: uchar
|
SPECIALIZED-ARRAY: uchar
|
||||||
|
@ -126,7 +126,7 @@ M: struct-c-type c-type ;
|
||||||
M: struct-c-type c-type-stack-align? drop f ;
|
M: struct-c-type c-type-stack-align? drop f ;
|
||||||
|
|
||||||
: if-value-struct ( ctype true false -- )
|
: 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
|
M: struct-c-type unbox-parameter
|
||||||
[ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
|
[ %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 ;
|
[ type>> c-type-align ] [ max ] map-reduce ;
|
||||||
PRIVATE>
|
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
|
M: struct byte-length class "struct-size" word-prop ; foldable
|
||||||
|
|
||||||
! class definition
|
! class definition
|
||||||
|
@ -259,7 +245,7 @@ M: struct byte-length class "struct-size" word-prop ; foldable
|
||||||
[ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
|
[ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
|
||||||
(struct-word-props)
|
(struct-word-props)
|
||||||
]
|
]
|
||||||
[ drop [ c-type-for-class ] [ name>> ] bi typedef ] 2tri ; inline
|
[ drop [ c-type-for-class ] keep typedef ] 2tri ; inline
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: define-struct-class ( class slots -- )
|
: define-struct-class ( class slots -- )
|
||||||
|
@ -284,9 +270,6 @@ ERROR: invalid-struct-slot token ;
|
||||||
[ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ;
|
[ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
: scan-c-type ( -- c-type )
|
|
||||||
scan dup "{" = [ drop \ } parse-until >array ] when ;
|
|
||||||
|
|
||||||
: parse-struct-slot ( -- slot )
|
: parse-struct-slot ( -- slot )
|
||||||
scan scan-c-type \ } parse-until <struct-slot-spec> ;
|
scan scan-c-type \ } parse-until <struct-slot-spec> ;
|
||||||
|
|
||||||
|
@ -317,7 +300,7 @@ SYNTAX: S@
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
: scan-c-type` ( -- c-type/param )
|
: 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 )
|
: parse-struct-slot` ( accum -- accum )
|
||||||
scan-string-param scan-c-type` \ } parse-until
|
scan-string-param scan-c-type` \ } parse-until
|
||||||
|
|
|
@ -1,17 +1,16 @@
|
||||||
! Copyright (C) 2008 Joe Groff.
|
! Copyright (C) 2008 Joe Groff.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors kernel classes.struct cocoa cocoa.types alien.c-types
|
USING: accessors kernel classes.struct cocoa cocoa.runtime cocoa.types alien.data
|
||||||
locals math sequences vectors fry libc destructors ;
|
locals math sequences vectors fry libc destructors specialized-arrays ;
|
||||||
|
SPECIALIZED-ARRAY: id
|
||||||
IN: cocoa.enumeration
|
IN: cocoa.enumeration
|
||||||
|
|
||||||
<< "id" require-c-array >>
|
|
||||||
|
|
||||||
CONSTANT: NS-EACH-BUFFER-SIZE 16
|
CONSTANT: NS-EACH-BUFFER-SIZE 16
|
||||||
|
|
||||||
: with-enumeration-buffers ( quot -- )
|
: with-enumeration-buffers ( quot -- )
|
||||||
'[
|
'[
|
||||||
NSFastEnumerationState malloc-struct &free
|
NSFastEnumerationState malloc-struct &free
|
||||||
NS-EACH-BUFFER-SIZE "id" malloc-array &free
|
NS-EACH-BUFFER-SIZE id malloc-array &free
|
||||||
NS-EACH-BUFFER-SIZE
|
NS-EACH-BUFFER-SIZE
|
||||||
@
|
@
|
||||||
] with-destructors ; inline
|
] with-destructors ; inline
|
||||||
|
@ -19,7 +18,7 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16
|
||||||
:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
|
:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
|
||||||
object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count
|
object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count
|
||||||
items-count 0 = [
|
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
|
items-count iota [ items nth quot call ] each
|
||||||
object quot state stackbuf count (NSFastEnumeration-each)
|
object quot state stackbuf count (NSFastEnumeration-each)
|
||||||
] unless ; inline recursive
|
] unless ; inline recursive
|
||||||
|
|
|
@ -4,8 +4,8 @@
|
||||||
USING: strings arrays hashtables assocs sequences fry macros
|
USING: strings arrays hashtables assocs sequences fry macros
|
||||||
cocoa.messages cocoa.classes cocoa.application cocoa kernel
|
cocoa.messages cocoa.classes cocoa.application cocoa kernel
|
||||||
namespaces io.backend math cocoa.enumeration byte-arrays
|
namespaces io.backend math cocoa.enumeration byte-arrays
|
||||||
combinators alien.c-types words core-foundation quotations
|
combinators alien.c-types alien.data words core-foundation
|
||||||
core-foundation.data core-foundation.utilities ;
|
quotations core-foundation.data core-foundation.utilities ;
|
||||||
IN: cocoa.plists
|
IN: cocoa.plists
|
||||||
|
|
||||||
: >plist ( value -- plist ) >cf -> autorelease ;
|
: >plist ( value -- plist ) >cf -> autorelease ;
|
||||||
|
|
|
@ -190,12 +190,14 @@ M: ##slot-imm insn-slot# slot>> ;
|
||||||
M: ##set-slot insn-slot# slot>> constant ;
|
M: ##set-slot insn-slot# slot>> constant ;
|
||||||
M: ##set-slot-imm insn-slot# slot>> ;
|
M: ##set-slot-imm insn-slot# slot>> ;
|
||||||
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
|
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 insn-object obj>> resolve ;
|
||||||
M: ##slot-imm insn-object obj>> resolve ;
|
M: ##slot-imm insn-object obj>> resolve ;
|
||||||
M: ##set-slot insn-object obj>> resolve ;
|
M: ##set-slot insn-object obj>> resolve ;
|
||||||
M: ##set-slot-imm insn-object obj>> resolve ;
|
M: ##set-slot-imm insn-object obj>> resolve ;
|
||||||
M: ##alien-global insn-object drop \ ##alien-global ;
|
M: ##alien-global insn-object drop \ ##alien-global ;
|
||||||
|
M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
|
||||||
|
|
||||||
: init-alias-analysis ( insns -- insns' )
|
: init-alias-analysis ( insns -- insns' )
|
||||||
H{ } clone histories set
|
H{ } clone histories set
|
||||||
|
|
|
@ -57,4 +57,4 @@ insn-classes get [
|
||||||
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
|
: ^^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
|
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ; inline
|
||||||
: ^^tag-fixnum ( src -- dst ) tag-bits get ^^shl-imm ; 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
|
||||||
|
|
|
@ -450,6 +450,10 @@ INSN: ##alien-global
|
||||||
def: dst/int-rep
|
def: dst/int-rep
|
||||||
literal: symbol library ;
|
literal: symbol library ;
|
||||||
|
|
||||||
|
INSN: ##vm-field-ptr
|
||||||
|
def: dst/int-rep
|
||||||
|
literal: fieldname ;
|
||||||
|
|
||||||
! FFI
|
! FFI
|
||||||
INSN: ##alien-invoke
|
INSN: ##alien-invoke
|
||||||
literal: params stack-frame ;
|
literal: params stack-frame ;
|
||||||
|
|
|
@ -10,7 +10,7 @@ IN: compiler.cfg.intrinsics.misc
|
||||||
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
|
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
|
||||||
|
|
||||||
: emit-getenv ( node -- )
|
: emit-getenv ( node -- )
|
||||||
"userenv" f ^^alien-global
|
"userenv" ^^vm-field-ptr
|
||||||
swap node-input-infos first literal>>
|
swap node-input-infos first literal>>
|
||||||
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if*
|
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if*
|
||||||
ds-push ;
|
ds-push ;
|
||||||
|
|
|
@ -270,6 +270,9 @@ M: ##alien-global generate-insn
|
||||||
[ dst>> ] [ symbol>> ] [ library>> ] tri
|
[ dst>> ] [ symbol>> ] [ library>> ] tri
|
||||||
%alien-global ;
|
%alien-global ;
|
||||||
|
|
||||||
|
M: ##vm-field-ptr generate-insn
|
||||||
|
[ dst>> ] [ fieldname>> ] bi %vm-field-ptr ;
|
||||||
|
|
||||||
! ##alien-invoke
|
! ##alien-invoke
|
||||||
GENERIC: next-fastcall-param ( rep -- )
|
GENERIC: next-fastcall-param ( rep -- )
|
||||||
|
|
||||||
|
@ -434,7 +437,7 @@ M: ##alien-indirect generate-insn
|
||||||
! Generate code for boxing input parameters in a callback.
|
! Generate code for boxing input parameters in a callback.
|
||||||
[
|
[
|
||||||
dup \ %save-param-reg move-parameters
|
dup \ %save-param-reg move-parameters
|
||||||
"nest_stacks" f %alien-invoke
|
"nest_stacks" %vm-invoke-1st-arg
|
||||||
box-parameters
|
box-parameters
|
||||||
] with-param-regs ;
|
] with-param-regs ;
|
||||||
|
|
||||||
|
@ -456,7 +459,7 @@ TUPLE: callback-context ;
|
||||||
|
|
||||||
: callback-return-quot ( ctype -- quot )
|
: callback-return-quot ( ctype -- quot )
|
||||||
return>> {
|
return>> {
|
||||||
{ [ dup "void" = ] [ drop [ ] ] }
|
{ [ dup void? ] [ drop [ ] ] }
|
||||||
{ [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
|
{ [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
|
||||||
[ c-type c-type-unboxer-quot ]
|
[ c-type c-type-unboxer-quot ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
@ -472,7 +475,7 @@ TUPLE: callback-context ;
|
||||||
[ callback-context new do-callback ] %
|
[ callback-context new do-callback ] %
|
||||||
] [ ] make ;
|
] [ ] make ;
|
||||||
|
|
||||||
: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
|
: %unnest-stacks ( -- ) "unnest_stacks" %vm-invoke-1st-arg ;
|
||||||
|
|
||||||
M: ##callback-return generate-insn
|
M: ##callback-return generate-insn
|
||||||
#! All the extra book-keeping for %unwind is only for x86.
|
#! All the extra book-keeping for %unwind is only for x86.
|
||||||
|
|
|
@ -50,6 +50,7 @@ CONSTANT: rt-immediate 8
|
||||||
CONSTANT: rt-stack-chain 9
|
CONSTANT: rt-stack-chain 9
|
||||||
CONSTANT: rt-untagged 10
|
CONSTANT: rt-untagged 10
|
||||||
CONSTANT: rt-megamorphic-cache-hits 11
|
CONSTANT: rt-megamorphic-cache-hits 11
|
||||||
|
CONSTANT: rt-vm 12
|
||||||
|
|
||||||
: rc-absolute? ( n -- ? )
|
: rc-absolute? ( n -- ? )
|
||||||
${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;
|
${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;
|
||||||
|
|
|
@ -5,6 +5,7 @@ io.streams.string kernel math memory namespaces
|
||||||
namespaces.private parser quotations sequences
|
namespaces.private parser quotations sequences
|
||||||
specialized-arrays stack-checker stack-checker.errors
|
specialized-arrays stack-checker stack-checker.errors
|
||||||
system threads tools.test words ;
|
system threads tools.test words ;
|
||||||
|
FROM: alien.c-types => float short ;
|
||||||
SPECIALIZED-ARRAY: float
|
SPECIALIZED-ARRAY: float
|
||||||
SPECIALIZED-ARRAY: char
|
SPECIALIZED-ARRAY: char
|
||||||
IN: compiler.tests.alien
|
IN: compiler.tests.alien
|
||||||
|
|
|
@ -4,6 +4,7 @@ namespaces.private slots.private sequences.private byte-arrays alien
|
||||||
alien.accessors layouts words definitions compiler.units io
|
alien.accessors layouts words definitions compiler.units io
|
||||||
combinators vectors grouping make alien.c-types combinators.short-circuit
|
combinators vectors grouping make alien.c-types combinators.short-circuit
|
||||||
math.order math.libm math.parser ;
|
math.order math.libm math.parser ;
|
||||||
|
FROM: math => float ;
|
||||||
QUALIFIED: namespaces.private
|
QUALIFIED: namespaces.private
|
||||||
IN: compiler.tests.codegen
|
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
|
[ "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
|
[ 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,8 +3,9 @@ math math.constants math.private math.integers.private sequences
|
||||||
strings tools.test words continuations sequences.private
|
strings tools.test words continuations sequences.private
|
||||||
hashtables.private byte-arrays system random layouts vectors
|
hashtables.private byte-arrays system random layouts vectors
|
||||||
sbufs strings.private slots.private alien math.order
|
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 ;
|
namespaces libc io.encodings.ascii classes compiler ;
|
||||||
|
FROM: math => float ;
|
||||||
IN: compiler.tests.intrinsics
|
IN: compiler.tests.intrinsics
|
||||||
|
|
||||||
! Make sure that intrinsic ops compile to correct code.
|
! Make sure that intrinsic ops compile to correct code.
|
||||||
|
|
|
@ -122,17 +122,6 @@ GENERIC: void-generic ( obj -- * )
|
||||||
|
|
||||||
[ t ] [ \ <tuple>-regression optimized? ] unit-test
|
[ 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
|
! regression
|
||||||
: constant-fold-2 ( -- value ) f ; foldable
|
: constant-fold-2 ( -- value ) f ; foldable
|
||||||
: constant-fold-3 ( -- value ) 4 ; foldable
|
: constant-fold-3 ( -- value ) 4 ; foldable
|
||||||
|
|
|
@ -16,6 +16,7 @@ compiler.tree.propagation
|
||||||
compiler.tree.propagation.info
|
compiler.tree.propagation.info
|
||||||
compiler.tree.checker
|
compiler.tree.checker
|
||||||
compiler.tree.debugger ;
|
compiler.tree.debugger ;
|
||||||
|
FROM: math => float ;
|
||||||
IN: compiler.tree.cleanup.tests
|
IN: compiler.tree.cleanup.tests
|
||||||
|
|
||||||
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
|
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
|
||||||
|
|
|
@ -52,7 +52,7 @@ M: callable splicing-nodes splicing-body ;
|
||||||
2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
|
2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
|
||||||
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
|
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
|
||||||
[ swap nth value-info class>> dup ] dip
|
[ swap nth value-info class>> dup ] dip
|
||||||
specific-method
|
method-for-class
|
||||||
] if
|
] if
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
|
|
@ -10,6 +10,7 @@ compiler.tree.debugger compiler.tree.checker
|
||||||
slots.private words hashtables classes assocs locals
|
slots.private words hashtables classes assocs locals
|
||||||
specialized-arrays system sorting math.libm
|
specialized-arrays system sorting math.libm
|
||||||
math.intervals quotations effects alien ;
|
math.intervals quotations effects alien ;
|
||||||
|
FROM: math => float ;
|
||||||
SPECIALIZED-ARRAY: double
|
SPECIALIZED-ARRAY: double
|
||||||
IN: compiler.tree.propagation.tests
|
IN: compiler.tree.propagation.tests
|
||||||
|
|
||||||
|
|
|
@ -14,7 +14,7 @@ IN: compiler.tree.propagation.transforms
|
||||||
! If first input has a known type and second input is an
|
! If first input has a known type and second input is an
|
||||||
! object, we convert this to [ swap equal? ].
|
! object, we convert this to [ swap equal? ].
|
||||||
in-d>> first2 value-info class>> object class= [
|
in-d>> first2 value-info class>> object class= [
|
||||||
value-info class>> \ equal? specific-method
|
value-info class>> \ equal? method-for-class
|
||||||
[ swap equal? ] f ?
|
[ swap equal? ] f ?
|
||||||
] [ drop f ] if
|
] [ drop f ] if
|
||||||
] "custom-inlining" set-word-prop
|
] "custom-inlining" set-word-prop
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
! Copyright (C) 2009 Slava Pestov.
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien.c-types alien.syntax kernel math core-foundation ;
|
USING: alien.c-types alien.syntax kernel math core-foundation ;
|
||||||
|
FROM: math => float ;
|
||||||
IN: core-foundation.numbers
|
IN: core-foundation.numbers
|
||||||
|
|
||||||
TYPEDEF: void* CFNumberRef
|
TYPEDEF: void* CFNumberRef
|
||||||
|
|
|
@ -202,6 +202,7 @@ HOOK: %set-alien-double cpu ( ptr value -- )
|
||||||
HOOK: %set-alien-vector cpu ( ptr value rep -- )
|
HOOK: %set-alien-vector cpu ( ptr value rep -- )
|
||||||
|
|
||||||
HOOK: %alien-global cpu ( dst symbol library -- )
|
HOOK: %alien-global cpu ( dst symbol library -- )
|
||||||
|
HOOK: %vm-field-ptr cpu ( dst fieldname -- )
|
||||||
|
|
||||||
HOOK: %allot cpu ( dst size class temp -- )
|
HOOK: %allot cpu ( dst size class temp -- )
|
||||||
HOOK: %write-barrier cpu ( src card# table -- )
|
HOOK: %write-barrier cpu ( src card# table -- )
|
||||||
|
@ -297,6 +298,9 @@ M: object %prepare-var-args ;
|
||||||
|
|
||||||
HOOK: %alien-invoke cpu ( function library -- )
|
HOOK: %alien-invoke cpu ( function library -- )
|
||||||
|
|
||||||
|
HOOK: %vm-invoke-1st-arg cpu ( function -- )
|
||||||
|
HOOK: %vm-invoke-3rd-arg cpu ( function -- )
|
||||||
|
|
||||||
HOOK: %cleanup cpu ( params -- )
|
HOOK: %cleanup cpu ( params -- )
|
||||||
|
|
||||||
M: object %cleanup ( params -- ) drop ;
|
M: object %cleanup ( params -- ) drop ;
|
||||||
|
|
|
@ -2,13 +2,14 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors assocs sequences kernel combinators make math
|
USING: accessors assocs sequences kernel combinators make math
|
||||||
math.order math.ranges system namespaces locals layouts words
|
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
|
cpu.ppc.assembler cpu.ppc.assembler.backend compiler.cfg.registers
|
||||||
compiler.cfg.instructions compiler.cfg.comparisons
|
compiler.cfg.instructions compiler.cfg.comparisons
|
||||||
compiler.codegen.fixup compiler.cfg.intrinsics
|
compiler.codegen.fixup compiler.cfg.intrinsics
|
||||||
compiler.cfg.stack-frame compiler.cfg.build-stack-frame
|
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: cpu.ppc.assembler => B ;
|
||||||
|
FROM: math => float ;
|
||||||
IN: cpu.ppc
|
IN: cpu.ppc
|
||||||
|
|
||||||
! PowerPC register assignments:
|
! PowerPC register assignments:
|
||||||
|
@ -29,6 +30,18 @@ enable-float-intrinsics
|
||||||
\ ##float>integer t frame-required? set-word-prop
|
\ ##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
|
M: ppc machine-registers
|
||||||
{
|
{
|
||||||
{ int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
|
{ 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 ;
|
M: ppc %set-alien-double swap 0 STFD ;
|
||||||
|
|
||||||
: load-zone-ptr ( reg -- )
|
: load-zone-ptr ( reg -- )
|
||||||
"nursery" f %alien-global ;
|
"nursery" %load-vm-field-addr ;
|
||||||
|
|
||||||
: load-allot-ptr ( nursery-ptr allot-ptr -- )
|
: load-allot-ptr ( nursery-ptr allot-ptr -- )
|
||||||
[ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ;
|
[ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ;
|
||||||
|
@ -441,10 +454,10 @@ M:: ppc %allot ( dst size class nursery-ptr -- )
|
||||||
dst class store-tagged ;
|
dst class store-tagged ;
|
||||||
|
|
||||||
: load-cards-offset ( dst -- )
|
: 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 -- )
|
: 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 -- )
|
M:: ppc %write-barrier ( src card# table -- )
|
||||||
card-mark scratch-reg LI
|
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
|
#! Save Factor stack pointers in case the C code calls a
|
||||||
#! callback which does a GC, which must reliably trace
|
#! callback which does a GC, which must reliably trace
|
||||||
#! all roots.
|
#! all roots.
|
||||||
temp1 "stack_chain" f %alien-global
|
temp1 "stack_chain" %load-vm-field-addr
|
||||||
temp1 temp1 0 LWZ
|
temp1 temp1 0 LWZ
|
||||||
1 temp1 0 STW
|
1 temp1 0 STW
|
||||||
callback-allowed? [
|
callback-allowed? [
|
||||||
|
@ -770,5 +783,5 @@ USE: vocabs.loader
|
||||||
4 >>align
|
4 >>align
|
||||||
"box_boolean" >>boxer
|
"box_boolean" >>boxer
|
||||||
"to_boolean" >>unboxer
|
"to_boolean" >>unboxer
|
||||||
"bool" define-primitive-type
|
bool define-primitive-type
|
||||||
] with-compilation-unit
|
] with-compilation-unit
|
||||||
|
|
|
@ -47,6 +47,18 @@ M: x86.32 reserved-area-size 0 ;
|
||||||
|
|
||||||
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
|
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 -- ? )
|
M: x86.32 return-struct-in-registers? ( c-type -- ? )
|
||||||
c-type
|
c-type
|
||||||
[ return-in-registers?>> ]
|
[ return-in-registers?>> ]
|
||||||
|
@ -103,9 +115,12 @@ M: x86.32 %save-param-reg 3drop ;
|
||||||
#! parameter being passed to a callback from C.
|
#! parameter being passed to a callback from C.
|
||||||
over [ load-return-reg ] [ 2drop ] if ;
|
over [ load-return-reg ] [ 2drop ] if ;
|
||||||
|
|
||||||
|
CONSTANT: vm-ptr-size 4
|
||||||
|
|
||||||
M:: x86.32 %box ( n rep func -- )
|
M:: x86.32 %box ( n rep func -- )
|
||||||
n rep (%box)
|
n rep (%box)
|
||||||
rep rep-size [
|
rep rep-size vm-ptr-size + [
|
||||||
|
push-vm-ptr
|
||||||
rep push-return-reg
|
rep push-return-reg
|
||||||
func f %alien-invoke
|
func f %alien-invoke
|
||||||
] with-aligned-stack ;
|
] with-aligned-stack ;
|
||||||
|
@ -118,7 +133,8 @@ M:: x86.32 %box ( n rep func -- )
|
||||||
|
|
||||||
M: x86.32 %box-long-long ( n func -- )
|
M: x86.32 %box-long-long ( n func -- )
|
||||||
[ (%box-long-long) ] dip
|
[ (%box-long-long) ] dip
|
||||||
8 [
|
8 vm-ptr-size + [
|
||||||
|
push-vm-ptr
|
||||||
EDX PUSH
|
EDX PUSH
|
||||||
EAX PUSH
|
EAX PUSH
|
||||||
f %alien-invoke
|
f %alien-invoke
|
||||||
|
@ -126,12 +142,13 @@ M: x86.32 %box-long-long ( n func -- )
|
||||||
|
|
||||||
M:: x86.32 %box-large-struct ( n c-type -- )
|
M:: x86.32 %box-large-struct ( n c-type -- )
|
||||||
! Compute destination address
|
! Compute destination address
|
||||||
ECX n struct-return@ LEA
|
EDX n struct-return@ LEA
|
||||||
8 [
|
8 vm-ptr-size + [
|
||||||
|
push-vm-ptr
|
||||||
! Push struct size
|
! Push struct size
|
||||||
c-type heap-size PUSH
|
c-type heap-size PUSH
|
||||||
! Push destination address
|
! Push destination address
|
||||||
ECX PUSH
|
EDX PUSH
|
||||||
! Copy the struct from the C stack
|
! Copy the struct from the C stack
|
||||||
"box_value_struct" f %alien-invoke
|
"box_value_struct" f %alien-invoke
|
||||||
] with-aligned-stack ;
|
] with-aligned-stack ;
|
||||||
|
@ -144,7 +161,8 @@ M: x86.32 %prepare-box-struct ( -- )
|
||||||
|
|
||||||
M: x86.32 %box-small-struct ( c-type -- )
|
M: x86.32 %box-small-struct ( c-type -- )
|
||||||
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
|
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
|
||||||
12 [
|
12 vm-ptr-size + [
|
||||||
|
push-vm-ptr
|
||||||
heap-size PUSH
|
heap-size PUSH
|
||||||
EDX PUSH
|
EDX PUSH
|
||||||
EAX PUSH
|
EAX PUSH
|
||||||
|
@ -157,7 +175,9 @@ M: x86.32 %prepare-unbox ( -- )
|
||||||
ESI 4 SUB ;
|
ESI 4 SUB ;
|
||||||
|
|
||||||
: call-unbox-func ( func -- )
|
: call-unbox-func ( func -- )
|
||||||
4 [
|
8 [
|
||||||
|
! push the vm ptr as an argument
|
||||||
|
push-vm-ptr
|
||||||
! Push parameter
|
! Push parameter
|
||||||
EAX PUSH
|
EAX PUSH
|
||||||
! Call the unboxer
|
! Call the unboxer
|
||||||
|
@ -183,7 +203,8 @@ M: x86.32 %unbox-long-long ( n func -- )
|
||||||
|
|
||||||
: %unbox-struct-1 ( -- )
|
: %unbox-struct-1 ( -- )
|
||||||
#! Alien must be in EAX.
|
#! Alien must be in EAX.
|
||||||
4 [
|
4 vm-ptr-size + [
|
||||||
|
push-vm-ptr
|
||||||
EAX PUSH
|
EAX PUSH
|
||||||
"alien_offset" f %alien-invoke
|
"alien_offset" f %alien-invoke
|
||||||
! Load first cell
|
! Load first cell
|
||||||
|
@ -192,7 +213,8 @@ M: x86.32 %unbox-long-long ( n func -- )
|
||||||
|
|
||||||
: %unbox-struct-2 ( -- )
|
: %unbox-struct-2 ( -- )
|
||||||
#! Alien must be in EAX.
|
#! Alien must be in EAX.
|
||||||
4 [
|
4 vm-ptr-size + [
|
||||||
|
push-vm-ptr
|
||||||
EAX PUSH
|
EAX PUSH
|
||||||
"alien_offset" f %alien-invoke
|
"alien_offset" f %alien-invoke
|
||||||
! Load second cell
|
! Load second cell
|
||||||
|
@ -211,12 +233,13 @@ M: x86 %unbox-small-struct ( size -- )
|
||||||
M:: x86.32 %unbox-large-struct ( n c-type -- )
|
M:: x86.32 %unbox-large-struct ( n c-type -- )
|
||||||
! Alien must be in EAX.
|
! Alien must be in EAX.
|
||||||
! Compute destination address
|
! Compute destination address
|
||||||
ECX n stack@ LEA
|
EDX n stack@ LEA
|
||||||
12 [
|
12 vm-ptr-size + [
|
||||||
|
push-vm-ptr
|
||||||
! Push struct size
|
! Push struct size
|
||||||
c-type heap-size PUSH
|
c-type heap-size PUSH
|
||||||
! Push destination address
|
! Push destination address
|
||||||
ECX PUSH
|
EDX PUSH
|
||||||
! Push source address
|
! Push source address
|
||||||
EAX PUSH
|
EAX PUSH
|
||||||
! Copy the struct to the stack
|
! Copy the struct to the stack
|
||||||
|
@ -224,7 +247,8 @@ M:: x86.32 %unbox-large-struct ( n c-type -- )
|
||||||
] with-aligned-stack ;
|
] with-aligned-stack ;
|
||||||
|
|
||||||
M: x86.32 %prepare-alien-indirect ( -- )
|
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 ;
|
EBP EAX MOV ;
|
||||||
|
|
||||||
M: x86.32 %alien-indirect ( -- )
|
M: x86.32 %alien-indirect ( -- )
|
||||||
|
@ -234,6 +258,7 @@ M: x86.32 %alien-callback ( quot -- )
|
||||||
4 [
|
4 [
|
||||||
EAX swap %load-reference
|
EAX swap %load-reference
|
||||||
EAX PUSH
|
EAX PUSH
|
||||||
|
param-reg-2 0 MOV rc-absolute-cell rt-vm rel-fixup
|
||||||
"c_to_factor" f %alien-invoke
|
"c_to_factor" f %alien-invoke
|
||||||
] with-aligned-stack ;
|
] with-aligned-stack ;
|
||||||
|
|
||||||
|
@ -243,9 +268,11 @@ M: x86.32 %callback-value ( ctype -- )
|
||||||
! Save top of data stack in non-volatile register
|
! Save top of data stack in non-volatile register
|
||||||
%prepare-unbox
|
%prepare-unbox
|
||||||
EAX PUSH
|
EAX PUSH
|
||||||
|
push-vm-ptr
|
||||||
! Restore data/call/retain stacks
|
! Restore data/call/retain stacks
|
||||||
"unnest_stacks" f %alien-invoke
|
"unnest_stacks" f %alien-invoke
|
||||||
! Place top of data stack in EAX
|
! Place top of data stack in EAX
|
||||||
|
temp-reg POP
|
||||||
EAX POP
|
EAX POP
|
||||||
! Restore C stack
|
! Restore C stack
|
||||||
ESP 12 ADD
|
ESP 12 ADD
|
||||||
|
|
|
@ -12,6 +12,7 @@ IN: bootstrap.x86
|
||||||
: div-arg ( -- reg ) EAX ;
|
: div-arg ( -- reg ) EAX ;
|
||||||
: mod-arg ( -- reg ) EDX ;
|
: mod-arg ( -- reg ) EDX ;
|
||||||
: arg ( -- reg ) EAX ;
|
: arg ( -- reg ) EAX ;
|
||||||
|
: arg2 ( -- reg ) EDX ;
|
||||||
: temp0 ( -- reg ) EAX ;
|
: temp0 ( -- reg ) EAX ;
|
||||||
: temp1 ( -- reg ) EDX ;
|
: temp1 ( -- reg ) EDX ;
|
||||||
: temp2 ( -- reg ) ECX ;
|
: temp2 ( -- reg ) ECX ;
|
||||||
|
@ -27,6 +28,8 @@ IN: bootstrap.x86
|
||||||
temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
|
temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
|
||||||
! save stack pointer
|
! save stack pointer
|
||||||
temp0 [] stack-reg MOV
|
temp0 [] stack-reg MOV
|
||||||
|
! pass vm ptr to primitive
|
||||||
|
arg 0 MOV rc-absolute-cell rt-vm jit-rel
|
||||||
! call the primitive
|
! call the primitive
|
||||||
0 JMP rc-relative rt-primitive jit-rel
|
0 JMP rc-relative rt-primitive jit-rel
|
||||||
] jit-primitive jit-define
|
] jit-primitive jit-define
|
||||||
|
|
|
@ -74,9 +74,26 @@ M: x86.64 %prepare-unbox ( -- )
|
||||||
param-reg-1 R14 [] MOV
|
param-reg-1 R14 [] MOV
|
||||||
R14 cell SUB ;
|
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 -- )
|
M:: x86.64 %unbox ( n rep func -- )
|
||||||
! Call the unboxer
|
! Call the unboxer
|
||||||
func f %alien-invoke
|
func %vm-invoke-2nd-arg
|
||||||
! Store the return value on the C stack if this is an
|
! Store the return value on the C stack if this is an
|
||||||
! alien-invoke, otherwise leave it the return register if
|
! alien-invoke, otherwise leave it the return register if
|
||||||
! this is the end of alien-callback
|
! 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 ] }
|
{ float-regs [ float-regs get pop swap MOVSD ] }
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
|
|
||||||
M: x86.64 %unbox-small-struct ( c-type -- )
|
M: x86.64 %unbox-small-struct ( c-type -- )
|
||||||
! Alien must be in param-reg-1.
|
! 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
|
! Move alien_offset() return value to R11 so that we don't
|
||||||
! clobber it.
|
! clobber it.
|
||||||
R11 RAX MOV
|
R11 RAX MOV
|
||||||
|
@ -109,7 +127,7 @@ M:: x86.64 %unbox-large-struct ( n c-type -- )
|
||||||
! Load structure size into param-reg-3
|
! Load structure size into param-reg-3
|
||||||
param-reg-3 c-type heap-size MOV
|
param-reg-3 c-type heap-size MOV
|
||||||
! Copy the struct to the C stack
|
! Copy the struct to the C stack
|
||||||
"to_value_struct" f %alien-invoke ;
|
"to_value_struct" %vm-invoke-4th-arg ;
|
||||||
|
|
||||||
: load-return-value ( rep -- )
|
: load-return-value ( rep -- )
|
||||||
[ [ 0 ] dip reg-class-of param-reg ]
|
[ [ 0 ] dip reg-class-of param-reg ]
|
||||||
|
@ -117,6 +135,8 @@ M:: x86.64 %unbox-large-struct ( n c-type -- )
|
||||||
[ ]
|
[ ]
|
||||||
tri copy-register ;
|
tri copy-register ;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
M:: x86.64 %box ( n rep func -- )
|
M:: x86.64 %box ( n rep func -- )
|
||||||
n [
|
n [
|
||||||
n
|
n
|
||||||
|
@ -125,7 +145,7 @@ M:: x86.64 %box ( n rep func -- )
|
||||||
] [
|
] [
|
||||||
rep load-return-value
|
rep load-return-value
|
||||||
] if
|
] 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 -- )
|
M: x86.64 %box-long-long ( n func -- )
|
||||||
[ int-rep ] dip %box ;
|
[ 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-3 swap heap-size MOV ] bi
|
||||||
param-reg-1 0 box-struct-field@ MOV
|
param-reg-1 0 box-struct-field@ MOV
|
||||||
param-reg-2 1 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 ;
|
] with-return-regs ;
|
||||||
|
|
||||||
: struct-return@ ( n -- operand )
|
: struct-return@ ( n -- operand )
|
||||||
|
@ -157,7 +177,7 @@ M: x86.64 %box-large-struct ( n c-type -- )
|
||||||
! Compute destination address
|
! Compute destination address
|
||||||
param-reg-1 swap struct-return@ LEA
|
param-reg-1 swap struct-return@ LEA
|
||||||
! Copy the struct from the C stack
|
! 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 ( -- )
|
M: x86.64 %prepare-box-struct ( -- )
|
||||||
! Compute target address for value struct return
|
! Compute target address for value struct return
|
||||||
|
@ -172,8 +192,9 @@ M: x86.64 %alien-invoke
|
||||||
rc-absolute-cell rel-dlsym
|
rc-absolute-cell rel-dlsym
|
||||||
R11 CALL ;
|
R11 CALL ;
|
||||||
|
|
||||||
|
|
||||||
M: x86.64 %prepare-alien-indirect ( -- )
|
M: x86.64 %prepare-alien-indirect ( -- )
|
||||||
"unbox_alien" f %alien-invoke
|
"unbox_alien" %vm-invoke-1st-arg
|
||||||
RBP RAX MOV ;
|
RBP RAX MOV ;
|
||||||
|
|
||||||
M: x86.64 %alien-indirect ( -- )
|
M: x86.64 %alien-indirect ( -- )
|
||||||
|
@ -181,7 +202,7 @@ M: x86.64 %alien-indirect ( -- )
|
||||||
|
|
||||||
M: x86.64 %alien-callback ( quot -- )
|
M: x86.64 %alien-callback ( quot -- )
|
||||||
param-reg-1 swap %load-reference
|
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 -- )
|
M: x86.64 %callback-value ( ctype -- )
|
||||||
! Save top of data stack
|
! Save top of data stack
|
||||||
|
@ -190,7 +211,7 @@ M: x86.64 %callback-value ( ctype -- )
|
||||||
RSP 8 SUB
|
RSP 8 SUB
|
||||||
param-reg-1 PUSH
|
param-reg-1 PUSH
|
||||||
! Restore data/call/retain stacks
|
! 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
|
! Put former top of data stack in param-reg-1
|
||||||
param-reg-1 POP
|
param-reg-1 POP
|
||||||
RSP 8 ADD
|
RSP 8 ADD
|
||||||
|
|
|
@ -21,6 +21,7 @@ IN: bootstrap.x86
|
||||||
: rex-length ( -- n ) 1 ;
|
: rex-length ( -- n ) 1 ;
|
||||||
|
|
||||||
[
|
[
|
||||||
|
|
||||||
! load stack_chain
|
! load stack_chain
|
||||||
temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel
|
temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel
|
||||||
temp0 temp0 [] MOV
|
temp0 temp0 [] MOV
|
||||||
|
@ -28,6 +29,8 @@ IN: bootstrap.x86
|
||||||
temp0 [] stack-reg MOV
|
temp0 [] stack-reg MOV
|
||||||
! load XT
|
! load XT
|
||||||
temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
|
temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
|
||||||
|
! load vm ptr
|
||||||
|
arg 0 MOV rc-absolute-cell rt-vm jit-rel
|
||||||
! go
|
! go
|
||||||
temp1 JMP
|
temp1 JMP
|
||||||
] jit-primitive jit-define
|
] jit-primitive jit-define
|
||||||
|
|
|
@ -6,6 +6,7 @@ IN: bootstrap.x86
|
||||||
|
|
||||||
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
|
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
|
||||||
: arg ( -- reg ) RDI ;
|
: arg ( -- reg ) RDI ;
|
||||||
|
: arg2 ( -- reg ) RSI ;
|
||||||
|
|
||||||
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >>
|
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >>
|
||||||
call
|
call
|
||||||
|
|
|
@ -16,9 +16,10 @@ M: float-regs param-regs
|
||||||
|
|
||||||
M: x86.64 reserved-area-size 0 ;
|
M: x86.64 reserved-area-size 0 ;
|
||||||
|
|
||||||
! The ABI for passing structs by value is pretty messed up
|
SYMBOL: (stack-value)
|
||||||
<< "void*" c-type clone "__stack_value" define-primitive-type
|
! The ABI for passing structs by value is pretty great
|
||||||
stack-params "__stack_value" c-type (>>rep) >>
|
<< void* c-type clone \ (stack-value) define-primitive-type
|
||||||
|
stack-params \ (stack-value) c-type (>>rep) >>
|
||||||
|
|
||||||
: struct-types&offset ( struct-type -- pairs )
|
: struct-types&offset ( struct-type -- pairs )
|
||||||
fields>> [
|
fields>> [
|
||||||
|
@ -33,12 +34,12 @@ stack-params "__stack_value" c-type (>>rep) >>
|
||||||
: flatten-small-struct ( c-type -- seq )
|
: flatten-small-struct ( c-type -- seq )
|
||||||
struct-types&offset split-struct [
|
struct-types&offset split-struct [
|
||||||
[ c-type c-type-rep reg-class-of ] map
|
[ 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 ;
|
] map ;
|
||||||
|
|
||||||
: flatten-large-struct ( c-type -- seq )
|
: flatten-large-struct ( c-type -- seq )
|
||||||
heap-size cell align
|
heap-size cell align
|
||||||
cell /i "__stack_value" c-type <repetition> ;
|
cell /i \ (stack-value) c-type <repetition> ;
|
||||||
|
|
||||||
: flatten-struct ( c-type -- seq )
|
: flatten-struct ( c-type -- seq )
|
||||||
dup heap-size 16 > [
|
dup heap-size 16 > [
|
||||||
|
|
|
@ -7,6 +7,7 @@ IN: bootstrap.x86
|
||||||
|
|
||||||
: stack-frame-size ( -- n ) 8 bootstrap-cells ;
|
: stack-frame-size ( -- n ) 8 bootstrap-cells ;
|
||||||
: arg ( -- reg ) RCX ;
|
: arg ( -- reg ) RCX ;
|
||||||
|
: arg2 ( -- reg ) RDX ;
|
||||||
|
|
||||||
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >>
|
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >>
|
||||||
call
|
call
|
||||||
|
|
|
@ -25,8 +25,8 @@ M: x86.64 dummy-fp-params? t ;
|
||||||
M: x86.64 temp-reg RAX ;
|
M: x86.64 temp-reg RAX ;
|
||||||
|
|
||||||
<<
|
<<
|
||||||
"longlong" "ptrdiff_t" typedef
|
longlong ptrdiff_t typedef
|
||||||
"longlong" "intptr_t" typedef
|
longlong intptr_t typedef
|
||||||
"int" c-type "long" define-primitive-type
|
int c-type long define-primitive-type
|
||||||
"uint" c-type "ulong" define-primitive-type
|
uint c-type ulong define-primitive-type
|
||||||
>>
|
>>
|
||||||
|
|
|
@ -251,6 +251,8 @@ big-endian off
|
||||||
arg ds-reg [] MOV
|
arg ds-reg [] MOV
|
||||||
! pop stack
|
! pop stack
|
||||||
ds-reg bootstrap-cell SUB
|
ds-reg bootstrap-cell SUB
|
||||||
|
! pass vm pointer
|
||||||
|
arg2 0 MOV rc-absolute-cell rt-vm jit-rel
|
||||||
! call quotation
|
! call quotation
|
||||||
arg quot-xt-offset [+] JMP
|
arg quot-xt-offset [+] JMP
|
||||||
] \ (call) define-sub-primitive
|
] \ (call) define-sub-primitive
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2009 Slava Pestov.
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: system kernel math math.order math.parser namespaces
|
USING: system kernel math math.order math.parser namespaces
|
||||||
alien.syntax combinators locals init io cpu.x86 compiler
|
alien.c-types alien.syntax combinators locals init io cpu.x86
|
||||||
compiler.units accessors ;
|
compiler compiler.units accessors ;
|
||||||
IN: cpu.x86.features
|
IN: cpu.x86.features
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
|
@ -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.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
|
||||||
cpu.architecture kernel kernel.private math memory namespaces make
|
cpu.architecture kernel kernel.private math memory namespaces make
|
||||||
sequences words system layouts combinators math.order fry locals
|
sequences words system layouts combinators math.order fry locals
|
||||||
compiler.constants byte-arrays
|
compiler.constants vm byte-arrays
|
||||||
compiler.cfg.registers
|
compiler.cfg.registers
|
||||||
compiler.cfg.instructions
|
compiler.cfg.instructions
|
||||||
compiler.cfg.intrinsics
|
compiler.cfg.intrinsics
|
||||||
compiler.cfg.comparisons
|
compiler.cfg.comparisons
|
||||||
compiler.cfg.stack-frame
|
compiler.cfg.stack-frame
|
||||||
compiler.codegen
|
|
||||||
compiler.codegen.fixup ;
|
compiler.codegen.fixup ;
|
||||||
|
FROM: layouts => cell ;
|
||||||
|
FROM: math => float ;
|
||||||
IN: cpu.x86
|
IN: cpu.x86
|
||||||
|
|
||||||
<< enable-fixnum-log2 >>
|
|
||||||
|
|
||||||
! Add some methods to the assembler to be more useful to the backend
|
! Add some methods to the assembler to be more useful to the backend
|
||||||
M: label JMP 0 JMP rc-relative label-fixup ;
|
M: label JMP 0 JMP rc-relative label-fixup ;
|
||||||
M: label JUMPcc [ 0 ] dip JUMPcc 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 %shr [ SHR ] emit-shift ;
|
||||||
M: x86 %sar [ SAR ] 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-zone-ptr ( reg -- )
|
||||||
#! Load pointer to start of zone array
|
#! 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 -- )
|
: load-allot-ptr ( nursery-ptr allot-ptr -- )
|
||||||
[ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
|
[ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
|
||||||
|
@ -577,18 +580,19 @@ M:: x86 %allot ( dst size class nursery-ptr -- )
|
||||||
dst class store-tagged
|
dst class store-tagged
|
||||||
nursery-ptr size inc-allot-ptr ;
|
nursery-ptr size inc-allot-ptr ;
|
||||||
|
|
||||||
|
|
||||||
M:: x86 %write-barrier ( src card# table -- )
|
M:: x86 %write-barrier ( src card# table -- )
|
||||||
#! Mark the card pointed to by vreg.
|
#! Mark the card pointed to by vreg.
|
||||||
! Mark the card
|
! Mark the card
|
||||||
card# src MOV
|
card# src MOV
|
||||||
card# card-bits SHR
|
card# card-bits SHR
|
||||||
table "cards_offset" f %alien-global
|
table "cards_offset" %vm-field-ptr
|
||||||
table table [] MOV
|
table table [] MOV
|
||||||
table card# [+] card-mark <byte> MOV
|
table card# [+] card-mark <byte> MOV
|
||||||
|
|
||||||
! Mark the card deck
|
! Mark the card deck
|
||||||
card# deck-bits card-bits - SHR
|
card# deck-bits card-bits - SHR
|
||||||
table "decks_offset" f %alien-global
|
table "decks_offset" %vm-field-ptr
|
||||||
table table [] MOV
|
table table [] MOV
|
||||||
table card# [+] card-mark <byte> 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
|
! Pass number of roots as second parameter
|
||||||
param-reg-2 gc-root-count MOV
|
param-reg-2 gc-root-count MOV
|
||||||
! Call GC
|
! Call GC
|
||||||
"inline_gc" f %alien-invoke ;
|
"inline_gc" %vm-invoke-3rd-arg ;
|
||||||
|
|
||||||
M: x86 %alien-global
|
M: x86 %alien-global ( dst symbol library -- )
|
||||||
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
|
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
|
||||||
|
|
||||||
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
|
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
|
#! Save Factor stack pointers in case the C code calls a
|
||||||
#! callback which does a GC, which must reliably trace
|
#! callback which does a GC, which must reliably trace
|
||||||
#! all roots.
|
#! all roots.
|
||||||
temp1 "stack_chain" f %alien-global
|
temp1 0 MOV rc-absolute-cell rt-vm rel-fixup
|
||||||
temp1 temp1 [] MOV
|
temp1 temp1 "stack_chain" vm-field-offset [+] MOV
|
||||||
temp2 stack-reg cell neg [+] LEA
|
temp2 stack-reg cell neg [+] LEA
|
||||||
temp1 [] temp2 MOV
|
temp1 [] temp2 MOV
|
||||||
callback-allowed? [
|
callback-allowed? [
|
||||||
|
@ -774,3 +778,4 @@ M: x86 small-enough? ( n -- ? )
|
||||||
enable-sse3-simd ;
|
enable-sse3-simd ;
|
||||||
|
|
||||||
enable-min/max
|
enable-min/max
|
||||||
|
enable-fixnum-log2
|
|
@ -2,11 +2,11 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays continuations db io kernel math namespaces
|
USING: arrays continuations db io kernel math namespaces
|
||||||
quotations sequences db.postgresql.ffi alien alien.c-types
|
quotations sequences db.postgresql.ffi alien alien.c-types
|
||||||
db.types tools.walker ascii splitting math.parser combinators
|
alien.data db.types tools.walker ascii splitting math.parser
|
||||||
libc calendar.format byte-arrays destructors prettyprint
|
combinators libc calendar.format byte-arrays destructors
|
||||||
accessors strings serialize io.encodings.binary io.encodings.utf8
|
prettyprint accessors strings serialize io.encodings.binary
|
||||||
alien.strings io.streams.byte-array summary present urls
|
io.encodings.utf8 alien.strings io.streams.byte-array summary
|
||||||
specialized-arrays db.private ;
|
present urls specialized-arrays db.private ;
|
||||||
SPECIALIZED-ARRAY: uint
|
SPECIALIZED-ARRAY: uint
|
||||||
SPECIALIZED-ARRAY: void*
|
SPECIALIZED-ARRAY: void*
|
||||||
IN: db.postgresql.lib
|
IN: db.postgresql.lib
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2008 Chris Double, Doug Coleman.
|
! Copyright (C) 2008 Chris Double, Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
namespaces sequences db.sqlite.ffi db combinators
|
||||||
continuations db.types calendar.format serialize
|
continuations db.types calendar.format serialize
|
||||||
io.streams.byte-array byte-arrays io.encodings.binary
|
io.streams.byte-array byte-arrays io.encodings.binary
|
||||||
|
|
|
@ -174,6 +174,8 @@ M: no-method error.
|
||||||
|
|
||||||
M: bad-slot-value summary drop "Bad store to specialized slot" ;
|
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
|
M: no-math-method summary
|
||||||
drop "No suitable arithmetic method" ;
|
drop "No suitable arithmetic method" ;
|
||||||
|
|
||||||
|
|
|
@ -1,8 +1,9 @@
|
||||||
! Copyright (C) 2008 Doug Coleman.
|
! Copyright (C) 2008 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.c-types alien.strings alien.syntax kernel
|
USING: alien alien.c-types alien.data alien.strings
|
||||||
layouts sequences system unix environment io.encodings.utf8
|
alien.syntax kernel layouts sequences system unix
|
||||||
unix.utilities vocabs.loader combinators alien.accessors ;
|
environment io.encodings.utf8 unix.utilities vocabs.loader
|
||||||
|
combinators alien.accessors ;
|
||||||
IN: environment.unix
|
IN: environment.unix
|
||||||
|
|
||||||
HOOK: environ os ( -- void* )
|
HOOK: environ os ( -- void* )
|
||||||
|
|
|
@ -1,15 +1,14 @@
|
||||||
! Copyright (C) 2008 Doug Coleman.
|
! Copyright (C) 2008 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien.strings fry io.encodings.utf16n kernel
|
USING: alien.strings fry io.encodings.utf16n kernel
|
||||||
splitting windows windows.kernel32 system environment
|
splitting windows windows.kernel32 windows.types system
|
||||||
alien.c-types sequences windows.errors io.streams.memory
|
environment alien.data sequences windows.errors
|
||||||
io.encodings io ;
|
io.streams.memory io.encodings io specialized-arrays ;
|
||||||
|
SPECIALIZED-ARRAY: TCHAR
|
||||||
IN: environment.winnt
|
IN: environment.winnt
|
||||||
|
|
||||||
<< "TCHAR" require-c-array >>
|
|
||||||
|
|
||||||
M: winnt os-env ( key -- value )
|
M: winnt os-env ( key -- value )
|
||||||
MAX_UNICODE_PATH "TCHAR" <c-array>
|
MAX_UNICODE_PATH TCHAR <c-array>
|
||||||
[ dup length GetEnvironmentVariable ] keep over 0 = [
|
[ dup length GetEnvironmentVariable ] keep over 0 = [
|
||||||
2drop f
|
2drop f
|
||||||
] [
|
] [
|
||||||
|
|
|
@ -1,5 +1,6 @@
|
||||||
USING: classes.struct functors tools.test math words kernel
|
USING: classes.struct functors tools.test math words kernel
|
||||||
multiline parser io.streams.string generic ;
|
multiline parser io.streams.string generic ;
|
||||||
|
QUALIFIED-WITH: alien.c-types c
|
||||||
IN: functors.tests
|
IN: functors.tests
|
||||||
|
|
||||||
<<
|
<<
|
||||||
|
@ -160,15 +161,15 @@ T-class DEFINES-CLASS ${T}
|
||||||
WHERE
|
WHERE
|
||||||
|
|
||||||
STRUCT: T-class
|
STRUCT: T-class
|
||||||
{ NAME int }
|
{ NAME c:int }
|
||||||
{ x { TYPE 4 } }
|
{ x { TYPE 4 } }
|
||||||
{ y { "short" N } }
|
{ y { c:short N } }
|
||||||
{ z TYPE initial: 5 }
|
{ z TYPE initial: 5 }
|
||||||
{ float { "float" 2 } } ;
|
{ float { c:float 2 } } ;
|
||||||
|
|
||||||
;FUNCTOR
|
;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 }
|
{ offset 0 }
|
||||||
{ class integer }
|
{ class integer }
|
||||||
{ initial 0 }
|
{ initial 0 }
|
||||||
{ c-type "int" }
|
{ type c:int }
|
||||||
}
|
}
|
||||||
T{ struct-slot-spec
|
T{ struct-slot-spec
|
||||||
{ name "x" }
|
{ name "x" }
|
||||||
{ offset 4 }
|
{ offset 4 }
|
||||||
{ class object }
|
{ class object }
|
||||||
{ initial f }
|
{ initial f }
|
||||||
{ c-type { "char" 4 } }
|
{ type { c:char 4 } }
|
||||||
}
|
}
|
||||||
T{ struct-slot-spec
|
T{ struct-slot-spec
|
||||||
{ name "y" }
|
{ name "y" }
|
||||||
{ offset 8 }
|
{ offset 8 }
|
||||||
{ class object }
|
{ class object }
|
||||||
{ initial f }
|
{ initial f }
|
||||||
{ c-type { "short" 2 } }
|
{ type { c:short 2 } }
|
||||||
}
|
}
|
||||||
T{ struct-slot-spec
|
T{ struct-slot-spec
|
||||||
{ name "z" }
|
{ name "z" }
|
||||||
{ offset 12 }
|
{ offset 12 }
|
||||||
{ class fixnum }
|
{ class fixnum }
|
||||||
{ initial 5 }
|
{ initial 5 }
|
||||||
{ c-type "char" }
|
{ type c:char }
|
||||||
}
|
}
|
||||||
T{ struct-slot-spec
|
T{ struct-slot-spec
|
||||||
{ name "float" }
|
{ name "float" }
|
||||||
{ offset 16 }
|
{ offset 16 }
|
||||||
{ class object }
|
{ class object }
|
||||||
{ initial f }
|
{ initial f }
|
||||||
{ c-type { "float" 2 } }
|
{ type { c:float 2 } }
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
] [ a-struct struct-slots ] unit-test
|
] [ a-struct struct-slots ] unit-test
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Doug Coleman
|
|
@ -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> ;
|
|
@ -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>
|
|
@ -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"
|
|
@ -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* ;
|
|
@ -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>
|
|
@ -0,0 +1 @@
|
||||||
|
Recaptcha library
|
|
@ -0,0 +1 @@
|
||||||
|
web
|
|
@ -6,7 +6,7 @@ math.rectangles namespaces parser sequences shuffle
|
||||||
specialized-arrays ui.backend.windows vectors windows.com
|
specialized-arrays ui.backend.windows vectors windows.com
|
||||||
windows.dinput windows.dinput.constants windows.errors
|
windows.dinput windows.dinput.constants windows.errors
|
||||||
windows.kernel32 windows.messages windows.ole32
|
windows.kernel32 windows.messages windows.ole32
|
||||||
windows.user32 classes.struct ;
|
windows.user32 classes.struct alien.data ;
|
||||||
SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA
|
SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA
|
||||||
IN: game-input.dinput
|
IN: game-input.dinput
|
||||||
|
|
||||||
|
@ -160,19 +160,24 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
||||||
[ device-attached? not ] filter
|
[ device-attached? not ] filter
|
||||||
[ remove-controller ] each ;
|
[ remove-controller ] each ;
|
||||||
|
|
||||||
: device-interface? ( dbt-broadcast-hdr -- ? )
|
: ?device-interface ( dbt-broadcast-hdr -- ? )
|
||||||
dbch_devicetype>> DBT_DEVTYP_DEVICEINTERFACE = ;
|
dup dbch_devicetype>> DBT_DEVTYP_DEVICEINTERFACE =
|
||||||
|
[ >c-ptr DEV_BROADCAST_DEVICEW memory>struct ]
|
||||||
|
[ drop f ] if ; inline
|
||||||
|
|
||||||
: device-arrived ( dbt-broadcast-hdr -- )
|
: device-arrived ( dbt-broadcast-hdr -- )
|
||||||
device-interface? [ find-controllers ] when ;
|
?device-interface [ find-controllers ] when ; inline
|
||||||
|
|
||||||
: device-removed ( dbt-broadcast-hdr -- )
|
: 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 -- )
|
: handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
|
||||||
[ 2drop ] 2dip swap {
|
[ 2drop ] 2dip swap {
|
||||||
{ [ dup DBT_DEVICEARRIVAL = ] [ drop <alien> device-arrived ] }
|
{ [ dup DBT_DEVICEARRIVAL = ] [ drop <DEV_BROADCAST_HDR> device-arrived ] }
|
||||||
{ [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <alien> device-removed ] }
|
{ [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <DEV_BROADCAST_HDR> device-removed ] }
|
||||||
[ 2drop ]
|
[ 2drop ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
USING: sequences sequences.private math alien.c-types
|
USING: sequences sequences.private math
|
||||||
accessors ;
|
accessors alien.data ;
|
||||||
IN: game-input.dinput.keys-array
|
IN: game-input.dinput.keys-array
|
||||||
|
|
||||||
TUPLE: keys-array
|
TUPLE: keys-array
|
||||||
|
|
|
@ -3,7 +3,8 @@ kernel cocoa.enumeration destructors math.parser cocoa.application
|
||||||
sequences locals combinators.short-circuit threads
|
sequences locals combinators.short-circuit threads
|
||||||
namespaces assocs arrays combinators hints alien
|
namespaces assocs arrays combinators hints alien
|
||||||
core-foundation.run-loop accessors sequences.private
|
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
|
IN: game-input.iokit
|
||||||
|
|
||||||
SINGLETON: iokit-game-input-backend
|
SINGLETON: iokit-game-input-backend
|
||||||
|
|
|
@ -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." } ;
|
{ $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:
|
HELP: CHLOE:
|
||||||
{ $syntax "name definition... ;" }
|
{ $syntax "CHLOE: name definition... ;" }
|
||||||
{ $values { "name" "the tag name" } { "definition" { $quotation "( tag -- )" } } }
|
{ $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." } ;
|
{ $description "Defines compilation semantics for the Chloe tag named " { $snippet "tag" } ". The definition body receives a " { $link tag } " on the stack." } ;
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2009 Slava Pestov.
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors alien.c-types destructors fry images kernel
|
USING: accessors alien.c-types alien.data destructors fry images
|
||||||
libc math sequences ;
|
kernel libc math sequences ;
|
||||||
IN: images.memory
|
IN: images.memory
|
||||||
|
|
||||||
! Some code shared by core-graphics and cairo for constructing
|
! Some code shared by core-graphics and cairo for constructing
|
||||||
|
@ -27,4 +27,4 @@ PRIVATE>
|
||||||
: make-memory-bitmap ( dim quot -- image )
|
: make-memory-bitmap ( dim quot -- image )
|
||||||
'[
|
'[
|
||||||
[ malloc-bitmap-data ] keep _ [ <bitmap-image> ] 2bi
|
[ malloc-bitmap-data ] keep _ [ <bitmap-image> ] 2bi
|
||||||
] with-destructors ; inline
|
] with-destructors ; inline
|
||||||
|
|
|
@ -1,52 +1,43 @@
|
||||||
USING: alien alien.c-types alien.syntax arrays continuations
|
USING: alien alien.c-types alien.data alien.syntax arrays continuations
|
||||||
destructors generic io.mmap io.ports io.backend.windows io.files.windows
|
destructors generic io.mmap io.ports io.backend.windows io.files.windows
|
||||||
kernel libc math math.bitwise namespaces quotations sequences windows
|
kernel libc locals math math.bitwise namespaces quotations sequences windows
|
||||||
windows.advapi32 windows.kernel32 io.backend system accessors
|
windows.advapi32 windows.kernel32 windows.types io.backend system accessors
|
||||||
io.backend.windows.privileges windows.errors ;
|
io.backend.windows.privileges classes.struct windows.errors ;
|
||||||
IN: io.backend.windows.nt.privileges
|
IN: io.backend.windows.nt.privileges
|
||||||
|
|
||||||
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
|
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
|
||||||
|
|
||||||
! Security tokens
|
! Security tokens
|
||||||
! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
|
! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
|
||||||
|
|
||||||
: (open-process-token) ( handle -- handle )
|
: (open-process-token) ( handle -- handle )
|
||||||
{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" <c-object>
|
{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags PHANDLE <c-object>
|
||||||
[ OpenProcessToken win32-error=0/f ] keep *void* ;
|
[ OpenProcessToken win32-error=0/f ] keep *void* ;
|
||||||
|
|
||||||
: open-process-token ( -- handle )
|
: open-process-token ( -- handle )
|
||||||
#! remember to CloseHandle
|
#! remember to CloseHandle
|
||||||
GetCurrentProcess (open-process-token) ;
|
GetCurrentProcess (open-process-token) ;
|
||||||
|
|
||||||
: with-process-token ( quot -- )
|
: with-process-token ( quot -- )
|
||||||
#! quot: ( token-handle -- token-handle )
|
#! quot: ( token-handle -- token-handle )
|
||||||
[ open-process-token ] dip
|
[ open-process-token ] dip
|
||||||
[ keep ] curry
|
[ keep ] curry
|
||||||
[ CloseHandle drop ] [ ] cleanup ; inline
|
[ CloseHandle drop ] [ ] cleanup ; inline
|
||||||
|
|
||||||
: lookup-privilege ( string -- luid )
|
: lookup-privilege ( string -- luid )
|
||||||
[ f ] dip "LUID" <c-object>
|
[ f ] dip LUID <struct>
|
||||||
[ LookupPrivilegeValue win32-error=0/f ] keep ;
|
[ LookupPrivilegeValue win32-error=0/f ] keep ;
|
||||||
|
|
||||||
: make-token-privileges ( name ? -- obj )
|
:: make-token-privileges ( name enabled? -- obj )
|
||||||
"TOKEN_PRIVILEGES" <c-object>
|
TOKEN_PRIVILEGES <struct>
|
||||||
1 over set-TOKEN_PRIVILEGES-PrivilegeCount
|
1 >>PrivilegeCount
|
||||||
"LUID_AND_ATTRIBUTES" malloc-object &free
|
LUID_AND_ATTRIBUTES malloc-struct &free
|
||||||
over set-TOKEN_PRIVILEGES-Privileges
|
enabled? [ SE_PRIVILEGE_ENABLED >>Attributes ] when
|
||||||
|
name lookup-privilege >>Luid
|
||||||
swap [
|
>>Privileges ;
|
||||||
SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges
|
|
||||||
set-LUID_AND_ATTRIBUTES-Attributes
|
M: winnt set-privilege ( name ? -- )
|
||||||
] when
|
[
|
||||||
|
-rot 0 -rot make-token-privileges
|
||||||
[ lookup-privilege ] dip
|
dup byte-length f f AdjustTokenPrivileges win32-error=0/f
|
||||||
[
|
] with-process-token ;
|
||||||
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 ;
|
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
IN: io.buffers.tests
|
IN: io.buffers.tests
|
||||||
USING: alien alien.c-types io.buffers kernel kernel.private libc
|
USING: alien alien.c-types alien.data io.buffers kernel
|
||||||
sequences tools.test namespaces byte-arrays strings accessors
|
kernel.private libc sequences tools.test namespaces byte-arrays
|
||||||
destructors ;
|
strings accessors destructors ;
|
||||||
|
|
||||||
: buffer-set ( string buffer -- )
|
: buffer-set ( string buffer -- )
|
||||||
over >byte-array over ptr>> byte-array>memory
|
over >byte-array over ptr>> byte-array>memory
|
||||||
|
|
|
@ -2,8 +2,8 @@
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors alien alien.accessors alien.c-types
|
USING: accessors alien alien.accessors alien.c-types
|
||||||
alien.syntax kernel libc math sequences byte-arrays strings
|
alien.data alien.syntax kernel libc math sequences byte-arrays
|
||||||
hints math.order destructors combinators ;
|
strings hints math.order destructors combinators ;
|
||||||
IN: io.buffers
|
IN: io.buffers
|
||||||
|
|
||||||
TUPLE: buffer
|
TUPLE: buffer
|
||||||
|
|
|
@ -6,7 +6,7 @@ windows.time windows accessors alien.c-types combinators
|
||||||
generalizations system alien.strings io.encodings.utf16n
|
generalizations system alien.strings io.encodings.utf16n
|
||||||
sequences splitting windows.errors fry continuations destructors
|
sequences splitting windows.errors fry continuations destructors
|
||||||
calendar ascii combinators.short-circuit locals classes.struct
|
calendar ascii combinators.short-circuit locals classes.struct
|
||||||
specialized-arrays ;
|
specialized-arrays alien.data ;
|
||||||
SPECIALIZED-ARRAY: ushort
|
SPECIALIZED-ARRAY: ushort
|
||||||
IN: io.files.info.windows
|
IN: io.files.info.windows
|
||||||
|
|
||||||
|
|
|
@ -6,7 +6,7 @@ io.backend.windows kernel math splitting fry alien.strings
|
||||||
windows windows.kernel32 windows.time calendar combinators
|
windows windows.kernel32 windows.time calendar combinators
|
||||||
math.functions sequences namespaces make words system
|
math.functions sequences namespaces make words system
|
||||||
destructors accessors math.bitwise continuations windows.errors
|
destructors accessors math.bitwise continuations windows.errors
|
||||||
arrays byte-arrays generalizations ;
|
arrays byte-arrays generalizations alien.data ;
|
||||||
IN: io.files.windows
|
IN: io.files.windows
|
||||||
|
|
||||||
: open-file ( path access-mode create-mode flags -- handle )
|
: open-file ( path access-mode create-mode flags -- handle )
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: continuations destructors io.files io.files.info
|
USING: continuations destructors io.files io.files.info
|
||||||
io.backend kernel quotations system alien alien.accessors
|
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 ;
|
math ;
|
||||||
IN: io.mmap
|
IN: io.mmap
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
|
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.c-types alien.strings libc destructors locals
|
USING: alien alien.c-types alien.data alien.strings libc destructors
|
||||||
kernel math assocs namespaces make continuations sequences
|
locals kernel math assocs namespaces make continuations sequences
|
||||||
hashtables sorting arrays combinators math.bitwise strings
|
hashtables sorting arrays combinators math.bitwise strings
|
||||||
system accessors threads splitting io.backend io.backend.windows
|
system accessors threads splitting io.backend io.backend.windows
|
||||||
io.backend.windows.nt io.files.windows.nt io.monitors io.ports
|
io.backend.windows.nt io.files.windows.nt io.monitors io.ports
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
|
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors byte-arrays kernel sequences namespaces math
|
USING: accessors byte-arrays kernel sequences namespaces math
|
||||||
math.order combinators init alien alien.c-types alien.strings
|
math.order combinators init alien alien.c-types alien.data
|
||||||
libc continuations destructors summary splitting assocs random
|
alien.strings libc continuations destructors summary splitting
|
||||||
math.parser locals unicode.case openssl openssl.libcrypto
|
assocs random math.parser locals unicode.case openssl
|
||||||
openssl.libssl io.backend io.ports io.pathnames
|
openssl.libcrypto openssl.libssl io.backend io.ports io.pathnames
|
||||||
io.encodings.8-bit io.timeouts io.sockets.secure ;
|
io.encodings.8-bit io.timeouts io.sockets.secure ;
|
||||||
IN: io.sockets.secure.openssl
|
IN: io.sockets.secure.openssl
|
||||||
|
|
||||||
|
@ -31,7 +31,7 @@ TUPLE: openssl-context < secure-context aliens sessions ;
|
||||||
] [ drop ] if ;
|
] [ drop ] if ;
|
||||||
|
|
||||||
: password-callback ( -- alien )
|
: password-callback ( -- alien )
|
||||||
"int" { "void*" "int" "bool" "void*" } "cdecl"
|
int { void* int bool void* } "cdecl"
|
||||||
[| buf size rwflag password! |
|
[| buf size rwflag password! |
|
||||||
password [ B{ 0 } password! ] unless
|
password [ B{ 0 } password! ] unless
|
||||||
|
|
||||||
|
|
|
@ -6,7 +6,7 @@ arrays io.encodings io.ports io.streams.duplex io.encodings.ascii
|
||||||
alien.strings io.binary accessors destructors classes byte-arrays
|
alien.strings io.binary accessors destructors classes byte-arrays
|
||||||
parser alien.c-types math.parser splitting grouping math assocs
|
parser alien.c-types math.parser splitting grouping math assocs
|
||||||
summary system vocabs.loader combinators present fry vocabs.parser
|
summary system vocabs.loader combinators present fry vocabs.parser
|
||||||
classes.struct ;
|
classes.struct alien.data ;
|
||||||
IN: io.sockets
|
IN: io.sockets
|
||||||
|
|
||||||
<< {
|
<< {
|
||||||
|
|
|
@ -5,7 +5,7 @@ threads sequences byte-arrays io.binary io.backend.unix
|
||||||
io.streams.duplex io.backend io.pathnames io.sockets.private
|
io.streams.duplex io.backend io.pathnames io.sockets.private
|
||||||
io.files.private io.encodings.utf8 math.parser continuations
|
io.files.private io.encodings.utf8 math.parser continuations
|
||||||
libc combinators system accessors destructors unix locals init
|
libc combinators system accessors destructors unix locals init
|
||||||
classes.struct ;
|
classes.struct alien.data ;
|
||||||
|
|
||||||
EXCLUDE: namespaces => bind ;
|
EXCLUDE: namespaces => bind ;
|
||||||
EXCLUDE: io => read write ;
|
EXCLUDE: io => read write ;
|
||||||
|
|
|
@ -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
|
continuations destructors io.ports io.timeouts io.sockets
|
||||||
io.sockets.private io namespaces io.streams.duplex
|
io.sockets.private io namespaces io.streams.duplex
|
||||||
io.backend.windows io.sockets.windows io.backend.windows.nt
|
io.backend.windows io.sockets.windows io.backend.windows.nt
|
||||||
|
|
|
@ -130,30 +130,11 @@ TYPEDEF: void* IOHIDTransactionRef
|
||||||
TYPEDEF: UInt32 IOHIDValueScaleType
|
TYPEDEF: UInt32 IOHIDValueScaleType
|
||||||
TYPEDEF: UInt32 IOHIDTransactionDirectionType
|
TYPEDEF: UInt32 IOHIDTransactionDirectionType
|
||||||
|
|
||||||
TYPEDEF: void* IOHIDCallback
|
CALLBACK: void IOHIDCallback ( void* context, IOReturn result, void* sender ) ;
|
||||||
: IOHIDCallback ( quot -- alien )
|
CALLBACK: void IOHIDReportCallback ( void* context, IOReturn result, void* sender, IOHIDReportType type, UInt32 reportID, uchar* report, CFIndex reportLength ) ;
|
||||||
[ "void" { "void*" "IOReturn" "void*" } "cdecl" ]
|
CALLBACK: void IOHIDValueCallback ( void* context, IOReturn result, void* sender, IOHIDValueRef value ) ;
|
||||||
dip alien-callback ; inline
|
CALLBACK: void IOHIDValueMultipleCallback ( void* context, IOReturn result, void* sender, CFDictionaryRef multiple ) ;
|
||||||
|
CALLBACK: void IOHIDDeviceCallback ( void* context, IOReturn result, void* sender, IOHIDDeviceRef device ) ;
|
||||||
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
|
|
||||||
|
|
||||||
! IOHIDDevice
|
! IOHIDDevice
|
||||||
|
|
||||||
|
|
|
@ -2,29 +2,29 @@
|
||||||
! Copyright (C) 2007, 2009 Slava Pestov
|
! Copyright (C) 2007, 2009 Slava Pestov
|
||||||
! Copyright (C) 2007, 2008 Doug Coleman
|
! Copyright (C) 2007, 2008 Doug Coleman
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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 ;
|
namespaces accessors sets summary destructors destructors.private ;
|
||||||
IN: libc
|
IN: libc
|
||||||
|
|
||||||
: errno ( -- int )
|
: errno ( -- int )
|
||||||
"int" "factor" "err_no" { } alien-invoke ;
|
int "factor" "err_no" { } alien-invoke ;
|
||||||
|
|
||||||
: clear-errno ( -- )
|
: clear-errno ( -- )
|
||||||
"void" "factor" "clear_err_no" { } alien-invoke ;
|
void "factor" "clear_err_no" { } alien-invoke ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: (malloc) ( size -- alien )
|
: (malloc) ( size -- alien )
|
||||||
"void*" "libc" "malloc" { "ulong" } alien-invoke ;
|
void* "libc" "malloc" { ulong } alien-invoke ;
|
||||||
|
|
||||||
: (calloc) ( count size -- alien )
|
: (calloc) ( count size -- alien )
|
||||||
"void*" "libc" "calloc" { "ulong" "ulong" } alien-invoke ;
|
void* "libc" "calloc" { ulong ulong } alien-invoke ;
|
||||||
|
|
||||||
: (free) ( alien -- )
|
: (free) ( alien -- )
|
||||||
"void" "libc" "free" { "void*" } alien-invoke ;
|
void "libc" "free" { void* } alien-invoke ;
|
||||||
|
|
||||||
: (realloc) ( alien size -- newalien )
|
: (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
|
! We stick malloc-ptr instances in the global disposables set
|
||||||
TUPLE: malloc-ptr value continuation ;
|
TUPLE: malloc-ptr value continuation ;
|
||||||
|
@ -81,15 +81,15 @@ PRIVATE>
|
||||||
>c-ptr [ delete-malloc ] [ (free) ] bi ;
|
>c-ptr [ delete-malloc ] [ (free) ] bi ;
|
||||||
|
|
||||||
: memcpy ( dst src size -- )
|
: 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 )
|
: 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 -- ? )
|
: memory= ( a b size -- ? )
|
||||||
memcmp 0 = ;
|
memcmp 0 = ;
|
||||||
|
|
||||||
: strlen ( alien -- len )
|
: strlen ( alien -- len )
|
||||||
"size_t" "libc" "strlen" { "char*" } alien-invoke ;
|
size_t "libc" "strlen" { char* } alien-invoke ;
|
||||||
|
|
||||||
DESTRUCTOR: free
|
DESTRUCTOR: free
|
||||||
|
|
|
@ -1,10 +1,11 @@
|
||||||
USING: accessors alien alien.c-types arrays byte-arrays combinators
|
USING: accessors alien alien.c-types alien.data arrays
|
||||||
combinators.short-circuit fry kernel locals macros
|
byte-arrays combinators combinators.short-circuit fry
|
||||||
math math.blas.ffi math.blas.vectors math.blas.vectors.private
|
kernel locals macros math math.blas.ffi math.blas.vectors
|
||||||
math.complex math.functions math.order functors words
|
math.blas.vectors.private math.complex math.functions
|
||||||
sequences sequences.merged sequences.private shuffle
|
math.order functors words sequences sequences.merged
|
||||||
parser prettyprint.backend prettyprint.custom ascii
|
sequences.private shuffle parser prettyprint.backend
|
||||||
specialized-arrays ;
|
prettyprint.custom ascii specialized-arrays ;
|
||||||
|
FROM: alien.c-types => float ;
|
||||||
SPECIALIZED-ARRAY: float
|
SPECIALIZED-ARRAY: float
|
||||||
SPECIALIZED-ARRAY: double
|
SPECIALIZED-ARRAY: double
|
||||||
SPECIALIZED-ARRAY: complex-float
|
SPECIALIZED-ARRAY: complex-float
|
||||||
|
|
|
@ -3,6 +3,7 @@ combinators.short-circuit fry kernel math math.blas.ffi
|
||||||
math.complex math.functions math.order sequences sequences.private
|
math.complex math.functions math.order sequences sequences.private
|
||||||
functors words locals parser prettyprint.backend prettyprint.custom
|
functors words locals parser prettyprint.backend prettyprint.custom
|
||||||
specialized-arrays ;
|
specialized-arrays ;
|
||||||
|
FROM: alien.c-types => float ;
|
||||||
SPECIALIZED-ARRAY: float
|
SPECIALIZED-ARRAY: float
|
||||||
SPECIALIZED-ARRAY: double
|
SPECIALIZED-ARRAY: double
|
||||||
SPECIALIZED-ARRAY: complex-float
|
SPECIALIZED-ARRAY: complex-float
|
||||||
|
|
|
@ -1,62 +1,62 @@
|
||||||
! Copyright (C) 2006 Slava Pestov.
|
! Copyright (C) 2006 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien ;
|
USING: alien alien.c-types ;
|
||||||
IN: math.libm
|
IN: math.libm
|
||||||
|
|
||||||
: facos ( x -- y )
|
: facos ( x -- y )
|
||||||
"double" "libm" "acos" { "double" } alien-invoke ;
|
double "libm" "acos" { double } alien-invoke ;
|
||||||
|
|
||||||
: fasin ( x -- y )
|
: fasin ( x -- y )
|
||||||
"double" "libm" "asin" { "double" } alien-invoke ;
|
double "libm" "asin" { double } alien-invoke ;
|
||||||
|
|
||||||
: fatan ( x -- y )
|
: fatan ( x -- y )
|
||||||
"double" "libm" "atan" { "double" } alien-invoke ;
|
double "libm" "atan" { double } alien-invoke ;
|
||||||
|
|
||||||
: fatan2 ( x y -- z )
|
: fatan2 ( x y -- z )
|
||||||
"double" "libm" "atan2" { "double" "double" } alien-invoke ;
|
double "libm" "atan2" { double double } alien-invoke ;
|
||||||
|
|
||||||
: fcos ( x -- y )
|
: fcos ( x -- y )
|
||||||
"double" "libm" "cos" { "double" } alien-invoke ;
|
double "libm" "cos" { double } alien-invoke ;
|
||||||
|
|
||||||
: fsin ( x -- y )
|
: fsin ( x -- y )
|
||||||
"double" "libm" "sin" { "double" } alien-invoke ;
|
double "libm" "sin" { double } alien-invoke ;
|
||||||
|
|
||||||
: ftan ( x -- y )
|
: ftan ( x -- y )
|
||||||
"double" "libm" "tan" { "double" } alien-invoke ;
|
double "libm" "tan" { double } alien-invoke ;
|
||||||
|
|
||||||
: fcosh ( x -- y )
|
: fcosh ( x -- y )
|
||||||
"double" "libm" "cosh" { "double" } alien-invoke ;
|
double "libm" "cosh" { double } alien-invoke ;
|
||||||
|
|
||||||
: fsinh ( x -- y )
|
: fsinh ( x -- y )
|
||||||
"double" "libm" "sinh" { "double" } alien-invoke ;
|
double "libm" "sinh" { double } alien-invoke ;
|
||||||
|
|
||||||
: ftanh ( x -- y )
|
: ftanh ( x -- y )
|
||||||
"double" "libm" "tanh" { "double" } alien-invoke ;
|
double "libm" "tanh" { double } alien-invoke ;
|
||||||
|
|
||||||
: fexp ( x -- y )
|
: fexp ( x -- y )
|
||||||
"double" "libm" "exp" { "double" } alien-invoke ;
|
double "libm" "exp" { double } alien-invoke ;
|
||||||
|
|
||||||
: flog ( x -- y )
|
: flog ( x -- y )
|
||||||
"double" "libm" "log" { "double" } alien-invoke ;
|
double "libm" "log" { double } alien-invoke ;
|
||||||
|
|
||||||
: flog10 ( x -- y )
|
: flog10 ( x -- y )
|
||||||
"double" "libm" "log10" { "double" } alien-invoke ;
|
double "libm" "log10" { double } alien-invoke ;
|
||||||
|
|
||||||
: fpow ( x y -- z )
|
: fpow ( x y -- z )
|
||||||
"double" "libm" "pow" { "double" "double" } alien-invoke ;
|
double "libm" "pow" { double double } alien-invoke ;
|
||||||
|
|
||||||
: fsqrt ( x -- y )
|
: fsqrt ( x -- y )
|
||||||
"double" "libm" "sqrt" { "double" } alien-invoke ;
|
double "libm" "sqrt" { double } alien-invoke ;
|
||||||
|
|
||||||
! Windows doesn't have these...
|
! Windows doesn't have these...
|
||||||
: flog1+ ( x -- y )
|
: flog1+ ( x -- y )
|
||||||
"double" "libm" "log1p" { "double" } alien-invoke ;
|
double "libm" "log1p" { double } alien-invoke ;
|
||||||
|
|
||||||
: facosh ( x -- y )
|
: facosh ( x -- y )
|
||||||
"double" "libm" "acosh" { "double" } alien-invoke ;
|
double "libm" "acosh" { double } alien-invoke ;
|
||||||
|
|
||||||
: fasinh ( x -- y )
|
: fasinh ( x -- y )
|
||||||
"double" "libm" "asinh" { "double" } alien-invoke ;
|
double "libm" "asinh" { double } alien-invoke ;
|
||||||
|
|
||||||
: fatanh ( x -- y )
|
: fatanh ( x -- y )
|
||||||
"double" "libm" "atanh" { "double" } alien-invoke ;
|
double "libm" "atanh" { double } alien-invoke ;
|
||||||
|
|
|
@ -147,7 +147,7 @@ SYMBOL: fast-math-ops
|
||||||
: math-both-known? ( word left right -- ? )
|
: math-both-known? ( word left right -- ? )
|
||||||
3dup math-op
|
3dup math-op
|
||||||
[ 2drop 2drop t ]
|
[ 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 )
|
: (derived-ops) ( word assoc -- words )
|
||||||
swap '[ swap first _ eq? nip ] assoc-filter ;
|
swap '[ swap first _ eq? nip ] assoc-filter ;
|
||||||
|
|
|
@ -9,14 +9,16 @@ ERROR: bad-length got expected ;
|
||||||
|
|
||||||
FUNCTOR: define-simd-128 ( T -- )
|
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-CLASS ${T}-${N}
|
||||||
>A DEFINES >${A}
|
>A DEFINES >${A}
|
||||||
A{ DEFINES ${A}{
|
A{ DEFINES ${A}{
|
||||||
|
|
||||||
NTH [ T dup c-type-getter-boxer array-accessor ]
|
NTH [ T-TYPE dup c-type-getter-boxer array-accessor ]
|
||||||
SET-NTH [ T dup c-setter array-accessor ]
|
SET-NTH [ T-TYPE dup c-setter array-accessor ]
|
||||||
|
|
||||||
A-rep IS ${A}-rep
|
A-rep IS ${A}-rep
|
||||||
A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
|
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
|
! Synthesize 256-bit vectors from a pair of 128-bit vectors
|
||||||
FUNCTOR: define-simd-256 ( T -- )
|
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 / ]
|
N/2 [ N 2 / ]
|
||||||
A/2 IS ${T}-${N/2}
|
A/2 IS ${T}-${N/2}
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2009 Slava Pestov.
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
IN: math.vectors.simd.intrinsics
|
||||||
|
|
||||||
ERROR: bad-simd-call ;
|
ERROR: bad-simd-call ;
|
||||||
|
|
|
@ -5,6 +5,8 @@ kernel math math.functions math.vectors
|
||||||
math.vectors.simd.functor math.vectors.simd.intrinsics
|
math.vectors.simd.functor math.vectors.simd.intrinsics
|
||||||
math.vectors.specialization parser prettyprint.custom sequences
|
math.vectors.specialization parser prettyprint.custom sequences
|
||||||
sequences.private locals assocs words fry ;
|
sequences.private locals assocs words fry ;
|
||||||
|
FROM: alien.c-types => float ;
|
||||||
|
QUALIFIED-WITH: math m
|
||||||
IN: math.vectors.simd
|
IN: math.vectors.simd
|
||||||
|
|
||||||
<<
|
<<
|
||||||
|
@ -15,9 +17,9 @@ DEFER: float-8
|
||||||
DEFER: double-4
|
DEFER: double-4
|
||||||
|
|
||||||
"double" define-simd-128
|
"double" define-simd-128
|
||||||
"float" define-simd-128
|
"float" define-simd-128
|
||||||
"double" define-simd-256
|
"double" define-simd-256
|
||||||
"float" define-simd-256
|
"float" define-simd-256
|
||||||
|
|
||||||
>>
|
>>
|
||||||
|
|
||||||
|
@ -136,7 +138,7 @@ DEFER: double-4
|
||||||
|
|
||||||
PRIVATE>
|
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 ] }
|
{ 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 ] }
|
{ sum [ [ (simd-sum) ] float-4-v->n-op ] }
|
||||||
} simd-vector-words
|
} 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 ] }
|
{ 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 ] }
|
{ sum [ [ (simd-sum) ] double-2-v->n-op ] }
|
||||||
} simd-vector-words
|
} 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 ] }
|
{ 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 ] }
|
{ sum [ [ (simd-sum) ] [ + ] float-8-v->n-op ] }
|
||||||
} simd-vector-words
|
} 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 ] }
|
{ v- [ [ (simd-v-) ] double-4-vv->v-op ] }
|
||||||
{ v* [ [ (simd-v*) ] double-4-vv->v-op ] }
|
{ v* [ [ (simd-v*) ] double-4-vv->v-op ] }
|
||||||
|
|
|
@ -8,6 +8,7 @@ math.parser opengl.gl combinators combinators.smart arrays
|
||||||
sequences splitting words byte-arrays assocs vocabs
|
sequences splitting words byte-arrays assocs vocabs
|
||||||
colors colors.constants accessors generalizations locals fry
|
colors colors.constants accessors generalizations locals fry
|
||||||
specialized-arrays ;
|
specialized-arrays ;
|
||||||
|
FROM: alien.c-types => float ;
|
||||||
SPECIALIZED-ARRAY: float
|
SPECIALIZED-ARRAY: float
|
||||||
SPECIALIZED-ARRAY: uint
|
SPECIALIZED-ARRAY: uint
|
||||||
IN: opengl
|
IN: opengl
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Joe Groff.
|
! Copyright (C) 2008 Joe Groff.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel opengl.gl alien.c-types continuations namespaces
|
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
|
macros arrays io.encodings.ascii fry specialized-arrays
|
||||||
destructors accessors ;
|
destructors accessors ;
|
||||||
SPECIALIZED-ARRAY: uint
|
SPECIALIZED-ARRAY: uint
|
||||||
|
|
|
@ -5,8 +5,8 @@
|
||||||
!
|
!
|
||||||
! export LD_LIBRARY_PATH=/opt/local/lib
|
! export LD_LIBRARY_PATH=/opt/local/lib
|
||||||
|
|
||||||
USING: alien alien.syntax combinators kernel system
|
USING: alien alien.c-types alien.syntax combinators kernel system
|
||||||
alien.libraries ;
|
alien.libraries classes.struct ;
|
||||||
|
|
||||||
IN: openssl.libcrypto
|
IN: openssl.libcrypto
|
||||||
|
|
||||||
|
@ -20,35 +20,35 @@ IN: openssl.libcrypto
|
||||||
} cond
|
} cond
|
||||||
>>
|
>>
|
||||||
|
|
||||||
C-STRUCT: bio-method
|
STRUCT: bio-method
|
||||||
{ "int" "type" }
|
{ type int }
|
||||||
{ "void*" "name" }
|
{ name void* }
|
||||||
{ "void*" "bwrite" }
|
{ bwrite void* }
|
||||||
{ "void*" "bread" }
|
{ bread void* }
|
||||||
{ "void*" "bputs" }
|
{ bputs void* }
|
||||||
{ "void*" "bgets" }
|
{ bgets void* }
|
||||||
{ "void*" "ctrl" }
|
{ ctrl void* }
|
||||||
{ "void*" "create" }
|
{ create void* }
|
||||||
{ "void*" "destroy" }
|
{ destroy void* }
|
||||||
{ "void*" "callback-ctrl" } ;
|
{ callback-ctrl void* } ;
|
||||||
|
|
||||||
C-STRUCT: bio
|
STRUCT: bio
|
||||||
{ "void*" "method" }
|
{ method void* }
|
||||||
{ "void*" "callback" }
|
{ callback void* }
|
||||||
{ "void*" "cb-arg" }
|
{ cb-arg void* }
|
||||||
{ "int" "init" }
|
{ init int }
|
||||||
{ "int" "shutdown" }
|
{ shutdown int }
|
||||||
{ "int" "flags" }
|
{ flags int }
|
||||||
{ "int" "retry-reason" }
|
{ retry-reason int }
|
||||||
{ "int" "num" }
|
{ num int }
|
||||||
{ "void*" "ptr" }
|
{ ptr void* }
|
||||||
{ "void*" "next-bio" }
|
{ next-bio void* }
|
||||||
{ "void*" "prev-bio" }
|
{ prev-bio void* }
|
||||||
{ "int" "references" }
|
{ references int }
|
||||||
{ "ulong" "num-read" }
|
{ num-read ulong }
|
||||||
{ "ulong" "num-write" }
|
{ num-write ulong }
|
||||||
{ "void*" "crypto-ex-data-stack" }
|
{ crypto-ex-data-stack void* }
|
||||||
{ "int" "crypto-ex-data-dummy" } ;
|
{ crypto-ex-data-dummy int } ;
|
||||||
|
|
||||||
CONSTANT: BIO_NOCLOSE HEX: 00
|
CONSTANT: BIO_NOCLOSE HEX: 00
|
||||||
CONSTANT: BIO_CLOSE HEX: 01
|
CONSTANT: BIO_CLOSE HEX: 01
|
||||||
|
@ -103,11 +103,11 @@ FUNCTION: void* BIO_f_buffer ( ) ;
|
||||||
|
|
||||||
CONSTANT: EVP_MAX_MD_SIZE 64
|
CONSTANT: EVP_MAX_MD_SIZE 64
|
||||||
|
|
||||||
C-STRUCT: EVP_MD_CTX
|
STRUCT: EVP_MD_CTX
|
||||||
{ "EVP_MD*" "digest" }
|
{ digest EVP_MD* }
|
||||||
{ "ENGINE*" "engine" }
|
{ engine ENGINE* }
|
||||||
{ "ulong" "flags" }
|
{ flags ulong }
|
||||||
{ "void*" "md_data" } ;
|
{ md_data void* } ;
|
||||||
|
|
||||||
TYPEDEF: void* EVP_MD*
|
TYPEDEF: void* EVP_MD*
|
||||||
TYPEDEF: void* ENGINE*
|
TYPEDEF: void* ENGINE*
|
||||||
|
|
|
@ -19,6 +19,9 @@ HELP: length-limit
|
||||||
HELP: line-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." } ;
|
{ $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?
|
HELP: string-limit?
|
||||||
{ $var-description "Toggles whether printed strings are truncated to the margin." } ;
|
{ $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
Loading…
Reference in New Issue