diff --git a/Makefile b/Makefile index 18cb7d15c7..10efe34d34 100755 --- a/Makefile +++ b/Makefile @@ -18,6 +18,10 @@ else CFLAGS += -O3 endif +ifdef REENTRANT + CFLAGS += -DFACTOR_REENTRANT +endif + CFLAGS += $(SITE_CFLAGS) ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION) @@ -164,17 +168,17 @@ macosx.app: factor Factor.app/Contents/MacOS/factor $(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS) - $(LINKER) $(ENGINE) $(DLL_OBJS) - $(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ + $(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS) + $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS) $(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS) - $(LINKER) $(ENGINE) $(DLL_OBJS) - $(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ + $(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS) + $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS) $(TEST_LIBRARY): vm/ffi_test.o - $(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS) + $(TOOLCHAIN_PREFIX)$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS) clean: rm -f vm/*.o @@ -187,22 +191,22 @@ tags: etags vm/*.{cpp,hpp,mm,S,c} vm/resources.o: - $(WINDRES) vm/factor.rs vm/resources.o + $(TOOLCHAIN_PREFIX)$(WINDRES) vm/factor.rs vm/resources.o vm/ffi_test.o: vm/ffi_test.c - $(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $< + $(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $< .c.o: - $(CC) -c $(CFLAGS) -o $@ $< + $(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) -o $@ $< .cpp.o: - $(CPP) -c $(CFLAGS) -o $@ $< + $(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $< .S.o: - $(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $< + $(TOOLCHAIN_PREFIX)$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $< .mm.o: - $(CPP) -c $(CFLAGS) -o $@ $< + $(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $< .PHONY: factor tags clean diff --git a/basis/alien/arrays/arrays-docs.factor b/basis/alien/arrays/arrays-docs.factor index db4a7bf595..74174485fe 100755 --- a/basis/alien/arrays/arrays-docs.factor +++ b/basis/alien/arrays/arrays-docs.factor @@ -1,5 +1,5 @@ +USING: help.syntax help.markup byte-arrays alien.c-types alien.data ; IN: alien.arrays -USING: help.syntax help.markup byte-arrays alien.c-types ; ARTICLE: "c-arrays" "C arrays" "C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "." diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 64827ec139..ee75d22c2c 100755 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.strings alien.c-types alien.accessors alien.structs -arrays words sequences math kernel namespaces fry libc cpu.architecture +USING: alien alien.strings alien.c-types alien.data alien.accessors +arrays words sequences math kernel namespaces fry cpu.architecture io.encodings.utf8 accessors ; IN: alien.arrays -UNION: value-type array struct-type ; +INSTANCE: array value-type M: array c-type ; @@ -22,15 +22,15 @@ M: array c-type-align first c-type-align ; M: array c-type-stack-align? drop f ; -M: array unbox-parameter drop "void*" unbox-parameter ; +M: array unbox-parameter drop void* unbox-parameter ; -M: array unbox-return drop "void*" unbox-return ; +M: array unbox-return drop void* unbox-return ; -M: array box-parameter drop "void*" box-parameter ; +M: array box-parameter drop void* box-parameter ; -M: array box-return drop "void*" box-return ; +M: array box-return drop void* box-return ; -M: array stack-size drop "void*" stack-size ; +M: array stack-size drop void* stack-size ; M: array c-type-boxer-quot unclip @@ -40,17 +40,8 @@ M: array c-type-boxer-quot M: array c-type-unboxer-quot drop [ >c-ptr ] ; -M: value-type c-type-rep drop int-rep ; - -M: value-type c-type-getter - drop [ swap ] ; - -M: value-type c-type-setter ( type -- quot ) - [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri - '[ @ swap @ _ memcpy ] ; - PREDICATE: string-type < pair - first2 [ "char*" = ] [ word? ] bi* and ; + first2 [ char* = ] [ word? ] bi* and ; M: string-type c-type ; @@ -59,37 +50,37 @@ M: string-type c-type-class drop object ; M: string-type c-type-boxed-class drop object ; M: string-type heap-size - drop "void*" heap-size ; + drop void* heap-size ; M: string-type c-type-align - drop "void*" c-type-align ; + drop void* c-type-align ; M: string-type c-type-stack-align? - drop "void*" c-type-stack-align? ; + drop void* c-type-stack-align? ; M: string-type unbox-parameter - drop "void*" unbox-parameter ; + drop void* unbox-parameter ; M: string-type unbox-return - drop "void*" unbox-return ; + drop void* unbox-return ; M: string-type box-parameter - drop "void*" box-parameter ; + drop void* box-parameter ; M: string-type box-return - drop "void*" box-return ; + drop void* box-return ; M: string-type stack-size - drop "void*" stack-size ; + drop void* stack-size ; M: string-type c-type-rep drop int-rep ; M: string-type c-type-boxer - drop "void*" c-type-boxer ; + drop void* c-type-boxer ; M: string-type c-type-unboxer - drop "void*" c-type-unboxer ; + drop void* c-type-unboxer ; M: string-type c-type-boxer-quot second '[ _ alien>string ] ; @@ -103,6 +94,8 @@ M: string-type c-type-getter M: string-type c-type-setter drop [ set-alien-cell ] ; -{ "char*" utf8 } "char*" typedef -"char*" "uchar*" typedef +{ char* utf8 } char* typedef +char* uchar* typedef +char char* "pointer-c-type" set-word-prop +uchar uchar* "pointer-c-type" set-word-prop diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index d9e1f7124a..390477dcac 100755 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -1,7 +1,27 @@ +USING: alien alien.complex help.syntax help.markup libc kernel.private +byte-arrays strings hashtables alien.syntax alien.strings sequences +io.encodings.string debugger destructors vocabs.loader +classes.struct ; +QUALIFIED: math IN: alien.c-types -USING: alien help.syntax help.markup libc kernel.private -byte-arrays math strings hashtables alien.syntax alien.strings sequences -io.encodings.string debugger destructors vocabs.loader ; + +HELP: byte-length +{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } } +{ $contract "Outputs the size of the byte array, struct, or specialized array data in bytes." } ; + +HELP: heap-size +{ $values { "type" string } { "size" math:integer } } +{ $description "Outputs the number of bytes needed for a heap-allocated value of this C type." } +{ $examples + "On a 32-bit system, you will get the following output:" + { $unchecked-example "USE: alien\n\"void*\" heap-size ." "4" } +} +{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; + +HELP: stack-size +{ $values { "type" string } { "size" math:integer } } +{ $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." } +{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; HELP: { $values { "type" hashtable } } @@ -20,24 +40,6 @@ HELP: c-type { $description "Looks up a C type by name." } { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; -HELP: heap-size -{ $values { "type" string } { "size" integer } } -{ $description "Outputs the number of bytes needed for a heap-allocated value of this C type." } -{ $examples - "On a 32-bit system, you will get the following output:" - { $unchecked-example "USE: alien\n\"void*\" heap-size ." "4" } -} -{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; - -HELP: stack-size -{ $values { "type" string } { "size" integer } } -{ $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." } -{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; - -HELP: byte-length -{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } } -{ $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ; - HELP: c-getter { $values { "name" string } { "quot" { $quotation "( c-ptr n -- obj )" } } } { $description "Outputs a quotation which reads values of this C type from a C structure." } @@ -48,51 +50,8 @@ HELP: c-setter { $description "Outputs a quotation which writes values of this C type to a C structure." } { $errors "Throws an error if the type does not exist." } ; -HELP: -{ $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: -{ $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." } ; - -{ 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 } "." } -{ $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." } ; - -{ malloc-array } related-words - HELP: box-parameter -{ $values { "n" integer } { "ctype" string } } +{ $values { "n" math:integer } { "ctype" string } } { $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." } { $notes "This is an internal word used by the compiler when compiling callbacks." } ; @@ -116,47 +75,41 @@ HELP: define-out { $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." } { $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ; -{ string>alien alien>string malloc-string } related-words +HELP: char +{ $description "This C type represents a one-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ; +HELP: uchar +{ $description "This C type represents a one-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ; +HELP: short +{ $description "This C type represents a two-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to sixteen bits; output values will be returned as " { $link math:fixnum } "s." } ; +HELP: ushort +{ $description "This C type represents a two-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to sixteen bits; output values will be returned as " { $link math:fixnum } "s." } ; +HELP: int +{ $description "This C type represents a four-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to 32 bits; output values will be returned as " { $link math:integer } "s." } ; +HELP: uint +{ $description "This C type represents a four-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 32 bits; output values will be returned as " { $link math:integer } "s." } ; +HELP: long +{ $description "This C type represents a four- or eight-byte signed integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ; +HELP: ulong +{ $description "This C type represents a four- or eight-byte unsigned integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ; +HELP: longlong +{ $description "This C type represents an eight-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ; +HELP: ulonglong +{ $description "This C type represents an eight-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ; +HELP: void +{ $description "This symbol is not a valid C type, but it can be used as the return type for a " { $link POSTPONE: FUNCTION: } " or " { $link POSTPONE: CALLBACK: } " definition, or an " { $link alien-invoke } " or " { $link alien-callback } " call." } ; +HELP: void* +{ $description "This C type represents a pointer to C memory. " { $link byte-array } " and " { $link alien } " values can be passed as inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. Output values are returned as " { $link alien } "s." } ; +HELP: char* +{ $description "This C type represents a pointer to a C string. See " { $link "c-strings" } " for details about using strings with the FFI." } ; +HELP: float +{ $description "This C type represents a single-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s and demoted to single-precision; output values will be returned as Factor " { $link math:float } "s." } ; +HELP: double +{ $description "This C type represents a double-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s; output values will be returned as Factor " { $link math:float } "s." } ; +HELP: complex-float +{ $description "This C type represents a single-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link math:complex } " objects into a single-precision complex float type; output values will be returned as Factor " { $link math:complex } " objects." } ; +HELP: complex-double +{ $description "This C type represents a double-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link math:complex } " objects into a double-precision complex float type; output values will be returned as Factor " { $link math:complex } " objects." } ; -HELP: malloc-string -{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } } -{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." } -{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } -{ $errors "Throws an error if one of the following conditions occurs:" - { $list - "the string contains null code points" - "the string contains characters not representable using the encoding specified" - "memory allocation fails" - } -} ; - -HELP: require-c-array -{ $values { "c-type" "a C type" } } -{ $description "Generates a specialized array of " { $snippet "c-type" } " using the " { $link } " or " { $link } " 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: -{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } } -{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." } -{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } ; - -ARTICLE: "c-strings" "C strings" -"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors." -$nl -"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function." -$nl -"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown." -$nl -"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array." -$nl -"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:" -{ $subsection string>alien } -{ $subsection malloc-string } -"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches." -$nl -"A word to read strings from arbitrary addresses:" -{ $subsection alien>string } -"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ; ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector" "The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data." @@ -205,90 +158,32 @@ $nl "Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link } " and " { $link *void* } " may be used." ; ARTICLE: "c-types-specs" "C type specifiers" -"C types are identified by strings, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words, as well as " { $link POSTPONE: C-STRUCT: } ", " { $link POSTPONE: C-UNION: } " and " { $link POSTPONE: TYPEDEF: } "." +"C types are identified by special words, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words. New C types can be defined by the words " { $link POSTPONE: STRUCT: } ", " { $link POSTPONE: UNION-STRUCT: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: TYPEDEF: } "." $nl "The following numerical types are available; a " { $snippet "u" } " prefix denotes an unsigned type:" { $table { "C type" "Notes" } - { { $snippet "char" } "always 1 byte" } - { { $snippet "uchar" } { } } - { { $snippet "short" } "always 2 bytes" } - { { $snippet "ushort" } { } } - { { $snippet "int" } "always 4 bytes" } - { { $snippet "uint" } { } } - { { $snippet "long" } { "same size as CPU word size and " { $snippet "void*" } ", except on 64-bit Windows, where it is 4 bytes" } } - { { $snippet "ulong" } { } } - { { $snippet "longlong" } "always 8 bytes" } - { { $snippet "ulonglong" } { } } - { { $snippet "float" } { } } - { { $snippet "double" } { "same format as " { $link float } " objects" } } - { { $snippet "complex-float" } { "C99 " { $snippet "complex float" } " type, converted to and from " { $link complex } " values" } } - { { $snippet "complex-double" } { "C99 " { $snippet "complex double" } " type, converted to and from " { $link complex } " values" } } + { { $link char } "always 1 byte" } + { { $link uchar } { } } + { { $link short } "always 2 bytes" } + { { $link ushort } { } } + { { $link int } "always 4 bytes" } + { { $link uint } { } } + { { $link long } { "same size as CPU word size and " { $link void* } ", except on 64-bit Windows, where it is 4 bytes" } } + { { $link ulong } { } } + { { $link longlong } "always 8 bytes" } + { { $link ulonglong } { } } + { { $link float } { "single-precision float (not the same as Factor's " { $link math:float } " class!)" } } + { { $link double } { "double-precision float (the same format as Factor's " { $link math:float } " objects)" } } + { { $link complex-float } { "C99 or Fortran " { $snippet "complex float" } " type, converted to and from Factor " { $link math:complex } " values" } } + { { $link complex-double } { "C99 or Fortran " { $snippet "complex double" } " type, converted to and from Factor " { $link math:complex } " values" } } } "When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision." $nl -"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $snippet "void*" } ", which denotes a generic pointer; " { $snippet "void" } " by itself is not a valid C type specifier. With the exception of strings (see " { $link "c-strings" } "), all pointer types are identical to " { $snippet "void*" } " as far as the C library interface is concerned." +"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $link void* } ", which denotes a generic pointer; " { $link void } " by itself is not a valid C type specifier. With the exception of strings (see " { $link "c-strings" } "), all pointer types are identical to " { $snippet "void*" } " as far as the C library interface is concerned." $nl "Fixed-size array types are supported; the syntax consists of a C type name followed by dimension sizes in brackets; the following denotes a 3 by 4 array of integers:" { $code "int[3][4]" } "Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however when used as function parameters they behave exactly like pointers and thus the dimensions only serve as documentation." $nl "Structure and union types are specified by the name of the structure or union." ; - -ARTICLE: "c-byte-arrays" "Passing data in byte arrays" -"Instances of the " { $link byte-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array." -$nl -"Byte arrays can be allocated directly with a byte count using the " { $link } " 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 } -{ $subsection } -{ $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" } ; diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index bfeff5f1de..792e7d416a 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -43,7 +43,7 @@ TYPEDEF: int* MyIntArray TYPEDEF: uchar* MyLPBYTE -[ t ] [ { "char*" utf8 } c-type "MyLPBYTE" c-type = ] unit-test +[ t ] [ { char* utf8 } c-type "MyLPBYTE" c-type = ] unit-test [ 0 B{ 1 2 3 4 } diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index b177ab35d4..fa27e29c04 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -1,18 +1,27 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: byte-arrays arrays assocs kernel kernel.private libc math +USING: byte-arrays arrays assocs kernel kernel.private math namespaces make parser sequences strings words splitting math.parser cpu.architecture alien alien.accessors alien.strings quotations layouts system compiler.units io io.files io.encodings.binary io.streams.memory accessors combinators effects continuations fry -classes vocabs vocabs.loader ; +classes vocabs vocabs.loader words.symbol ; +QUALIFIED: math IN: alien.c-types +SYMBOLS: + char uchar + short ushort + int uint + long ulong + longlong ulonglong + float double + void* bool + void ; + DEFER: DEFER: *char -: little-endian? ( -- ? ) 1 *char 1 = ; foldable - TUPLE: abstract-c-type { class class initial: object } { boxed-class class initial: object } @@ -40,142 +49,124 @@ global [ ERROR: no-c-type name ; -: (c-type) ( name -- type/f ) - c-types get-global at dup [ - dup string? [ (c-type) ] when - ] when ; +PREDICATE: c-type-word < word + "c-type" word-prop ; + +UNION: c-type-name string c-type-word ; ! C type protocol GENERIC: c-type ( name -- type ) foldable -: resolve-pointer-type ( name -- name ) - c-types get at dup string? - [ "*" append ] [ drop "void*" ] if - c-type ; +GENERIC: resolve-pointer-type ( name -- c-type ) + +M: word resolve-pointer-type + dup "pointer-c-type" word-prop + [ ] [ drop void* ] ?if ; +M: string resolve-pointer-type + dup "*" append dup c-types get at + [ nip ] [ + drop + c-types get at dup c-type-name? + [ resolve-pointer-type ] [ drop void* ] if + ] if ; : resolve-typedef ( name -- type ) - dup string? [ c-type ] when ; + dup c-type-name? [ c-type ] when ; -: parse-array-type ( name -- array ) +: parse-array-type ( name -- dims type ) "[" split unclip - [ [ "]" ?tail drop string>number ] map ] dip prefix ; + [ [ "]" ?tail drop string>number ] map ] dip ; M: string c-type ( name -- type ) CHAR: ] over member? [ - parse-array-type + parse-array-type prefix ] [ - dup c-types get at [ - resolve-typedef - ] [ + dup c-types get at [ ] [ "*" ?tail [ resolve-pointer-type ] [ no-c-type ] if - ] ?if + ] ?if resolve-typedef ] if ; +M: word c-type + "c-type" word-prop resolve-typedef ; + +: void? ( c-type -- ? ) + { void "void" } member? ; + +GENERIC: c-struct? ( type -- ? ) + +M: object c-struct? + drop f ; +M: c-type-name c-struct? + dup void? [ drop f ] [ c-type c-struct? ] if ; + ! These words being foldable means that words need to be ! recompiled if a C type is redefined. Even so, folding the ! size facilitates some optimizations. -GENERIC: heap-size ( type -- size ) foldable - -M: string heap-size c-type heap-size ; - -M: abstract-c-type heap-size size>> ; - -GENERIC: require-c-array ( c-type -- ) - -M: array require-c-array first require-c-array ; - -GENERIC: c-array-constructor ( c-type -- word ) - -GENERIC: c-(array)-constructor ( c-type -- word ) - -GENERIC: c-direct-array-constructor ( c-type -- word ) - -GENERIC: ( len c-type -- array ) - -M: string - 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: ( alien len c-type -- array ) - -M: string - c-direct-array-constructor execute( alien len -- array ) ; inline - -: malloc-array ( n type -- alien ) - [ heap-size calloc ] [ ] 2bi ; inline - -: (malloc-array) ( n type -- alien ) - [ heap-size * malloc ] [ ] 2bi ; inline - GENERIC: c-type-class ( name -- class ) M: abstract-c-type c-type-class class>> ; -M: string c-type-class c-type c-type-class ; +M: c-type-name c-type-class c-type c-type-class ; GENERIC: c-type-boxed-class ( name -- class ) M: abstract-c-type c-type-boxed-class boxed-class>> ; -M: string c-type-boxed-class c-type c-type-boxed-class ; +M: c-type-name c-type-boxed-class c-type c-type-boxed-class ; GENERIC: c-type-boxer ( name -- boxer ) M: c-type c-type-boxer boxer>> ; -M: string c-type-boxer c-type c-type-boxer ; +M: c-type-name c-type-boxer c-type c-type-boxer ; GENERIC: c-type-boxer-quot ( name -- quot ) M: abstract-c-type c-type-boxer-quot boxer-quot>> ; -M: string c-type-boxer-quot c-type c-type-boxer-quot ; +M: c-type-name c-type-boxer-quot c-type c-type-boxer-quot ; GENERIC: c-type-unboxer ( name -- boxer ) M: c-type c-type-unboxer unboxer>> ; -M: string c-type-unboxer c-type c-type-unboxer ; +M: c-type-name c-type-unboxer c-type c-type-unboxer ; GENERIC: c-type-unboxer-quot ( name -- quot ) M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ; -M: string c-type-unboxer-quot c-type c-type-unboxer-quot ; +M: c-type-name c-type-unboxer-quot c-type c-type-unboxer-quot ; GENERIC: c-type-rep ( name -- rep ) M: c-type c-type-rep rep>> ; -M: string c-type-rep c-type c-type-rep ; +M: c-type-name c-type-rep c-type c-type-rep ; GENERIC: c-type-getter ( name -- quot ) M: c-type c-type-getter getter>> ; -M: string c-type-getter c-type c-type-getter ; +M: c-type-name c-type-getter c-type c-type-getter ; GENERIC: c-type-setter ( name -- quot ) M: c-type c-type-setter setter>> ; -M: string c-type-setter c-type c-type-setter ; +M: c-type-name c-type-setter c-type c-type-setter ; GENERIC: c-type-align ( name -- n ) M: abstract-c-type c-type-align align>> ; -M: string c-type-align c-type c-type-align ; +M: c-type-name c-type-align c-type c-type-align ; GENERIC: c-type-stack-align? ( name -- ? ) M: c-type c-type-stack-align? stack-align?>> ; -M: string c-type-stack-align? c-type c-type-stack-align? ; +M: c-type-name c-type-stack-align? c-type c-type-stack-align? ; : c-type-box ( n type -- ) [ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi @@ -189,29 +180,37 @@ GENERIC: box-parameter ( n ctype -- ) M: c-type box-parameter c-type-box ; -M: string box-parameter c-type box-parameter ; +M: c-type-name box-parameter c-type box-parameter ; GENERIC: box-return ( ctype -- ) M: c-type box-return f swap c-type-box ; -M: string box-return c-type box-return ; +M: c-type-name box-return c-type box-return ; GENERIC: unbox-parameter ( n ctype -- ) M: c-type unbox-parameter c-type-unbox ; -M: string unbox-parameter c-type unbox-parameter ; +M: c-type-name unbox-parameter c-type unbox-parameter ; GENERIC: unbox-return ( ctype -- ) M: c-type unbox-return f swap c-type-unbox ; -M: string unbox-return c-type unbox-return ; +M: c-type-name unbox-return c-type unbox-return ; + +: little-endian? ( -- ? ) 1 *char 1 = ; foldable + +GENERIC: heap-size ( type -- size ) foldable + +M: c-type-name heap-size c-type heap-size ; + +M: abstract-c-type heap-size size>> ; GENERIC: stack-size ( type -- size ) foldable -M: string stack-size c-type stack-size ; +M: c-type-name stack-size c-type stack-size ; M: c-type stack-size size>> cell align ; @@ -221,6 +220,8 @@ M: byte-array byte-length length ; inline M: f byte-length drop 0 ; inline +MIXIN: value-type + : c-getter ( name -- quot ) c-type-getter [ [ "Cannot read struct fields with this type" throw ] @@ -234,42 +235,29 @@ M: f byte-length drop 0 ; inline [ "Cannot write struct fields with this type" throw ] ] unless* ; -: ( type -- array ) - heap-size ; 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 - swap memory>byte-array - ] [ [ + ] change-index drop ] 2bi ; - -: byte-array>memory ( byte-array base -- ) - swap dup byte-length memcpy ; inline - : array-accessor ( type quot -- def ) [ \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi* ] [ ] make ; -: typedef ( old new -- ) c-types get set-at ; +GENERIC: typedef ( old new -- ) + +PREDICATE: typedef-word < c-type-word + "c-type" word-prop c-type-name? ; + +M: string typedef ( old new -- ) c-types get set-at ; +M: word typedef ( old new -- ) + { + [ nip define-symbol ] + [ name>> typedef ] + [ swap "c-type" set-word-prop ] + [ + swap dup c-type-name? [ + resolve-pointer-type + "pointer-c-type" set-word-prop + ] [ 2drop ] if + ] + } 2cleave ; TUPLE: long-long-type < c-type ; @@ -294,36 +282,33 @@ M: long-long-type box-return ( type -- ) : define-out ( name -- ) [ "alien.c-types" constructor-word ] - [ dup c-setter '[ _ [ 0 @ ] keep ] ] bi + [ dup c-setter '[ _ heap-size [ 0 @ ] keep ] ] bi (( value -- c-ptr )) define-inline ; -: >c-bool ( ? -- int ) 1 0 ? ; inline - -: c-bool> ( int -- ? ) 0 = not ; inline - : define-primitive-type ( type name -- ) [ typedef ] - [ define-deref ] - [ define-out ] + [ name>> define-deref ] + [ name>> define-out ] tri ; -: malloc-file-contents ( path -- alien len ) - binary file-contents [ malloc-byte-array ] [ length ] bi ; - : if-void ( type true false -- ) - pick "void" = [ drop nip call ] [ nip call ] if ; inline + pick void? [ drop nip call ] [ nip call ] if ; inline CONSTANT: primitive-types { - "char" "uchar" - "short" "ushort" - "int" "uint" - "long" "ulong" - "longlong" "ulonglong" - "float" "double" - "void*" "bool" + char uchar + short ushort + int uint + long ulong + longlong ulonglong + float double + void* bool } +SYMBOLS: + ptrdiff_t intptr_t size_t + char* uchar* ; + [ c-ptr >>class @@ -335,7 +320,7 @@ CONSTANT: primitive-types [ >c-ptr ] >>unboxer-quot "box_alien" >>boxer "alien_offset" >>unboxer - "void*" define-primitive-type + \ void* define-primitive-type integer >>class @@ -346,7 +331,7 @@ CONSTANT: primitive-types 8 >>align "box_signed_8" >>boxer "to_signed_8" >>unboxer - "longlong" define-primitive-type + \ longlong define-primitive-type integer >>class @@ -357,7 +342,7 @@ CONSTANT: primitive-types 8 >>align "box_unsigned_8" >>boxer "to_unsigned_8" >>unboxer - "ulonglong" define-primitive-type + \ ulonglong define-primitive-type integer >>class @@ -368,7 +353,7 @@ CONSTANT: primitive-types bootstrap-cell >>align "box_signed_cell" >>boxer "to_fixnum" >>unboxer - "long" define-primitive-type + \ long define-primitive-type integer >>class @@ -379,7 +364,7 @@ CONSTANT: primitive-types bootstrap-cell >>align "box_unsigned_cell" >>boxer "to_cell" >>unboxer - "ulong" define-primitive-type + \ ulong define-primitive-type integer >>class @@ -390,7 +375,7 @@ CONSTANT: primitive-types 4 >>align "box_signed_4" >>boxer "to_fixnum" >>unboxer - "int" define-primitive-type + \ int define-primitive-type integer >>class @@ -401,7 +386,7 @@ CONSTANT: primitive-types 4 >>align "box_unsigned_4" >>boxer "to_cell" >>unboxer - "uint" define-primitive-type + \ uint define-primitive-type fixnum >>class @@ -412,7 +397,7 @@ CONSTANT: primitive-types 2 >>align "box_signed_2" >>boxer "to_fixnum" >>unboxer - "short" define-primitive-type + \ short define-primitive-type fixnum >>class @@ -423,7 +408,7 @@ CONSTANT: primitive-types 2 >>align "box_unsigned_2" >>boxer "to_cell" >>unboxer - "ushort" define-primitive-type + \ ushort define-primitive-type fixnum >>class @@ -434,7 +419,7 @@ CONSTANT: primitive-types 1 >>align "box_signed_1" >>boxer "to_fixnum" >>unboxer - "char" define-primitive-type + \ char define-primitive-type fixnum >>class @@ -445,20 +430,20 @@ CONSTANT: primitive-types 1 >>align "box_unsigned_1" >>boxer "to_cell" >>unboxer - "uchar" define-primitive-type + \ uchar define-primitive-type - [ alien-unsigned-1 c-bool> ] >>getter - [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter + [ alien-unsigned-1 0 = not ] >>getter + [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter 1 >>size 1 >>align "box_boolean" >>boxer "to_boolean" >>unboxer - "bool" define-primitive-type + \ bool define-primitive-type - float >>class - float >>boxed-class + math:float >>class + math:float >>boxed-class [ alien-float ] >>getter [ [ >float ] 2dip set-alien-float ] >>setter 4 >>size @@ -467,11 +452,11 @@ CONSTANT: primitive-types "to_float" >>unboxer float-rep >>rep [ >float ] >>unboxer-quot - "float" define-primitive-type + \ float define-primitive-type - float >>class - float >>boxed-class + math:float >>class + math:float >>boxed-class [ alien-double ] >>getter [ [ >float ] 2dip set-alien-double ] >>setter 8 >>size @@ -480,10 +465,10 @@ CONSTANT: primitive-types "to_double" >>unboxer double-rep >>rep [ >float ] >>unboxer-quot - "double" define-primitive-type + \ double define-primitive-type - "long" "ptrdiff_t" typedef - "long" "intptr_t" typedef - "ulong" "size_t" typedef + \ long \ ptrdiff_t typedef + \ long \ intptr_t typedef + \ ulong \ size_t typedef ] with-compilation-unit diff --git a/basis/alien/complex/complex.factor b/basis/alien/complex/complex.factor index b0229358d1..65c4095e25 100644 --- a/basis/alien/complex/complex.factor +++ b/basis/alien/complex/complex.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.structs alien.complex.functor accessors +USING: alien.c-types alien.complex.functor accessors sequences kernel ; IN: alien.complex diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index b1f9c2be85..1faa64be61 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.structs alien.c-types classes.struct math +USING: accessors alien alien.c-types classes.struct math math.functions sequences arrays kernel functors vocabs.parser namespaces quotations ; IN: alien.complex.functor diff --git a/basis/alien/data/authors.txt b/basis/alien/data/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/alien/data/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/alien/data/data-docs.factor b/basis/alien/data/data-docs.factor new file mode 100644 index 0000000000..685639beed --- /dev/null +++ b/basis/alien/data/data-docs.factor @@ -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: +{ $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: +{ $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." } ; + +{ 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 } "." } +{ $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." } ; + +{ 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 } " 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 } +{ $subsection } +{ $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 } " or " { $link } " 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: +{ $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 } "." ; + diff --git a/basis/alien/data/data.factor b/basis/alien/data/data.factor new file mode 100644 index 0000000000..1f2c5160e1 --- /dev/null +++ b/basis/alien/data/data.factor @@ -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: ( len c-type -- array ) + +M: c-type-name + 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: ( alien len c-type -- array ) + +M: c-type-name + c-direct-array-constructor execute( alien len -- array ) ; inline + +: malloc-array ( n type -- alien ) + [ heap-size calloc ] [ ] 2bi ; inline + +: (malloc-array) ( n type -- alien ) + [ heap-size * malloc ] [ ] 2bi ; inline + +: ( type -- array ) + heap-size ; 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 + 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 ] ; + +M: value-type c-type-setter ( type -- quot ) + [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri + '[ @ swap @ _ memcpy ] ; + diff --git a/basis/alien/data/summary.txt b/basis/alien/data/summary.txt new file mode 100644 index 0000000000..addddb2da4 --- /dev/null +++ b/basis/alien/data/summary.txt @@ -0,0 +1 @@ +Words for allocating objects and arrays of C types diff --git a/basis/alien/fortran/fortran-docs.factor b/basis/alien/fortran/fortran-docs.factor index 8027020c75..7778500bf1 100644 --- a/basis/alien/fortran/fortran-docs.factor +++ b/basis/alien/fortran/fortran-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Joe Groff ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel quotations sequences strings words.symbol ; +USING: help.markup help.syntax kernel quotations sequences strings words.symbol classes.struct ; QUALIFIED-WITH: alien.syntax c IN: alien.fortran @@ -25,7 +25,7 @@ ARTICLE: "alien.fortran-types" "Fortran types" { { $snippet "DOUBLE-COMPLEX" } " specifies a double-precision floating-point complex value. The alias " { $snippet "COMPLEX*16" } " is also recognized." } { { $snippet "CHARACTER(n)" } " specifies a character string of length " { $snippet "n" } ". The Fortran 77 syntax " { $snippet "CHARACTER*n" } " is also recognized." } { "Fortran arrays can be specified by suffixing a comma-separated set of dimensions in parentheses, e.g. " { $snippet "REAL(2,3,4)" } ". Arrays of unspecified length can be specified using " { $snippet "*" } " as a dimension. Arrays are passed in as flat " { $link "specialized-arrays" } "." } - { "Fortran records defined by " { $link POSTPONE: RECORD: } " and C structs defined by " { $link POSTPONE: c:C-STRUCT: } " are also supported as parameter and return types." } + { "Struct classes defined by " { $link POSTPONE: STRUCT: } " are also supported as parameter and return types." } } "When declaring the parameters of Fortran functions, an output argument can be specified by prefixing an exclamation point to the type name. This will cause the function word to leave the final value of the parameter on the stack." ; @@ -42,10 +42,6 @@ HELP: LIBRARY: { $values { "name" "a logical library name" } } { $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions. The given library name must have been opened with a previous call to " { $link add-fortran-library } "." } ; -HELP: RECORD: -{ $syntax "RECORD: NAME { \"TYPE\" \"SLOT\" } ... ;" } -{ $description "Defines a Fortran record type with the given slots. The record is defined as the corresponding C struct and can be used as a type for subsequent Fortran or C function declarations." } ; - HELP: add-fortran-library { $values { "name" string } { "soname" string } { "fortran-abi" symbol } } { $description "Opens the shared library in the file specified by " { $snippet "soname" } " under the logical name " { $snippet "name" } " so that it may be used in subsequent " { $link POSTPONE: LIBRARY: } " and " { $link fortran-invoke } " calls. Functions and subroutines from the library will be defined using the specified " { $snippet "fortran-abi" } ", which must be one of the supported " { $link "alien.fortran-abis" } "." } @@ -66,7 +62,6 @@ ARTICLE: "alien.fortran" "Fortran FFI" { $subsection POSTPONE: LIBRARY: } { $subsection POSTPONE: FUNCTION: } { $subsection POSTPONE: SUBROUTINE: } -{ $subsection POSTPONE: RECORD: } { $subsection fortran-invoke } ; diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 177d1077c2..238207f192 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -1,17 +1,17 @@ ! (c) 2009 Joe Groff, see BSD license USING: accessors alien alien.c-types alien.complex -alien.fortran alien.fortran.private alien.strings alien.structs -arrays assocs byte-arrays combinators fry +alien.data alien.fortran alien.fortran.private alien.strings +classes.struct arrays assocs byte-arrays combinators fry generalizations io.encodings.ascii kernel macros macros.expander namespaces sequences shuffle tools.test ; IN: alien.fortran.tests << intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >> LIBRARY: (alien.fortran-tests) -RECORD: FORTRAN_TEST_RECORD - { "INTEGER" "FOO" } - { "REAL(2)" "BAR" } - { "CHARACTER*4" "BAS" } ; +STRUCT: FORTRAN_TEST_RECORD + { FOO int } + { BAR double[2] } + { BAS char[4] } ; intel-unix-abi fortran-abi [ @@ -168,29 +168,6 @@ intel-unix-abi fortran-abi [ [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ] unit-test - ! fortran-record>c-struct - - [ { - { "double" "ex" } - { "float" "wye" } - { "int" "zee" } - { "char[20]" "woo" } - } ] [ - { - { "DOUBLE-PRECISION" "EX" } - { "REAL" "WYE" } - { "INTEGER" "ZEE" } - { "CHARACTER(20)" "WOO" } - } fortran-record>c-struct - ] unit-test - - ! RECORD: - - [ 16 ] [ "fortran_test_record" heap-size ] unit-test - [ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test - [ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test - [ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test - ! (fortran-invoke) [ [ diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 013c4d6f6a..bf8721b549 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -1,6 +1,6 @@ ! (c) 2009 Joe Groff, see BSD license -USING: accessors alien alien.c-types alien.complex alien.parser -alien.strings alien.structs alien.syntax arrays ascii assocs +USING: accessors alien alien.c-types alien.complex alien.data grouping +alien.strings alien.syntax arrays ascii assocs byte-arrays combinators combinators.short-circuit fry generalizations kernel lexer macros math math.parser namespaces parser sequences splitting stack-checker vectors vocabs.parser words locals @@ -415,14 +415,6 @@ PRIVATE> : fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args ) [ fortran-ret-type>c-type ] [ fortran-arg-types>c-types ] bi* append ; -: fortran-record>c-struct ( record -- struct ) - [ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ; - -: define-fortran-record ( name vocab fields -- ) - [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ; - -SYNTAX: RECORD: scan current-vocab parse-definition define-fortran-record ; - : set-fortran-abi ( library -- ) library-fortran-abis get-global at fortran-abi set ; @@ -437,6 +429,11 @@ SYNTAX: RECORD: scan current-vocab parse-definition define-fortran-record ; MACRO: fortran-invoke ( return library function parameters -- ) { [ 2drop nip set-fortran-abi ] [ (fortran-invoke) ] } 4 ncleave ; +: parse-arglist ( parameters return -- types effect ) + [ 2 group unzip [ "," ?tail drop ] map ] + [ [ { } ] [ 1array ] if-void ] + bi* ; + :: define-fortran-function ( return library function parameters -- ) function create-in dup reset-generic return library function parameters return [ "void" ] unless* parse-arglist diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 19ab08c03c..d58f9a315c 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -1,16 +1,42 @@ ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays assocs effects grouping kernel -parser sequences splitting words fry locals lexer namespaces -summary math ; +USING: accessors alien alien.c-types arrays assocs +combinators combinators.short-circuit effects grouping +kernel parser sequences splitting words fry locals lexer +namespaces summary math vocabs.parser ; IN: alien.parser +: parse-c-type-name ( name -- word/string ) + [ search ] keep or ; + +: parse-c-type ( string -- array ) + { + { [ dup "void" = ] [ drop void ] } + { [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] } + { [ dup search c-type-word? ] [ parse-c-type-name ] } + { [ dup c-types get at ] [ ] } + { [ "*" ?tail ] [ parse-c-type-name resolve-pointer-type ] } + [ no-c-type ] + } cond ; + +: scan-c-type ( -- c-type ) + scan dup "{" = + [ drop \ } parse-until >array ] + [ parse-c-type ] if ; + +: reset-c-type ( word -- ) + { "c-type" "pointer-c-type" "callback-effect" "callback-abi" } reset-props ; + +: CREATE-C-TYPE ( -- word ) + scan current-vocab create dup reset-c-type ; + : normalize-c-arg ( type name -- type' name' ) [ length ] [ [ CHAR: * = ] trim-head [ length - CHAR: * append ] keep - ] bi ; + ] bi + [ parse-c-type ] dip ; : parse-arglist ( parameters return -- types effect ) [ @@ -29,10 +55,37 @@ IN: alien.parser return library function parameters return parse-arglist [ function-quot ] dip ; +: parse-arg-tokens ( -- tokens ) + ";" parse-tokens [ "()" subseq? not ] filter ; + : (FUNCTION:) ( -- word quot effect ) - scan "c-library" get scan ";" parse-tokens - [ "()" subseq? not ] filter - make-function ; + scan "c-library" get scan parse-arg-tokens make-function ; : define-function ( return library function parameters -- ) make-function define-declared ; + +: callback-quot ( return types abi -- quot ) + [ [ ] 3curry dip alien-callback ] 3curry ; + +:: make-callback-type ( abi return! type-name! parameters -- word quot effect ) + return type-name normalize-c-arg type-name! return! + type-name current-vocab create :> type-word + type-word [ reset-generic ] [ reset-c-type ] bi + void* type-word typedef + parameters return parse-arglist :> callback-effect :> types + type-word callback-effect "callback-effect" set-word-prop + type-word abi "callback-abi" set-word-prop + type-word return types abi callback-quot (( quot -- alien )) ; + +: (CALLBACK:) ( abi -- word quot effect ) + scan scan parse-arg-tokens make-callback-type ; + +PREDICATE: alien-function-word < word + def>> { + [ length 5 = ] + [ last \ alien-invoke eq? ] + } 1&& ; + +PREDICATE: alien-callback-type-word < typedef-word + "callback-effect" word-prop ; + diff --git a/basis/alien/prettyprint/prettyprint.factor b/basis/alien/prettyprint/prettyprint.factor index 0794ab7789..eea3515c8f 100644 --- a/basis/alien/prettyprint/prettyprint.factor +++ b/basis/alien/prettyprint/prettyprint.factor @@ -1,14 +1,83 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel combinators alien alien.strings alien.syntax -prettyprint.backend prettyprint.custom prettyprint.sections ; +USING: accessors kernel combinators alien alien.strings alien.c-types +alien.parser alien.syntax arrays assocs effects math.parser +prettyprint.backend prettyprint.custom prettyprint.sections +definitions see see.private sequences strings words ; IN: alien.prettyprint M: alien pprint* { { [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] } { [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] } - [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] + [ \ ALIEN: [ alien-address >hex text ] pprint-prefix ] } cond ; M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ; + +M: c-type-word definer drop \ C-TYPE: f ; +M: c-type-word definition drop f ; +M: c-type-word declarations. drop ; + +GENERIC: pprint-c-type ( c-type -- ) +M: word pprint-c-type pprint-word ; +M: wrapper pprint-c-type wrapped>> pprint-word ; +M: string pprint-c-type text ; +M: array pprint-c-type pprint* ; + +M: typedef-word definer drop \ TYPEDEF: f ; + +M: typedef-word synopsis* + { + [ seeing-word ] + [ definer. ] + [ "c-type" word-prop pprint-c-type ] + [ pprint-word ] + } cleave ; + +: pprint-function-arg ( type name -- ) + [ pprint-c-type ] [ text ] bi* ; + +: pprint-function-args ( types names -- ) + zip [ ] [ + unclip-last + [ [ first2 "," append pprint-function-arg ] each ] dip + first2 pprint-function-arg + ] if-empty ; + +M: alien-function-word definer + drop \ FUNCTION: \ ; ; +M: alien-function-word definition drop f ; +M: alien-function-word synopsis* + { + [ seeing-word ] + [ def>> second [ \ LIBRARY: [ text ] pprint-prefix ] when* ] + [ definer. ] + [ def>> first pprint-c-type ] + [ pprint-word ] + [ + > 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 ] + [ + > second ] [ "callback-effect" word-prop in>> ] bi + pprint-function-args + ")" text block> + ] + } cleave ; diff --git a/basis/alien/remote-control/remote-control.factor b/basis/alien/remote-control/remote-control.factor index b72c79e478..4ccd0e7488 100644 --- a/basis/alien/remote-control/remote-control.factor +++ b/basis/alien/remote-control/remote-control.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.c-types alien.strings parser +USING: accessors alien alien.data alien.strings parser threads words kernel.private kernel io.encodings.utf8 eval ; IN: alien.remote-control diff --git a/basis/alien/structs/structs-docs.factor b/basis/alien/structs/structs-docs.factor index 62a3817fec..d0485ae4ba 100644 --- a/basis/alien/structs/structs-docs.factor +++ b/basis/alien/structs/structs-docs.factor @@ -1,4 +1,4 @@ -USING: alien.c-types strings help.markup help.syntax alien.syntax +USING: alien.c-types alien.data strings help.markup help.syntax alien.syntax sequences io arrays kernel words assocs namespaces ; IN: alien.structs diff --git a/basis/alien/structs/structs-tests.factor b/basis/alien/structs/structs-tests.factor index 3f84377d5c..d22aa5ee45 100755 --- a/basis/alien/structs/structs-tests.factor +++ b/basis/alien/structs/structs-tests.factor @@ -1,4 +1,4 @@ -USING: alien alien.syntax alien.c-types kernel tools.test +USING: alien alien.syntax alien.c-types alien.data kernel tools.test sequences system libc words vocabs namespaces layouts ; IN: alien.structs.tests diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index a80adf5137..9478f98c63 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -8,12 +8,14 @@ IN: alien.structs TUPLE: struct-type < abstract-c-type fields return-in-registers? ; +INSTANCE: struct-type value-type + M: struct-type c-type ; M: struct-type c-type-stack-align? drop f ; : if-value-struct ( ctype true false -- ) - [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline + [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline M: struct-type unbox-parameter [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ; @@ -33,7 +35,7 @@ M: struct-type box-return M: struct-type stack-size [ heap-size ] [ stack-size ] if-value-struct ; -: c-struct? ( type -- ? ) (c-type) struct-type? ; +M: struct-type c-struct? drop t ; : (define-struct) ( name size align fields class -- ) [ [ align ] keep ] 2dip new diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor index c9e03724f5..93a74c3b0a 100644 --- a/basis/alien/syntax/syntax-docs.factor +++ b/basis/alien/syntax/syntax-docs.factor @@ -9,7 +9,7 @@ HELP: DLL" HELP: ALIEN: { $syntax "ALIEN: address" } -{ $values { "address" "a non-negative integer" } } +{ $values { "address" "a non-negative hexadecimal integer" } } { $description "Creates an alien object at parse time." } { $notes "Alien objects are invalidated between image saves and loads, and hence source files should not contain alien literals; this word is for interactive use only. See " { $link "alien-expiry" } " for details." } ; @@ -73,12 +73,50 @@ HELP: C-ENUM: { $syntax "C-ENUM: words... ;" } { $values { "words" "a sequence of word names" } } { $description "Creates a sequence of word definitions in the current vocabulary. Each word pushes an integer according to its index in the enumeration definition. The first word pushes 0." } -{ $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use symbolic constants instead." } +{ $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use " { $link "words.symbol" } " or " { $link "singletons" } " instead." } { $examples - "The following two lines are equivalent:" - { $code "C-ENUM: red green blue ;" ": red 0 ; : green 1 ; : blue 2 ;" } + "Here is an example enumeration definition:" + { $code "C-ENUM: red green blue ;" } + "It is equivalent to the following series of definitions:" + { $code "CONSTANT: red 0" "CONSTANT: green 1" "CONSTANT: blue 2" } } ; +HELP: CALLBACK: +{ $syntax "CALLBACK: return type ( parameters ) ;" } +{ $values { "return" "a C return type" } { "type" "a type name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } } +{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters with the " { $snippet "\"cdecl\"" } " ABI." } +{ $examples + { $code + "CALLBACK: bool FakeCallback ( int message, void* payload ) ;" + ": MyFakeCallback ( -- alien )" + " [| message payload |" + " \"message #\" write" + " message number>string write" + " \" received\" write nl" + " t" + " ] FakeCallback ;" + } +} ; + +HELP: STDCALL-CALLBACK: +{ $syntax "STDCALL-CALLBACK: return type ( parameters ) ;" } +{ $values { "return" "a C return type" } { "type" "a type name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } } +{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters with the " { $snippet "\"stdcall\"" } " ABI." } +{ $examples + { $code + "STDCALL-CALLBACK: bool FakeCallback ( int message, void* payload ) ;" + ": MyFakeCallback ( -- alien )" + " [| message payload |" + " \"message #\" write" + " message number>string write" + " \" received\" write nl" + " t" + " ] FakeCallback ;" + } +} ; + +{ POSTPONE: CALLBACK: POSTPONE: STDCALL-CALLBACK: } related-words + HELP: &: { $syntax "&: symbol" } { $values { "symbol" "A C library symbol name" } } @@ -86,7 +124,7 @@ HELP: &: HELP: typedef { $values { "old" "a string" } { "new" "a string" } } -{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." } +{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } "." } { $notes "Using this word in the same source file which defines C bindings can cause problems, because words are compiled before top-level forms are run. Use the " { $link POSTPONE: TYPEDEF: } " word instead." } ; { POSTPONE: TYPEDEF: typedef } related-words diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 2b0270d5f5..611133bacb 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -9,7 +9,7 @@ IN: alien.syntax SYNTAX: DLL" lexer get skip-blank parse-string dlopen parsed ; -SYNTAX: ALIEN: scan string>number parsed ; +SYNTAX: ALIEN: 16 scan-base parsed ; SYNTAX: BAD-ALIEN parsed ; @@ -18,8 +18,14 @@ SYNTAX: LIBRARY: scan "c-library" set ; SYNTAX: FUNCTION: (FUNCTION:) define-declared ; +SYNTAX: CALLBACK: + "cdecl" (CALLBACK:) define-inline ; + +SYNTAX: STDCALL-CALLBACK: + "stdcall" (CALLBACK:) define-inline ; + SYNTAX: TYPEDEF: - scan scan typedef ; + scan-c-type CREATE-C-TYPE typedef ; SYNTAX: C-STRUCT: scan current-vocab parse-definition define-struct ; deprecated @@ -31,6 +37,9 @@ SYNTAX: C-ENUM: ";" parse-tokens [ [ create-in ] dip define-constant ] each-index ; +SYNTAX: C-TYPE: + "Primitive C type definition not supported" throw ; + ERROR: no-such-symbol name library ; : address-of ( name library -- value ) diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index 0f87cf4cb6..f5613da6b5 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types accessors math alien.accessors kernel +USING: alien.c-types alien.data accessors math alien.accessors kernel kernel.private sequences sequences.private byte-arrays parser prettyprint.custom fry ; IN: bit-arrays diff --git a/basis/cairo/ffi/ffi.factor b/basis/cairo/ffi/ffi.factor index ce5f0cc233..947869e357 100644 --- a/basis/cairo/ffi/ffi.factor +++ b/basis/cairo/ffi/ffi.factor @@ -6,7 +6,7 @@ USING: system combinators alien alien.syntax alien.c-types alien.destructors kernel accessors sequences arrays ui.gadgets -alien.libraries ; +alien.libraries classes.struct ; IN: cairo.ffi << { @@ -26,23 +26,23 @@ TYPEDEF: int cairo_bool_t TYPEDEF: void* cairo_t TYPEDEF: void* cairo_surface_t -C-STRUCT: cairo_matrix_t - { "double" "xx" } - { "double" "yx" } - { "double" "xy" } - { "double" "yy" } - { "double" "x0" } - { "double" "y0" } ; +STRUCT: cairo_matrix_t + { xx double } + { yx double } + { xy double } + { yy double } + { x0 double } + { y0 double } ; TYPEDEF: void* cairo_pattern_t TYPEDEF: void* cairo_destroy_func_t : cairo-destroy-func ( quot -- callback ) - [ "void" { "void*" } "cdecl" ] dip alien-callback ; inline + [ void { void* } "cdecl" ] dip alien-callback ; inline ! See cairo.h for details -C-STRUCT: cairo_user_data_key_t - { "int" "unused" } ; +STRUCT: cairo_user_data_key_t + { unused int } ; TYPEDEF: int cairo_status_t C-ENUM: @@ -79,11 +79,11 @@ CONSTANT: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 TYPEDEF: void* cairo_write_func_t : cairo-write-func ( quot -- callback ) - [ "cairo_status_t" { "void*" "uchar*" "int" } "cdecl" ] dip alien-callback ; inline + [ cairo_status_t { void* uchar* int } "cdecl" ] dip alien-callback ; inline TYPEDEF: void* cairo_read_func_t : cairo-read-func ( quot -- callback ) - [ "cairo_status_t" { "void*" "uchar*" "int" } "cdecl" ] dip alien-callback ; inline + [ cairo_status_t { void* uchar* int } "cdecl" ] dip alien-callback ; inline ! Functions for manipulating state objects FUNCTION: cairo_t* @@ -336,16 +336,16 @@ cairo_clip_preserve ( cairo_t* cr ) ; FUNCTION: void cairo_clip_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ; -C-STRUCT: cairo_rectangle_t - { "double" "x" } - { "double" "y" } - { "double" "width" } - { "double" "height" } ; +STRUCT: cairo_rectangle_t + { x double } + { y double } + { width double } + { height double } ; -C-STRUCT: cairo_rectangle_list_t - { "cairo_status_t" "status" } - { "cairo_rectangle_t*" "rectangles" } - { "int" "num_rectangles" } ; +STRUCT: cairo_rectangle_list_t + { status cairo_status_t } + { rectangles cairo_rectangle_t* } + { num_rectangles int } ; FUNCTION: cairo_rectangle_list_t* cairo_copy_clip_rectangle_list ( cairo_t* cr ) ; @@ -359,25 +359,25 @@ TYPEDEF: void* cairo_scaled_font_t TYPEDEF: void* cairo_font_face_t -C-STRUCT: cairo_glyph_t - { "ulong" "index" } - { "double" "x" } - { "double" "y" } ; +STRUCT: cairo_glyph_t + { index ulong } + { x double } + { y double } ; -C-STRUCT: cairo_text_extents_t - { "double" "x_bearing" } - { "double" "y_bearing" } - { "double" "width" } - { "double" "height" } - { "double" "x_advance" } - { "double" "y_advance" } ; +STRUCT: cairo_text_extents_t + { x_bearing double } + { y_bearing double } + { width double } + { height double } + { x_advance double } + { y_advance double } ; -C-STRUCT: cairo_font_extents_t - { "double" "ascent" } - { "double" "descent" } - { "double" "height" } - { "double" "max_x_advance" } - { "double" "max_y_advance" } ; +STRUCT: cairo_font_extents_t + { ascent double } + { descent double } + { height double } + { max_x_advance double } + { max_y_advance double } ; TYPEDEF: int cairo_font_slant_t C-ENUM: @@ -648,20 +648,22 @@ C-ENUM: CAIRO_PATH_CLOSE_PATH ; ! NEED TO DO UNION HERE -C-STRUCT: cairo_path_data_t-point - { "double" "x" } - { "double" "y" } ; +STRUCT: cairo_path_data_t-point + { x double } + { y double } ; -C-STRUCT: cairo_path_data_t-header - { "cairo_path_data_type_t" "type" } - { "int" "length" } ; +STRUCT: cairo_path_data_t-header + { type cairo_path_data_type_t } + { length int } ; -C-UNION: cairo_path_data_t "cairo_path_data_t-point" "cairo_path_data_t-header" ; +UNION-STRUCT: cairo_path_data_t + { point cairo_path_data_t-point } + { header cairo_path_data_t-header } ; -C-STRUCT: cairo_path_t - { "cairo_status_t" "status" } - { "cairo_path_data_t*" "data" } - { "int" "num_data" } ; +STRUCT: cairo_path_t + { status cairo_status_t } + { data cairo_path_data_t* } + { num_data int } ; FUNCTION: cairo_path_t* cairo_copy_path ( cairo_t* cr ) ; diff --git a/basis/checksums/openssl/openssl.factor b/basis/checksums/openssl/openssl.factor index 6f21d96e86..bc70230fd0 100644 --- a/basis/checksums/openssl/openssl.factor +++ b/basis/checksums/openssl/openssl.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors byte-arrays alien.c-types kernel continuations -destructors sequences io openssl openssl.libcrypto checksums -checksums.stream ; +USING: accessors byte-arrays alien.c-types alien.data kernel +continuations destructors sequences io openssl openssl.libcrypto +checksums checksums.stream classes.struct ; IN: checksums.openssl ERROR: unknown-digest name ; @@ -23,7 +23,7 @@ TUPLE: evp-md-context < disposable handle ; : ( -- ctx ) evp-md-context new-disposable - "EVP_MD_CTX" dup EVP_MD_CTX_init >>handle ; + EVP_MD_CTX dup EVP_MD_CTX_init >>handle ; M: evp-md-context dispose* handle>> EVP_MD_CTX_cleanup drop ; diff --git a/basis/classes/struct/prettyprint/prettyprint.factor b/basis/classes/struct/prettyprint/prettyprint.factor index e88834530c..43d24e5716 100644 --- a/basis/classes/struct/prettyprint/prettyprint.factor +++ b/basis/classes/struct/prettyprint/prettyprint.factor @@ -1,9 +1,9 @@ ! (c)Joe Groff bsd license -USING: accessors alien alien.c-types arrays assocs classes -classes.struct combinators combinators.short-circuit continuations -fry kernel libc make math math.parser mirrors prettyprint.backend -prettyprint.custom prettyprint.sections see.private sequences -slots strings summary words ; +USING: accessors alien alien.c-types alien.data alien.prettyprint arrays +assocs classes classes.struct combinators combinators.short-circuit +continuations fry kernel libc make math math.parser mirrors +prettyprint.backend prettyprint.custom prettyprint.sections +see.private sequences slots strings summary words ; IN: classes.struct.prettyprint > text ] - [ c-type>> dup string? [ text ] [ pprint* ] if ] + [ type>> pprint-c-type ] [ read-only>> [ \ read-only pprint-word ] when ] [ initial>> [ \ initial: pprint-word pprint* ] when* ] } cleave block> @@ -111,7 +111,7 @@ M: struct-mirror >alist ( mirror -- alist ) ] [ '[ _ struct>assoc - [ [ [ name>> ] [ c-type>> ] bi 2array ] dip ] assoc-map + [ [ [ name>> ] [ type>> ] bi 2array ] dip ] assoc-map ] [ drop { } ] recover ] bi append ; diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 8508230bb2..b60bfa375b 100755 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -1,11 +1,13 @@ ! (c)Joe Groff bsd license -USING: accessors alien alien.c-types alien.structs.fields ascii +USING: accessors alien alien.c-types alien.data ascii assocs byte-arrays classes.struct classes.tuple.private combinators compiler.tree.debugger compiler.units destructors io.encodings.utf8 io.pathnames io.streams.string kernel libc literals math mirrors multiline namespaces prettyprint prettyprint.config see sequences specialized-arrays system -tools.test parser lexer eval ; +tools.test parser lexer eval layouts ; +FROM: math => float ; +QUALIFIED-WITH: alien.c-types c SPECIALIZED-ARRAY: char SPECIALIZED-ARRAY: int SPECIALIZED-ARRAY: ushort @@ -46,9 +48,9 @@ STRUCT: struct-test-bar [ { { "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } } - { { "x" "char" } 98 } - { { "y" "int" } HEX: 7F00007F } - { { "z" "bool" } f } + { { "x" char } 98 } + { { "y" int } HEX: 7F00007F } + { { "z" bool } f } } ] [ B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct make-mirror >alist @@ -128,7 +130,7 @@ STRUCT: struct-test-bar ] unit-test UNION-STRUCT: struct-test-float-and-bits - { f float } + { f c:float } { bits uint } ; [ 1.0 ] [ struct-test-float-and-bits 1.0 float>bits >>bits f>> ] unit-test @@ -181,14 +183,14 @@ STRUCT: struct-test-string-ptr ] with-scope ] unit-test -[ <" USING: classes.struct ; +[ <" USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-foo { x char initial: 0 } { y int initial: 123 } { z bool } ; "> ] [ [ struct-test-foo see ] with-string-writer ] unit-test -[ <" USING: classes.struct ; +[ <" USING: alien.c-types classes.struct ; IN: classes.struct.tests UNION-STRUCT: struct-test-float-and-bits { f float initial: 0.0 } { bits uint initial: 0 } ; @@ -196,43 +198,43 @@ UNION-STRUCT: struct-test-float-and-bits [ [ struct-test-float-and-bits see ] with-string-writer ] unit-test [ { - T{ field-spec + T{ struct-slot-spec { name "x" } { offset 0 } - { type "char" } - { reader x>> } - { writer (>>x) } + { initial 0 } + { class fixnum } + { type char } } - T{ field-spec + T{ struct-slot-spec { name "y" } { offset 4 } - { type "int" } - { reader y>> } - { writer (>>y) } + { initial 123 } + { class integer } + { type int } } - T{ field-spec + T{ struct-slot-spec { name "z" } { offset 8 } - { type "bool" } - { reader z>> } - { writer (>>z) } + { initial f } + { type bool } + { class object } } } ] [ "struct-test-foo" c-type fields>> ] unit-test [ { - T{ field-spec + T{ struct-slot-spec { name "f" } { offset 0 } - { type "float" } - { reader f>> } - { writer (>>f) } + { type c:float } + { class float } + { initial 0.0 } } - T{ field-spec + T{ struct-slot-spec { name "bits" } { offset 0 } - { type "uint" } - { reader bits>> } - { writer (>>bits) } + { type uint } + { class integer } + { initial 0 } } } ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test @@ -277,7 +279,7 @@ STRUCT: struct-test-array-slots ] unit-test STRUCT: struct-test-optimization - { x { "int" 3 } } { y int } ; + { x { int 3 } } { y int } ; SPECIALIZED-ARRAY: struct-test-optimization diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 893bc5a257..7e99328652 100755 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -1,14 +1,12 @@ ! (c)Joe Groff bsd license -USING: accessors alien alien.c-types alien.structs -alien.structs.fields arrays byte-arrays classes classes.parser -classes.tuple classes.tuple.parser classes.tuple.private -combinators combinators.short-circuit combinators.smart -definitions functors.backend fry generalizations generic.parser -kernel kernel.private lexer libc locals macros make math -math.order parser quotations sequences slots slots.private -specialized-arrays vectors words summary namespaces assocs -compiler.tree.propagation.transforms ; -FROM: slots => reader-word writer-word ; +USING: accessors alien alien.c-types alien.data alien.parser arrays +byte-arrays classes classes.parser classes.tuple classes.tuple.parser +classes.tuple.private combinators combinators.short-circuit +combinators.smart cpu.architecture definitions functors.backend +fry generalizations generic.parser kernel kernel.private lexer +libc locals macros make math math.order parser quotations +sequences slots slots.private specialized-arrays vectors words +summary namespaces assocs vocabs.parser ; IN: classes.struct SPECIALIZED-ARRAY: uchar @@ -22,7 +20,7 @@ TUPLE: struct { (underlying) c-ptr read-only } ; TUPLE: struct-slot-spec < slot-spec - c-type ; + type ; PREDICATE: struct-class < tuple-class superclass \ struct eq? ; @@ -86,11 +84,11 @@ MACRO: ( class -- quot: ( ... -- struct ) ) [ struct-slots [ initial>> ] map over length tail append ] keep ; : (reader-quot) ( slot -- quot ) - [ c-type>> c-type-getter-boxer ] + [ type>> c-type-getter-boxer ] [ offset>> [ >c-ptr ] swap suffix ] bi prepend ; : (writer-quot) ( slot -- quot ) - [ c-type>> c-setter ] + [ type>> c-setter ] [ offset>> [ >c-ptr ] swap suffix ] bi prepend ; : (boxer-quot) ( class -- quot ) @@ -117,6 +115,39 @@ M: struct-class writer-quot ! c-types +TUPLE: struct-c-type < abstract-c-type + fields + return-in-registers? ; + +INSTANCE: struct-c-type value-type + +M: struct-c-type c-type ; + +M: struct-c-type c-type-stack-align? drop f ; + +: if-value-struct ( ctype true false -- ) + [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline + +M: struct-c-type unbox-parameter + [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ; + +M: struct-c-type box-parameter + [ %box-large-struct ] [ box-parameter ] if-value-struct ; + +: if-small-struct ( c-type true false -- ? ) + [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline + +M: struct-c-type unbox-return + [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ; + +M: struct-c-type box-return + [ %box-small-struct ] [ %box-large-struct ] if-small-struct ; + +M: struct-c-type stack-size + [ heap-size ] [ stack-size ] if-value-struct ; + +M: struct-c-type c-struct? drop t ; + struct [ ] 3sequence ] bi define-inline-method ; -: slot>field ( slot -- field ) - field-spec new swap { - [ name>> >>name ] - [ offset>> >>offset ] - [ c-type>> >>type ] - [ name>> reader-word >>reader ] - [ name>> writer-word >>writer ] +: c-type-for-class ( class -- c-type ) + struct-c-type new swap { + [ drop byte-array >>class ] + [ >>boxed-class ] + [ struct-slots >>fields ] + [ "struct-size" word-prop >>size ] + [ "struct-align" word-prop >>align ] + [ (unboxer-quot) >>unboxer-quot ] + [ (boxer-quot) >>boxer-quot ] } cleave ; - -: define-struct-for-class ( class -- ) - [ - { - [ name>> ] - [ "struct-size" word-prop ] - [ "struct-align" word-prop ] - [ struct-slots [ slot>field ] map ] - } cleave - struct-type (define-struct) - ] [ - { - [ name>> c-type ] - [ (unboxer-quot) >>unboxer-quot ] - [ (boxer-quot) >>boxer-quot ] - [ >>boxed-class ] - } cleave drop - ] bi ; - + : align-offset ( offset class -- offset' ) c-type-align align ; : struct-offsets ( slots -- size ) 0 [ - [ c-type>> align-offset ] keep - [ (>>offset) ] [ c-type>> heap-size + ] 2bi + [ type>> align-offset ] keep + [ (>>offset) ] [ type>> heap-size + ] 2bi ] reduce ; : union-struct-offsets ( slots -- size ) - [ 0 >>offset c-type>> heap-size ] [ max ] map-reduce ; + [ 0 >>offset type>> heap-size ] [ max ] map-reduce ; : struct-align ( slots -- align ) - [ c-type>> c-type-align ] [ max ] map-reduce ; + [ type>> c-type-align ] [ max ] map-reduce ; PRIVATE> -M: struct-class c-type name>> c-type ; - -M: struct-class c-type-align c-type c-type-align ; - -M: struct-class c-type-getter c-type c-type-getter ; - -M: struct-class c-type-setter c-type c-type-setter ; - -M: struct-class c-type-boxer-quot c-type c-type-boxer-quot ; - -M: struct-class c-type-unboxer-quot c-type c-type-boxer-quot ; - -M: struct-class heap-size c-type heap-size ; - M: struct byte-length class "struct-size" word-prop ; foldable ! class definition @@ -228,7 +229,7 @@ M: struct byte-length class "struct-size" word-prop ; foldable [ (struct-methods) ] tri ; : check-struct-slots ( slots -- ) - [ c-type>> c-type drop ] each ; + [ type>> c-type drop ] each ; : redefine-struct-tuple-class ( class -- ) [ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ; @@ -244,7 +245,7 @@ M: struct byte-length class "struct-size" word-prop ; foldable [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri (struct-word-props) ] - [ drop define-struct-for-class ] 2tri ; inline + [ drop [ c-type-for-class ] keep typedef ] 2tri ; inline PRIVATE> : define-struct-class ( class slots -- ) @@ -265,13 +266,10 @@ ERROR: invalid-struct-slot token ; : ( name c-type attributes -- slot-spec ) [ struct-slot-spec new ] 3dip [ >>name ] - [ [ >>c-type ] [ struct-slot-class >>class ] bi ] + [ [ >>type ] [ struct-slot-class >>class ] bi ] [ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ; array ] when ; - : parse-struct-slot ( -- slot ) scan scan-c-type \ } parse-until ; @@ -302,7 +300,7 @@ SYNTAX: S@ array ] [ >string-param ] if ; + scan dup "{" = [ drop \ } parse-until >array ] [ search ] if ; : parse-struct-slot` ( accum -- accum ) scan-string-param scan-c-type` \ } parse-until diff --git a/basis/cocoa/enumeration/enumeration.factor b/basis/cocoa/enumeration/enumeration.factor index caa83331ab..c7bdf625d9 100755 --- a/basis/cocoa/enumeration/enumeration.factor +++ b/basis/cocoa/enumeration/enumeration.factor @@ -1,17 +1,16 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel classes.struct cocoa cocoa.types alien.c-types -locals math sequences vectors fry libc destructors ; +USING: accessors kernel classes.struct cocoa cocoa.runtime cocoa.types alien.data +locals math sequences vectors fry libc destructors specialized-arrays ; +SPECIALIZED-ARRAY: id IN: cocoa.enumeration -<< "id" require-c-array >> - CONSTANT: NS-EACH-BUFFER-SIZE 16 : with-enumeration-buffers ( quot -- ) '[ NSFastEnumerationState malloc-struct &free - NS-EACH-BUFFER-SIZE "id" malloc-array &free + NS-EACH-BUFFER-SIZE id malloc-array &free NS-EACH-BUFFER-SIZE @ ] with-destructors ; inline @@ -19,7 +18,7 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16 :: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- ) object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count items-count 0 = [ - state itemsPtr>> [ items-count "id" ] [ stackbuf ] if* :> items + state itemsPtr>> [ items-count id ] [ stackbuf ] if* :> items items-count iota [ items nth quot call ] each object quot state stackbuf count (NSFastEnumeration-each) ] unless ; inline recursive diff --git a/basis/cocoa/plists/plists.factor b/basis/cocoa/plists/plists.factor index ceb097bb3a..86b13b2ddc 100644 --- a/basis/cocoa/plists/plists.factor +++ b/basis/cocoa/plists/plists.factor @@ -4,8 +4,8 @@ USING: strings arrays hashtables assocs sequences fry macros cocoa.messages cocoa.classes cocoa.application cocoa kernel namespaces io.backend math cocoa.enumeration byte-arrays -combinators alien.c-types words core-foundation quotations -core-foundation.data core-foundation.utilities ; +combinators alien.c-types alien.data words core-foundation +quotations core-foundation.data core-foundation.utilities ; IN: cocoa.plists : >plist ( value -- plist ) >cf -> autorelease ; diff --git a/basis/colors/constants/constants.factor b/basis/colors/constants/constants.factor index 3912994066..8598fc0663 100644 --- a/basis/colors/constants/constants.factor +++ b/basis/colors/constants/constants.factor @@ -11,23 +11,23 @@ IN: colors.constants [ [ string>number 255 /f ] tri@ 1.0 ] dip [ blank? ] trim-head { { CHAR: \s CHAR: - } } substitute swap ; -: parse-rgb.txt ( lines -- assoc ) +: parse-colors ( lines -- assoc ) [ "!" head? not ] filter [ 11 cut [ " \t" split harvest ] dip suffix ] map [ parse-color ] H{ } map>assoc ; -MEMO: rgb.txt ( -- assoc ) +MEMO: colors ( -- assoc ) "resource:basis/colors/constants/rgb.txt" "resource:basis/colors/constants/factor-colors.txt" - [ utf8 file-lines parse-rgb.txt ] bi@ assoc-union ; + [ utf8 file-lines parse-colors ] bi@ assoc-union ; PRIVATE> -: named-colors ( -- keys ) rgb.txt keys ; +: named-colors ( -- keys ) colors keys ; ERROR: no-such-color name ; : named-color ( name -- color ) - dup rgb.txt at [ ] [ no-such-color ] ?if ; + dup colors at [ ] [ no-such-color ] ?if ; SYNTAX: COLOR: scan named-color parsed ; \ No newline at end of file diff --git a/basis/colors/constants/factor-colors.txt b/basis/colors/constants/factor-colors.txt index c032aae5c4..b8af9d3949 100644 --- a/basis/colors/constants/factor-colors.txt +++ b/basis/colors/constants/factor-colors.txt @@ -1,6 +1,6 @@ ! Factor UI theme colors -243 242 234 FactorLightLightTan -227 226 219 FactorLightTan +243 242 234 FactorLightTan +227 226 219 FactorTan 172 167 147 FactorDarkTan 81 91 105 FactorLightSlateBlue 55 62 72 FactorDarkSlateBlue diff --git a/basis/compiler/alien/alien.factor b/basis/compiler/alien/alien.factor index 59901cf79a..dd2b029266 100644 --- a/basis/compiler/alien/alien.factor +++ b/basis/compiler/alien/alien.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces make math sequences layouts -alien.c-types alien.structs cpu.architecture ; +alien.c-types cpu.architecture ; IN: compiler.alien : large-struct? ( ctype -- ? ) diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index fcfc89ea52..cb8b2de543 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -190,12 +190,14 @@ M: ##slot-imm insn-slot# slot>> ; M: ##set-slot insn-slot# slot>> constant ; M: ##set-slot-imm insn-slot# slot>> ; M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ; +M: ##vm-field-ptr insn-slot# fieldname>> 1array ; ! is this right? M: ##slot insn-object obj>> resolve ; M: ##slot-imm insn-object obj>> resolve ; M: ##set-slot insn-object obj>> resolve ; M: ##set-slot-imm insn-object obj>> resolve ; M: ##alien-global insn-object drop \ ##alien-global ; +M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ; : init-alias-analysis ( insns -- insns' ) H{ } clone histories set diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 8da73a1e0e..db0dd65a83 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -192,14 +192,16 @@ IN: compiler.cfg.builder.tests [ [ ##unbox-alien? ] contains-insn? ] bi ] unit-test -[ f t ] [ - [ { byte-array fixnum } declare alien-cell 4 alien-float ] - [ [ ##box-alien? ] contains-insn? ] - [ [ ##box-float? ] contains-insn? ] bi -] unit-test +\ alien-float "intrinsic" word-prop [ + [ f t ] [ + [ { byte-array fixnum } declare alien-cell 4 alien-float ] + [ [ ##box-alien? ] contains-insn? ] + [ [ ##box-float? ] contains-insn? ] bi + ] unit-test -[ f t ] [ - [ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ] - [ [ ##box-alien? ] contains-insn? ] - [ [ ##box-float? ] contains-insn? ] bi -] unit-test \ No newline at end of file + [ f t ] [ + [ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ] + [ [ ##box-alien? ] contains-insn? ] + [ [ ##box-float? ] contains-insn? ] bi + ] unit-test +] when \ No newline at end of file diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 8f52071e22..74586c6eeb 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs combinators hashtables kernel math fry namespaces make sequences words byte-arrays -layouts alien.c-types alien.structs +layouts alien.c-types stack-checker.inlining cpu.architecture compiler.tree compiler.tree.builder @@ -247,4 +247,4 @@ M: #enter-recursive emit-node drop ; M: #phi emit-node drop ; -M: #declare emit-node drop ; \ No newline at end of file +M: #declare emit-node drop ; diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 469ba37703..1b99b5d4dd 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -57,4 +57,4 @@ insn-classes get [ : ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline : ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ; inline : ^^tag-fixnum ( src -- dst ) tag-bits get ^^shl-imm ; inline -: ^^untag-fixnum ( src -- dst ) tag-bits get ^^sar-imm ; inline \ No newline at end of file +: ^^untag-fixnum ( src -- dst ) tag-bits get ^^sar-imm ; inline diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 32e5d46c61..7c28198f67 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -450,6 +450,10 @@ INSN: ##alien-global def: dst/int-rep literal: symbol library ; +INSN: ##vm-field-ptr +def: dst/int-rep +literal: fieldname ; + ! FFI INSN: ##alien-invoke literal: params stack-frame ; diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor index 8dab157f4e..8a65de5805 100644 --- a/basis/compiler/cfg/intrinsics/float/float.factor +++ b/basis/compiler/cfg/intrinsics/float/float.factor @@ -7,7 +7,10 @@ IN: compiler.cfg.intrinsics.float : emit-float-op ( insn -- ) [ 2inputs ] dip call ds-push ; inline -: emit-float-comparison ( cc -- ) +: emit-float-ordered-comparison ( cc -- ) + [ 2inputs ] dip ^^compare-float-ordered ds-push ; inline + +: emit-float-unordered-comparison ( cc -- ) [ 2inputs ] dip ^^compare-float-unordered ds-push ; inline : emit-float>fixnum ( -- ) diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index ec567558bd..0daab82395 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -86,13 +86,18 @@ IN: compiler.cfg.intrinsics { math.private:float- [ drop [ ^^sub-float ] emit-float-op ] } { math.private:float* [ drop [ ^^mul-float ] emit-float-op ] } { math.private:float/f [ drop [ ^^div-float ] emit-float-op ] } - { math.private:float< [ drop cc< emit-float-comparison ] } - { math.private:float<= [ drop cc<= emit-float-comparison ] } - { math.private:float>= [ drop cc>= emit-float-comparison ] } - { math.private:float> [ drop cc> emit-float-comparison ] } - { math.private:float= [ drop cc= emit-float-comparison ] } + { math.private:float< [ drop cc< emit-float-ordered-comparison ] } + { math.private:float<= [ drop cc<= emit-float-ordered-comparison ] } + { math.private:float>= [ drop cc>= emit-float-ordered-comparison ] } + { math.private:float> [ drop cc> emit-float-ordered-comparison ] } + { math.private:float-u< [ drop cc< emit-float-unordered-comparison ] } + { math.private:float-u<= [ drop cc<= emit-float-unordered-comparison ] } + { math.private:float-u>= [ drop cc>= emit-float-unordered-comparison ] } + { math.private:float-u> [ drop cc> emit-float-unordered-comparison ] } + { math.private:float= [ drop cc= emit-float-unordered-comparison ] } { math.private:float>fixnum [ drop emit-float>fixnum ] } { math.private:fixnum>float [ drop emit-fixnum>float ] } + { math.floats.private:float-unordered? [ drop cc/<>= emit-float-unordered-comparison ] } { alien.accessors:alien-float [ float-rep emit-alien-float-getter ] } { alien.accessors:set-alien-float [ float-rep emit-alien-float-setter ] } { alien.accessors:alien-double [ double-rep emit-alien-float-getter ] } @@ -124,6 +129,7 @@ IN: compiler.cfg.intrinsics { math.libm:ftanh [ drop "tanh" emit-unary-float-function ] } { math.libm:fexp [ drop "exp" emit-unary-float-function ] } { math.libm:flog [ drop "log" emit-unary-float-function ] } + { math.libm:flog10 [ drop "log10" emit-unary-float-function ] } { math.libm:fpow [ drop "pow" emit-binary-float-function ] } { math.libm:facosh [ drop "acosh" emit-unary-float-function ] } { math.libm:fasinh [ drop "asinh" emit-unary-float-function ] } diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor index f9f2182a4e..f9f3488773 100644 --- a/basis/compiler/cfg/intrinsics/misc/misc.factor +++ b/basis/compiler/cfg/intrinsics/misc/misc.factor @@ -10,7 +10,7 @@ IN: compiler.cfg.intrinsics.misc ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ; : emit-getenv ( node -- ) - "userenv" f ^^alien-global + "userenv" ^^vm-field-ptr swap node-input-infos first literal>> [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if* ds-push ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 8754b65475..572107be6c 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -28,10 +28,12 @@ SYMBOL: pending-interval-assoc : remove-pending ( live-interval -- ) vreg>> pending-interval-assoc get delete-at ; +ERROR: bad-vreg vreg ; + : (vreg>reg) ( vreg pending -- reg ) ! If a live vreg is not in the pending set, then it must ! have been spilled. - ?at [ spill-slots get at ] unless ; + ?at [ spill-slots get ?at [ ] [ bad-vreg ] if ] unless ; : vreg>reg ( vreg -- reg ) pending-interval-assoc get (vreg>reg) ; @@ -157,8 +159,6 @@ M: insn assign-registers-in-insn drop ; : end-block ( bb -- ) [ live-out vregs>regs ] keep register-live-outs get set-at ; -ERROR: bad-vreg vreg ; - : vreg-at-start ( vreg bb -- state ) register-live-ins get at ?at [ bad-vreg ] unless ; diff --git a/basis/compiler/cfg/linear-scan/numbering/numbering.factor b/basis/compiler/cfg/linear-scan/numbering/numbering.factor index 6fd97c64da..44b2ff907a 100644 --- a/basis/compiler/cfg/linear-scan/numbering/numbering.factor +++ b/basis/compiler/cfg/linear-scan/numbering/numbering.factor @@ -4,12 +4,18 @@ USING: kernel accessors math sequences grouping namespaces compiler.cfg.linearization.order ; IN: compiler.cfg.linear-scan.numbering -: number-instructions ( rpo -- ) - linearization-order 0 [ - instructions>> [ - [ (>>insn#) ] [ drop 2 + ] 2bi - ] each - ] reduce drop ; +ERROR: already-numbered insn ; + +: number-instruction ( n insn -- n' ) + [ nip dup insn#>> [ already-numbered ] [ drop ] if ] + [ (>>insn#) ] + [ drop 2 + ] + 2tri ; + +: number-instructions ( cfg -- ) + linearization-order + 0 [ instructions>> [ number-instruction ] each ] reduce + drop ; SYMBOL: check-numbering? diff --git a/basis/compiler/cfg/linearization/order/order-tests.factor b/basis/compiler/cfg/linearization/order/order-tests.factor new file mode 100644 index 0000000000..67fb55f507 --- /dev/null +++ b/basis/compiler/cfg/linearization/order/order-tests.factor @@ -0,0 +1,14 @@ +USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization.order +kernel accessors sequences sets tools.test namespaces ; +IN: compiler.cfg.linearization.order.tests + +V{ } 0 test-bb + +V{ } 1 test-bb + +V{ } 2 test-bb + +0 { 1 1 } edges +1 2 edge + +[ t ] [ cfg new 0 get >>entry linearization-order [ id>> ] map all-unique? ] unit-test diff --git a/basis/compiler/cfg/linearization/order/order.factor b/basis/compiler/cfg/linearization/order/order.factor index 703db8e516..1fcc137c60 100644 --- a/basis/compiler/cfg/linearization/order/order.factor +++ b/basis/compiler/cfg/linearization/order/order.factor @@ -3,7 +3,7 @@ USING: accessors assocs deques dlists kernel make sorting namespaces sequences combinators combinators.short-circuit fry math sets compiler.cfg.rpo compiler.cfg.utilities -compiler.cfg.loop-detection ; +compiler.cfg.loop-detection compiler.cfg.predecessors ; IN: compiler.cfg.linearization.order ! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp @@ -56,10 +56,12 @@ SYMBOLS: work-list loop-heads visited ; successors>> [ loop-nesting-at ] sort-with ; : process-block ( bb -- ) - [ , ] - [ visited get conjoin ] - [ sorted-successors [ process-successor ] each ] - tri ; + dup visited? [ drop ] [ + [ , ] + [ visited get conjoin ] + [ sorted-successors [ process-successor ] each ] + tri + ] if ; : (linearization-order) ( cfg -- bbs ) init-linearization-order @@ -69,7 +71,7 @@ SYMBOLS: work-list loop-heads visited ; PRIVATE> : linearization-order ( cfg -- bbs ) - needs-post-order needs-loops + needs-post-order needs-loops needs-predecessors dup linear-order>> [ ] [ dup (linearization-order) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index d441b961c5..e1551f54c0 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces make math math.order math.parser sequences accessors kernel kernel.private layouts assocs words summary arrays -combinators classes.algebra alien alien.c-types alien.structs +combinators classes.algebra alien alien.c-types alien.strings alien.arrays alien.complex alien.libraries sets libc continuations.private fry cpu.architecture classes locals source-files.errors slots parser generic.parser @@ -16,6 +16,8 @@ compiler.cfg.registers compiler.cfg.builder compiler.codegen.fixup compiler.utilities ; +QUALIFIED: classes.struct +QUALIFIED: alien.structs IN: compiler.codegen SYMBOL: insn-counts @@ -268,6 +270,9 @@ M: ##alien-global generate-insn [ dst>> ] [ symbol>> ] [ library>> ] tri %alien-global ; +M: ##vm-field-ptr generate-insn + [ dst>> ] [ fieldname>> ] bi %vm-field-ptr ; + ! ##alien-invoke GENERIC: next-fastcall-param ( rep -- ) @@ -316,7 +321,10 @@ GENERIC: flatten-value-type ( type -- types ) M: object flatten-value-type 1array ; -M: struct-type flatten-value-type ( type -- types ) +M: alien.structs:struct-type flatten-value-type ( type -- types ) + stack-size cell align (flatten-int-type) ; + +M: classes.struct:struct-c-type flatten-value-type ( type -- types ) stack-size cell align (flatten-int-type) ; M: long-long-type flatten-value-type ( type -- types ) @@ -429,7 +437,7 @@ M: ##alien-indirect generate-insn ! Generate code for boxing input parameters in a callback. [ dup \ %save-param-reg move-parameters - "nest_stacks" f %alien-invoke + "nest_stacks" %vm-invoke-1st-arg box-parameters ] with-param-regs ; @@ -451,7 +459,7 @@ TUPLE: callback-context ; : callback-return-quot ( ctype -- quot ) return>> { - { [ dup "void" = ] [ drop [ ] ] } + { [ dup void? ] [ drop [ ] ] } { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] } [ c-type c-type-unboxer-quot ] } cond ; @@ -467,7 +475,7 @@ TUPLE: callback-context ; [ callback-context new do-callback ] % ] [ ] make ; -: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ; +: %unnest-stacks ( -- ) "unnest_stacks" %vm-invoke-1st-arg ; M: ##callback-return generate-insn #! All the extra book-keeping for %unwind is only for x86. diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index b795862970..cc6003b89c 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -50,6 +50,7 @@ CONSTANT: rt-immediate 8 CONSTANT: rt-stack-chain 9 CONSTANT: rt-untagged 10 CONSTANT: rt-megamorphic-cache-hits 11 +CONSTANT: rt-vm 12 : rc-absolute? ( n -- ? ) ${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 484b1f4f2f..e21e13dc13 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -5,6 +5,7 @@ io.streams.string kernel math memory namespaces namespaces.private parser quotations sequences specialized-arrays stack-checker stack-checker.errors system threads tools.test words ; +FROM: alien.c-types => float short ; SPECIALIZED-ARRAY: float SPECIALIZED-ARRAY: char IN: compiler.tests.alien diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index fcbac30444..14ed2294c7 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -4,6 +4,7 @@ namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units io combinators vectors grouping make alien.c-types combinators.short-circuit math.order math.libm math.parser ; +FROM: math => float ; QUALIFIED: namespaces.private IN: compiler.tests.codegen @@ -414,4 +415,19 @@ cell 4 = [ [ "0.169967142900241" "0.9854497299884601" ] [ 1.4 [ [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test [ 1 "0.169967142900241" "0.9854497299884601" ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test -[ 6.0 ] [ 1.0 [ >float 3.0 + [ B{ 0 0 0 0 } 0 set-alien-float ] [ 2.0 + ] bi ] compile-call ] unit-test \ No newline at end of file +[ 6.0 ] [ 1.0 [ >float 3.0 + [ B{ 0 0 0 0 } 0 set-alien-float ] [ 2.0 + ] bi ] compile-call ] unit-test + +! Bug in linearization +[ 283686952174081 ] [ + B{ 1 1 1 1 } [ + { byte-array } declare + [ 0 2 ] dip + [ + [ drop ] 2dip + [ + swap 1 < [ [ ] dip ] [ [ ] dip ] if + 0 alien-signed-4 + ] curry dup bi * + ] curry each-integer + ] compile-call +] unit-test diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index 86d7899fab..14b347008c 100644 --- a/basis/compiler/tests/float.factor +++ b/basis/compiler/tests/float.factor @@ -88,3 +88,15 @@ IN: compiler.tests.float [ 17.5 ] [ 17.5 -11.3 [ float-max ] compile-call ] unit-test [ -11.3 ] [ -11.3 17.5 [ float-min ] compile-call ] unit-test [ -11.3 ] [ 17.5 -11.3 [ float-min ] compile-call ] unit-test + +[ t ] [ 0/0. 0/0. [ float-unordered? ] compile-call ] unit-test +[ t ] [ 0/0. 1.0 [ float-unordered? ] compile-call ] unit-test +[ t ] [ 1.0 0/0. [ float-unordered? ] compile-call ] unit-test +[ f ] [ 3.0 1.0 [ float-unordered? ] compile-call ] unit-test +[ f ] [ 1.0 3.0 [ float-unordered? ] compile-call ] unit-test + +[ 1 ] [ 0/0. 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 1 ] [ 0/0. 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 1 ] [ 1.0 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 2 ] [ 3.0 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 2 ] [ 1.0 3.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 988164143f..24114e0ccb 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -3,8 +3,9 @@ math math.constants math.private math.integers.private sequences strings tools.test words continuations sequences.private hashtables.private byte-arrays system random layouts vectors sbufs strings.private slots.private alien math.order -alien.accessors alien.c-types alien.syntax alien.strings +alien.accessors alien.c-types alien.data alien.syntax alien.strings namespaces libc io.encodings.ascii classes compiler ; +FROM: math => float ; IN: compiler.tests.intrinsics ! Make sure that intrinsic ops compile to correct code. @@ -472,15 +473,15 @@ cell 8 = [ ] unit-test [ ALIEN: 123 ] [ - 123 [ ] compile-call + HEX: 123 [ ] compile-call ] unit-test [ ALIEN: 123 ] [ - 123 [ { fixnum } declare ] compile-call + HEX: 123 [ { fixnum } declare ] compile-call ] unit-test [ ALIEN: 123 ] [ - [ 123 ] compile-call + [ HEX: 123 ] compile-call ] unit-test [ f ] [ @@ -522,8 +523,8 @@ cell 8 = [ [ ALIEN: 1234 ALIEN: 2234 ] [ ALIEN: 234 [ { c-ptr } declare - [ 1000 swap ] - [ 2000 swap ] bi + [ HEX: 1000 swap ] + [ HEX: 2000 swap ] bi ] compile-call ] unit-test diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor index e2fc26e94b..76d7e6de42 100644 --- a/basis/compiler/tests/low-level-ir.factor +++ b/basis/compiler/tests/low-level-ir.factor @@ -18,7 +18,7 @@ IN: compiler.tests.low-level-ir compile-cfg ; : compile-test-bb ( insns -- result ) - V{ T{ ##prologue } T{ ##branch } } 0 test-bb + V{ T{ ##prologue } T{ ##branch } } [ clone ] map 0 test-bb V{ T{ ##inc-d f 1 } T{ ##replace f 0 D 0 } @@ -73,7 +73,7 @@ IN: compiler.tests.low-level-ir [ t ] [ V{ T{ ##load-reference f 0 { t f t } } - T{ ##slot-imm f 0 0 2 $[ array tag-number ] 2 } + T{ ##slot-imm f 0 0 2 $[ array tag-number ] } } compile-test-bb ] unit-test diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 45ea841a73..18679ce77b 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -122,17 +122,6 @@ GENERIC: void-generic ( obj -- * ) [ t ] [ \ -regression optimized? ] unit-test -GENERIC: foozul ( a -- b ) -M: reversed foozul ; -M: integer foozul ; -M: slice foozul ; - -[ t ] [ - reversed \ foozul specific-method - reversed \ foozul method - eq? -] unit-test - ! regression : constant-fold-2 ( -- value ) f ; foldable : constant-fold-3 ( -- value ) 4 ; foldable diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index faf6968670..02e7409c24 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -16,6 +16,7 @@ compiler.tree.propagation compiler.tree.propagation.info compiler.tree.checker compiler.tree.debugger ; +FROM: math => float ; IN: compiler.tree.cleanup.tests [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test diff --git a/basis/compiler/tree/comparisons/comparisons.factor b/basis/compiler/tree/comparisons/comparisons.factor index 5f4b1e8dab..b8e79e33ca 100644 --- a/basis/compiler/tree/comparisons/comparisons.factor +++ b/basis/compiler/tree/comparisons/comparisons.factor @@ -1,28 +1,36 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: math math.order math.intervals assocs combinators ; IN: compiler.tree.comparisons ! Some utilities for working with comparison operations. -CONSTANT: comparison-ops { < > <= >= } +CONSTANT: comparison-ops { < > <= >= u< u> u<= u>= } CONSTANT: generic-comparison-ops { before? after? before=? after=? } : assumption ( i1 i2 op -- i3 ) { - { \ < [ assume< ] } - { \ > [ assume> ] } - { \ <= [ assume<= ] } - { \ >= [ assume>= ] } + { \ < [ assume< ] } + { \ > [ assume> ] } + { \ <= [ assume<= ] } + { \ >= [ assume>= ] } + { \ u< [ assume< ] } + { \ u> [ assume> ] } + { \ u<= [ assume<= ] } + { \ u>= [ assume>= ] } } case ; : interval-comparison ( i1 i2 op -- result ) { - { \ < [ interval< ] } - { \ > [ interval> ] } - { \ <= [ interval<= ] } - { \ >= [ interval>= ] } + { \ < [ interval< ] } + { \ > [ interval> ] } + { \ <= [ interval<= ] } + { \ >= [ interval>= ] } + { \ u< [ interval< ] } + { \ u> [ interval> ] } + { \ u<= [ interval<= ] } + { \ u>= [ interval>= ] } } case ; : swap-comparison ( op -- op' ) @@ -31,6 +39,10 @@ CONSTANT: generic-comparison-ops { before? after? before=? after=? } { > < } { <= >= } { >= <= } + { u< u> } + { u> u< } + { u<= u>= } + { u>= u<= } } at ; : negate-comparison ( op -- op' ) @@ -39,6 +51,10 @@ CONSTANT: generic-comparison-ops { before? after? before=? after=? } { > <= } { <= > } { >= < } + { u< u>= } + { u> u<= } + { u<= u> } + { u>= u< } } at ; : specific-comparison ( op -- op' ) diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 0b50632e4e..367427c716 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -52,7 +52,7 @@ M: callable splicing-nodes splicing-body ; 2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [ [ in-d>> ] [ [ dispatch# ] keep ] bi* [ swap nth value-info class>> dup ] dip - specific-method + method-for-class ] if ] if ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 5fe7d5ee1b..621b8d082b 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -23,7 +23,7 @@ IN: compiler.tree.propagation.known-words { + - * / } [ { number number } "input-classes" set-word-prop ] each -{ /f < > <= >= } +{ /f < > <= >= u< u> u<= u>= } [ { real real } "input-classes" set-word-prop ] each { /i mod /mod } @@ -34,21 +34,6 @@ IN: compiler.tree.propagation.known-words \ bitnot { integer } "input-classes" set-word-prop -: real-op ( info quot -- quot' ) - [ - dup class>> real classes-intersect? - [ clone ] [ drop real ] if - ] dip - change-interval ; inline - -{ bitnot fixnum-bitnot bignum-bitnot } [ - [ [ interval-bitnot ] real-op ] "outputs" set-word-prop -] each - -\ abs [ [ interval-abs ] real-op ] "outputs" set-word-prop - -\ absq [ [ interval-absq ] real-op ] "outputs" set-word-prop - : math-closure ( class -- newclass ) { fixnum bignum integer rational float real number object } [ class<= ] with find nip ; @@ -56,15 +41,6 @@ IN: compiler.tree.propagation.known-words : fits-in-fixnum? ( interval -- ? ) fixnum-interval interval-subset? ; -: binary-op-class ( info1 info2 -- newclass ) - [ class>> ] bi@ - 2dup [ null-class? ] either? [ 2drop null ] [ - [ math-closure ] bi@ math-class-max - ] if ; - -: binary-op-interval ( info1 info2 quot -- newinterval ) - [ [ interval>> ] bi@ ] dip call ; inline - : won't-overflow? ( class interval -- ? ) [ fixnum class<= ] [ fits-in-fixnum? ] bi* and ; @@ -101,6 +77,39 @@ IN: compiler.tree.propagation.known-words [ drop float ] dip ] unless ; +: unary-op-class ( info -- newclass ) + class>> dup null-class? [ drop null ] [ math-closure ] if ; + +: unary-op-interval ( info quot -- newinterval ) + [ + dup class>> real classes-intersect? + [ interval>> ] [ drop full-interval ] if + ] dip call ; inline + +: unary-op ( word interval-quot post-proc-quot -- ) + '[ + [ unary-op-class ] [ _ unary-op-interval ] bi + @ + + ] "outputs" set-word-prop ; + +{ bitnot fixnum-bitnot bignum-bitnot } [ + [ interval-bitnot ] [ integer-valued ] unary-op +] each + +\ abs [ interval-abs ] [ may-overflow real-valued ] unary-op + +\ absq [ interval-absq ] [ may-overflow real-valued ] unary-op + +: binary-op-class ( info1 info2 -- newclass ) + [ class>> ] bi@ + 2dup [ null-class? ] either? [ 2drop null ] [ + [ math-closure ] bi@ math-class-max + ] if ; + +: binary-op-interval ( info1 info2 quot -- newinterval ) + [ [ interval>> ] bi@ ] dip call ; inline + : binary-op ( word interval-quot post-proc-quot -- ) '[ [ binary-op-class ] [ _ binary-op-interval ] 2bi diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index e7cb1b270a..b436b21329 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -10,6 +10,7 @@ compiler.tree.debugger compiler.tree.checker slots.private words hashtables classes assocs locals specialized-arrays system sorting math.libm math.intervals quotations effects alien ; +FROM: math => float ; SPECIALIZED-ARRAY: double IN: compiler.tree.propagation.tests @@ -31,6 +32,8 @@ IN: compiler.tree.propagation.tests [ V{ 69 } ] [ [ [ 69 ] [ 69 ] if ] final-literals ] unit-test +[ V{ integer } ] [ [ bitnot ] final-classes ] unit-test + [ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test ! Test type propagation for math ops @@ -164,6 +167,18 @@ IN: compiler.tree.propagation.tests [ t ] [ [ absq ] final-info first interval>> [0,inf] = ] unit-test +[ t ] [ [ { fixnum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test + +[ t ] [ [ { fixnum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test + +[ V{ integer } ] [ [ { fixnum } declare abs ] final-classes ] unit-test + +[ V{ integer } ] [ [ { fixnum } declare absq ] final-classes ] unit-test + +[ t ] [ [ { bignum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test + +[ t ] [ [ { bignum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test + [ t ] [ [ { float } declare abs ] final-info first interval>> [0,inf] = ] unit-test [ t ] [ [ { float } declare absq ] final-info first interval>> [0,inf] = ] unit-test @@ -172,6 +187,10 @@ IN: compiler.tree.propagation.tests [ t ] [ [ { complex } declare absq ] final-info first interval>> [0,inf] = ] unit-test +[ t ] [ [ { float float } declare rect> C{ 0.0 0.0 } + absq ] final-info first interval>> [0,inf] = ] unit-test + +[ V{ float } ] [ [ { float float } declare rect> C{ 0.0 0.0 } + absq ] final-classes ] unit-test + [ t ] [ [ [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test [ t ] [ [ { double-array double-array } declare [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test @@ -247,6 +266,13 @@ IN: compiler.tree.propagation.tests ] final-literals ] unit-test +[ V{ 1.5 } ] [ + [ + /f + dup 1.5 u<= [ dup 1.5 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if + ] final-literals +] unit-test + [ V{ 1.5 } ] [ [ /f @@ -254,6 +280,13 @@ IN: compiler.tree.propagation.tests ] final-literals ] unit-test +[ V{ 1.5 } ] [ + [ + /f + dup 1.5 u<= [ dup 10 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if + ] final-literals +] unit-test + [ V{ f } ] [ [ /f @@ -261,6 +294,13 @@ IN: compiler.tree.propagation.tests ] final-literals ] unit-test +[ V{ f } ] [ + [ + /f + dup 0.0 u<= [ dup 0.0 u>= [ drop 0.0 ] unless ] [ drop 0.0 ] if + ] final-literals +] unit-test + [ V{ fixnum } ] [ [ 0 dup 10 > [ 100 * ] when ] final-classes ] unit-test @@ -269,6 +309,14 @@ IN: compiler.tree.propagation.tests [ 0 dup 10 > [ drop "foo" ] when ] final-classes ] unit-test +[ V{ fixnum } ] [ + [ 0 dup 10 u> [ 100 * ] when ] final-classes +] unit-test + +[ V{ fixnum } ] [ + [ 0 dup 10 u> [ drop "foo" ] when ] final-classes +] unit-test + [ V{ fixnum } ] [ [ { fixnum } declare 3 3 - + ] final-classes ] unit-test @@ -277,6 +325,10 @@ IN: compiler.tree.propagation.tests [ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals ] unit-test +[ V{ t } ] [ + [ dup 10 u< [ 3 * 30 u< ] [ drop t ] if ] final-literals +] unit-test + [ V{ "d" } ] [ [ 3 { @@ -300,10 +352,18 @@ IN: compiler.tree.propagation.tests [ >fixnum dup 100 < [ 1 + ] [ "Oops" throw ] if ] final-classes ] unit-test +[ V{ fixnum } ] [ + [ >fixnum dup 100 u< [ 1 + ] [ "Oops" throw ] if ] final-classes +] unit-test + [ V{ -1 } ] [ [ 0 dup 100 < not [ 1 + ] [ 1 - ] if ] final-literals ] unit-test +[ V{ -1 } ] [ + [ 0 dup 100 u< not [ 1 + ] [ 1 - ] if ] final-literals +] unit-test + [ V{ 2 } ] [ [ [ 1 ] [ 1 ] if 1 + ] final-literals ] unit-test @@ -312,12 +372,22 @@ IN: compiler.tree.propagation.tests [ 0 * 10 < ] final-classes ] unit-test +[ V{ object } ] [ + [ 0 * 10 u< ] final-classes +] unit-test + [ V{ 27 } ] [ [ 123 bitand dup 10 < over 8 > and [ 3 * ] [ "B" throw ] if ] final-literals ] unit-test +[ V{ 27 } ] [ + [ + 123 bitand dup 10 u< over 8 u> and [ 3 * ] [ "B" throw ] if + ] final-literals +] unit-test + [ V{ 27 } ] [ [ dup number? over sequence? and [ diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index e08a21d4b9..8aa6a821d8 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -14,7 +14,7 @@ IN: compiler.tree.propagation.transforms ! If first input has a known type and second input is an ! object, we convert this to [ swap equal? ]. in-d>> first2 value-info class>> object class= [ - value-info class>> \ equal? specific-method + value-info class>> \ equal? method-for-class [ swap equal? ] f ? ] [ drop f ] if ] "custom-inlining" set-word-prop diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor index 63bfaf37ce..2ef388563e 100644 --- a/basis/core-foundation/core-foundation.factor +++ b/basis/core-foundation/core-foundation.factor @@ -8,11 +8,16 @@ TYPEDEF: void* CFTypeRef TYPEDEF: void* CFAllocatorRef CONSTANT: kCFAllocatorDefault f -TYPEDEF: bool Boolean -TYPEDEF: long CFIndex -TYPEDEF: char UInt8 -TYPEDEF: int SInt32 -TYPEDEF: uint UInt32 +TYPEDEF: bool Boolean +TYPEDEF: long CFIndex +TYPEDEF: uchar UInt8 +TYPEDEF: ushort UInt16 +TYPEDEF: uint UInt32 +TYPEDEF: ulonglong UInt64 +TYPEDEF: char SInt8 +TYPEDEF: short SInt16 +TYPEDEF: int SInt32 +TYPEDEF: longlong SInt64 TYPEDEF: ulong CFTypeID TYPEDEF: UInt32 CFOptionFlags TYPEDEF: void* CFUUIDRef @@ -32,3 +37,4 @@ FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ; FUNCTION: void CFRelease ( CFTypeRef cf ) ; DESTRUCTOR: CFRelease + diff --git a/basis/core-foundation/numbers/numbers.factor b/basis/core-foundation/numbers/numbers.factor index f01f522d61..ae061cb4eb 100644 --- a/basis/core-foundation/numbers/numbers.factor +++ b/basis/core-foundation/numbers/numbers.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types alien.syntax kernel math core-foundation ; +FROM: math => float ; IN: core-foundation.numbers TYPEDEF: void* CFNumberRef diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 6446eacd08..10d858a32f 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -54,11 +54,7 @@ FUNCTION: void CFRunLoopRemoveTimer ( CFStringRef mode ) ; -: CFRunLoopDefaultMode ( -- alien ) - #! Ugly, but we don't have static NSStrings - \ CFRunLoopDefaultMode [ - "kCFRunLoopDefaultMode" - ] initialize-alien ; +CFSTRING: CFRunLoopDefaultMode "kCFRunLoopDefaultMode" TUPLE: run-loop fds sources timers ; diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor index 413709d142..4bbe050230 100644 --- a/basis/core-foundation/strings/strings.factor +++ b/basis/core-foundation/strings/strings.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.syntax alien.strings io.encodings.string kernel sequences byte-arrays io.encodings.utf8 math core-foundation -core-foundation.arrays destructors ; +core-foundation.arrays destructors parser fry alien words ; IN: core-foundation.strings TYPEDEF: void* CFStringRef @@ -83,3 +83,8 @@ FUNCTION: CFStringRef CFStringCreateWithCString ( : ( seq -- alien ) [ [ &CFRelease ] map ] with-destructors ; + +SYNTAX: CFSTRING: + CREATE scan-object + [ drop ] [ '[ _ [ _ ] initialize-alien ] ] 2bi + (( -- alien )) define-declared ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index d6611c3384..fbec9f697a 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -202,6 +202,7 @@ HOOK: %set-alien-double cpu ( ptr value -- ) HOOK: %set-alien-vector cpu ( ptr value rep -- ) HOOK: %alien-global cpu ( dst symbol library -- ) +HOOK: %vm-field-ptr cpu ( dst fieldname -- ) HOOK: %allot cpu ( dst size class temp -- ) HOOK: %write-barrier cpu ( src card# table -- ) @@ -297,6 +298,9 @@ M: object %prepare-var-args ; HOOK: %alien-invoke cpu ( function library -- ) +HOOK: %vm-invoke-1st-arg cpu ( function -- ) +HOOK: %vm-invoke-3rd-arg cpu ( function -- ) + HOOK: %cleanup cpu ( params -- ) M: object %cleanup ( params -- ) drop ; diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 9c829bc390..eb9709a350 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -2,13 +2,15 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs sequences kernel combinators make math math.order math.ranges system namespaces locals layouts words -alien alien.accessors alien.c-types literals cpu.architecture +alien alien.accessors alien.c-types alien.data literals cpu.architecture cpu.ppc.assembler cpu.ppc.assembler.backend compiler.cfg.registers compiler.cfg.instructions compiler.cfg.comparisons compiler.codegen.fixup compiler.cfg.intrinsics compiler.cfg.stack-frame compiler.cfg.build-stack-frame -compiler.units compiler.constants compiler.codegen ; +compiler.units compiler.constants compiler.codegen vm ; FROM: cpu.ppc.assembler => B ; +FROM: layouts => cell ; +FROM: math => float ; IN: cpu.ppc ! PowerPC register assignments: @@ -29,6 +31,18 @@ enable-float-intrinsics \ ##float>integer t frame-required? set-word-prop >> +: %load-vm-addr ( reg -- ) + 0 swap LOAD32 rc-absolute-ppc-2/2 rt-vm rel-fixup ; + +: %load-vm-field-addr ( reg symbol -- ) + [ drop %load-vm-addr ] + [ [ dup ] dip vm-field-offset ADDI ] 2bi ; + +M: ppc %vm-field-ptr ( dst field -- ) %load-vm-field-addr ; + +M: ppc %vm-invoke-1st-arg ( function -- ) f %alien-invoke ; +M: ppc %vm-invoke-3rd-arg ( function -- ) f %alien-invoke ; + M: ppc machine-registers { { int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] } @@ -418,7 +432,7 @@ M: ppc %set-alien-float swap 0 STFS ; M: ppc %set-alien-double swap 0 STFD ; : load-zone-ptr ( reg -- ) - "nursery" f %alien-global ; + "nursery" %load-vm-field-addr ; : load-allot-ptr ( nursery-ptr allot-ptr -- ) [ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ; @@ -441,10 +455,10 @@ M:: ppc %allot ( dst size class nursery-ptr -- ) dst class store-tagged ; : load-cards-offset ( dst -- ) - [ "cards_offset" f %alien-global ] [ dup 0 LWZ ] bi ; + [ "cards_offset" %load-vm-field-addr ] [ dup 0 LWZ ] bi ; : load-decks-offset ( dst -- ) - [ "decks_offset" f %alien-global ] [ dup 0 LWZ ] bi ; + [ "decks_offset" %load-vm-field-addr ] [ dup 0 LWZ ] bi ; M:: ppc %write-barrier ( src card# table -- ) card-mark scratch-reg LI @@ -682,7 +696,7 @@ M:: ppc %save-context ( temp1 temp2 callback-allowed? -- ) #! Save Factor stack pointers in case the C code calls a #! callback which does a GC, which must reliably trace #! all roots. - temp1 "stack_chain" f %alien-global + temp1 "stack_chain" %load-vm-field-addr temp1 temp1 0 LWZ 1 temp1 0 STW callback-allowed? [ @@ -770,5 +784,5 @@ USE: vocabs.loader 4 >>align "box_boolean" >>boxer "to_boolean" >>unboxer - "bool" define-primitive-type + bool define-primitive-type ] with-compilation-unit diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 9939154512..85db5fb09c 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -47,6 +47,18 @@ M: x86.32 reserved-area-size 0 ; M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ; +: push-vm-ptr ( -- ) + temp-reg 0 MOV rc-absolute-cell rt-vm rel-fixup ! push the vm ptr as an argument + temp-reg PUSH ; + +M: x86.32 %vm-invoke-1st-arg ( function -- ) + push-vm-ptr + f %alien-invoke + temp-reg POP ; + +M: x86.32 %vm-invoke-3rd-arg ( function -- ) + %vm-invoke-1st-arg ; ! first 2 args are regs, 3rd is stack so vm-invoke-1st-arg works here + M: x86.32 return-struct-in-registers? ( c-type -- ? ) c-type [ return-in-registers?>> ] @@ -103,9 +115,12 @@ M: x86.32 %save-param-reg 3drop ; #! parameter being passed to a callback from C. over [ load-return-reg ] [ 2drop ] if ; +CONSTANT: vm-ptr-size 4 + M:: x86.32 %box ( n rep func -- ) n rep (%box) - rep rep-size [ + rep rep-size vm-ptr-size + [ + push-vm-ptr rep push-return-reg func f %alien-invoke ] with-aligned-stack ; @@ -118,7 +133,8 @@ M:: x86.32 %box ( n rep func -- ) M: x86.32 %box-long-long ( n func -- ) [ (%box-long-long) ] dip - 8 [ + 8 vm-ptr-size + [ + push-vm-ptr EDX PUSH EAX PUSH f %alien-invoke @@ -126,12 +142,13 @@ M: x86.32 %box-long-long ( n func -- ) M:: x86.32 %box-large-struct ( n c-type -- ) ! Compute destination address - ECX n struct-return@ LEA - 8 [ + EDX n struct-return@ LEA + 8 vm-ptr-size + [ + push-vm-ptr ! Push struct size c-type heap-size PUSH ! Push destination address - ECX PUSH + EDX PUSH ! Copy the struct from the C stack "box_value_struct" f %alien-invoke ] with-aligned-stack ; @@ -144,7 +161,8 @@ M: x86.32 %prepare-box-struct ( -- ) M: x86.32 %box-small-struct ( c-type -- ) #! Box a <= 8-byte struct returned in EAX:EDX. OS X only. - 12 [ + 12 vm-ptr-size + [ + push-vm-ptr heap-size PUSH EDX PUSH EAX PUSH @@ -157,7 +175,9 @@ M: x86.32 %prepare-unbox ( -- ) ESI 4 SUB ; : call-unbox-func ( func -- ) - 4 [ + 8 [ + ! push the vm ptr as an argument + push-vm-ptr ! Push parameter EAX PUSH ! Call the unboxer @@ -183,7 +203,8 @@ M: x86.32 %unbox-long-long ( n func -- ) : %unbox-struct-1 ( -- ) #! Alien must be in EAX. - 4 [ + 4 vm-ptr-size + [ + push-vm-ptr EAX PUSH "alien_offset" f %alien-invoke ! Load first cell @@ -192,7 +213,8 @@ M: x86.32 %unbox-long-long ( n func -- ) : %unbox-struct-2 ( -- ) #! Alien must be in EAX. - 4 [ + 4 vm-ptr-size + [ + push-vm-ptr EAX PUSH "alien_offset" f %alien-invoke ! Load second cell @@ -211,12 +233,13 @@ M: x86 %unbox-small-struct ( size -- ) M:: x86.32 %unbox-large-struct ( n c-type -- ) ! Alien must be in EAX. ! Compute destination address - ECX n stack@ LEA - 12 [ + EDX n stack@ LEA + 12 vm-ptr-size + [ + push-vm-ptr ! Push struct size c-type heap-size PUSH ! Push destination address - ECX PUSH + EDX PUSH ! Push source address EAX PUSH ! Copy the struct to the stack @@ -224,7 +247,8 @@ M:: x86.32 %unbox-large-struct ( n c-type -- ) ] with-aligned-stack ; M: x86.32 %prepare-alien-indirect ( -- ) - "unbox_alien" f %alien-invoke + push-vm-ptr "unbox_alien" f %alien-invoke + temp-reg POP EBP EAX MOV ; M: x86.32 %alien-indirect ( -- ) @@ -234,6 +258,7 @@ M: x86.32 %alien-callback ( quot -- ) 4 [ EAX swap %load-reference EAX PUSH + param-reg-2 0 MOV rc-absolute-cell rt-vm rel-fixup "c_to_factor" f %alien-invoke ] with-aligned-stack ; @@ -243,9 +268,11 @@ M: x86.32 %callback-value ( ctype -- ) ! Save top of data stack in non-volatile register %prepare-unbox EAX PUSH + push-vm-ptr ! Restore data/call/retain stacks "unnest_stacks" f %alien-invoke ! Place top of data stack in EAX + temp-reg POP EAX POP ! Restore C stack ESP 12 ADD diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 674cc817d7..e2096987da 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -12,6 +12,7 @@ IN: bootstrap.x86 : div-arg ( -- reg ) EAX ; : mod-arg ( -- reg ) EDX ; : arg ( -- reg ) EAX ; +: arg2 ( -- reg ) EDX ; : temp0 ( -- reg ) EAX ; : temp1 ( -- reg ) EDX ; : temp2 ( -- reg ) ECX ; @@ -27,6 +28,8 @@ IN: bootstrap.x86 temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel ! save stack pointer temp0 [] stack-reg MOV + ! pass vm ptr to primitive + arg 0 MOV rc-absolute-cell rt-vm jit-rel ! call the primitive 0 JMP rc-relative rt-primitive jit-rel ] jit-primitive jit-define diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 7cfcb7c557..0528733af1 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel math namespaces make sequences system -layouts alien alien.c-types alien.accessors alien.structs slots +layouts alien alien.c-types alien.accessors slots splitting assocs combinators locals compiler.constants compiler.codegen compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame @@ -74,9 +74,26 @@ M: x86.64 %prepare-unbox ( -- ) param-reg-1 R14 [] MOV R14 cell SUB ; +M: x86.64 %vm-invoke-1st-arg ( function -- ) + param-reg-1 0 MOV rc-absolute-cell rt-vm rel-fixup + f %alien-invoke ; + +: %vm-invoke-2nd-arg ( function -- ) + param-reg-2 0 MOV rc-absolute-cell rt-vm rel-fixup + f %alien-invoke ; + +M: x86.64 %vm-invoke-3rd-arg ( function -- ) + param-reg-3 0 MOV rc-absolute-cell rt-vm rel-fixup + f %alien-invoke ; + +: %vm-invoke-4th-arg ( function -- ) + int-regs param-regs fourth 0 MOV rc-absolute-cell rt-vm rel-fixup + f %alien-invoke ; + + M:: x86.64 %unbox ( n rep func -- ) ! Call the unboxer - func f %alien-invoke + func %vm-invoke-2nd-arg ! Store the return value on the C stack if this is an ! alien-invoke, otherwise leave it the return register if ! this is the end of alien-callback @@ -92,9 +109,10 @@ M: x86.64 %unbox-long-long ( n func -- ) { float-regs [ float-regs get pop swap MOVSD ] } } case ; + M: x86.64 %unbox-small-struct ( c-type -- ) ! Alien must be in param-reg-1. - "alien_offset" f %alien-invoke + "alien_offset" %vm-invoke-2nd-arg ! Move alien_offset() return value to R11 so that we don't ! clobber it. R11 RAX MOV @@ -109,7 +127,7 @@ M:: x86.64 %unbox-large-struct ( n c-type -- ) ! Load structure size into param-reg-3 param-reg-3 c-type heap-size MOV ! Copy the struct to the C stack - "to_value_struct" f %alien-invoke ; + "to_value_struct" %vm-invoke-4th-arg ; : load-return-value ( rep -- ) [ [ 0 ] dip reg-class-of param-reg ] @@ -117,6 +135,8 @@ M:: x86.64 %unbox-large-struct ( n c-type -- ) [ ] tri copy-register ; + + M:: x86.64 %box ( n rep func -- ) n [ n @@ -125,7 +145,7 @@ M:: x86.64 %box ( n rep func -- ) ] [ rep load-return-value ] if - func f %alien-invoke ; + rep int-rep? [ func %vm-invoke-2nd-arg ] [ func %vm-invoke-1st-arg ] if ; M: x86.64 %box-long-long ( n func -- ) [ int-rep ] dip %box ; @@ -145,7 +165,7 @@ M: x86.64 %box-small-struct ( c-type -- ) [ param-reg-3 swap heap-size MOV ] bi param-reg-1 0 box-struct-field@ MOV param-reg-2 1 box-struct-field@ MOV - "box_small_struct" f %alien-invoke + "box_small_struct" %vm-invoke-4th-arg ] with-return-regs ; : struct-return@ ( n -- operand ) @@ -157,7 +177,7 @@ M: x86.64 %box-large-struct ( n c-type -- ) ! Compute destination address param-reg-1 swap struct-return@ LEA ! Copy the struct from the C stack - "box_value_struct" f %alien-invoke ; + "box_value_struct" %vm-invoke-3rd-arg ; M: x86.64 %prepare-box-struct ( -- ) ! Compute target address for value struct return @@ -172,8 +192,9 @@ M: x86.64 %alien-invoke rc-absolute-cell rel-dlsym R11 CALL ; + M: x86.64 %prepare-alien-indirect ( -- ) - "unbox_alien" f %alien-invoke + "unbox_alien" %vm-invoke-1st-arg RBP RAX MOV ; M: x86.64 %alien-indirect ( -- ) @@ -181,7 +202,7 @@ M: x86.64 %alien-indirect ( -- ) M: x86.64 %alien-callback ( quot -- ) param-reg-1 swap %load-reference - "c_to_factor" f %alien-invoke ; + "c_to_factor" %vm-invoke-2nd-arg ; M: x86.64 %callback-value ( ctype -- ) ! Save top of data stack @@ -190,7 +211,7 @@ M: x86.64 %callback-value ( ctype -- ) RSP 8 SUB param-reg-1 PUSH ! Restore data/call/retain stacks - "unnest_stacks" f %alien-invoke + "unnest_stacks" %vm-invoke-1st-arg ! Put former top of data stack in param-reg-1 param-reg-1 POP RSP 8 ADD diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 8b0d53cda5..aa7a5dcd67 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -21,6 +21,7 @@ IN: bootstrap.x86 : rex-length ( -- n ) 1 ; [ + ! load stack_chain temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel temp0 temp0 [] MOV @@ -28,6 +29,8 @@ IN: bootstrap.x86 temp0 [] stack-reg MOV ! load XT temp1 0 MOV rc-absolute-cell rt-primitive jit-rel + ! load vm ptr + arg 0 MOV rc-absolute-cell rt-vm jit-rel ! go temp1 JMP ] jit-primitive jit-define diff --git a/basis/cpu/x86/64/unix/bootstrap.factor b/basis/cpu/x86/64/unix/bootstrap.factor index b6d56840e2..199fe8daf4 100644 --- a/basis/cpu/x86/64/unix/bootstrap.factor +++ b/basis/cpu/x86/64/unix/bootstrap.factor @@ -6,6 +6,7 @@ IN: bootstrap.x86 : stack-frame-size ( -- n ) 4 bootstrap-cells ; : arg ( -- reg ) RDI ; +: arg2 ( -- reg ) RSI ; << "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >> call diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index e06c026d39..13e91a87a4 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/basis/cpu/x86/64/unix/unix.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays sequences math splitting make assocs kernel -layouts system alien.c-types alien.structs cpu.architecture +layouts system alien.c-types cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 compiler.codegen compiler.cfg.registers ; +QUALIFIED: alien.structs +QUALIFIED: classes.struct IN: cpu.x86.64.unix M: int-regs param-regs @@ -14,9 +16,10 @@ M: float-regs param-regs M: x86.64 reserved-area-size 0 ; -! The ABI for passing structs by value is pretty messed up -<< "void*" c-type clone "__stack_value" define-primitive-type -stack-params "__stack_value" c-type (>>rep) >> +SYMBOL: (stack-value) +! The ABI for passing structs by value is pretty great +<< void* c-type clone \ (stack-value) define-primitive-type +stack-params \ (stack-value) c-type (>>rep) >> : struct-types&offset ( struct-type -- pairs ) fields>> [ @@ -31,20 +34,25 @@ stack-params "__stack_value" c-type (>>rep) >> : flatten-small-struct ( c-type -- seq ) struct-types&offset split-struct [ [ c-type c-type-rep reg-class-of ] map - int-regs swap member? "void*" "double" ? c-type + int-regs swap member? void* double ? c-type ] map ; : flatten-large-struct ( c-type -- seq ) heap-size cell align - cell /i "__stack_value" c-type ; + cell /i \ (stack-value) c-type ; -M: struct-type flatten-value-type ( type -- seq ) +: flatten-struct ( c-type -- seq ) dup heap-size 16 > [ flatten-large-struct ] [ flatten-small-struct ] if ; +M: alien.structs:struct-type flatten-value-type ( type -- seq ) + flatten-struct ; +M: classes.struct:struct-c-type flatten-value-type ( type -- seq ) + flatten-struct ; + M: x86.64 return-struct-in-registers? ( c-type -- ? ) heap-size 2 cells <= ; diff --git a/basis/cpu/x86/64/winnt/bootstrap.factor b/basis/cpu/x86/64/winnt/bootstrap.factor index 0228082956..72b9d27ca4 100644 --- a/basis/cpu/x86/64/winnt/bootstrap.factor +++ b/basis/cpu/x86/64/winnt/bootstrap.factor @@ -7,6 +7,7 @@ IN: bootstrap.x86 : stack-frame-size ( -- n ) 8 bootstrap-cells ; : arg ( -- reg ) RCX ; +: arg2 ( -- reg ) RDX ; << "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >> call diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor index d9f83612e6..bbe943e06b 100644 --- a/basis/cpu/x86/64/winnt/winnt.factor +++ b/basis/cpu/x86/64/winnt/winnt.factor @@ -25,8 +25,8 @@ M: x86.64 dummy-fp-params? t ; M: x86.64 temp-reg RAX ; << -"longlong" "ptrdiff_t" typedef -"longlong" "intptr_t" typedef -"int" c-type "long" define-primitive-type -"uint" c-type "ulong" define-primitive-type +longlong ptrdiff_t typedef +longlong intptr_t typedef +int c-type long define-primitive-type +uint c-type ulong define-primitive-type >> diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 0dafc3d9c4..5bc5272ab4 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -251,6 +251,8 @@ big-endian off arg ds-reg [] MOV ! pop stack ds-reg bootstrap-cell SUB + ! pass vm pointer + arg2 0 MOV rc-absolute-cell rt-vm jit-rel ! call quotation arg quot-xt-offset [+] JMP ] \ (call) define-sub-primitive diff --git a/basis/cpu/x86/features/features.factor b/basis/cpu/x86/features/features.factor index 02235bb62e..c5cf2d470a 100644 --- a/basis/cpu/x86/features/features.factor +++ b/basis/cpu/x86/features/features.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: system kernel math math.order math.parser namespaces -alien.syntax combinators locals init io cpu.x86 compiler -compiler.units accessors ; +alien.c-types alien.syntax combinators locals init io cpu.x86 +compiler compiler.units accessors ; IN: cpu.x86.features cell ; +FROM: math => float ; IN: cpu.x86 -<< enable-fixnum-log2 >> - ! Add some methods to the assembler to be more useful to the backend M: label JMP 0 JMP rc-relative label-fixup ; M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ; @@ -555,9 +554,13 @@ M: x86 %shl [ SHL ] emit-shift ; M: x86 %shr [ SHR ] emit-shift ; M: x86 %sar [ SAR ] emit-shift ; +M: x86 %vm-field-ptr ( dst field -- ) + [ drop 0 MOV rc-absolute-cell rt-vm rel-fixup ] + [ vm-field-offset ADD ] 2bi ; + : load-zone-ptr ( reg -- ) #! Load pointer to start of zone array - 0 MOV "nursery" f rc-absolute-cell rel-dlsym ; + "nursery" %vm-field-ptr ; : load-allot-ptr ( nursery-ptr allot-ptr -- ) [ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ; @@ -577,18 +580,19 @@ M:: x86 %allot ( dst size class nursery-ptr -- ) dst class store-tagged nursery-ptr size inc-allot-ptr ; + M:: x86 %write-barrier ( src card# table -- ) #! Mark the card pointed to by vreg. ! Mark the card card# src MOV card# card-bits SHR - table "cards_offset" f %alien-global + table "cards_offset" %vm-field-ptr table table [] MOV table card# [+] card-mark MOV ! Mark the card deck card# deck-bits card-bits - SHR - table "decks_offset" f %alien-global + table "decks_offset" %vm-field-ptr table table [] MOV table card# [+] card-mark MOV ; @@ -610,10 +614,10 @@ M:: x86 %call-gc ( gc-root-count -- ) ! Pass number of roots as second parameter param-reg-2 gc-root-count MOV ! Call GC - "inline_gc" f %alien-invoke ; + "inline_gc" %vm-invoke-3rd-arg ; -M: x86 %alien-global - [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ; +M: x86 %alien-global ( dst symbol library -- ) + [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ; M: x86 %epilogue ( n -- ) cell - incr-stack-reg ; @@ -742,8 +746,8 @@ M:: x86 %save-context ( temp1 temp2 callback-allowed? -- ) #! Save Factor stack pointers in case the C code calls a #! callback which does a GC, which must reliably trace #! all roots. - temp1 "stack_chain" f %alien-global - temp1 temp1 [] MOV + temp1 0 MOV rc-absolute-cell rt-vm rel-fixup + temp1 temp1 "stack_chain" vm-field-offset [+] MOV temp2 stack-reg cell neg [+] LEA temp1 [] temp2 MOV callback-allowed? [ @@ -774,3 +778,4 @@ M: x86 small-enough? ( n -- ? ) enable-sse3-simd ; enable-min/max +enable-fixnum-log2 \ No newline at end of file diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index 154d8961a2..e73783fdfc 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -252,14 +252,14 @@ ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial" "Here's an example usage where we'll make a book table, insert some objects, and query them." $nl "First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details." { $code <" -USING: db.sqlite db io.files ; +USING: db.sqlite db io.files io.files.temp ; : with-book-db ( quot -- ) - "book.db" temp-file swap with-db ;"> } + "book.db" temp-file swap with-db ; inline"> } "Now let's create the table manually:" { $code <" "create table books (id integer primary key, title text, author text, date_published timestamp, edition integer, cover_price double, condition text)" - [ sql-command ] with-book-db" "> } + [ sql-command ] with-book-db"> } "Time to insert some books:" { $code <" "insert into books diff --git a/basis/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor index 2278afe4ed..5398e669ed 100644 --- a/basis/db/postgresql/lib/lib.factor +++ b/basis/db/postgresql/lib/lib.factor @@ -2,11 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays continuations db io kernel math namespaces quotations sequences db.postgresql.ffi alien alien.c-types -db.types tools.walker ascii splitting math.parser combinators -libc calendar.format byte-arrays destructors prettyprint -accessors strings serialize io.encodings.binary io.encodings.utf8 -alien.strings io.streams.byte-array summary present urls -specialized-arrays db.private ; +alien.data db.types tools.walker ascii splitting math.parser +combinators libc calendar.format byte-arrays destructors +prettyprint accessors strings serialize io.encodings.binary +io.encodings.utf8 alien.strings io.streams.byte-array summary +present urls specialized-arrays db.private ; SPECIALIZED-ARRAY: uint SPECIALIZED-ARRAY: void* IN: db.postgresql.lib diff --git a/basis/db/sqlite/lib/lib.factor b/basis/db/sqlite/lib/lib.factor index 3565b09856..163026f5ff 100644 --- a/basis/db/sqlite/lib/lib.factor +++ b/basis/db/sqlite/lib/lib.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types arrays assocs kernel math math.parser +USING: alien.c-types alien.data arrays assocs kernel math math.parser namespaces sequences db.sqlite.ffi db combinators continuations db.types calendar.format serialize io.streams.byte-array byte-arrays io.encodings.binary diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 2fad0e4c2e..1e08896e8d 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -174,6 +174,8 @@ M: no-method error. M: bad-slot-value summary drop "Bad store to specialized slot" ; +M: bad-slot-name summary drop "Bad slot name in object literal" ; + M: no-math-method summary drop "No suitable arithmetic method" ; diff --git a/basis/environment/unix/unix.factor b/basis/environment/unix/unix.factor index 84dfbbd43e..3fc8c2f79b 100644 --- a/basis/environment/unix/unix.factor +++ b/basis/environment/unix/unix.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.strings alien.syntax kernel -layouts sequences system unix environment io.encodings.utf8 -unix.utilities vocabs.loader combinators alien.accessors ; +USING: alien alien.c-types alien.data alien.strings +alien.syntax kernel layouts sequences system unix +environment io.encodings.utf8 unix.utilities vocabs.loader +combinators alien.accessors ; IN: environment.unix HOOK: environ os ( -- void* ) diff --git a/basis/environment/winnt/winnt.factor b/basis/environment/winnt/winnt.factor index 518a7d5d7a..894415ace8 100755 --- a/basis/environment/winnt/winnt.factor +++ b/basis/environment/winnt/winnt.factor @@ -1,15 +1,14 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien.strings fry io.encodings.utf16n kernel -splitting windows windows.kernel32 system environment -alien.c-types sequences windows.errors io.streams.memory -io.encodings io ; +splitting windows windows.kernel32 windows.types system +environment alien.data sequences windows.errors +io.streams.memory io.encodings io specialized-arrays ; +SPECIALIZED-ARRAY: TCHAR IN: environment.winnt -<< "TCHAR" require-c-array >> - M: winnt os-env ( key -- value ) - MAX_UNICODE_PATH "TCHAR" + MAX_UNICODE_PATH TCHAR [ dup length GetEnvironmentVariable ] keep over 0 = [ 2drop f ] [ diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index bcdc1bae74..58da96aa17 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -1,5 +1,6 @@ USING: classes.struct functors tools.test math words kernel multiline parser io.streams.string generic ; +QUALIFIED-WITH: alien.c-types c IN: functors.tests << @@ -160,15 +161,15 @@ T-class DEFINES-CLASS ${T} WHERE STRUCT: T-class - { NAME int } + { NAME c:int } { x { TYPE 4 } } - { y { "short" N } } + { y { c:short N } } { z TYPE initial: 5 } - { float { "float" 2 } } ; + { float { c:float 2 } } ; ;FUNCTOR -"a-struct" "nemo" "char" 2 define-a-struct +"a-struct" "nemo" c:char 2 define-a-struct >> @@ -179,35 +180,35 @@ STRUCT: T-class { offset 0 } { class integer } { initial 0 } - { c-type "int" } + { type c:int } } T{ struct-slot-spec { name "x" } { offset 4 } { class object } { initial f } - { c-type { "char" 4 } } + { type { c:char 4 } } } T{ struct-slot-spec { name "y" } { offset 8 } { class object } { initial f } - { c-type { "short" 2 } } + { type { c:short 2 } } } T{ struct-slot-spec { name "z" } { offset 12 } { class fixnum } { initial 5 } - { c-type "char" } + { type c:char } } T{ struct-slot-spec { name "float" } { offset 16 } { class object } { initial f } - { c-type { "float" 2 } } + { type { c:float 2 } } } } ] [ a-struct struct-slots ] unit-test diff --git a/extra/system-info/authors.txt b/basis/furnace/recaptcha/authors.txt similarity index 100% rename from extra/system-info/authors.txt rename to basis/furnace/recaptcha/authors.txt diff --git a/basis/furnace/recaptcha/example/authors.txt b/basis/furnace/recaptcha/example/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/furnace/recaptcha/example/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/furnace/recaptcha/example/example.factor b/basis/furnace/recaptcha/example/example.factor new file mode 100644 index 0000000000..264be678ae --- /dev/null +++ b/basis/furnace/recaptcha/example/example.factor @@ -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" ; + +: ( -- obj ) + + [ + begin-conversation + validate-recaptcha + recaptcha-valid? cget + "?good" "?bad" ? >url + ] >>submit + { recaptcha-app "example" } >>template ; + +: ( -- obj ) + \ recaptcha-app new-dispatcher + "" add-responder + + "concatenative.org" >>domain + "6LeJWQgAAAAAAFlYV7SuBClE9uSpGtV_ZS-qVON7" >>public-key + "6LeJWQgAAAAAALh-XJgSSQ6xKygRgJ8-029Ip2Xv" >>private-key + recaptcha-db ; diff --git a/basis/furnace/recaptcha/example/example.xml b/basis/furnace/recaptcha/example/example.xml new file mode 100644 index 0000000000..e59f441f7f --- /dev/null +++ b/basis/furnace/recaptcha/example/example.xml @@ -0,0 +1,4 @@ + + +
+
 diff --git a/basis/furnace/recaptcha/recaptcha-docs.factor b/basis/furnace/recaptcha/recaptcha-docs.factor new file mode 100644 index 0000000000..e6473a4bf9 --- /dev/null +++ b/basis/furnace/recaptcha/recaptcha-docs.factor @@ -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: +{ $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 } } + { "Wrap the responder in a " { $link } " if it is not already" } + { "Ensure that there is a database connected, with the " { $link } " 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 } } + { "Put the chloe tag " { $snippet "" } " inside a form tag in the template for your " { $link page-action } } +} +$nl +"Run this example vocabulary:" +{ $code + "USE: furnace.recaptcha.example" + " 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 } +"Validating recaptcha:" +{ $subsection validate-recaptcha } +"Symbols set after validation:" +{ $subsection recaptcha-valid? } +{ $subsection recaptcha-error } +{ $subsection "recaptcha-example" } ; + +ABOUT: "furnace.recaptcha" diff --git a/basis/furnace/recaptcha/recaptcha.factor b/basis/furnace/recaptcha/recaptcha.factor new file mode 100644 index 0000000000..99b223b8e3 --- /dev/null +++ b/basis/furnace/recaptcha/recaptcha.factor @@ -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 ; + +: ( responder -- obj ) + recaptcha new + swap >>responder ; + +M: recaptcha call-responder* + dup \ recaptcha set + responder>> call-responder ; + +> + + + +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" + 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* ; diff --git a/basis/furnace/recaptcha/recaptcha.xml b/basis/furnace/recaptcha/recaptcha.xml new file mode 100644 index 0000000000..6cbf795310 --- /dev/null +++ b/basis/furnace/recaptcha/recaptcha.xml @@ -0,0 +1,7 @@ + + + + + + + diff --git a/basis/furnace/recaptcha/summary.txt b/basis/furnace/recaptcha/summary.txt new file mode 100644 index 0000000000..909566f3cc --- /dev/null +++ b/basis/furnace/recaptcha/summary.txt @@ -0,0 +1 @@ +Recaptcha library diff --git a/basis/furnace/recaptcha/tags.txt b/basis/furnace/recaptcha/tags.txt new file mode 100644 index 0000000000..c0772185a0 --- /dev/null +++ b/basis/furnace/recaptcha/tags.txt @@ -0,0 +1 @@ +web diff --git a/basis/game-input/dinput/dinput.factor b/basis/game-input/dinput/dinput.factor index ea3100f95f..16bea60ea5 100755 --- a/basis/game-input/dinput/dinput.factor +++ b/basis/game-input/dinput/dinput.factor @@ -6,7 +6,7 @@ math.rectangles namespaces parser sequences shuffle specialized-arrays ui.backend.windows vectors windows.com windows.dinput windows.dinput.constants windows.errors windows.kernel32 windows.messages windows.ole32 -windows.user32 classes.struct ; +windows.user32 classes.struct alien.data ; SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA IN: game-input.dinput @@ -160,19 +160,24 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ [ device-attached? not ] filter [ remove-controller ] each ; -: device-interface? ( dbt-broadcast-hdr -- ? ) - dbch_devicetype>> DBT_DEVTYP_DEVICEINTERFACE = ; +: ?device-interface ( dbt-broadcast-hdr -- ? ) + dup dbch_devicetype>> DBT_DEVTYP_DEVICEINTERFACE = + [ >c-ptr DEV_BROADCAST_DEVICEW memory>struct ] + [ drop f ] if ; inline : device-arrived ( dbt-broadcast-hdr -- ) - device-interface? [ find-controllers ] when ; + ?device-interface [ find-controllers ] when ; inline : device-removed ( dbt-broadcast-hdr -- ) - device-interface? [ find-and-remove-detached-devices ] when ; + ?device-interface [ find-and-remove-detached-devices ] when ; inline + +: ( wParam -- struct ) + DEV_BROADCAST_HDR memory>struct ; : handle-wm-devicechange ( hWnd uMsg wParam lParam -- ) [ 2drop ] 2dip swap { - { [ dup DBT_DEVICEARRIVAL = ] [ drop device-arrived ] } - { [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop device-removed ] } + { [ dup DBT_DEVICEARRIVAL = ] [ drop device-arrived ] } + { [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop device-removed ] } [ 2drop ] } cond ; diff --git a/basis/game-input/dinput/keys-array/keys-array.factor b/basis/game-input/dinput/keys-array/keys-array.factor index 9a84747dd8..a8813b0397 100755 --- a/basis/game-input/dinput/keys-array/keys-array.factor +++ b/basis/game-input/dinput/keys-array/keys-array.factor @@ -1,5 +1,5 @@ -USING: sequences sequences.private math alien.c-types -accessors ; +USING: sequences sequences.private math +accessors alien.data ; IN: game-input.dinput.keys-array TUPLE: keys-array diff --git a/basis/game-input/iokit/iokit.factor b/basis/game-input/iokit/iokit.factor index 71d547ad29..85f058f283 100755 --- a/basis/game-input/iokit/iokit.factor +++ b/basis/game-input/iokit/iokit.factor @@ -3,7 +3,8 @@ kernel cocoa.enumeration destructors math.parser cocoa.application sequences locals combinators.short-circuit threads namespaces assocs arrays combinators hints alien core-foundation.run-loop accessors sequences.private -alien.c-types math parser game-input vectors bit-arrays ; +alien.c-types alien.data math parser game-input vectors +bit-arrays ; IN: game-input.iokit SINGLETON: iokit-game-input-backend diff --git a/basis/help/html/html-tests.factor b/basis/help/html/html-tests.factor index 90ff6c110f..b4e6103868 100644 --- a/basis/help/html/html-tests.factor +++ b/basis/help/html/html-tests.factor @@ -1,6 +1,12 @@ -USING: help.html tools.test help.topics kernel ; +USING: help.html tools.test help.topics kernel sequences vocabs ; IN: help.html.tests [ ] [ "xml" >link help>html drop ] unit-test [ "article-foobar.html" ] [ "foobar" >link topic>filename ] unit-test + +[ t ] [ all-vocabs-really [ vocab-spec? ] all? ] unit-test + +[ t ] [ all-vocabs-really [ vocab-name "sequences.private" = ] any? ] unit-test + +[ f ] [ all-vocabs-really [ vocab-name "scratchpad" = ] any? ] unit-test diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index e8cc7e04c5..948b52a345 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -73,7 +73,8 @@ M: topic url-of topic>filename ; dup topic>filename utf8 [ help>html write-xml ] with-file-writer ; : all-vocabs-really ( -- seq ) - all-vocabs-recursive >hashtable f over delete-at no-roots remove-redundant-prefixes ; + all-vocabs-recursive >hashtable no-roots remove-redundant-prefixes + [ vocab-name "scratchpad" = not ] filter ; : all-topics ( -- topics ) [ diff --git a/basis/help/stylesheet/stylesheet.factor b/basis/help/stylesheet/stylesheet.factor index 2475fba0f6..8a119823cc 100644 --- a/basis/help/stylesheet/stylesheet.factor +++ b/basis/help/stylesheet/stylesheet.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: colors colors.constants io.styles literals namespaces ; +USING: colors colors.constants io.styles namespaces ; IN: help.stylesheet SYMBOL: default-span-style @@ -34,7 +34,7 @@ H{ { font-style bold } { wrap-margin 500 } { foreground COLOR: gray20 } - { page-color COLOR: FactorLightLightTan } + { page-color COLOR: FactorLightTan } { inset { 5 5 } } } title-style set-global @@ -42,7 +42,7 @@ SYMBOL: help-path-style H{ { font-size 10 } { table-gap { 5 5 } } - { table-border $ transparent } + { table-border COLOR: FactorLightTan } } help-path-style set-global SYMBOL: heading-style @@ -75,7 +75,7 @@ H{ SYMBOL: code-style H{ - { page-color COLOR: FactorLightLightTan } + { page-color COLOR: FactorLightTan } { inset { 5 5 } } { wrap-margin f } } code-style set-global @@ -113,7 +113,7 @@ H{ SYMBOL: table-style H{ { table-gap { 5 5 } } - { table-border COLOR: FactorLightTan } + { table-border COLOR: FactorTan } } table-style set-global SYMBOL: list-style diff --git a/basis/help/vocabs/vocabs.factor b/basis/help/vocabs/vocabs.factor index e8b145d37e..d8f351f57d 100644 --- a/basis/help/vocabs/vocabs.factor +++ b/basis/help/vocabs/vocabs.factor @@ -227,6 +227,18 @@ C: vocab-author ] bi ] unless-empty ; +: vocab-is-not-loaded ( vocab -- ) + "Not loaded" $heading + "You must first load this vocabulary to browse its documentation and words." + print-element vocab-name "USE: " prepend 1array $code ; + +: describe-words ( vocab -- ) + { + { [ dup vocab ] [ words $words ] } + { [ dup find-vocab-root ] [ vocab-is-not-loaded ] } + [ drop ] + } cond ; + : words. ( vocab -- ) last-element off [ require ] [ words $words ] bi nl ; @@ -243,7 +255,7 @@ C: vocab-author first { [ describe-help ] [ describe-metadata ] - [ words $words ] + [ describe-words ] [ describe-files ] [ describe-children ] } cleave ; diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor index 9716407de8..61121bd769 100644 --- a/basis/html/templates/chloe/chloe-docs.factor +++ b/basis/html/templates/chloe/chloe-docs.factor @@ -24,7 +24,7 @@ HELP: compile-attr { $description "Compiles code which pushes an attribute value previously extracted by " { $link required-attr } " or " { $link optional-attr } " on the stack. If the attribute value begins with " { $snippet "@" } ", compiles into code which pushes the a form value." } ; HELP: CHLOE: -{ $syntax "name definition... ;" } +{ $syntax "CHLOE: name definition... ;" } { $values { "name" "the tag name" } { "definition" { $quotation "( tag -- )" } } } { $description "Defines compilation semantics for the Chloe tag named " { $snippet "tag" } ". The definition body receives a " { $link tag } " on the stack." } ; diff --git a/basis/images/memory/memory.factor b/basis/images/memory/memory.factor index 1a977b604e..ccf891d770 100644 --- a/basis/images/memory/memory.factor +++ b/basis/images/memory/memory.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types destructors fry images kernel -libc math sequences ; +USING: accessors alien.c-types alien.data destructors fry images +kernel libc math sequences ; IN: images.memory ! Some code shared by core-graphics and cairo for constructing @@ -27,4 +27,4 @@ PRIVATE> : make-memory-bitmap ( dim quot -- image ) '[ [ malloc-bitmap-data ] keep _ [ ] 2bi - ] with-destructors ; inline \ No newline at end of file + ] with-destructors ; inline diff --git a/basis/io/backend/windows/nt/privileges/privileges.factor b/basis/io/backend/windows/nt/privileges/privileges.factor index 57878ba75b..6022e91efd 100755 --- a/basis/io/backend/windows/nt/privileges/privileges.factor +++ b/basis/io/backend/windows/nt/privileges/privileges.factor @@ -1,52 +1,43 @@ -USING: alien alien.c-types alien.syntax arrays continuations -destructors generic io.mmap io.ports io.backend.windows io.files.windows -kernel libc math math.bitwise namespaces quotations sequences windows -windows.advapi32 windows.kernel32 io.backend system accessors -io.backend.windows.privileges windows.errors ; -IN: io.backend.windows.nt.privileges - -TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES - -! Security tokens -! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/ - -: (open-process-token) ( handle -- handle ) - { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" - [ OpenProcessToken win32-error=0/f ] keep *void* ; - -: open-process-token ( -- handle ) - #! remember to CloseHandle - GetCurrentProcess (open-process-token) ; - -: with-process-token ( quot -- ) - #! quot: ( token-handle -- token-handle ) - [ open-process-token ] dip - [ keep ] curry - [ CloseHandle drop ] [ ] cleanup ; inline - -: lookup-privilege ( string -- luid ) - [ f ] dip "LUID" - [ LookupPrivilegeValue win32-error=0/f ] keep ; - -: make-token-privileges ( name ? -- obj ) - "TOKEN_PRIVILEGES" - 1 over set-TOKEN_PRIVILEGES-PrivilegeCount - "LUID_AND_ATTRIBUTES" malloc-object &free - over set-TOKEN_PRIVILEGES-Privileges - - swap [ - SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges - set-LUID_AND_ATTRIBUTES-Attributes - ] when - - [ lookup-privilege ] dip - [ - TOKEN_PRIVILEGES-Privileges - set-LUID_AND_ATTRIBUTES-Luid - ] keep ; - -M: winnt set-privilege ( name ? -- ) - [ - -rot 0 -rot make-token-privileges - dup length f f AdjustTokenPrivileges win32-error=0/f - ] with-process-token ; +USING: alien alien.c-types alien.data alien.syntax arrays continuations +destructors generic io.mmap io.ports io.backend.windows io.files.windows +kernel libc locals math math.bitwise namespaces quotations sequences windows +windows.advapi32 windows.kernel32 windows.types io.backend system accessors +io.backend.windows.privileges classes.struct windows.errors ; +IN: io.backend.windows.nt.privileges + +TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES + +! Security tokens +! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/ + +: (open-process-token) ( handle -- handle ) + { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags PHANDLE + [ OpenProcessToken win32-error=0/f ] keep *void* ; + +: open-process-token ( -- handle ) + #! remember to CloseHandle + GetCurrentProcess (open-process-token) ; + +: with-process-token ( quot -- ) + #! quot: ( token-handle -- token-handle ) + [ open-process-token ] dip + [ keep ] curry + [ CloseHandle drop ] [ ] cleanup ; inline + +: lookup-privilege ( string -- luid ) + [ f ] dip LUID + [ LookupPrivilegeValue win32-error=0/f ] keep ; + +:: make-token-privileges ( name enabled? -- obj ) + TOKEN_PRIVILEGES + 1 >>PrivilegeCount + LUID_AND_ATTRIBUTES malloc-struct &free + enabled? [ SE_PRIVILEGE_ENABLED >>Attributes ] when + name lookup-privilege >>Luid + >>Privileges ; + +M: winnt set-privilege ( name ? -- ) + [ + -rot 0 -rot make-token-privileges + dup byte-length f f AdjustTokenPrivileges win32-error=0/f + ] with-process-token ; diff --git a/basis/io/buffers/buffers-tests.factor b/basis/io/buffers/buffers-tests.factor index 4425e08106..d366df7c54 100644 --- a/basis/io/buffers/buffers-tests.factor +++ b/basis/io/buffers/buffers-tests.factor @@ -1,7 +1,7 @@ IN: io.buffers.tests -USING: alien alien.c-types io.buffers kernel kernel.private libc -sequences tools.test namespaces byte-arrays strings accessors -destructors ; +USING: alien alien.c-types alien.data io.buffers kernel +kernel.private libc sequences tools.test namespaces byte-arrays +strings accessors destructors ; : buffer-set ( string buffer -- ) over >byte-array over ptr>> byte-array>memory diff --git a/basis/io/buffers/buffers.factor b/basis/io/buffers/buffers.factor index 82c5326b1d..aa9cedf340 100644 --- a/basis/io/buffers/buffers.factor +++ b/basis/io/buffers/buffers.factor @@ -2,8 +2,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.accessors alien.c-types -alien.syntax kernel libc math sequences byte-arrays strings -hints math.order destructors combinators ; +alien.data alien.syntax kernel libc math sequences byte-arrays +strings hints math.order destructors combinators ; IN: io.buffers TUPLE: buffer diff --git a/basis/io/files/info/unix/openbsd/openbsd.factor b/basis/io/files/info/unix/openbsd/openbsd.factor index ef1b55cda3..be88929f2e 100755 --- a/basis/io/files/info/unix/openbsd/openbsd.factor +++ b/basis/io/files/info/unix/openbsd/openbsd.factor @@ -6,7 +6,7 @@ sequences system unix unix.getfsstat.openbsd grouping unix.statfs.openbsd unix.statvfs.openbsd unix.types arrays io.files.info.unix classes.struct specialized-arrays io.encodings.utf8 ; -SPECIALIZED-ARRAY: statvfs +SPECIALIZED-ARRAY: statfs IN: io.files.unix.openbsd TUPLE: openbsd-file-system-info < unix-file-system-info @@ -49,6 +49,6 @@ M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-in M: openbsd file-systems ( -- seq ) f 0 0 getfsstat dup io-error - + [ dup byte-length 0 getfsstat io-error ] [ [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ] bi ; diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index bb3a412669..5ae21fcfee 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -6,7 +6,7 @@ windows.time windows accessors alien.c-types combinators generalizations system alien.strings io.encodings.utf16n sequences splitting windows.errors fry continuations destructors calendar ascii combinators.short-circuit locals classes.struct -specialized-arrays ; +specialized-arrays alien.data ; SPECIALIZED-ARRAY: ushort IN: io.files.info.windows diff --git a/basis/io/files/windows/windows.factor b/basis/io/files/windows/windows.factor index 43463bd3f1..ca5c9b3c4a 100755 --- a/basis/io/files/windows/windows.factor +++ b/basis/io/files/windows/windows.factor @@ -6,7 +6,7 @@ io.backend.windows kernel math splitting fry alien.strings windows windows.kernel32 windows.time calendar combinators math.functions sequences namespaces make words system destructors accessors math.bitwise continuations windows.errors -arrays byte-arrays generalizations ; +arrays byte-arrays generalizations alien.data ; IN: io.files.windows : open-file ( path access-mode create-mode flags -- handle ) diff --git a/basis/io/mmap/mmap.factor b/basis/io/mmap/mmap.factor index 704a585dd4..a866232760 100644 --- a/basis/io/mmap/mmap.factor +++ b/basis/io/mmap/mmap.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: continuations destructors io.files io.files.info io.backend kernel quotations system alien alien.accessors -accessors vocabs.loader combinators alien.c-types +accessors vocabs.loader combinators alien.c-types alien.data math ; IN: io.mmap diff --git a/basis/io/monitors/windows/nt/nt.factor b/basis/io/monitors/windows/nt/nt.factor index 3d837d79d8..9cd8bc4df8 100755 --- a/basis/io/monitors/windows/nt/nt.factor +++ b/basis/io/monitors/windows/nt/nt.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.strings libc destructors locals -kernel math assocs namespaces make continuations sequences +USING: alien alien.c-types alien.data alien.strings libc destructors +locals kernel math assocs namespaces make continuations sequences hashtables sorting arrays combinators math.bitwise strings system accessors threads splitting io.backend io.backend.windows io.backend.windows.nt io.files.windows.nt io.monitors io.ports diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor index 8f596da0bd..400a44ea02 100644 --- a/basis/io/sockets/secure/openssl/openssl.factor +++ b/basis/io/sockets/secure/openssl/openssl.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. ! See http://factorcode.org/license.txt for BSD license. USING: accessors byte-arrays kernel sequences namespaces math -math.order combinators init alien alien.c-types alien.strings -libc continuations destructors summary splitting assocs random -math.parser locals unicode.case openssl openssl.libcrypto -openssl.libssl io.backend io.ports io.pathnames +math.order combinators init alien alien.c-types alien.data +alien.strings libc continuations destructors summary splitting +assocs random math.parser locals unicode.case openssl +openssl.libcrypto openssl.libssl io.backend io.ports io.pathnames io.encodings.8-bit io.timeouts io.sockets.secure ; IN: io.sockets.secure.openssl @@ -31,7 +31,7 @@ TUPLE: openssl-context < secure-context aliens sessions ; ] [ drop ] if ; : password-callback ( -- alien ) - "int" { "void*" "int" "bool" "void*" } "cdecl" + int { void* int bool void* } "cdecl" [| buf size rwflag password! | password [ B{ 0 } password! ] unless diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index 601d269d5c..a542575446 100755 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -6,7 +6,7 @@ arrays io.encodings io.ports io.streams.duplex io.encodings.ascii alien.strings io.binary accessors destructors classes byte-arrays parser alien.c-types math.parser splitting grouping math assocs summary system vocabs.loader combinators present fry vocabs.parser -classes.struct ; +classes.struct alien.data ; IN: io.sockets << { diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index e892c6a7ef..fa46a71ca0 100755 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -5,7 +5,7 @@ threads sequences byte-arrays io.binary io.backend.unix io.streams.duplex io.backend io.pathnames io.sockets.private io.files.private io.encodings.utf8 math.parser continuations libc combinators system accessors destructors unix locals init -classes.struct ; +classes.struct alien.data ; EXCLUDE: namespaces => bind ; EXCLUDE: io => read write ; diff --git a/basis/io/sockets/windows/nt/nt.factor b/basis/io/sockets/windows/nt/nt.factor index f423a42b65..7cc21c9611 100755 --- a/basis/io/sockets/windows/nt/nt.factor +++ b/basis/io/sockets/windows/nt/nt.factor @@ -1,4 +1,4 @@ -USING: alien alien.accessors alien.c-types byte-arrays +USING: alien alien.accessors alien.c-types alien.data byte-arrays continuations destructors io.ports io.timeouts io.sockets io.sockets.private io namespaces io.streams.duplex io.backend.windows io.sockets.windows io.backend.windows.nt diff --git a/basis/iokit/hid/hid.factor b/basis/iokit/hid/hid.factor index 63f91ffc78..a1a4b942b7 100644 --- a/basis/iokit/hid/hid.factor +++ b/basis/iokit/hid/hid.factor @@ -130,30 +130,11 @@ TYPEDEF: void* IOHIDTransactionRef TYPEDEF: UInt32 IOHIDValueScaleType TYPEDEF: UInt32 IOHIDTransactionDirectionType -TYPEDEF: void* IOHIDCallback -: IOHIDCallback ( quot -- alien ) - [ "void" { "void*" "IOReturn" "void*" } "cdecl" ] - dip alien-callback ; inline - -TYPEDEF: void* IOHIDReportCallback -: IOHIDReportCallback ( quot -- alien ) - [ "void" { "void*" "IOReturn" "void*" "IOHIDReportType" "UInt32" "uchar*" "CFIndex" } "cdecl" ] - dip alien-callback ; inline - -TYPEDEF: void* IOHIDValueCallback -: IOHIDValueCallback ( quot -- alien ) - [ "void" { "void*" "IOReturn" "void*" "IOHIDValueRef" } "cdecl" ] - dip alien-callback ; inline - -TYPEDEF: void* IOHIDValueMultipleCallback -: IOHIDValueMultipleCallback ( quot -- alien ) - [ "void" { "void*" "IOReturn" "void*" "CFDictionaryRef" } "cdecl" ] - dip alien-callback ; inline - -TYPEDEF: void* IOHIDDeviceCallback -: IOHIDDeviceCallback ( quot -- alien ) - [ "void" { "void*" "IOReturn" "void*" "IOHIDDeviceRef" } "cdecl" ] - dip alien-callback ; inline +CALLBACK: void IOHIDCallback ( void* context, IOReturn result, void* sender ) ; +CALLBACK: void IOHIDReportCallback ( void* context, IOReturn result, void* sender, IOHIDReportType type, UInt32 reportID, uchar* report, CFIndex reportLength ) ; +CALLBACK: void IOHIDValueCallback ( void* context, IOReturn result, void* sender, IOHIDValueRef value ) ; +CALLBACK: void IOHIDValueMultipleCallback ( void* context, IOReturn result, void* sender, CFDictionaryRef multiple ) ; +CALLBACK: void IOHIDDeviceCallback ( void* context, IOReturn result, void* sender, IOHIDDeviceRef device ) ; ! IOHIDDevice diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor index 4142e40c68..fe56c83516 100644 --- a/basis/libc/libc.factor +++ b/basis/libc/libc.factor @@ -2,29 +2,29 @@ ! Copyright (C) 2007, 2009 Slava Pestov ! Copyright (C) 2007, 2008 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: alien assocs continuations alien.destructors kernel +USING: alien alien.c-types assocs continuations alien.destructors kernel namespaces accessors sets summary destructors destructors.private ; IN: libc : errno ( -- int ) - "int" "factor" "err_no" { } alien-invoke ; + int "factor" "err_no" { } alien-invoke ; : clear-errno ( -- ) - "void" "factor" "clear_err_no" { } alien-invoke ; + void "factor" "clear_err_no" { } alien-invoke ; >c-ptr [ delete-malloc ] [ (free) ] bi ; : memcpy ( dst src size -- ) - "void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ; + void "libc" "memcpy" { void* void* ulong } alien-invoke ; : memcmp ( a b size -- cmp ) - "int" "libc" "memcmp" { "void*" "void*" "ulong" } alien-invoke ; + int "libc" "memcmp" { void* void* ulong } alien-invoke ; : memory= ( a b size -- ? ) memcmp 0 = ; : strlen ( alien -- len ) - "size_t" "libc" "strlen" { "char*" } alien-invoke ; + size_t "libc" "strlen" { char* } alien-invoke ; DESTRUCTOR: free diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor index a051fb250d..aa9681bb2e 100755 --- a/basis/math/blas/matrices/matrices.factor +++ b/basis/math/blas/matrices/matrices.factor @@ -1,10 +1,11 @@ -USING: accessors alien alien.c-types arrays byte-arrays combinators -combinators.short-circuit fry kernel locals macros -math math.blas.ffi math.blas.vectors math.blas.vectors.private -math.complex math.functions math.order functors words -sequences sequences.merged sequences.private shuffle -parser prettyprint.backend prettyprint.custom ascii -specialized-arrays ; +USING: accessors alien alien.c-types alien.data arrays +byte-arrays combinators combinators.short-circuit fry +kernel locals macros math math.blas.ffi math.blas.vectors +math.blas.vectors.private math.complex math.functions +math.order functors words sequences sequences.merged +sequences.private shuffle parser prettyprint.backend +prettyprint.custom ascii specialized-arrays ; +FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float SPECIALIZED-ARRAY: double SPECIALIZED-ARRAY: complex-float diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index c08fdb6120..20ee7925b0 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -3,6 +3,7 @@ combinators.short-circuit fry kernel math math.blas.ffi math.complex math.functions math.order sequences sequences.private functors words locals parser prettyprint.backend prettyprint.custom specialized-arrays ; +FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float SPECIALIZED-ARRAY: double SPECIALIZED-ARRAY: complex-float diff --git a/basis/math/floats/env/env-docs.factor b/basis/math/floats/env/env-docs.factor index ef580b9040..0fc781713c 100644 --- a/basis/math/floats/env/env-docs.factor +++ b/basis/math/floats/env/env-docs.factor @@ -1,5 +1,5 @@ ! (c)Joe Groff bsd license -USING: help help.markup help.syntax quotations ; +USING: help help.markup help.syntax kernel quotations ; IN: math.floats.env HELP: fp-exception @@ -97,13 +97,21 @@ HELP: fp-traps HELP: with-fp-traps { $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } { "quot" quotation } } -{ $description "Replaces the floating-point exception mask to enable processor traps to be raised for the set of exception conditions specified in " { $snippet "exceptions" } " for the dynamic extent of " { $snippet "quot" } ", restoring the original exception mask on " { $snippet "quot" } "'s completion." } ; +{ $description "Clears the floating-point exception flags and replaces the exception mask, enabling processor traps for the set of exception conditions specified in " { $snippet "exceptions" } " for the dynamic extent of " { $snippet "quot" } ". The original exception mask is restored on " { $snippet "quot" } "'s completion." } ; HELP: without-fp-traps { $values { "quot" quotation } } { $description "Disables all floating-pointer processor traps for the dynamic extent of " { $snippet "quot" } ", restoring the original exception mask on " { $snippet "quot" } "'s completion." } ; -{ fp-traps with-fp-traps without-fp-traps } related-words +{ fp-traps with-fp-traps without-fp-traps vm-error>exception-flags vm-error-exception-flag? } related-words + +HELP: vm-error>exception-flags +{ $values { "error" "a floating-point error object from the Factor VM" } { "exceptions" "a sequence of " { $link fp-exception } " symbols" } } +{ $description "When a floating-point trap is raised, the Factor VM reports the trap by throwing a Factor exception containing the exception flags at the time the trap was raised. This word extracts the exception flag information from " { $snippet "error" } " and converts it into a sequence of " { $link fp-exception } "s." } ; + +HELP: vm-error-exception-flag? +{ $values { "error" "a floating-point error object from the Factor VM" } { "flag" fp-exception } { "?" boolean } } +{ $description "When a floating-point trap is raised, the Factor VM reports the trap by throwing a Factor exception containing the exception flags at the time the trap was raised. This word returns a boolean indicating whether the exception " { $snippet "flag" } " was raised at the time " { $snippet "error" } " was thrown." } ; ARTICLE: "math.floats.env" "Controlling the floating-point environment" "The " { $vocab-link "math.floats.env" } " vocabulary contains words for querying and controlling the floating-point environment." @@ -117,11 +125,13 @@ $nl { $subsection fp-traps } { $subsection with-fp-traps } { $subsection without-fp-traps } +"Getting the floating-point exception state from errors raised by enabled traps:" +{ $subsection vm-error>exception-flags } +{ $subsection vm-error-exception-flag? } "Querying and controlling the rounding mode and treatment of denormals:" { $subsection rounding-mode } { $subsection with-rounding-mode } { $subsection denormal-mode } -{ $subsection with-denormal-mode } -{ $notes "On PowerPC, the above words only modify the scalar FPU's state (in FPSCR); the AltiVec unit is currently unaffected." } ; +{ $subsection with-denormal-mode } ; ABOUT: "math.floats.env" diff --git a/basis/math/floats/env/env-tests.factor b/basis/math/floats/env/env-tests.factor index a0ffa0713c..7f5a20efd0 100644 --- a/basis/math/floats/env/env-tests.factor +++ b/basis/math/floats/env/env-tests.factor @@ -1,5 +1,7 @@ USING: kernel math math.floats.env math.floats.env.private -math.functions math.libm sequences tools.test ; +math.functions math.libm sequences tools.test locals +compiler.units kernel.private fry compiler math.private words +system ; IN: math.floats.env.tests : set-default-fp-env ( -- ) @@ -8,45 +10,35 @@ IN: math.floats.env.tests ! In case the tests screw up the FP env because of bugs in math.floats.env set-default-fp-env -[ t ] [ - [ 1.0 0.0 / drop ] collect-fp-exceptions - +fp-zero-divide+ swap member? -] unit-test +: test-fp-exception ( exception inputs quot -- quot' ) + '[ _ [ @ @ ] collect-fp-exceptions nip member? ] ; -[ t ] [ - [ 1.0 3.0 / drop ] collect-fp-exceptions - +fp-inexact+ swap member? -] unit-test +: test-fp-exception-compiled ( exception inputs quot -- quot' ) + '[ _ @ [ _ collect-fp-exceptions ] compile-call nip member? ] ; -[ t ] [ - [ 1.0e250 1.0e100 * drop ] collect-fp-exceptions - +fp-overflow+ swap member? -] unit-test +[ t ] +fp-zero-divide+ [ 1.0 0.0 ] [ /f ] test-fp-exception unit-test +[ t ] +fp-inexact+ [ 1.0 3.0 ] [ /f ] test-fp-exception unit-test +[ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception unit-test +[ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception unit-test +[ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception unit-test +[ t ] +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception unit-test +[ t ] +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception unit-test -[ t ] [ - [ 1.0e-250 1.0e-100 * drop ] collect-fp-exceptions - +fp-underflow+ swap member? -] unit-test +[ t ] +fp-zero-divide+ [ 1.0 0.0 ] [ /f ] test-fp-exception-compiled unit-test +[ t ] +fp-inexact+ [ 1.0 3.0 ] [ /f ] test-fp-exception-compiled unit-test +[ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception-compiled unit-test +[ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception-compiled unit-test +[ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test -[ t ] [ - [ 2.0 100,000.0 ^ drop ] collect-fp-exceptions - +fp-overflow+ swap member? -] unit-test +! No underflow on Linux with this test, just inexact. Reported as an Ubuntu bug: +! https://bugs.launchpad.net/ubuntu/+source/glibc/+bug/429113 +os linux? cpu x86.64? and [ + [ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception unit-test + [ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test +] unless -[ t ] [ - [ 2.0 -100,000.0 ^ drop ] collect-fp-exceptions - +fp-underflow+ swap member? -] unit-test - -[ t ] [ - [ 0.0 0.0 /f drop ] collect-fp-exceptions - +fp-invalid-operation+ swap member? -] unit-test - -[ t ] [ - [ -1.0 fsqrt drop ] collect-fp-exceptions - +fp-invalid-operation+ swap member? -] unit-test +[ t ] +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception-compiled unit-test +[ t ] +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception-compiled unit-test [ HEX: 3fd5,5555,5555,5555 @@ -117,11 +109,72 @@ set-default-fp-env -1.0 3.0 /f double>bits ] unit-test -[ { +fp-zero-divide+ } [ 1.0 0.0 /f ] with-fp-traps ] must-fail -[ { +fp-inexact+ } [ 1.0 3.0 /f ] with-fp-traps ] must-fail -[ { +fp-invalid-operation+ } [ -1.0 fsqrt ] with-fp-traps ] must-fail -[ { +fp-overflow+ } [ 2.0 100,000.0 ^ ] with-fp-traps ] must-fail -[ { +fp-underflow+ } [ 2.0 -100,000.0 ^ ] with-fp-traps ] must-fail +: test-traps ( traps inputs quot -- quot' ) + append '[ _ _ with-fp-traps ] ; + +: test-traps-compiled ( traps inputs quot -- quot' ) + swapd '[ @ [ _ _ with-fp-traps ] compile-call ] ; + +{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps must-fail +{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps must-fail +{ +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps must-fail +{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps must-fail +{ +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps must-fail + +{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps-compiled must-fail +{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps-compiled must-fail +{ +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps-compiled must-fail +{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps-compiled must-fail +{ +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps-compiled must-fail + +! Ensure ordered comparisons raise traps +:: test-comparison-quot ( word -- quot ) + [ + { float float } declare + { +fp-invalid-operation+ } [ word execute ] with-fp-traps + ] ; + +: test-comparison ( inputs word -- quot ) + test-comparison-quot append ; + +: test-comparison-compiled ( inputs word -- quot ) + test-comparison-quot '[ @ _ compile-call ] ; + +\ float< "intrinsic" word-prop [ + [ 0/0. -15.0 ] \ < test-comparison must-fail + [ 0/0. -15.0 ] \ < test-comparison-compiled must-fail + [ -15.0 0/0. ] \ < test-comparison must-fail + [ -15.0 0/0. ] \ < test-comparison-compiled must-fail + [ 0/0. -15.0 ] \ <= test-comparison must-fail + [ 0/0. -15.0 ] \ <= test-comparison-compiled must-fail + [ -15.0 0/0. ] \ <= test-comparison must-fail + [ -15.0 0/0. ] \ <= test-comparison-compiled must-fail + [ 0/0. -15.0 ] \ > test-comparison must-fail + [ 0/0. -15.0 ] \ > test-comparison-compiled must-fail + [ -15.0 0/0. ] \ > test-comparison must-fail + [ -15.0 0/0. ] \ > test-comparison-compiled must-fail + [ 0/0. -15.0 ] \ >= test-comparison must-fail + [ 0/0. -15.0 ] \ >= test-comparison-compiled must-fail + [ -15.0 0/0. ] \ >= test-comparison must-fail + [ -15.0 0/0. ] \ >= test-comparison-compiled must-fail + + [ f ] [ 0/0. -15.0 ] \ u< test-comparison unit-test + [ f ] [ 0/0. -15.0 ] \ u< test-comparison-compiled unit-test + [ f ] [ -15.0 0/0. ] \ u< test-comparison unit-test + [ f ] [ -15.0 0/0. ] \ u< test-comparison-compiled unit-test + [ f ] [ 0/0. -15.0 ] \ u<= test-comparison unit-test + [ f ] [ 0/0. -15.0 ] \ u<= test-comparison-compiled unit-test + [ f ] [ -15.0 0/0. ] \ u<= test-comparison unit-test + [ f ] [ -15.0 0/0. ] \ u<= test-comparison-compiled unit-test + [ f ] [ 0/0. -15.0 ] \ u> test-comparison unit-test + [ f ] [ 0/0. -15.0 ] \ u> test-comparison-compiled unit-test + [ f ] [ -15.0 0/0. ] \ u> test-comparison unit-test + [ f ] [ -15.0 0/0. ] \ u> test-comparison-compiled unit-test + [ f ] [ 0/0. -15.0 ] \ u>= test-comparison unit-test + [ f ] [ 0/0. -15.0 ] \ u>= test-comparison-compiled unit-test + [ f ] [ -15.0 0/0. ] \ u>= test-comparison unit-test + [ f ] [ -15.0 0/0. ] \ u>= test-comparison-compiled unit-test +] when ! Ensure traps get cleared [ 1/0. ] [ 1.0 0.0 /f ] unit-test diff --git a/basis/math/floats/env/env.factor b/basis/math/floats/env/env.factor index 6a8110c4c1..04fbc4f26c 100644 --- a/basis/math/floats/env/env.factor +++ b/basis/math/floats/env/env.factor @@ -1,7 +1,8 @@ ! (c)Joe Groff bsd license -USING: alien.syntax arrays assocs biassocs combinators continuations -generalizations kernel literals locals math math.bitwise -sequences sets system vocabs.loader ; +USING: alien.syntax arrays assocs biassocs combinators +combinators.short-circuit continuations generalizations kernel +literals locals math math.bitwise sequences sets system +vocabs.loader ; IN: math.floats.env SINGLETONS: @@ -18,6 +19,15 @@ UNION: fp-exception +fp-zero-divide+ +fp-inexact+ ; +CONSTANT: all-fp-exceptions + { + +fp-invalid-operation+ + +fp-overflow+ + +fp-underflow+ + +fp-zero-divide+ + +fp-inexact+ + } + SINGLETONS: +round-nearest+ +round-down+ @@ -93,6 +103,15 @@ GENERIC# (set-denormal-mode) 1 ( fp-env mode -- fp-env ) } spread ] 4 ncurry change-fp-env-registers ; +CONSTANT: vm-error-exception-flag>bit + H{ + { +fp-invalid-operation+ HEX: 01 } + { +fp-overflow+ HEX: 02 } + { +fp-underflow+ HEX: 04 } + { +fp-zero-divide+ HEX: 08 } + { +fp-inexact+ HEX: 10 } + } + PRIVATE> : fp-exception-flags ( -- exceptions ) @@ -102,7 +121,12 @@ PRIVATE> : clear-fp-exception-flags ( -- ) { } set-fp-exception-flags ; inline : collect-fp-exceptions ( quot -- exceptions ) - clear-fp-exception-flags call fp-exception-flags ; inline + [ clear-fp-exception-flags ] dip call fp-exception-flags ; inline + +: vm-error>exception-flags ( error -- exceptions ) + third vm-error-exception-flag>bit mask> ; +: vm-error-exception-flag? ( error flag -- ? ) + vm-error>exception-flags member? ; : denormal-mode ( -- mode ) fp-env-register (get-denormal-mode) ; @@ -122,6 +146,7 @@ PRIVATE> (fp-env-registers) [ (get-fp-traps) ] [ union ] map-reduce >array ; inline :: with-fp-traps ( exceptions quot -- ) + clear-fp-exception-flags fp-traps :> orig exceptions set-fp-traps quot [ orig set-fp-traps ] [ ] cleanup ; inline diff --git a/basis/math/floats/env/ppc/ppc.factor b/basis/math/floats/env/ppc/ppc.factor index c4c81471ca..d6a6ae6834 100644 --- a/basis/math/floats/env/ppc/ppc.factor +++ b/basis/math/floats/env/ppc/ppc.factor @@ -7,21 +7,34 @@ STRUCT: ppc-fpu-env { padding uint } { fpscr uint } ; +STRUCT: ppc-vmx-env + { vscr uint } ; + ! defined in the vm, cpu-ppc*.S FUNCTION: void get_ppc_fpu_env ( ppc-fpu-env* env ) ; FUNCTION: void set_ppc_fpu_env ( ppc-fpu-env* env ) ; +FUNCTION: void get_ppc_vmx_env ( ppc-vmx-env* env ) ; +FUNCTION: void set_ppc_vmx_env ( ppc-vmx-env* env ) ; + : ( -- ppc-fpu-env ) ppc-fpu-env (struct) [ get_ppc_fpu_env ] keep ; +: ( -- ppc-fpu-env ) + ppc-vmx-env (struct) + [ get_ppc_vmx_env ] keep ; + M: ppc-fpu-env (set-fp-env-register) set_ppc_fpu_env ; -M: ppc (fp-env-registers) - 1array ; +M: ppc-vmx-env (set-fp-env-register) + set_ppc_vmx_env ; -CONSTANT: ppc-exception-flag-bits HEX: 3e00,0000 +M: ppc (fp-env-registers) + 2array ; + +CONSTANT: ppc-exception-flag-bits HEX: fff8,0700 CONSTANT: ppc-exception-flag>bit H{ { +fp-invalid-operation+ HEX: 2000,0000 } @@ -77,3 +90,30 @@ M: ppc-fpu-env (set-denormal-mode) ( register mode -- register' ) } case ] curry change-fpscr ; inline +CONSTANT: vmx-denormal-mode-bits HEX: 10000 + +M: ppc-vmx-env (get-exception-flags) ( register -- exceptions ) + drop { } ; inline +M: ppc-vmx-env (set-exception-flags) ( register exceptions -- register' ) + drop ; + +M: ppc-vmx-env (get-fp-traps) ( register -- exceptions ) + drop { } ; inline +M: ppc-vmx-env (set-fp-traps) ( register exceptions -- register' ) + drop ; + +M: ppc-vmx-env (get-rounding-mode) ( register -- mode ) + drop +round-nearest+ ; +M: ppc-vmx-env (set-rounding-mode) ( register mode -- register' ) + drop ; + +M: ppc-vmx-env (get-denormal-mode) ( register -- mode ) + vscr>> vmx-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline +M: ppc-vmx-env (set-denormal-mode) ( register mode -- register ) + [ + { + { +denormal-keep+ [ vmx-denormal-mode-bits unmask ] } + { +denormal-flush+ [ vmx-denormal-mode-bits bitor ] } + } case + ] curry change-vscr ; inline + diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index 134cbd398c..fb392191d4 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -20,10 +20,6 @@ ARTICLE: "arithmetic-functions" "Arithmetic functions" "Computing additive and multiplicative inverses:" { $subsection neg } { $subsection recip } -"Minimum, maximum, clamping:" -{ $subsection min } -{ $subsection max } -{ $subsection clamp } "Complex conjugation:" { $subsection conjugate } "Tests:" @@ -41,7 +37,8 @@ ARTICLE: "arithmetic-functions" "Arithmetic functions" { $subsection truncate } { $subsection round } "Inexact comparison:" -{ $subsection ~ } ; +{ $subsection ~ } +"Numbers implement the " { $link "math.order" } ", therefore operations such as " { $link min } " and " { $link max } " can be used with numbers." ; ARTICLE: "power-functions" "Powers and logarithms" "Squares:" @@ -51,6 +48,7 @@ ARTICLE: "power-functions" "Powers and logarithms" { $subsection exp } { $subsection cis } { $subsection log } +"Other logarithms:" { $subsection log1+ } { $subsection log10 } "Raising a number to a power:" diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index cde1c64f94..4502e993a3 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -6,6 +6,10 @@ IN: math.functions.tests [ t ] [ 4.0000001 4.0000001 .000001 ~ ] unit-test [ f ] [ -4.0000001 4.0000001 .00001 ~ ] unit-test [ t ] [ -.0000000000001 0 .0000000001 ~ ] unit-test +[ t ] [ 100 101 -.9 ~ ] unit-test +[ f ] [ 100 120 -.09 ~ ] unit-test +[ t ] [ 0 0 -.9 ~ ] unit-test +[ f ] [ 0 10 -.9 ~ ] unit-test ! Lets get the argument order correct, eh? [ 0.0 ] [ 0.0 1.0 fatan2 ] unit-test @@ -33,9 +37,15 @@ IN: math.functions.tests [ 0.0 ] [ 1.0 log ] unit-test [ 1.0 ] [ e log ] unit-test -[ t ] [ 1 exp e = ] unit-test -[ t ] [ 1.0 exp e = ] unit-test -[ 1.0 ] [ -1 exp e * ] unit-test +[ 0.0 ] [ 1.0 log10 ] unit-test +[ 1.0 ] [ 10.0 log10 ] unit-test +[ 2.0 ] [ 100.0 log10 ] unit-test +[ 3.0 ] [ 1000.0 log10 ] unit-test +[ 4.0 ] [ 10000.0 log10 ] unit-test + +[ t ] [ 1 exp e 1.e-10 ~ ] unit-test +[ t ] [ 1.0 exp e 1.e-10 ~ ] unit-test +[ t ] [ -1 exp e * 1.0 1.e-10 ~ ] unit-test [ 1.0 ] [ 0 cosh ] unit-test [ 1.0 ] [ 0.0 cosh ] unit-test diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 0cf9467795..a31b6ee7cc 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -137,13 +137,13 @@ M: real absq sq ; inline [ - abs ] dip < ; : ~rel ( x y epsilon -- ? ) - [ [ - abs ] 2keep [ abs ] bi@ + ] dip * < ; + [ [ - abs ] 2keep [ abs ] bi@ + ] dip * <= ; : ~ ( x y epsilon -- ? ) { { [ 2over [ fp-nan? ] either? ] [ 3drop f ] } { [ dup zero? ] [ drop number= ] } - { [ dup 0 < ] [ ~rel ] } + { [ dup 0 < ] [ neg ~rel ] } [ ~abs ] } cond ; @@ -173,7 +173,11 @@ M: float log1+ dup -1.0 >= [ flog1+ ] [ 1.0 + 0.0 rect> log ] if ; inline : 10^ ( x -- y ) 10 swap ^ ; inline -: log10 ( x -- y ) log 10 log / ; inline +GENERIC: log10 ( x -- y ) foldable + +M: real log10 >float flog10 ; inline + +M: complex log10 log 10 log / ; inline GENERIC: cos ( x -- y ) foldable diff --git a/basis/math/libm/libm-docs.factor b/basis/math/libm/libm-docs.factor index abbb6f1289..64f6026f0b 100644 --- a/basis/math/libm/libm-docs.factor +++ b/basis/math/libm/libm-docs.factor @@ -6,7 +6,7 @@ ARTICLE: "math.libm" "C standard library math functions" { $warning "These functions are unsafe. The compiler special-cases them to operate on floats only. They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:" { $example "USE: math.functions" "2.0 acos ." "C{ 0.0 1.316957896924817 }" } -{ $unchecked-example "USE: math.libm" "2 facos ." "0/0." } } +{ $unchecked-example "USE: math.libm" "2.0 facos ." "0/0." } } "Trigonometric functions:" { $subsection fcos } { $subsection fsin } @@ -20,6 +20,7 @@ ARTICLE: "math.libm" "C standard library math functions" "Exponentials and logarithms:" { $subsection fexp } { $subsection flog } +{ $subsection flog10 } "Powers:" { $subsection fpow } { $subsection fsqrt } ; @@ -66,6 +67,10 @@ HELP: flog { $values { "x" real } { "y" real } } { $description "Calls the natural logarithm function from the C standard library. User code should call " { $link log } " instead." } ; +HELP: flog10 +{ $values { "x" real } { "y" real } } +{ $description "Calls the base 10 logarithm function from the C standard library. User code should call " { $link log10 } " instead." } ; + HELP: fpow { $values { "x" real } { "y" real } { "z" real } } { $description "Calls the power function (" { $snippet "z=x^y" } ") from the C standard library. User code should call " { $link ^ } " instead." } ; diff --git a/basis/math/libm/libm.factor b/basis/math/libm/libm.factor index 1ac0ec0ae7..0288894081 100644 --- a/basis/math/libm/libm.factor +++ b/basis/math/libm/libm.factor @@ -1,59 +1,62 @@ ! Copyright (C) 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien ; +USING: alien alien.c-types ; IN: math.libm : facos ( x -- y ) - "double" "libm" "acos" { "double" } alien-invoke ; + double "libm" "acos" { double } alien-invoke ; : fasin ( x -- y ) - "double" "libm" "asin" { "double" } alien-invoke ; + double "libm" "asin" { double } alien-invoke ; : fatan ( x -- y ) - "double" "libm" "atan" { "double" } alien-invoke ; + double "libm" "atan" { double } alien-invoke ; : fatan2 ( x y -- z ) - "double" "libm" "atan2" { "double" "double" } alien-invoke ; + double "libm" "atan2" { double double } alien-invoke ; : fcos ( x -- y ) - "double" "libm" "cos" { "double" } alien-invoke ; + double "libm" "cos" { double } alien-invoke ; : fsin ( x -- y ) - "double" "libm" "sin" { "double" } alien-invoke ; + double "libm" "sin" { double } alien-invoke ; : ftan ( x -- y ) - "double" "libm" "tan" { "double" } alien-invoke ; + double "libm" "tan" { double } alien-invoke ; : fcosh ( x -- y ) - "double" "libm" "cosh" { "double" } alien-invoke ; + double "libm" "cosh" { double } alien-invoke ; : fsinh ( x -- y ) - "double" "libm" "sinh" { "double" } alien-invoke ; + double "libm" "sinh" { double } alien-invoke ; : ftanh ( x -- y ) - "double" "libm" "tanh" { "double" } alien-invoke ; + double "libm" "tanh" { double } alien-invoke ; : fexp ( x -- y ) - "double" "libm" "exp" { "double" } alien-invoke ; + double "libm" "exp" { double } alien-invoke ; : flog ( x -- y ) - "double" "libm" "log" { "double" } alien-invoke ; + double "libm" "log" { double } alien-invoke ; + +: flog10 ( x -- y ) + double "libm" "log10" { double } alien-invoke ; : fpow ( x y -- z ) - "double" "libm" "pow" { "double" "double" } alien-invoke ; + double "libm" "pow" { double double } alien-invoke ; : fsqrt ( x -- y ) - "double" "libm" "sqrt" { "double" } alien-invoke ; + double "libm" "sqrt" { double } alien-invoke ; ! Windows doesn't have these... : flog1+ ( x -- y ) - "double" "libm" "log1p" { "double" } alien-invoke ; + double "libm" "log1p" { double } alien-invoke ; : facosh ( x -- y ) - "double" "libm" "acosh" { "double" } alien-invoke ; + double "libm" "acosh" { double } alien-invoke ; : fasinh ( x -- y ) - "double" "libm" "asinh" { "double" } alien-invoke ; + double "libm" "asinh" { double } alien-invoke ; : fatanh ( x -- y ) - "double" "libm" "atanh" { "double" } alien-invoke ; + double "libm" "atanh" { double } alien-invoke ; diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index 6679e81fcd..e72d77ee1f 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -147,7 +147,7 @@ SYMBOL: fast-math-ops : math-both-known? ( word left right -- ? ) 3dup math-op [ 2drop 2drop t ] - [ drop math-class-max swap specific-method >boolean ] if ; + [ drop math-class-max swap method-for-class >boolean ] if ; : (derived-ops) ( word assoc -- words ) swap '[ swap first _ eq? nip ] assoc-filter ; @@ -197,6 +197,12 @@ SYMBOL: fast-math-ops \ <= define-math-ops \ > define-math-ops \ >= define-math-ops + + \ u< define-math-ops + \ u<= define-math-ops + \ u> define-math-ops + \ u>= define-math-ops + \ number= define-math-ops { { shift bignum bignum } bignum-shift } , diff --git a/basis/math/vectors/simd/functor/functor.factor b/basis/math/vectors/simd/functor/functor.factor index cabb731fef..641585a5d7 100644 --- a/basis/math/vectors/simd/functor/functor.factor +++ b/basis/math/vectors/simd/functor/functor.factor @@ -9,14 +9,16 @@ ERROR: bad-length got expected ; FUNCTOR: define-simd-128 ( T -- ) -N [ 16 T heap-size /i ] +T-TYPE IS ${T} + +N [ 16 T-TYPE heap-size /i ] A DEFINES-CLASS ${T}-${N} >A DEFINES >${A} A{ DEFINES ${A}{ -NTH [ T dup c-type-getter-boxer array-accessor ] -SET-NTH [ T dup c-setter array-accessor ] +NTH [ T-TYPE dup c-type-getter-boxer array-accessor ] +SET-NTH [ T-TYPE dup c-setter array-accessor ] A-rep IS ${A}-rep A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op @@ -74,7 +76,9 @@ PRIVATE> ! Synthesize 256-bit vectors from a pair of 128-bit vectors FUNCTOR: define-simd-256 ( T -- ) -N [ 32 T heap-size /i ] +T-TYPE IS ${T} + +N [ 32 T-TYPE heap-size /i ] N/2 [ N 2 / ] A/2 IS ${T}-${N/2} diff --git a/basis/math/vectors/simd/intrinsics/intrinsics.factor b/basis/math/vectors/simd/intrinsics/intrinsics.factor index 28547f8cf9..914d1ef169 100644 --- a/basis/math/vectors/simd/intrinsics/intrinsics.factor +++ b/basis/math/vectors/simd/intrinsics/intrinsics.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel alien alien.c-types cpu.architecture libc ; +USING: kernel alien alien.data cpu.architecture libc ; IN: math.vectors.simd.intrinsics ERROR: bad-simd-call ; diff --git a/basis/math/vectors/simd/simd.factor b/basis/math/vectors/simd/simd.factor index 7df9b2d8d2..a3c99ae217 100644 --- a/basis/math/vectors/simd/simd.factor +++ b/basis/math/vectors/simd/simd.factor @@ -5,6 +5,8 @@ kernel math math.functions math.vectors math.vectors.simd.functor math.vectors.simd.intrinsics math.vectors.specialization parser prettyprint.custom sequences sequences.private locals assocs words fry ; +FROM: alien.c-types => float ; +QUALIFIED-WITH: math m IN: math.vectors.simd << @@ -15,9 +17,9 @@ DEFER: float-8 DEFER: double-4 "double" define-simd-128 -"float" define-simd-128 +"float" define-simd-128 "double" define-simd-256 -"float" define-simd-256 +"float" define-simd-256 >> @@ -136,7 +138,7 @@ DEFER: double-4 PRIVATE> -\ float-4 \ float-4-with float H{ +\ float-4 \ float-4-with m:float H{ { v+ [ [ (simd-v+) ] float-4-vv->v-op ] } { v- [ [ (simd-v-) ] float-4-vv->v-op ] } { v* [ [ (simd-v*) ] float-4-vv->v-op ] } @@ -146,7 +148,7 @@ PRIVATE> { sum [ [ (simd-sum) ] float-4-v->n-op ] } } simd-vector-words -\ double-2 \ double-2-with float H{ +\ double-2 \ double-2-with m:float H{ { v+ [ [ (simd-v+) ] double-2-vv->v-op ] } { v- [ [ (simd-v-) ] double-2-vv->v-op ] } { v* [ [ (simd-v*) ] double-2-vv->v-op ] } @@ -156,7 +158,7 @@ PRIVATE> { sum [ [ (simd-sum) ] double-2-v->n-op ] } } simd-vector-words -\ float-8 \ float-8-with float H{ +\ float-8 \ float-8-with m:float H{ { v+ [ [ (simd-v+) ] float-8-vv->v-op ] } { v- [ [ (simd-v-) ] float-8-vv->v-op ] } { v* [ [ (simd-v*) ] float-8-vv->v-op ] } @@ -166,7 +168,7 @@ PRIVATE> { sum [ [ (simd-sum) ] [ + ] float-8-v->n-op ] } } simd-vector-words -\ double-4 \ double-4-with float H{ +\ double-4 \ double-4-with m:float H{ { v+ [ [ (simd-v+) ] double-4-vv->v-op ] } { v- [ [ (simd-v-) ] double-4-vv->v-op ] } { v* [ [ (simd-v*) ] double-4-vv->v-op ] } diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index 75f327664d..cdf68cebd3 100755 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -8,6 +8,7 @@ math.parser opengl.gl combinators combinators.smart arrays sequences splitting words byte-arrays assocs vocabs colors colors.constants accessors generalizations locals fry specialized-arrays ; +FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float SPECIALIZED-ARRAY: uint IN: opengl diff --git a/basis/opengl/shaders/shaders.factor b/basis/opengl/shaders/shaders.factor index 26ffd0cf88..562cbc91ce 100755 --- a/basis/opengl/shaders/shaders.factor +++ b/basis/opengl/shaders/shaders.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: kernel opengl.gl alien.c-types continuations namespaces -assocs alien alien.strings libc opengl math sequences combinators +assocs alien alien.data alien.strings libc opengl math sequences combinators macros arrays io.encodings.ascii fry specialized-arrays destructors accessors ; SPECIALIZED-ARRAY: uint diff --git a/basis/openssl/libcrypto/libcrypto.factor b/basis/openssl/libcrypto/libcrypto.factor index 0eba1d2854..df9955a53c 100644 --- a/basis/openssl/libcrypto/libcrypto.factor +++ b/basis/openssl/libcrypto/libcrypto.factor @@ -5,8 +5,8 @@ ! ! export LD_LIBRARY_PATH=/opt/local/lib -USING: alien alien.syntax combinators kernel system -alien.libraries ; +USING: alien alien.c-types alien.syntax combinators kernel system +alien.libraries classes.struct ; IN: openssl.libcrypto @@ -20,35 +20,35 @@ IN: openssl.libcrypto } cond >> -C-STRUCT: bio-method - { "int" "type" } - { "void*" "name" } - { "void*" "bwrite" } - { "void*" "bread" } - { "void*" "bputs" } - { "void*" "bgets" } - { "void*" "ctrl" } - { "void*" "create" } - { "void*" "destroy" } - { "void*" "callback-ctrl" } ; +STRUCT: bio-method + { type int } + { name void* } + { bwrite void* } + { bread void* } + { bputs void* } + { bgets void* } + { ctrl void* } + { create void* } + { destroy void* } + { callback-ctrl void* } ; -C-STRUCT: bio - { "void*" "method" } - { "void*" "callback" } - { "void*" "cb-arg" } - { "int" "init" } - { "int" "shutdown" } - { "int" "flags" } - { "int" "retry-reason" } - { "int" "num" } - { "void*" "ptr" } - { "void*" "next-bio" } - { "void*" "prev-bio" } - { "int" "references" } - { "ulong" "num-read" } - { "ulong" "num-write" } - { "void*" "crypto-ex-data-stack" } - { "int" "crypto-ex-data-dummy" } ; +STRUCT: bio + { method void* } + { callback void* } + { cb-arg void* } + { init int } + { shutdown int } + { flags int } + { retry-reason int } + { num int } + { ptr void* } + { next-bio void* } + { prev-bio void* } + { references int } + { num-read ulong } + { num-write ulong } + { crypto-ex-data-stack void* } + { crypto-ex-data-dummy int } ; CONSTANT: BIO_NOCLOSE HEX: 00 CONSTANT: BIO_CLOSE HEX: 01 @@ -103,11 +103,11 @@ FUNCTION: void* BIO_f_buffer ( ) ; CONSTANT: EVP_MAX_MD_SIZE 64 -C-STRUCT: EVP_MD_CTX - { "EVP_MD*" "digest" } - { "ENGINE*" "engine" } - { "ulong" "flags" } - { "void*" "md_data" } ; +STRUCT: EVP_MD_CTX + { digest EVP_MD* } + { engine ENGINE* } + { flags ulong } + { md_data void* } ; TYPEDEF: void* EVP_MD* TYPEDEF: void* ENGINE* diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 90e2388934..cba40bbff1 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -45,7 +45,23 @@ M: method-body pprint* ] "" make ] [ word-style ] bi styled-text ; -M: real pprint* number>string text ; +M: real pprint* + number-base get { + { 16 [ \ HEX: [ 16 >base text ] pprint-prefix ] } + { 8 [ \ OCT: [ 8 >base text ] pprint-prefix ] } + { 2 [ \ BIN: [ 2 >base text ] pprint-prefix ] } + [ drop number>string text ] + } case ; + +M: float pprint* + dup fp-nan? [ + \ NAN: [ fp-nan-payload >hex text ] pprint-prefix + ] [ + number-base get { + { 16 [ \ HEX: [ 16 >base text ] pprint-prefix ] } + [ drop number>string text ] + } case + ] if ; M: f pprint* drop \ f pprint-word ; diff --git a/basis/prettyprint/config/config-docs.factor b/basis/prettyprint/config/config-docs.factor index 1dcb1b5617..ccc63c61cb 100644 --- a/basis/prettyprint/config/config-docs.factor +++ b/basis/prettyprint/config/config-docs.factor @@ -19,6 +19,9 @@ HELP: length-limit HELP: line-limit { $var-description "The maximum number of lines output by the prettyprinter before output is truncated with \"...\". The default is " { $link f } ", denoting unlimited line count." } ; +HELP: number-base +{ $var-description "The number base in which the prettyprinter will output numeric literals. A value of " { $snippet "2" } " will print integers and ratios in binary with " { $link POSTPONE: BIN: } ", and " { $snippet "8" } " will print them in octal with " { $link POSTPONE: OCT: } ". A value of " { $snippet "16" } " will print all integers, ratios, and floating-point values in hexadecimal with " { $link POSTPONE: HEX: } ". Other values of " { $snippet "number-base" } " will print numbers in decimal, which is the default." } ; + HELP: string-limit? { $var-description "Toggles whether printed strings are truncated to the margin." } ; diff --git a/basis/prettyprint/config/config.factor b/basis/prettyprint/config/config.factor index d42b134d4c..dd61e3e23d 100644 --- a/basis/prettyprint/config/config.factor +++ b/basis/prettyprint/config/config.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic assocs io kernel math -namespaces sequences strings io.styles vectors words +namespaces sequences strings vectors words continuations ; IN: prettyprint.config @@ -11,9 +11,11 @@ SYMBOL: margin SYMBOL: nesting-limit SYMBOL: length-limit SYMBOL: line-limit +SYMBOL: number-base SYMBOL: string-limit? SYMBOL: boa-tuples? SYMBOL: c-object-pointers? 4 tab-size set-global 64 margin set-global +10 number-base set-global diff --git a/basis/prettyprint/prettyprint-docs.factor b/basis/prettyprint/prettyprint-docs.factor index 7c114f2e22..1560b208ab 100644 --- a/basis/prettyprint/prettyprint-docs.factor +++ b/basis/prettyprint/prettyprint-docs.factor @@ -28,6 +28,7 @@ ARTICLE: "prettyprint-variables" "Prettyprint control variables" { $subsection nesting-limit } { $subsection length-limit } { $subsection line-limit } +{ $subsection number-base } { $subsection string-limit? } { $subsection boa-tuples? } { $subsection c-object-pointers? } @@ -202,8 +203,8 @@ HELP: .o { $description "Outputs an integer in octal." } ; HELP: .h -{ $values { "n" "an integer" } } -{ $description "Outputs an integer in hexadecimal." } ; +{ $values { "n" "an integer or floating-point value" } } +{ $description "Outputs an integer or floating-point value in hexadecimal." } ; HELP: stack. { $values { "seq" "a sequence" } } diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index b3897960f0..db3331305e 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -8,7 +8,15 @@ listener ; IN: prettyprint.tests [ "4" ] [ 4 unparse ] unit-test +[ "4096" ] [ 4096 unparse ] unit-test +[ "BIN: 1000000000000" ] [ 2 number-base [ 4096 unparse ] with-variable ] unit-test +[ "OCT: 10000" ] [ 8 number-base [ 4096 unparse ] with-variable ] unit-test +[ "HEX: 1000" ] [ 16 number-base [ 4096 unparse ] with-variable ] unit-test [ "1.0" ] [ 1.0 unparse ] unit-test +[ "8.0" ] [ 8.0 unparse ] unit-test +[ "8.0" ] [ 2 number-base [ 8.0 unparse ] with-variable ] unit-test +[ "8.0" ] [ 8 number-base [ 8.0 unparse ] with-variable ] unit-test +[ "HEX: 1.0p3" ] [ 16 number-base [ 8.0 unparse ] with-variable ] unit-test [ "1267650600228229401496703205376" ] [ 1 100 shift unparse ] unit-test [ "+" ] [ \ + unparse ] unit-test diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index 83b1fab0d0..d959b191c9 100644 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -1,4 +1,4 @@ -USING: accessors alien.c-types byte-arrays +USING: accessors alien.c-types alien.data byte-arrays combinators.short-circuit continuations destructors init kernel locals namespaces random windows.advapi32 windows.errors windows.kernel32 math.bitwise ; diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index ebc21eec56..5d88f42d50 100755 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -4,7 +4,8 @@ specialized-arrays.private sequences alien.c-types accessors kernel arrays combinators compiler compiler.units classes.struct combinators.smart compiler.tree.debugger math libc destructors sequences.private multiline eval words vocabs namespaces -assocs prettyprint ; +assocs prettyprint alien.data ; +FROM: alien.c-types => float ; SPECIALIZED-ARRAY: int SPECIALIZED-ARRAY: bool @@ -100,12 +101,12 @@ SPECIALIZED-ARRAY: test-struct ] unit-test ! Regression -STRUCT: fixed-string { text char[100] } ; +STRUCT: fixed-string { text char[64] } ; SPECIALIZED-ARRAY: fixed-string -[ { ALIEN: 123 ALIEN: 223 ALIEN: 323 ALIEN: 423 } ] [ - ALIEN: 123 4 [ (underlying)>> ] { } map-as +[ { ALIEN: 100 ALIEN: 140 ALIEN: 180 ALIEN: 1c0 } ] [ + ALIEN: 100 4 [ (underlying)>> ] { } map-as ] unit-test ! Ensure that byte-length works with direct arrays diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index 15245cc710..6931c83677 100755 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.c-types assocs byte-arrays classes -compiler.units functors kernel lexer libc math +USING: accessors alien alien.c-types alien.data alien.parser assocs +byte-arrays classes compiler.units functors kernel lexer libc math math.vectors.specialization namespaces parser prettyprint.custom sequences sequences.private strings summary vocabs vocabs.loader vocabs.parser words fry combinators ; @@ -103,13 +103,21 @@ A T c-type-boxed-class f specialize-vector-words ;FUNCTOR +GENERIC: (underlying-type) ( c-type -- c-type' ) + +M: string (underlying-type) c-types get at ; +M: word (underlying-type) "c-type" word-prop ; + : underlying-type ( c-type -- c-type' ) - dup c-types get at { + dup (underlying-type) { { [ dup not ] [ drop no-c-type ] } - { [ dup string? ] [ nip underlying-type ] } + { [ dup c-type-name? ] [ nip underlying-type ] } [ drop ] } cond ; +: underlying-type-name ( c-type -- name ) + underlying-type dup word? [ name>> ] when ; + : specialized-array-vocab ( c-type -- vocab ) "specialized-arrays.instances." prepend ; @@ -125,31 +133,31 @@ PRIVATE> ] ?if ; inline : define-array-vocab ( type -- vocab ) - underlying-type + underlying-type-name [ specialized-array-vocab ] [ '[ _ define-array ] ] bi generate-vocab ; -M: string require-c-array define-array-vocab drop ; +M: c-type-name require-c-array define-array-vocab drop ; ERROR: specialized-array-vocab-not-loaded c-type ; -M: string c-array-constructor - underlying-type +M: c-type-name c-array-constructor + underlying-type-name dup [ "<" "-array>" surround ] [ specialized-array-vocab ] bi lookup [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable -M: string c-(array)-constructor - underlying-type +M: c-type-name c-(array)-constructor + underlying-type-name dup [ "(" "-array)" surround ] [ specialized-array-vocab ] bi lookup [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable -M: string c-direct-array-constructor - underlying-type +M: c-type-name c-direct-array-constructor + underlying-type-name dup [ "" surround ] [ specialized-array-vocab ] bi lookup [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable SYNTAX: SPECIALIZED-ARRAY: - scan define-array-vocab use-vocab ; + scan-c-type define-array-vocab use-vocab ; "prettyprint" vocab [ "specialized-arrays.prettyprint" require diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index da559abd78..3d150adf91 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/basis/stack-checker/alien/alien.factor @@ -19,7 +19,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; : alien-stack ( params extra -- ) over parameters>> length + consume-d >>in-d - dup return>> "void" = 0 1 ? produce-d >>out-d + dup return>> void? 0 1 ? produce-d >>out-d drop ; : return-prep-quot ( node -- quot ) diff --git a/basis/stack-checker/errors/errors-docs.factor b/basis/stack-checker/errors/errors-docs.factor index 6a67b815cd..e451c53c71 100755 --- a/basis/stack-checker/errors/errors-docs.factor +++ b/basis/stack-checker/errors/errors-docs.factor @@ -1,14 +1,43 @@ USING: help.markup help.syntax kernel effects sequences -sequences.private words ; +sequences.private words combinators ; IN: stack-checker.errors +HELP: do-not-compile +{ $error-description "Thrown when inference encounters a macro being applied to a value which is not known to be a literal. Such code needs changes before it can compile and run. See " { $link "inference-combinators" } " and " { $link "inference-escape" } " for details." } +{ $examples + "In this example, " { $link cleave } " is being applied to an array that is constructed on the fly. This is not allowed and fails to compile with a " { $link do-not-compile } " error:" + { $code + ": cannot-compile-call-example ( x -- y z )" + " [ 1 + ] [ 1 - ] 2array cleave ;" + } +} ; + HELP: literal-expected { $error-description "Thrown when inference encounters a combinator or macro being applied to a value which is not known to be a literal, or constructed in a manner which can be analyzed statically. Such code needs changes before it can compile and run. See " { $link "inference-combinators" } " and " { $link "inference-escape" } " for details." } { $examples - "In this example, words calling " { $snippet "literal-expected-example" } " will have a static stac keffect, even if " { $snippet "literal-expected-example" } " does not:" + "In this example, the words being defined cannot be called, because they fail to compile with a " { $link literal-expected } " error:" { $code - ": literal-expected-example ( quot -- )" + ": bad-example ( quot -- )" + " [ call ] [ call ] bi ;" + "" + ": usage ( -- )" + " 10 [ 2 * ] bad-example . ;" + } + "One fix is to declare the combinator as inline:" + { $code + ": good-example ( quot -- )" " [ call ] [ call ] bi ; inline" + "" + ": usage ( -- )" + " 10 [ 2 * ] good-example . ;" + } + "Another fix is to use " { $link POSTPONE: call( } ":" + { $code + ": good-example ( quot -- )" + " [ call( x -- y ) ] [ call( x -- y ) ] bi ;" + "" + ": usage ( -- )" + " 10 [ 2 * ] good-example . ;" } } ; @@ -89,7 +118,8 @@ ARTICLE: "inference-errors" "Stack checker errors" { { $link "tools.inference" } " throws them as errors" } { "The " { $link "compiler" } " reports them via " { $link "tools.errors" } } } -"Error thrown when insufficient information is available to calculate the stack effect of a combinator call (see " { $link "inference-combinators" } "):" +"Errors thrown when insufficient information is available to calculate the stack effect of a call to a combinator or macro (see " { $link "inference-combinators" } "):" +{ $subsection do-not-compile } { $subsection literal-expected } "Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:" { $subsection effect-error } diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index ea8f6f5f49..0de957b785 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -455,12 +455,12 @@ M: bad-executable summary \ float/f { float float } { float } define-primitive \ float/f make-foldable -\ float< { float float } { object } define-primitive -\ float< make-foldable - \ float-mod { float float } { float } define-primitive \ float-mod make-foldable +\ float< { float float } { object } define-primitive +\ float< make-foldable + \ float<= { float float } { object } define-primitive \ float<= make-foldable @@ -470,6 +470,18 @@ M: bad-executable summary \ float>= { float float } { object } define-primitive \ float>= make-foldable +\ float-u< { float float } { object } define-primitive +\ float-u< make-foldable + +\ float-u<= { float float } { object } define-primitive +\ float-u<= make-foldable + +\ float-u> { float float } { object } define-primitive +\ float-u> make-foldable + +\ float-u>= { float float } { object } define-primitive +\ float-u>= make-foldable + \ { object object } { word } define-primitive \ make-flushable diff --git a/extra/system-info/backend/authors.txt b/basis/system-info/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from extra/system-info/backend/authors.txt rename to basis/system-info/authors.txt diff --git a/extra/system-info/linux/authors.txt b/basis/system-info/backend/authors.txt similarity index 100% rename from extra/system-info/linux/authors.txt rename to basis/system-info/backend/authors.txt diff --git a/extra/system-info/backend/backend.factor b/basis/system-info/backend/backend.factor similarity index 100% rename from extra/system-info/backend/backend.factor rename to basis/system-info/backend/backend.factor diff --git a/extra/system-info/macosx/authors.txt b/basis/system-info/linux/authors.txt similarity index 100% rename from extra/system-info/macosx/authors.txt rename to basis/system-info/linux/authors.txt diff --git a/extra/system-info/linux/linux.factor b/basis/system-info/linux/linux.factor similarity index 100% rename from extra/system-info/linux/linux.factor rename to basis/system-info/linux/linux.factor diff --git a/extra/system-info/linux/tags.txt b/basis/system-info/linux/tags.txt similarity index 100% rename from extra/system-info/linux/tags.txt rename to basis/system-info/linux/tags.txt diff --git a/extra/system-info/windows/authors.txt b/basis/system-info/macosx/authors.txt similarity index 100% rename from extra/system-info/windows/authors.txt rename to basis/system-info/macosx/authors.txt diff --git a/extra/system-info/macosx/macosx.factor b/basis/system-info/macosx/macosx.factor similarity index 100% rename from extra/system-info/macosx/macosx.factor rename to basis/system-info/macosx/macosx.factor diff --git a/extra/system-info/macosx/tags.txt b/basis/system-info/macosx/tags.txt similarity index 100% rename from extra/system-info/macosx/tags.txt rename to basis/system-info/macosx/tags.txt diff --git a/extra/system-info/summary.txt b/basis/system-info/summary.txt similarity index 100% rename from extra/system-info/summary.txt rename to basis/system-info/summary.txt diff --git a/extra/system-info/system-info.factor b/basis/system-info/system-info.factor similarity index 100% rename from extra/system-info/system-info.factor rename to basis/system-info/system-info.factor diff --git a/extra/system-info/windows/ce/authors.txt b/basis/system-info/windows/authors.txt similarity index 100% rename from extra/system-info/windows/ce/authors.txt rename to basis/system-info/windows/authors.txt diff --git a/extra/system-info/windows/nt/authors.txt b/basis/system-info/windows/ce/authors.txt similarity index 100% rename from extra/system-info/windows/nt/authors.txt rename to basis/system-info/windows/ce/authors.txt diff --git a/extra/system-info/windows/ce/ce.factor b/basis/system-info/windows/ce/ce.factor similarity index 93% rename from extra/system-info/windows/ce/ce.factor rename to basis/system-info/windows/ce/ce.factor index 13c7cb9433..8c4f81a117 100755 --- a/extra/system-info/windows/ce/ce.factor +++ b/basis/system-info/windows/ce/ce.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types system-info kernel math namespaces +USING: alien.c-types alien.data system-info kernel math namespaces windows windows.kernel32 system-info.backend system ; IN: system-info.windows.ce diff --git a/extra/system-info/windows/ce/tags.txt b/basis/system-info/windows/ce/tags.txt similarity index 100% rename from extra/system-info/windows/ce/tags.txt rename to basis/system-info/windows/ce/tags.txt diff --git a/basis/system-info/windows/nt/authors.txt b/basis/system-info/windows/nt/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/system-info/windows/nt/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/system-info/windows/nt/nt.factor b/basis/system-info/windows/nt/nt.factor similarity index 100% rename from extra/system-info/windows/nt/nt.factor rename to basis/system-info/windows/nt/nt.factor diff --git a/extra/system-info/windows/nt/tags.txt b/basis/system-info/windows/nt/tags.txt similarity index 100% rename from extra/system-info/windows/nt/tags.txt rename to basis/system-info/windows/nt/tags.txt diff --git a/extra/system-info/windows/tags.txt b/basis/system-info/windows/tags.txt similarity index 100% rename from extra/system-info/windows/tags.txt rename to basis/system-info/windows/tags.txt diff --git a/extra/system-info/windows/windows.factor b/basis/system-info/windows/windows.factor similarity index 100% rename from extra/system-info/windows/windows.factor rename to basis/system-info/windows/windows.factor diff --git a/basis/tools/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor index 89ef6192c6..17743610bc 100644 --- a/basis/tools/annotations/annotations-docs.factor +++ b/basis/tools/annotations/annotations-docs.factor @@ -8,9 +8,6 @@ $nl "Printing messages when a word is called or returns:" { $subsection watch } { $subsection watch-vars } -"Starting the walker when a word is called:" -{ $subsection breakpoint } -{ $subsection breakpoint-if } "Timing words:" { $subsection reset-word-timing } { $subsection add-timing } @@ -34,14 +31,6 @@ HELP: watch { watch watch-vars reset } related-words -HELP: breakpoint -{ $values { "word" word } } -{ $description "Annotates a word definition to enter the single stepper when executed." } ; - -HELP: breakpoint-if -{ $values { "quot" { $quotation "( -- ? )" } } { "word" word } } -{ $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ; - HELP: reset { $values { "word" word } } diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index 2fb246786c..5d4a9226ce 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -2,9 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel math sorting words parser io summary quotations sequences prettyprint continuations effects -definitions compiler.units namespaces assocs tools.walker -tools.time generic inspector fry tools.continuations -locals generalizations macros ; +definitions compiler.units namespaces assocs tools.time generic +inspector fry locals generalizations macros ; IN: tools.annotations : watch-vars ( word vars -- ) dupd '[ [ _ _ ] dip (watch-vars) ] annotate ; -: breakpoint ( word -- ) - [ add-breakpoint ] annotate ; - -: breakpoint-if ( word quot -- ) - '[ [ _ [ [ break ] when ] ] dip 3append ] annotate ; - SYMBOL: word-timing word-timing [ H{ } clone ] initialize diff --git a/basis/tools/deploy/config/config-docs.factor b/basis/tools/deploy/config/config-docs.factor index bd612c644a..12016168fb 100644 --- a/basis/tools/deploy/config/config-docs.factor +++ b/basis/tools/deploy/config/config-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax words alien.c-types assocs +USING: help.markup help.syntax words alien.c-types alien.data assocs kernel math ; IN: tools.deploy.config diff --git a/basis/tools/disassembler/disassembler.factor b/basis/tools/disassembler/disassembler.factor index 0a8ab0b116..16408c0eb8 100755 --- a/basis/tools/disassembler/disassembler.factor +++ b/basis/tools/disassembler/disassembler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays byte-arrays combinators destructors generic io kernel libc math sequences system tr -vocabs.loader words ; +vocabs.loader words alien.data ; IN: tools.disassembler GENERIC: disassemble ( obj -- ) diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index 2f0456ab62..89bd5f726c 100755 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -4,7 +4,8 @@ USING: tools.disassembler namespaces combinators alien alien.syntax alien.c-types lexer parser kernel sequences layouts math math.order alien.libraries math.parser system make fry arrays libc destructors -tools.disassembler.utils splitting ; +tools.disassembler.utils splitting alien.data +classes.struct ; IN: tools.disassembler.udis << @@ -17,57 +18,57 @@ IN: tools.disassembler.udis LIBRARY: libudis86 -C-STRUCT: ud_operand - { "int" "type" } - { "uchar" "size" } - { "ulonglong" "lval" } - { "int" "base" } - { "int" "index" } - { "uchar" "offset" } - { "uchar" "scale" } ; +STRUCT: ud_operand + { type int } + { size uchar } + { lval ulonglong } + { base int } + { index int } + { offset uchar } + { scale uchar } ; -C-STRUCT: ud - { "void*" "inp_hook" } - { "uchar" "inp_curr" } - { "uchar" "inp_fill" } - { "FILE*" "inp_file" } - { "uchar" "inp_ctr" } - { "uchar*" "inp_buff" } - { "uchar*" "inp_buff_end" } - { "uchar" "inp_end" } - { "void*" "translator" } - { "ulonglong" "insn_offset" } - { "char[32]" "insn_hexcode" } - { "char[64]" "insn_buffer" } - { "uint" "insn_fill" } - { "uchar" "dis_mode" } - { "ulonglong" "pc" } - { "uchar" "vendor" } - { "struct map_entry*" "mapen" } - { "int" "mnemonic" } - { "ud_operand[3]" "operand" } - { "uchar" "error" } - { "uchar" "pfx_rex" } - { "uchar" "pfx_seg" } - { "uchar" "pfx_opr" } - { "uchar" "pfx_adr" } - { "uchar" "pfx_lock" } - { "uchar" "pfx_rep" } - { "uchar" "pfx_repe" } - { "uchar" "pfx_repne" } - { "uchar" "pfx_insn" } - { "uchar" "default64" } - { "uchar" "opr_mode" } - { "uchar" "adr_mode" } - { "uchar" "br_far" } - { "uchar" "br_near" } - { "uchar" "implicit_addr" } - { "uchar" "c1" } - { "uchar" "c2" } - { "uchar" "c3" } - { "uchar[256]" "inp_cache" } - { "uchar[64]" "inp_sess" } - { "ud_itab_entry*" "itab_entry" } ; +STRUCT: ud + { inp_hook void* } + { inp_curr uchar } + { inp_fill uchar } + { inp_file FILE* } + { inp_ctr uchar } + { inp_buff uchar* } + { inp_buff_end uchar* } + { inp_end uchar } + { translator void* } + { insn_offset ulonglong } + { insn_hexcode char[32] } + { insn_buffer char[64] } + { insn_fill uint } + { dis_mode uchar } + { pc ulonglong } + { vendor uchar } + { mapen void* } + { mnemonic int } + { operand ud_operand[3] } + { error uchar } + { pfx_rex uchar } + { pfx_seg uchar } + { pfx_opr uchar } + { pfx_adr uchar } + { pfx_lock uchar } + { pfx_rep uchar } + { pfx_repe uchar } + { pfx_repne uchar } + { pfx_insn uchar } + { default64 uchar } + { opr_mode uchar } + { adr_mode uchar } + { br_far uchar } + { br_near uchar } + { implicit_addr uchar } + { c1 uchar } + { c2 uchar } + { c3 uchar } + { inp_cache uchar[256] } + { inp_sess uchar[64] } + { itab_entry ud_itab_entry* } ; FUNCTION: void ud_translate_intel ( ud* u ) ; FUNCTION: void ud_translate_att ( ud* u ) ; @@ -98,7 +99,7 @@ FUNCTION: uint ud_insn_len ( ud* u ) ; FUNCTION: char* ud_lookup_mnemonic ( int c ) ; : ( -- ud ) - "ud" malloc-object &free + ud malloc-struct &free dup ud_init dup cell-bits ud_set_mode dup UD_SYN_INTEL ud_set_syntax ; diff --git a/basis/tools/walker/walker-docs.factor b/basis/tools/walker/walker-docs.factor index b636760634..5a78e0cfc2 100644 --- a/basis/tools/walker/walker-docs.factor +++ b/basis/tools/walker/walker-docs.factor @@ -1,5 +1,26 @@ IN: tools.walker -USING: help.syntax help.markup tools.continuations ; +USING: help.syntax help.markup tools.continuations sequences math words ; + +HELP: breakpoint +{ $values { "word" word } } +{ $description "Annotates a word definition to enter the single stepper when executed." } ; + +HELP: breakpoint-if +{ $values { "quot" { $quotation "( -- ? )" } } { "word" word } } +{ $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ; HELP: B -{ $description "An alias for " { $link break } ", defined in the " { $vocab-link "syntax" } " vocabulary so that it is always available." } ; \ No newline at end of file +{ $description "An alias for " { $link break } ", defined in the " { $vocab-link "syntax" } " vocabulary so that it is always available." } ; + +ARTICLE: "breakpoints" "Setting breakpoints" +"In addition to invoking the walker explicitly through the UI, it is possible to set breakpoints on words using words in the " { $vocab-link "tools.walker" } " vocabulary." +$nl +"Annotating a word with a breakpoint (see " { $link "tools.annotations" } "):" +{ $subsection breakpoint } +{ $subsection breakpoint-if } +"Breakpoints can be inserted directly into code:" +{ $subsection break } +{ $subsection POSTPONE: B } +"Note that because the walker calls various core library and UI words while rendering its own user interface, setting a breakpoint on a word such as " { $link append } " or " { $link + } " will hang the UI." ; + +ABOUT: "breakpoints" diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor index 4208c4420f..19924d67e4 100644 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -5,7 +5,7 @@ sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words sequences.private assocs models models.arrow arrays accessors generic generic.standard definitions make sbufs -tools.continuations parser ; +tools.continuations parser tools.annotations fry ; IN: tools.walker SYMBOL: show-walker-hook ! ( status continuation thread -- ) @@ -158,6 +158,12 @@ SYMBOL: +stopped+ "Walker on " self name>> append spawn [ associate-thread ] keep ; +: breakpoint ( word -- ) + [ add-breakpoint ] annotate ; + +: breakpoint-if ( word quot -- ) + '[ [ _ [ [ break ] when ] ] dip 3append ] annotate ; + ! For convenience IN: syntax diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index 6ae56af030..a49d22735d 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.c-types alien.strings arrays assocs -cocoa kernel math cocoa.messages cocoa.subclassing cocoa.classes -cocoa.views cocoa.application cocoa.pasteboard cocoa.types -cocoa.windows sequences io.encodings.utf8 ui ui.private ui.gadgets -ui.gadgets.private ui.gadgets.worlds ui.gestures +USING: accessors alien alien.c-types alien.data alien.strings +arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing +cocoa.classes cocoa.views cocoa.application cocoa.pasteboard +cocoa.types cocoa.windows sequences io.encodings.utf8 ui ui.private +ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures core-foundation.strings core-graphics core-graphics.types threads combinators math.rectangles ; IN: ui.backend.cocoa.views diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 2be6e70df8..1e01f889dc 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -13,7 +13,7 @@ opengl ui.render math.bitwise locals accessors math.rectangles math.order calendar ascii sets io.encodings.utf16n windows.errors literals ui.pixel-formats ui.pixel-formats.private memoize classes -specialized-arrays classes.struct ; +specialized-arrays classes.struct alien.data ; SPECIALIZED-ARRAY: POINT IN: ui.backend.windows @@ -653,7 +653,7 @@ M: windows-ui-backend do-events : init-win32-ui ( -- ) V{ } clone nc-buttons set-global - "MSG" malloc-object msg-obj set-global + MSG malloc-struct msg-obj set-global GetDoubleClickTime milliseconds double-click-timeout set-global ; : cleanup-win32-ui ( -- ) diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index 26cbafc0d5..fb6f8153e9 100644 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -119,7 +119,7 @@ PRIVATE> [ append theme-image ] tri-curry@ tri ] 2dip ; -CONSTANT: button-background COLOR: FactorLightTan +CONSTANT: button-background COLOR: FactorTan CONSTANT: button-clicked-background COLOR: FactorDarkSlateBlue : ( -- pen ) diff --git a/basis/ui/tools/walker/walker-docs.factor b/basis/ui/tools/walker/walker-docs.factor index ce354da268..da4f345de2 100644 --- a/basis/ui/tools/walker/walker-docs.factor +++ b/basis/ui/tools/walker/walker-docs.factor @@ -23,14 +23,6 @@ ARTICLE: "ui-walker-step" "Stepping through code" $nl "The " { $link com-back } " command travels backwards through time, and restore stacks. This does not undo side effects (modifying array entries, writing to files, formatting the hard drive, etc) and therefore can only be used reliably on referentially transparent code." ; -ARTICLE: "breakpoints" "Setting breakpoints" -"In addition to invoking the walker explicitly through the UI, it is possible to set breakpoints on words. See " { $link "tools.annotations" } "." -$nl -"Breakpoints can be inserted directly into code:" -{ $subsection break } -{ $subsection POSTPONE: B } -"Note that because the walker calls various core library and UI words while rendering its own user interface, setting a breakpoint on a word such as " { $link append } " or " { $link draw-gadget } " will hang the UI." ; - ARTICLE: "ui-walker" "UI walker" "The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "." $nl diff --git a/basis/unix/bsd/macosx/macosx.factor b/basis/unix/bsd/macosx/macosx.factor index 5edd1a5093..c263be7056 100644 --- a/basis/unix/bsd/macosx/macosx.factor +++ b/basis/unix/bsd/macosx/macosx.factor @@ -1,4 +1,5 @@ -USING: alien.syntax unix.time classes.struct ; +USING: alien.c-types alien.syntax unix.time unix.types +unix.types.macosx classes.struct ; IN: unix CONSTANT: FD_SETSIZE 1024 @@ -18,15 +19,15 @@ CONSTANT: _UTX_LINESIZE 32 CONSTANT: _UTX_IDSIZE 4 CONSTANT: _UTX_HOSTSIZE 256 -C-STRUCT: utmpx - { { "char" _UTX_USERSIZE } "ut_user" } - { { "char" _UTX_IDSIZE } "ut_id" } - { { "char" _UTX_LINESIZE } "ut_line" } - { "pid_t" "ut_pid" } - { "short" "ut_type" } - { "timeval" "ut_tv" } - { { "char" _UTX_HOSTSIZE } "ut_host" } - { { "uint" 16 } "ut_pad" } ; +STRUCT: utmpx + { ut_user { char _UTX_USERSIZE } } + { ut_id { char _UTX_IDSIZE } } + { ut_line { char _UTX_LINESIZE } } + { ut_pid pid_t } + { ut_type short } + { ut_tv timeval } + { ut_host { char _UTX_HOSTSIZE } } + { ut_pad { uint 16 } } ; CONSTANT: __DARWIN_MAXPATHLEN 1024 CONSTANT: __DARWIN_MAXNAMELEN 255 @@ -37,7 +38,7 @@ STRUCT: dirent { d_reclen __uint16_t } { d_type __uint8_t } { d_namlen __uint8_t } - { d_name { "char" __DARWIN_MAXNAMELEN+1 } } ; + { d_name { char __DARWIN_MAXNAMELEN+1 } } ; CONSTANT: EPERM 1 CONSTANT: ENOENT 2 diff --git a/basis/unix/bsd/netbsd/structs/structs.factor b/basis/unix/bsd/netbsd/structs/structs.factor index f8aee1635d..1882fa830b 100644 --- a/basis/unix/bsd/netbsd/structs/structs.factor +++ b/basis/unix/bsd/netbsd/structs/structs.factor @@ -1,29 +1,30 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax unix.time classes.struct ; +USING: alien.c-types alien.syntax unix.time unix.types +unix.types.netbsd classes.struct ; IN: unix STRUCT: sockaddr_storage { ss_len __uint8_t } { ss_family sa_family_t } - { __ss_pad1 { "char" _SS_PAD1SIZE } } + { __ss_pad1 { char _SS_PAD1SIZE } } { __ss_align __int64_t } - { __ss_pad2 { "char" _SS_PAD2SIZE } } ; + { __ss_pad2 { char _SS_PAD2SIZE } } ; STRUCT: exit_struct { e_termination uint16_t } { e_exit uint16_t } ; -C-STRUCT: utmpx - { { "char" _UTX_USERSIZE } "ut_user" } - { { "char" _UTX_IDSIZE } "ut_id" } - { { "char" _UTX_LINESIZE } "ut_line" } - { { "char" _UTX_HOSTSIZE } "ut_host" } - { "uint16_t" "ut_session" } - { "uint16_t" "ut_type" } - { "pid_t" "ut_pid" } - { "exit_struct" "ut_exit" } - { "sockaddr_storage" "ut_ss" } - { "timeval" "ut_tv" } - { { "uint32_t" 10 } "ut_pad" } ; +STRUCT: utmpx + { ut_user { char _UTX_USERSIZE } } + { ut_id { char _UTX_IDSIZE } } + { ut_line { char _UTX_LINESIZE } } + { ut_host { char _UTX_HOSTSIZE } } + { ut_session uint16_t } + { ut_type uint16_t } + { ut_pid pid_t } + { ut_exit exit_struct } + { ut_ss sockaddr_storage } + { ut_tv timeval } + { ut_pad { uint32_t 10 } } ; diff --git a/basis/unix/process/process.factor b/basis/unix/process/process.factor index 131d8dda5d..2912f8b744 100644 --- a/basis/unix/process/process.factor +++ b/basis/unix/process/process.factor @@ -1,6 +1,6 @@ -USING: kernel alien.c-types alien.strings sequences math alien.syntax -unix namespaces continuations threads assocs io.backend.unix -io.encodings.utf8 unix.utilities fry ; +USING: kernel alien.c-types alien.data alien.strings sequences +math alien.syntax unix namespaces continuations threads assocs +io.backend.unix io.encodings.utf8 unix.utilities fry ; IN: unix.process ! Low-level Unix process launching utilities. These are used diff --git a/basis/unix/utilities/utilities.factor b/basis/unix/utilities/utilities.factor index 8d141ccb24..919b2ae8a2 100644 --- a/basis/unix/utilities/utilities.factor +++ b/basis/unix/utilities/utilities.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.strings +USING: alien alien.c-types alien.data alien.strings combinators.short-circuit fry kernel layouts sequences accessors specialized-arrays ; IN: unix.utilities diff --git a/basis/unix/utmpx/utmpx.factor b/basis/unix/utmpx/utmpx.factor index 6e72f7d114..6083776fc6 100644 --- a/basis/unix/utmpx/utmpx.factor +++ b/basis/unix/utmpx/utmpx.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.syntax combinators continuations -io.encodings.string io.encodings.utf8 kernel sequences strings -unix calendar system accessors unix.time calendar.unix -vocabs.loader ; +USING: alien.c-types alien.data alien.syntax combinators +continuations io.encodings.string io.encodings.utf8 kernel +sequences strings unix calendar system accessors unix.time +calendar.unix vocabs.loader classes.struct ; IN: unix.utmpx CONSTANT: EMPTY 0 @@ -39,15 +39,15 @@ M: unix new-utmpx-record utmpx-record new ; M: unix utmpx>utmpx-record ( utmpx -- utmpx-record ) - [ new-utmpx-record ] dip + [ new-utmpx-record ] dip \ utmpx memory>struct { - [ utmpx-ut_user _UTX_USERSIZE memory>string >>user ] - [ utmpx-ut_id _UTX_IDSIZE memory>string >>id ] - [ utmpx-ut_line _UTX_LINESIZE memory>string >>line ] - [ utmpx-ut_pid >>pid ] - [ utmpx-ut_type >>type ] - [ utmpx-ut_tv timeval>unix-time >>timestamp ] - [ utmpx-ut_host _UTX_HOSTSIZE memory>string >>host ] + [ ut_user>> _UTX_USERSIZE memory>string >>user ] + [ ut_id>> _UTX_IDSIZE memory>string >>id ] + [ ut_line>> _UTX_LINESIZE memory>string >>line ] + [ ut_pid>> >>pid ] + [ ut_type>> >>type ] + [ ut_tv>> timeval>unix-time >>timestamp ] + [ ut_host>> _UTX_HOSTSIZE memory>string >>host ] } cleave ; : with-utmpx ( quot -- ) diff --git a/basis/vm/authors.txt b/basis/vm/authors.txt new file mode 100644 index 0000000000..b125620d17 --- /dev/null +++ b/basis/vm/authors.txt @@ -0,0 +1 @@ +Phil Dawes \ No newline at end of file diff --git a/basis/vm/summary.txt b/basis/vm/summary.txt new file mode 100644 index 0000000000..bfa1067bc7 --- /dev/null +++ b/basis/vm/summary.txt @@ -0,0 +1 @@ +Layout of the C vm structure diff --git a/basis/vm/vm.factor b/basis/vm/vm.factor new file mode 100644 index 0000000000..ab5a98ab3c --- /dev/null +++ b/basis/vm/vm.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2009 Phil Dawes. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.structs alien.syntax ; +IN: vm + +TYPEDEF: void* cell + +C-STRUCT: zone + { "cell" "start" } + { "cell" "here" } + { "cell" "size" } + { "cell" "end" } + ; + +C-STRUCT: vm + { "context*" "stack_chain" } + { "zone" "nursery" } + { "cell" "cards_offset" } + { "cell" "decks_offset" } + { "cell[70]" "userenv" } + ; + +: vm-field-offset ( field -- offset ) "vm" offset-of ; \ No newline at end of file diff --git a/basis/vocabs/prettyprint/prettyprint.factor b/basis/vocabs/prettyprint/prettyprint.factor index 6b759dddde..40493e4e99 100644 --- a/basis/vocabs/prettyprint/prettyprint.factor +++ b/basis/vocabs/prettyprint/prettyprint.factor @@ -88,7 +88,7 @@ PRIVATE> "at the top of the source file:" print nl ] with-style { - { page-color COLOR: FactorLightLightTan } + { page-color COLOR: FactorLightTan } { border-color COLOR: FactorDarkTan } { inset { 5 5 } } } [ manifest get pprint-manifest ] with-nesting diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor index 6d80534e8c..21f048a00f 100755 --- a/basis/windows/advapi32/advapi32.factor +++ b/basis/windows/advapi32/advapi32.factor @@ -1,5 +1,5 @@ USING: alien.syntax kernel math windows.types windows.kernel32 -math.bitwise ; +math.bitwise classes.struct ; IN: windows.advapi32 LIBRARY: advapi32 @@ -62,12 +62,12 @@ CONSTANT: CRYPT_DELETEKEYSET HEX: 10 CONSTANT: CRYPT_MACHINE_KEYSET HEX: 20 CONSTANT: CRYPT_SILENT HEX: 40 -C-STRUCT: ACL - { "BYTE" "AclRevision" } - { "BYTE" "Sbz1" } - { "WORD" "AclSize" } - { "WORD" "AceCount" } - { "WORD" "Sbz2" } ; +STRUCT: ACL + { AclRevision BYTE } + { Sbz1 BYTE } + { AclSize WORD } + { AceCount WORD } + { Sbz2 WORD } ; TYPEDEF: ACL* PACL @@ -82,56 +82,56 @@ CONSTANT: NO_PROPAGATE_INHERIT_ACE HEX: 4 CONSTANT: INHERIT_ONLY_ACE HEX: 8 CONSTANT: VALID_INHERIT_FLAGS HEX: f -C-STRUCT: ACE_HEADER - { "BYTE" "AceType" } - { "BYTE" "AceFlags" } - { "WORD" "AceSize" } ; +STRUCT: ACE_HEADER + { AceType BYTE } + { AceFlags BYTE } + { AceSize WORD } ; TYPEDEF: ACE_HEADER* PACE_HEADER -C-STRUCT: ACCESS_ALLOWED_ACE - { "ACE_HEADER" "Header" } - { "DWORD" "Mask" } - { "DWORD" "SidStart" } ; +STRUCT: ACCESS_ALLOWED_ACE + { Header ACE_HEADER } + { Mask DWORD } + { SidStart DWORD } ; TYPEDEF: ACCESS_ALLOWED_ACE* PACCESS_ALLOWED_ACE -C-STRUCT: ACCESS_DENIED_ACE - { "ACE_HEADER" "Header" } - { "DWORD" "Mask" } - { "DWORD" "SidStart" } ; +STRUCT: ACCESS_DENIED_ACE + { Header ACE_HEADER } + { Mask DWORD } + { SidStart DWORD } ; TYPEDEF: ACCESS_DENIED_ACE* PACCESS_DENIED_ACE -C-STRUCT: SYSTEM_AUDIT_ACE - { "ACE_HEADER" "Header" } - { "DWORD" "Mask" } - { "DWORD" "SidStart" } ; +STRUCT: SYSTEM_AUDIT_ACE + { Header ACE_HEADER } + { Mask DWORD } + { SidStart DWORD } ; TYPEDEF: SYSTEM_AUDIT_ACE* PSYSTEM_AUDIT_ACE -C-STRUCT: SYSTEM_ALARM_ACE - { "ACE_HEADER" "Header" } - { "DWORD" "Mask" } - { "DWORD" "SidStart" } ; +STRUCT: SYSTEM_ALARM_ACE + { Header ACE_HEADER } + { Mask DWORD } + { SidStart DWORD } ; TYPEDEF: SYSTEM_ALARM_ACE* PSYSTEM_ALARM_ACE -C-STRUCT: ACCESS_ALLOWED_CALLBACK_ACE - { "ACE_HEADER" "Header" } - { "DWORD" "Mask" } - { "DWORD" "SidStart" } ; +STRUCT: ACCESS_ALLOWED_CALLBACK_ACE + { Header ACE_HEADER } + { Mask DWORD } + { SidStart DWORD } ; TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE -C-STRUCT: SECURITY_DESCRIPTOR - { "UCHAR" "Revision" } - { "UCHAR" "Sbz1" } - { "WORD" "Control" } - { "PVOID" "Owner" } - { "PVOID" "Group" } - { "PACL" "Sacl" } - { "PACL" "Dacl" } ; +STRUCT: SECURITY_DESCRIPTOR + { Revision UCHAR } + { Sbz1 UCHAR } + { Control WORD } + { Owner PVOID } + { Group PVOID } + { Sacl PACL } + { Dacl PACL } ; TYPEDEF: SECURITY_DESCRIPTOR* PSECURITY_DESCRIPTOR @@ -224,21 +224,21 @@ C-ENUM: TYPEDEF: TRUSTEE* PTRUSTEE -C-STRUCT: TRUSTEE - { "PTRUSTEE" "pMultipleTrustee" } - { "MULTIPLE_TRUSTEE_OPERATION" "MultipleTrusteeOperation" } - { "TRUSTEE_FORM" "TrusteeForm" } - { "TRUSTEE_TYPE" "TrusteeType" } - { "LPTSTR" "ptstrName" } ; +STRUCT: TRUSTEE + { pMultipleTrustee PTRUSTEE } + { MultipleTrusteeOperation MULTIPLE_TRUSTEE_OPERATION } + { TrusteeForm TRUSTEE_FORM } + { TrusteeType TRUSTEE_TYPE } + { ptstrName LPTSTR } ; -C-STRUCT: EXPLICIT_ACCESS - { "DWORD" "grfAccessPermissions" } - { "ACCESS_MODE" "grfAccessMode" } - { "DWORD" "grfInheritance" } - { "TRUSTEE" "Trustee" } ; +STRUCT: EXPLICIT_ACCESS + { grfAccessPermissions DWORD } + { grfAccessMode ACCESS_MODE } + { grfInheritance DWORD } + { Trustee TRUSTEE } ; -C-STRUCT: SID_IDENTIFIER_AUTHORITY - { { "BYTE" 6 } "Value" } ; +STRUCT: SID_IDENTIFIER_AUTHORITY + { Value { BYTE 6 } } ; TYPEDEF: SID_IDENTIFIER_AUTHORITY* PSID_IDENTIFIER_AUTHORITY diff --git a/basis/windows/com/com.factor b/basis/windows/com/com.factor index d485692a91..e06f5b6071 100644 --- a/basis/windows/com/com.factor +++ b/basis/windows/com/com.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types alien.destructors windows.com.syntax windows.ole32 windows.types continuations kernel alien.syntax -libc destructors accessors ; +libc destructors accessors alien.data ; IN: windows.com LIBRARY: ole32 diff --git a/basis/windows/com/syntax/syntax.factor b/basis/windows/com/syntax/syntax.factor index 2100d6a215..3cf8b55e39 100755 --- a/basis/windows/com/syntax/syntax.factor +++ b/basis/windows/com/syntax/syntax.factor @@ -67,7 +67,7 @@ unless : (stack-effect-from-return-and-parameters) ( return parameters -- stack-effect ) swap [ [ second ] map ] - [ dup "void" = [ drop { } ] [ 1array ] if ] bi* + [ dup void? [ drop { } ] [ 1array ] if ] bi* ; : (define-word-for-function) ( function interface n -- ) diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index e69fc5b820..e4f0ef0654 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -1,9 +1,9 @@ -USING: alien alien.c-types alien.accessors windows.com.syntax -init windows.com.syntax.private windows.com continuations kernel -namespaces windows.ole32 libc vocabs assocs accessors arrays -sequences quotations combinators math words compiler.units -destructors fry math.parser generalizations sets -specialized-arrays windows.kernel32 classes.struct ; +USING: alien alien.c-types alien.data alien.accessors +windows.com.syntax init windows.com.syntax.private windows.com +continuations kernel namespaces windows.ole32 libc vocabs +assocs accessors arrays sequences quotations combinators math +words compiler.units destructors fry math.parser generalizations +sets specialized-arrays windows.kernel32 classes.struct ; SPECIALIZED-ARRAY: void* IN: windows.com.wrapper diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor index b67b5fa08f..3c0509c49d 100755 --- a/basis/windows/dinput/constants/constants.factor +++ b/basis/windows/dinput/constants/constants.factor @@ -1,8 +1,9 @@ USING: windows.dinput windows.kernel32 windows.ole32 windows.com -windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces -combinators sequences fry math accessors macros words quotations -libc continuations generalizations splitting locals assocs init -specialized-arrays memoize classes.struct ; +windows.com.syntax alien alien.c-types alien.data alien.syntax +kernel system namespaces combinators sequences fry math accessors +macros words quotations libc continuations generalizations +splitting locals assocs init specialized-arrays memoize +classes.struct strings arrays ; SPECIALIZED-ARRAY: DIOBJECTDATAFORMAT IN: windows.dinput.constants @@ -22,12 +23,17 @@ SYMBOLS: MEMO: c-type* ( name -- c-type ) c-type ; MEMO: heap-size* ( c-type -- n ) heap-size ; +GENERIC: array-base-type ( c-type -- c-type' ) +M: object array-base-type ; +M: string array-base-type "[" split1 drop ; +M: array array-base-type first ; + : (field-spec-of) ( field struct -- field-spec ) c-type* fields>> [ name>> = ] with find nip ; : (offsetof) ( field struct -- offset ) [ (field-spec-of) offset>> ] [ drop 0 ] if* ; : (sizeof) ( field struct -- size ) - [ (field-spec-of) type>> "[" split1 drop heap-size* ] [ drop 1 ] if* ; + [ (field-spec-of) type>> array-base-type heap-size* ] [ drop 1 ] if* ; : (flag) ( thing -- integer ) { diff --git a/basis/windows/dinput/dinput.factor b/basis/windows/dinput/dinput.factor index 46317ab604..598df9a389 100755 --- a/basis/windows/dinput/dinput.factor +++ b/basis/windows/dinput/dinput.factor @@ -5,35 +5,6 @@ IN: windows.dinput LIBRARY: dinput -TYPEDEF: void* LPDIENUMDEVICESCALLBACKW -: LPDIENUMDEVICESCALLBACKW ( quot -- alien ) - [ "BOOL" { "LPCDIDEVICEINSTANCEW" "LPVOID" } "stdcall" ] - dip alien-callback ; inline -TYPEDEF: void* LPDIENUMDEVICESBYSEMANTICSCBW -: LPDIENUMDEVICESBYSEMANTICSCBW ( quot -- alien ) - [ "BOOL" { "LPCDIDEVICEINSTANCEW" "IDirectInputDevice8W*" "DWORD" "DWORD" "LPVOID" } "stdcall" ] - dip alien-callback ; inline -TYPEDEF: void* LPDICONFIGUREDEVICESCALLBACK -: LPDICONFIGUREDEVICESCALLBACK ( quot -- alien ) - [ "BOOL" { "IUnknown*" "LPVOID" } "stdcall" ] - dip alien-callback ; inline -TYPEDEF: void* LPDIENUMEFFECTSCALLBACKW -: LPDIENUMEFFECTSCALLBACKW ( quot -- alien ) - [ "BOOL" { "LPCDIEFFECTINFOW" "LPVOID" } "stdcall" ] - dip alien-callback ; inline -TYPEDEF: void* LPDIENUMCREATEDEFFECTOBJECTSCALLBACK -: LPDIENUMCREATEDEFFECTOBJECTSCALLBACK ( quot -- callback ) - [ "BOOL" { "LPDIRECTINPUTEFFECT" "LPVOID" } "stdcall" ] - dip alien-callback ; inline -TYPEDEF: void* LPDIENUMEFFECTSINFILECALLBACK -: LPDIENUMEFFECTSINFILECALLBACK ( quot -- callback ) - [ "BOOL" { "LPCDIFILEEFFECT" "LPVOID" } "stdcall" ] - dip alien-callback ; inline -TYPEDEF: void* LPDIENUMDEVICEOBJECTSCALLBACKW -: LPDIENUMDEVICEOBJECTSCALLBACKW ( quot -- callback ) - [ "BOOL" { "LPCDIDEVICEOBJECTINSTANCEW" "LPVOID" } "stdcall" ] - dip alien-callback ; inline - TYPEDEF: DWORD D3DCOLOR STRUCT: DIDEVICEINSTANCEW @@ -326,6 +297,27 @@ STRUCT: DIJOYSTATE2 TYPEDEF: DIJOYSTATE2* LPDIJOYSTATE2 TYPEDEF: DIJOYSTATE2* LPCDIJOYSTATE2 +STDCALL-CALLBACK: BOOL LPDIENUMDEVICESCALLBACKW ( + LPCDIDEVICEINSTANCEW lpddi, + LPVOID pvRef +) ; +STDCALL-CALLBACK: BOOL LPDICONFIGUREDEVICESCALLBACK ( + IUnknown* lpDDSTarget, + LPVOID pvRef +) ; +STDCALL-CALLBACK: BOOL LPDIENUMEFFECTSCALLBACKW ( + LPCDIEFFECTINFOW pdei, + LPVOID pvRef +) ; +STDCALL-CALLBACK: BOOL LPDIENUMEFFECTSINFILECALLBACK ( + LPCDIFILEEFFECT lpDiFileEf, + LPVOID pvRef +) ; +STDCALL-CALLBACK: BOOL LPDIENUMDEVICEOBJECTSCALLBACKW ( + LPCDIDEVICEOBJECTINSTANCEW lpddoi, + LPVOID pvRef +) ; + COM-INTERFACE: IDirectInputEffect IUnknown {E7E1F7C0-88D2-11D0-9AD0-00A0C9A06E35} HRESULT Initialize ( HINSTANCE hinst, DWORD dwVersion, REFGUID rguid ) HRESULT GetEffectGuid ( LPGUID pguid ) @@ -338,6 +330,11 @@ COM-INTERFACE: IDirectInputEffect IUnknown {E7E1F7C0-88D2-11D0-9AD0-00A0C9A06E35 HRESULT Unload ( ) HRESULT Escape ( LPDIEFFESCAPE pesc ) ; +STDCALL-CALLBACK: BOOL LPDIENUMCREATEDEFFECTOBJECTSCALLBACK ( + IDirectInputEffect* peff, + LPVOID pvRef +) ; + COM-INTERFACE: IDirectInputDevice8W IUnknown {54D41081-DC15-4833-A41B-748F73A38179} HRESULT GetCapabilities ( LPDIDEVCAPS lpDIDeviceCaps ) HRESULT EnumObjects ( LPDIENUMDEVICEOBJECTSCALLBACKW lpCallback, LPVOID pvRef, DWORD dwFlags ) @@ -369,6 +366,14 @@ COM-INTERFACE: IDirectInputDevice8W IUnknown {54D41081-DC15-4833-A41B-748F73A381 HRESULT SetActionMap ( LPDIACTIONFORMATW lpdiActionFormat, LPCWSTR lpwszUserName, DWORD dwFlags ) HRESULT GetImageInfo ( LPDIDEVICEIMAGEINFOHEADERW lpdiDeviceImageInfoHeader ) ; +STDCALL-CALLBACK: BOOL LPDIENUMDEVICESBYSEMANTICSCBW ( + LPCDIDEVICEINSTANCEW lpddi, + IDirectInputDevice8W* lpdid, + DWORD dwFlags, + DWORD dwRemaining, + LPVOID pvRef +) ; + COM-INTERFACE: IDirectInput8W IUnknown {BF798031-483A-4DA2-AA99-5D64ED369700} HRESULT CreateDevice ( REFGUID rguid, IDirectInputDevice8W** lplpDevice, LPUNKNOWN pUnkOuter ) HRESULT EnumDevices ( DWORD dwDevType, LPDIENUMDEVICESCALLBACKW lpCallback, LPVOID pvRef, DWORD dwFlags ) diff --git a/basis/windows/dragdrop-listener/dragdrop-listener.factor b/basis/windows/dragdrop-listener/dragdrop-listener.factor index bd6512341f..3ed2256c7d 100755 --- a/basis/windows/dragdrop-listener/dragdrop-listener.factor +++ b/basis/windows/dragdrop-listener/dragdrop-listener.factor @@ -1,31 +1,30 @@ USING: alien.strings io.encodings.utf16n windows.com windows.com.wrapper combinators windows.kernel32 windows.ole32 -windows.shell32 kernel accessors +windows.shell32 kernel accessors windows.types prettyprint namespaces ui.tools.listener ui.tools.workspace -alien.c-types alien sequences math ; +alien.data alien sequences math classes.struct ; +SPECIALIZED-ARRAY: WCHAR IN: windows.dragdrop-listener -<< "WCHAR" require-c-array >> - : filenames-from-hdrop ( hdrop -- filenames ) dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files [ 2dup f 0 DragQueryFile 1 + ! get size of filename buffer - dup "WCHAR" + dup WCHAR [ swap DragQueryFile drop ] keep utf16n alien>string ] with map ; : filenames-from-data-object ( data-object -- filenames ) - "FORMATETC" - CF_HDROP over set-FORMATETC-cfFormat - f over set-FORMATETC-ptd - DVASPECT_CONTENT over set-FORMATETC-dwAspect - -1 over set-FORMATETC-lindex - TYMED_HGLOBAL over set-FORMATETC-tymed - "STGMEDIUM" + FORMATETC + CF_HDROP >>cfFormat + f >>ptd + DVASPECT_CONTENT >>dwAspect + -1 >>lindex + TYMED_HGLOBAL >>tymed + STGMEDIUM [ IDataObject::GetData ] keep swap succeeded? [ - dup STGMEDIUM-data + dup data>> [ filenames-from-hdrop ] with-global-lock swap ReleaseStgMedium ] [ drop f ] if ; diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index d2ee337726..a7a41433f7 100755 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -1,11 +1,10 @@ -USING: alien.c-types kernel locals math math.bitwise +USING: alien.data kernel locals math math.bitwise windows.kernel32 sequences byte-arrays unicode.categories io.encodings.string io.encodings.utf16n alien.strings -arrays literals ; +arrays literals windows.types specialized-arrays ; +SPECIALIZED-ARRAY: TCHAR IN: windows.errors -<< "TCHAR" require-c-array >> - CONSTANT: ERROR_SUCCESS 0 CONSTANT: ERROR_INVALID_FUNCTION 1 CONSTANT: ERROR_FILE_NOT_FOUND 2 @@ -698,8 +697,6 @@ CONSTANT: FORMAT_MESSAGE_MAX_WIDTH_MASK HEX: 000000FF : make-lang-id ( lang1 lang2 -- n ) 10 shift bitor ; inline -<< "TCHAR" require-c-array >> - ERROR: error-message-failed id ; :: n>win32-error-string ( id -- string ) { @@ -709,7 +706,7 @@ ERROR: error-message-failed id ; f id LANG_NEUTRAL SUBLANG_DEFAULT make-lang-id - 32768 [ "TCHAR" ] [ ] bi + 32768 [ TCHAR ] [ ] bi f pick [ FormatMessage 0 = [ id error-message-failed ] when ] dip utf16n alien>string [ blank? ] trim ; diff --git a/basis/windows/fonts/fonts.factor b/basis/windows/fonts/fonts.factor index b8acf5d8d1..9e113e8c3b 100755 --- a/basis/windows/fonts/fonts.factor +++ b/basis/windows/fonts/fonts.factor @@ -1,13 +1,23 @@ USING: assocs memoize locals kernel accessors init fonts math -combinators windows.errors windows.types windows.gdi32 ; +combinators system-info.windows windows.errors windows.types +windows.gdi32 ; IN: windows.fonts -: windows-font-name ( string -- string' ) +MEMO: windows-fonts ( -- fonts ) + windows-major 6 >= + H{ + { "sans-serif" "Segoe UI" } + { "serif" "Cambria" } + { "monospace" "Consolas" } + } H{ { "sans-serif" "Tahoma" } { "serif" "Times New Roman" } { "monospace" "Courier New" } - } ?at drop ; + } ? ; + +: windows-font-name ( string -- string' ) + windows-fonts ?at drop ; MEMO:: (cache-font) ( font -- HFONT ) font size>> neg ! nHeight diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 2cba1173d5..075b0218b3 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -317,14 +317,14 @@ STRUCT: OSVERSIONINFO TYPEDEF: void* LPOSVERSIONINFO -C-STRUCT: MEMORY_BASIC_INFORMATION - { "void*" "BaseAddress" } - { "void*" "AllocationBase" } - { "DWORD" "AllocationProtect" } - { "SIZE_T" "RegionSize" } - { "DWORD" "state" } - { "DWORD" "protect" } - { "DWORD" "type" } ; +STRUCT: MEMORY_BASIC_INFORMATION + { BaseAddress void* } + { AllocationBase void* } + { AllocationProtect DWORD } + { RegionSize SIZE_T } + { state DWORD } + { protect DWORD } + { type DWORD } ; STRUCT: GUID { Data1 ULONG } @@ -524,55 +524,55 @@ CONSTANT: EV_RX80FULL HEX: 400 CONSTANT: EV_EVENT1 HEX: 800 CONSTANT: EV_EVENT2 HEX: 1000 -C-STRUCT: DCB - { "DWORD" "DCBlength" } - { "DWORD" "BaudRate" } - { "DWORD" "flags" } - { "WORD" "wReserved" } - { "WORD" "XonLim" } - { "WORD" "XoffLim" } - { "BYTE" "ByteSize" } - { "BYTE" "Parity" } - { "BYTE" "StopBits" } - { "char" "XonChar" } - { "char" "XoffChar" } - { "char" "ErrorChar" } - { "char" "EofChar" } - { "char" "EvtChar" } - { "WORD" "wReserved1" } ; +STRUCT: DCB + { DCBlength DWORD } + { BaudRate DWORD } + { flags DWORD } + { wReserved WORD } + { XonLim WORD } + { XoffLim WORD } + { ByteSize BYTE } + { Parity BYTE } + { StopBits BYTE } + { XonChar char } + { XoffChar char } + { ErrorChar char } + { EofChar char } + { EvtChar char } + { wReserved1 WORD } ; TYPEDEF: DCB* PDCB TYPEDEF: DCB* LPDCB -C-STRUCT: COMM_CONFIG - { "DWORD" "dwSize" } - { "WORD" "wVersion" } - { "WORD" "wReserved" } - { "DCB" "dcb" } - { "DWORD" "dwProviderSubType" } - { "DWORD" "dwProviderOffset" } - { "DWORD" "dwProviderSize" } - { { "WCHAR" 1 } "wcProviderData" } ; +STRUCT: COMM_CONFIG + { dwSize DWORD } + { wVersion WORD } + { wReserved WORD } + { dcb DCB } + { dwProviderSubType DWORD } + { dwProviderOffset DWORD } + { dwProviderSize DWORD } + { wcProviderData { WCHAR 1 } } ; TYPEDEF: COMMCONFIG* LPCOMMCONFIG -C-STRUCT: COMMPROP - { "WORD" "wPacketLength" } - { "WORD" "wPacketVersion" } - { "DWORD" "dwServiceMask" } - { "DWORD" "dwReserved1" } - { "DWORD" "dwMaxTxQueue" } - { "DWORD" "dwMaxRxQueue" } - { "DWORD" "dwMaxBaud" } - { "DWORD" "dwProvSubType" } - { "DWORD" "dwProvCapabilities" } - { "DWORD" "dwSettableParams" } - { "DWORD" "dwSettableBaud" } - { "WORD" "wSettableData" } - { "WORD" "wSettableStopParity" } - { "DWORD" "dwCurrentTxQueue" } - { "DWORD" "dwCurrentRxQueue" } - { "DWORD" "dwProvSpec1" } - { "DWORD" "dwProvSpec2" } - { { "WCHAR" 1 } "wcProvChar" } ; +STRUCT: COMMPROP + { wPacketLength WORD } + { wPacketVersion WORD } + { dwServiceMask DWORD } + { dwReserved1 DWORD } + { dwMaxTxQueue DWORD } + { dwMaxRxQueue DWORD } + { dwMaxBaud DWORD } + { dwProvSubType DWORD } + { dwProvCapabilities DWORD } + { dwSettableParams DWORD } + { dwSettableBaud DWORD } + { wSettableData WORD } + { wSettableStopParity WORD } + { dwCurrentTxQueue DWORD } + { dwCurrentRxQueue DWORD } + { dwProvSpec1 DWORD } + { dwProvSpec2 DWORD } + { wcProvChar { WCHAR 1 } } ; TYPEDEF: COMMPROP* LPCOMMPROP @@ -645,19 +645,19 @@ CONSTANT: WAIT_TIMEOUT 258 CONSTANT: WAIT_IO_COMPLETION HEX: c0 CONSTANT: WAIT_FAILED HEX: ffffffff -C-STRUCT: LUID - { "DWORD" "LowPart" } - { "LONG" "HighPart" } ; +STRUCT: LUID + { LowPart DWORD } + { HighPart LONG } ; TYPEDEF: LUID* PLUID -C-STRUCT: LUID_AND_ATTRIBUTES - { "LUID" "Luid" } - { "DWORD" "Attributes" } ; +STRUCT: LUID_AND_ATTRIBUTES + { Luid LUID } + { Attributes DWORD } ; TYPEDEF: LUID_AND_ATTRIBUTES* PLUID_AND_ATTRIBUTES -C-STRUCT: TOKEN_PRIVILEGES - { "DWORD" "PrivilegeCount" } - { "LUID_AND_ATTRIBUTES*" "Privileges" } ; +STRUCT: TOKEN_PRIVILEGES + { PrivilegeCount DWORD } + { Privileges LUID_AND_ATTRIBUTES* } ; TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES STRUCT: WIN32_FILE_ATTRIBUTE_DATA @@ -669,29 +669,29 @@ STRUCT: WIN32_FILE_ATTRIBUTE_DATA { nFileSizeLow DWORD } ; TYPEDEF: WIN32_FILE_ATTRIBUTE_DATA* LPWIN32_FILE_ATTRIBUTE_DATA -C-STRUCT: BY_HANDLE_FILE_INFORMATION - { "DWORD" "dwFileAttributes" } - { "FILETIME" "ftCreationTime" } - { "FILETIME" "ftLastAccessTime" } - { "FILETIME" "ftLastWriteTime" } - { "DWORD" "dwVolumeSerialNumber" } - { "DWORD" "nFileSizeHigh" } - { "DWORD" "nFileSizeLow" } - { "DWORD" "nNumberOfLinks" } - { "DWORD" "nFileIndexHigh" } - { "DWORD" "nFileIndexLow" } ; +STRUCT: BY_HANDLE_FILE_INFORMATION + { dwFileAttributes DWORD } + { ftCreationTime FILETIME } + { ftLastAccessTime FILETIME } + { ftLastWriteTime FILETIME } + { dwVolumeSerialNumber DWORD } + { nFileSizeHigh DWORD } + { nFileSizeLow DWORD } + { nNumberOfLinks DWORD } + { nFileIndexHigh DWORD } + { nFileIndexLow DWORD } ; TYPEDEF: BY_HANDLE_FILE_INFORMATION* LPBY_HANDLE_FILE_INFORMATION CONSTANT: OFS_MAXPATHNAME 128 -C-STRUCT: OFSTRUCT - { "BYTE" "cBytes" } - { "BYTE" "fFixedDisk" } - { "WORD" "nErrCode" } - { "WORD" "Reserved1" } - { "WORD" "Reserved2" } - ! { { "CHAR" OFS_MAXPATHNAME } "szPathName" } ; - { { "CHAR" 128 } "szPathName" } ; +STRUCT: OFSTRUCT + { cBytes BYTE } + { fFixedDisk BYTE } + { nErrCode WORD } + { Reserved1 WORD } + { Reserved2 WORD } + { szPathName { CHAR 128 } } ; + ! { szPathName { CHAR OFS_MAXPATHNAME } } ; TYPEDEF: OFSTRUCT* LPOFSTRUCT @@ -707,18 +707,6 @@ STRUCT: WIN32_FIND_DATA { cFileName { "TCHAR" MAX_PATH } } { cAlternateFileName TCHAR[14] } ; -STRUCT: BY_HANDLE_FILE_INFORMATION - { dwFileAttributes DWORD } - { ftCreationTime FILETIME } - { ftLastAccessTime FILETIME } - { ftLastWriteTime FILETIME } - { dwVolumeSerialNumber DWORD } - { nFileSizeHigh DWORD } - { nFileSizeLow DWORD } - { nNumberOfLinks DWORD } - { nFileIndexHigh DWORD } - { nFileIndexLow DWORD } ; - TYPEDEF: WIN32_FIND_DATA* PWIN32_FIND_DATA TYPEDEF: WIN32_FIND_DATA* LPWIN32_FIND_DATA TYPEDEF: void* POVERLAPPED diff --git a/basis/windows/offscreen/offscreen.factor b/basis/windows/offscreen/offscreen.factor index 63cfd92ba1..e38477c98c 100755 --- a/basis/windows/offscreen/offscreen.factor +++ b/basis/windows/offscreen/offscreen.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Joe Groff, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel combinators sequences -math windows.gdi32 windows.types images destructors -accessors fry locals classes.struct ; +USING: alien.c-types alien.data kernel combinators +sequences math windows.gdi32 windows.types images +destructors accessors fry locals classes.struct ; IN: windows.offscreen : (bitmap-info) ( dim -- BITMAPINFO ) diff --git a/basis/windows/ole32/ole32.factor b/basis/windows/ole32/ole32.factor index 9e117c8522..3bc7f45960 100755 --- a/basis/windows/ole32/ole32.factor +++ b/basis/windows/ole32/ole32.factor @@ -1,5 +1,5 @@ -USING: alien alien.syntax alien.c-types alien.strings math -kernel sequences windows.errors windows.types io accessors +USING: alien alien.syntax alien.c-types alien.data alien.strings +math kernel sequences windows.errors windows.types io accessors math.order namespaces make math.parser windows.kernel32 combinators locals specialized-arrays literals splitting grouping classes.struct combinators.smart ; @@ -78,29 +78,29 @@ CONSTANT: TYMED_MFPICT 32 CONSTANT: TYMED_ENHMF 64 CONSTANT: TYMED_NULL 0 -C-STRUCT: DVTARGETDEVICE - { "DWORD" "tdSize" } - { "WORD" "tdDriverNameOffset" } - { "WORD" "tdDeviceNameOffset" } - { "WORD" "tdPortNameOffset" } - { "WORD" "tdExtDevmodeOffset" } - { "BYTE[1]" "tdData" } ; +STRUCT: DVTARGETDEVICE + { tdSize DWORD } + { tdDriverNameOffset WORD } + { tdDeviceNameOffset WORD } + { tdPortNameOffset WORD } + { tdExtDevmodeOffset WORD } + { tdData BYTE[1] } ; TYPEDEF: WORD CLIPFORMAT TYPEDEF: POINT POINTL -C-STRUCT: FORMATETC - { "CLIPFORMAT" "cfFormat" } - { "DVTARGETDEVICE*" "ptd" } - { "DWORD" "dwAspect" } - { "LONG" "lindex" } - { "DWORD" "tymed" } ; +STRUCT: FORMATETC + { cfFormat CLIPFORMAT } + { ptd DVTARGETDEVICE* } + { dwAspect DWORD } + { lindex LONG } + { tymed DWORD } ; TYPEDEF: FORMATETC* LPFORMATETC -C-STRUCT: STGMEDIUM - { "DWORD" "tymed" } - { "void*" "data" } - { "LPUNKNOWN" "punkForRelease" } ; +STRUCT: STGMEDIUM + { tymed DWORD } + { data void* } + { punkForRelease LPUNKNOWN } ; TYPEDEF: STGMEDIUM* LPSTGMEDIUM CONSTANT: COINIT_MULTITHREADED 0 diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index c882ba2e7f..6275f2d3c9 100755 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -3,6 +3,7 @@ USING: alien alien.c-types alien.syntax namespaces kernel words sequences math math.bitwise math.vectors colors io.encodings.utf16n classes.struct accessors ; +FROM: alien.c-types => float short ; IN: windows.types TYPEDEF: char CHAR @@ -10,6 +11,12 @@ TYPEDEF: uchar UCHAR TYPEDEF: uchar BYTE TYPEDEF: ushort wchar_t +SYMBOL: wchar_t* +<< +{ char* utf16n } \ wchar_t* typedef +\ wchar_t \ wchar_t* "pointer-c-type" set-word-prop +>> + TYPEDEF: wchar_t WCHAR TYPEDEF: short SHORT @@ -69,8 +76,6 @@ TYPEDEF: ulonglong ULARGE_INTEGER TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER TYPEDEF: ULARGE_INTEGER* PULARGE_INTEGER -<< { "char*" utf16n } "wchar_t*" typedef >> - TYPEDEF: wchar_t* LPCSTR TYPEDEF: wchar_t* LPWSTR TYPEDEF: WCHAR TCHAR @@ -248,14 +253,13 @@ STRUCT: RECT { right LONG } { bottom LONG } ; -C-STRUCT: PAINTSTRUCT - { "HDC" " hdc" } - { "BOOL" "fErase" } - { "RECT" "rcPaint" } - { "BOOL" "fRestore" } - { "BOOL" "fIncUpdate" } - { "BYTE[32]" "rgbReserved" } -; +STRUCT: PAINTSTRUCT + { hdc HDC } + { fErase BOOL } + { rcPaint RECT } + { fRestore BOOL } + { fIncUpdate BOOL } + { rgbReserved BYTE[32] } ; STRUCT: BITMAPINFOHEADER { biSize DWORD } @@ -283,21 +287,21 @@ STRUCT: BITMAPINFO TYPEDEF: void* LPPAINTSTRUCT TYPEDEF: void* PAINTSTRUCT -C-STRUCT: POINT - { "LONG" "x" } - { "LONG" "y" } ; +STRUCT: POINT + { x LONG } + { y LONG } ; STRUCT: SIZE { cx LONG } { cy LONG } ; -C-STRUCT: MSG - { "HWND" "hWnd" } - { "UINT" "message" } - { "WPARAM" "wParam" } - { "LPARAM" "lParam" } - { "DWORD" "time" } - { "POINT" "pt" } ; +STRUCT: MSG + { hWnd HWND } + { message UINT } + { wParam WPARAM } + { lParam LPARAM } + { time DWORD } + { pt POINT } ; TYPEDEF: MSG* LPMSG @@ -339,34 +343,34 @@ TYPEDEF: PFD* LPPFD TYPEDEF: HANDLE HGLRC TYPEDEF: HANDLE HRGN -C-STRUCT: LVITEM - { "uint" "mask" } - { "int" "iItem" } - { "int" "iSubItem" } - { "uint" "state" } - { "uint" "stateMask" } - { "void*" "pszText" } - { "int" "cchTextMax" } - { "int" "iImage" } - { "long" "lParam" } - { "int" "iIndent" } - { "int" "iGroupId" } - { "uint" "cColumns" } - { "uint*" "puColumns" } - { "int*" "piColFmt" } - { "int" "iGroup" } ; +STRUCT: LVITEM + { mask uint } + { iItem int } + { iSubItem int } + { state uint } + { stateMask uint } + { pszText void* } + { cchTextMax int } + { iImage int } + { lParam long } + { iIndent int } + { iGroupId int } + { cColumns uint } + { puColumns uint* } + { piColFmt int* } + { iGroup int } ; -C-STRUCT: LVFINDINFO - { "uint" "flags" } - { "char*" "psz" } - { "long" "lParam" } - { "POINT" "pt" } - { "uint" "vkDirection" } ; +STRUCT: LVFINDINFO + { flags uint } + { psz char* } + { lParam long } + { pt POINT } + { vkDirection uint } ; -C-STRUCT: ACCEL - { "BYTE" "fVirt" } - { "WORD" "key" } - { "WORD" "cmd" } ; +STRUCT: ACCEL + { fVirt BYTE } + { key WORD } + { cmd WORD } ; TYPEDEF: ACCEL* LPACCEL TYPEDEF: DWORD COLORREF diff --git a/basis/windows/usp10/usp10.factor b/basis/windows/usp10/usp10.factor index 50fa98996c..eb57a46925 100755 --- a/basis/windows/usp10/usp10.factor +++ b/basis/windows/usp10/usp10.factor @@ -1,23 +1,23 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax alien.destructors ; +USING: alien.syntax alien.destructors classes.struct ; IN: windows.usp10 LIBRARY: usp10 -C-STRUCT: SCRIPT_CONTROL - { "DWORD" "flags" } ; +STRUCT: SCRIPT_CONTROL + { flags DWORD } ; -C-STRUCT: SCRIPT_STATE - { "WORD" "flags" } ; +STRUCT: SCRIPT_STATE + { flags WORD } ; -C-STRUCT: SCRIPT_ANALYSIS - { "WORD" "flags" } - { "SCRIPT_STATE" "s" } ; +STRUCT: SCRIPT_ANALYSIS + { flags WORD } + { s SCRIPT_STATE } ; -C-STRUCT: SCRIPT_ITEM - { "int" "iCharPos" } - { "SCRIPT_ANALYSIS" "a" } ; +STRUCT: SCRIPT_ITEM + { iCharPos int } + { a SCRIPT_ANALYSIS } ; FUNCTION: HRESULT ScriptItemize ( WCHAR* pwcInChars, @@ -53,8 +53,8 @@ SCRIPT_JUSTIFY_BARA SCRIPT_JUSTIFY_SEEN SCRIPT_JUSTIFFY_RESERVED4 ; -C-STRUCT: SCRIPT_VISATTR - { "WORD" "flags" } ; +STRUCT: SCRIPT_VISATTR + { flags WORD } ; FUNCTION: HRESULT ScriptShape ( HDC hdc, @@ -69,9 +69,9 @@ FUNCTION: HRESULT ScriptShape ( int* pcGlyphs ) ; -C-STRUCT: GOFFSET - { "LONG" "du" } - { "LONG" "dv" } ; +STRUCT: GOFFSET + { du LONG } + { dv LONG } ; FUNCTION: HRESULT ScriptPlace ( HDC hdc, @@ -111,8 +111,8 @@ FUNCTION: HRESULT ScriptJustify ( int* piJustify ) ; -C-STRUCT: SCRIPT_LOGATTR - { "BYTE" "flags" } ; +STRUCT: SCRIPT_LOGATTR + { flags BYTE } ; FUNCTION: HRESULT ScriptBreak ( WCHAR* pwcChars, @@ -184,21 +184,21 @@ FUNCTION: HRESULT ScriptGetGlyphABCWidth ( ABC* pABC ) ; -C-STRUCT: SCRIPT_PROPERTIES - { "DWORD" "flags" } ; +STRUCT: SCRIPT_PROPERTIES + { flags DWORD } ; FUNCTION: HRESULT ScriptGetProperties ( SCRIPT_PROPERTIES*** ppSp, int* piNumScripts ) ; -C-STRUCT: SCRIPT_FONTPROPERTIES - { "int" "cBytes" } - { "WORD" "wgBlank" } - { "WORD" "wgDefault" } - { "WORD" "wgInvalid" } - { "WORD" "wgKashida" } - { "int" "iKashidaWidth" } ; +STRUCT: SCRIPT_FONTPROPERTIES + { cBytes int } + { wgBlank WORD } + { wgDefault WORD } + { wgInvalid WORD } + { wgKashida WORD } + { iKashidaWidth int } ; FUNCTION: HRESULT ScriptGetFontProperties ( HDC hdc, @@ -234,11 +234,11 @@ CONSTANT: SSA_LAYOUTRTL HEX: 20000000 CONSTANT: SSA_DONTGLYPH HEX: 40000000 CONSTANT: SSA_NOKASHIDA HEX: 80000000 -C-STRUCT: SCRIPT_TABDEF - { "int" "cTabStops" } - { "int" "iScale" } - { "int*" "pTabStops" } - { "int" "iTabOrigin" } ; +STRUCT: SCRIPT_TABDEF + { cTabStops int } + { iScale int } + { pTabStops int* } + { iTabOrigin int } ; TYPEDEF: void* SCRIPT_STRING_ANALYSIS @@ -319,8 +319,8 @@ FUNCTION: HRESULT ScriptIsComplex ( DWORD dwFlags ) ; -C-STRUCT: SCRIPT_DIGITSUBSTITUTE - { "DWORD" "flags" } ; +STRUCT: SCRIPT_DIGITSUBSTITUTE + { flags DWORD } ; FUNCTION: HRESULT ScriptRecordDigitSubstitution ( LCID Locale, @@ -336,4 +336,4 @@ FUNCTION: HRESULT ScriptApplyDigitSubstitution ( SCRIPT_DIGITSUBSTITUTE* psds, SCRIPT_CONTROL* psc, SCRIPT_STATE* pss -) ; \ No newline at end of file +) ; diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor index 87b8970b02..dc751e64a6 100755 --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -4,6 +4,7 @@ USING: alien alien.c-types alien.strings alien.syntax arrays byte-arrays kernel literals math sequences windows.types windows.kernel32 windows.errors math.bitwise io.encodings.utf16n classes.struct windows.com.syntax init ; +FROM: alien.c-types => short ; IN: windows.winsock TYPEDEF: void* SOCKET @@ -134,9 +135,9 @@ STRUCT: addrinfo { addr sockaddr* } { next addrinfo* } ; -C-STRUCT: timeval - { "long" "sec" } - { "long" "usec" } ; +STRUCT: timeval + { sec long } + { usec long } ; LIBRARY: winsock @@ -176,15 +177,15 @@ TYPEDEF: HANDLE WSAEVENT TYPEDEF: LPHANDLE LPWSAEVENT TYPEDEF: sockaddr* LPSOCKADDR -C-STRUCT: FLOWSPEC - { "uint" "TokenRate" } - { "uint" "TokenBucketSize" } - { "uint" "PeakBandwidth" } - { "uint" "Latency" } - { "uint" "DelayVariation" } - { "SERVICETYPE" "ServiceType" } - { "uint" "MaxSduSize" } - { "uint" "MinimumPolicedSize" } ; +STRUCT: FLOWSPEC + { TokenRate uint } + { TokenBucketSize uint } + { PeakBandwidth uint } + { Latency uint } + { DelayVariation uint } + { ServiceType SERVICETYPE } + { MaxSduSize uint } + { MinimumPolicedSize uint } ; TYPEDEF: FLOWSPEC* PFLOWSPEC TYPEDEF: FLOWSPEC* LPFLOWSPEC @@ -193,44 +194,44 @@ STRUCT: WSABUF { buf void* } ; TYPEDEF: WSABUF* LPWSABUF -C-STRUCT: QOS - { "FLOWSPEC" "SendingFlowspec" } - { "FLOWSPEC" "ReceivingFlowspec" } - { "WSABUF" "ProviderSpecific" } ; +STRUCT: QOS + { SendingFlowspec FLOWSPEC } + { ReceivingFlowspec FLOWSPEC } + { ProviderSpecific WSABUF } ; TYPEDEF: QOS* LPQOS CONSTANT: MAX_PROTOCOL_CHAIN 7 -C-STRUCT: WSAPROTOCOLCHAIN - { "int" "ChainLen" } - ! { { "DWORD" MAX_PROTOCOL_CHAIN } "ChainEntries" } ; - { { "DWORD" 7 } "ChainEntries" } ; +STRUCT: WSAPROTOCOLCHAIN + { ChainLen int } + { ChainEntries { DWORD 7 } } ; + ! { ChainEntries { DWORD MAX_PROTOCOL_CHAIN } } ; TYPEDEF: WSAPROTOCOLCHAIN* LPWSAPROTOCOLCHAIN CONSTANT: WSAPROTOCOL_LEN 255 -C-STRUCT: WSAPROTOCOL_INFOW - { "DWORD" "dwServiceFlags1" } - { "DWORD" "dwServiceFlags2" } - { "DWORD" "dwServiceFlags3" } - { "DWORD" "dwServiceFlags4" } - { "DWORD" "dwProviderFlags" } - { "GUID" "ProviderId" } - { "DWORD" "dwCatalogEntryId" } - { "WSAPROTOCOLCHAIN" "ProtocolChain" } - { "int" "iVersion" } - { "int" "iAddressFamily" } - { "int" "iMaxSockAddr" } - { "int" "iMinSockAddr" } - { "int" "iSocketType" } - { "int" "iProtocol" } - { "int" "iProtocolMaxOffset" } - { "int" "iNetworkByteOrder" } - { "int" "iSecurityScheme" } - { "DWORD" "dwMessageSize" } - { "DWORD" "dwProviderReserved" } - { { "WCHAR" 256 } "szProtocol" } ; - ! { { "WCHAR" 256 } "szProtocol"[WSAPROTOCOL_LEN+1] } ; +STRUCT: WSAPROTOCOL_INFOW + { dwServiceFlags1 DWORD } + { dwServiceFlags2 DWORD } + { dwServiceFlags3 DWORD } + { dwServiceFlags4 DWORD } + { dwProviderFlags DWORD } + { ProviderId GUID } + { dwCatalogEntryId DWORD } + { ProtocolChain WSAPROTOCOLCHAIN } + { iVersion int } + { iAddressFamily int } + { iMaxSockAddr int } + { iMinSockAddr int } + { iSocketType int } + { iProtocol int } + { iProtocolMaxOffset int } + { iNetworkByteOrder int } + { iSecurityScheme int } + { dwMessageSize DWORD } + { dwProviderReserved DWORD } + { szProtocol { WCHAR 256 } } ; + ! { szProtocol[WSAPROTOCOL_LEN+1] { WCHAR 256 } } ; TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFOW TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFOW TYPEDEF: WSAPROTOCOL_INFOW WSAPROTOCOL_INFO @@ -238,12 +239,12 @@ TYPEDEF: WSAPROTOCOL_INFOW* PWSAPROTOCOL_INFO TYPEDEF: WSAPROTOCOL_INFOW* LPWSAPROTOCOL_INFO -C-STRUCT: WSANAMESPACE_INFOW - { "GUID" "NSProviderId" } - { "DWORD" "dwNameSpace" } - { "BOOL" "fActive" } - { "DWORD" "dwVersion" } - { "LPWSTR" "lpszIdentifier" } ; +STRUCT: WSANAMESPACE_INFOW + { NSProviderId GUID } + { dwNameSpace DWORD } + { fActive BOOL } + { dwVersion DWORD } + { lpszIdentifier LPWSTR } ; TYPEDEF: WSANAMESPACE_INFOW* PWSANAMESPACE_INFOW TYPEDEF: WSANAMESPACE_INFOW* LPWSANAMESPACE_INFOW TYPEDEF: WSANAMESPACE_INFOW WSANAMESPACE_INFO @@ -252,19 +253,19 @@ TYPEDEF: WSANAMESPACE_INFO* LPWSANAMESPACE_INFO CONSTANT: FD_MAX_EVENTS 10 -C-STRUCT: WSANETWORKEVENTS - { "long" "lNetworkEvents" } - { { "int" FD_MAX_EVENTS } "iErrorCode" } ; +STRUCT: WSANETWORKEVENTS + { lNetworkEvents long } + { iErrorCode { int FD_MAX_EVENTS } } ; TYPEDEF: WSANETWORKEVENTS* PWSANETWORKEVENTS TYPEDEF: WSANETWORKEVENTS* LPWSANETWORKEVENTS -! C-STRUCT: WSAOVERLAPPED - ! { "DWORD" "Internal" } - ! { "DWORD" "InternalHigh" } - ! { "DWORD" "Offset" } - ! { "DWORD" "OffsetHigh" } - ! { "WSAEVENT" "hEvent" } - ! { "DWORD" "bytesTransferred" } ; +! STRUCT: WSAOVERLAPPED + ! { Internal DWORD } + ! { InternalHigh DWORD } + ! { Offset DWORD } + ! { OffsetHigh DWORD } + ! { hEvent WSAEVENT } + ! { bytesTransferred DWORD } ; ! TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED FUNCTION: SOCKET WSAAccept ( SOCKET s, diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index 48d556de1d..0cd7704cf8 100644 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -10,9 +10,10 @@ ! add to this library and are wondering what part of the file to ! modify, just find the function or data structure in the manual ! and note the section. -USING: accessors kernel arrays alien alien.c-types alien.strings -alien.syntax classes.struct math math.bitwise words sequences -namespaces continuations io io.encodings.ascii x11.syntax ; +USING: accessors kernel arrays alien alien.c-types alien.data +alien.strings alien.syntax classes.struct math math.bitwise words +sequences namespaces continuations io io.encodings.ascii x11.syntax ; +FROM: alien.c-types => short ; IN: x11.xlib LIBRARY: xlib diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor index 690ebe94f8..370c778787 100644 --- a/basis/xml-rpc/xml-rpc.factor +++ b/basis/xml-rpc/xml-rpc.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel xml arrays math generic http.client -combinators hashtables namespaces io base64 sequences strings -calendar xml.data xml.writer xml.traversal assocs math.parser -debugger calendar.format math.order xml.syntax ; +USING: accessors arrays assocs base64 calendar calendar.format +combinators debugger generic hashtables http http.client +http.client.private io io.encodings.string io.encodings.utf8 +kernel math math.order math.parser namespaces sequences strings +xml xml.data xml.syntax xml.traversal xml.writer ; IN: xml-rpc ! * Sending RPC requests @@ -174,9 +175,20 @@ TAG: array xml>item ] [ "Bad main tag name" server-error ] if ] if ; +string utf8 encode "text/xml" swap >>data ; + +: rpc-post-request ( xml url -- request ) + [ send-rpc xml-post-data ] [ "POST" ] bi* + swap >>post-data ; + +PRIVATE> + : post-rpc ( rpc url -- rpc ) ! This needs to do something in the event of an error - [ send-rpc ] dip http-post nip string>xml receive-rpc ; + rpc-post-request http-request nip string>xml receive-rpc ; : invoke-method ( params method url -- response ) [ swap ] dip post-rpc ; diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 66e67ab322..b310345464 100644 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -175,6 +175,8 @@ $nl ARTICLE: "alien-callback" "Calling Factor from C" "Callbacks can be defined and passed to C code as function pointers; the C code can then invoke the callback and run Factor code:" { $subsection alien-callback } +{ $subsection POSTPONE: CALLBACK: } +{ $subsection POSTPONE: STDCALL-CALLBACK: } "There are some caveats concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." { $subsection "alien-callback-gc" } { $see-also "byte-arrays-gc" } ; diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index 2d2cec168f..7eaa5cc50b 100644 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -55,7 +55,7 @@ cell 8 = [ ] unit-test ] when -[ "ALIEN: 1234" ] [ 1234 unparse ] unit-test +[ "ALIEN: 1234" ] [ HEX: 1234 unparse ] unit-test [ ] [ 0 B{ 1 2 3 } drop ] unit-test diff --git a/core/alien/strings/strings-tests.factor b/core/alien/strings/strings-tests.factor index 6a0a42253b..c1b5a9e159 100644 --- a/core/alien/strings/strings-tests.factor +++ b/core/alien/strings/strings-tests.factor @@ -1,4 +1,4 @@ -USING: alien.strings alien.c-types tools.test kernel libc +USING: alien.strings alien.c-types alien.data tools.test kernel libc io.encodings.8-bit io.encodings.utf8 io.encodings.utf16 io.encodings.utf16n io.encodings.ascii alien io.encodings.string ; IN: alien.strings.tests diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 13e17f90fd..fc071cc566 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -103,6 +103,7 @@ bootstrapping? on "words" "vectors" "vectors.private" + "vm" } [ create-vocab drop ] each ! Builtin classes @@ -409,6 +410,10 @@ tuple { "float<=" "math.private" (( x y -- ? )) } { "float>" "math.private" (( x y -- ? )) } { "float>=" "math.private" (( x y -- ? )) } + { "float-u<" "math.private" (( x y -- ? )) } + { "float-u<=" "math.private" (( x y -- ? )) } + { "float-u>" "math.private" (( x y -- ? )) } + { "float-u>=" "math.private" (( x y -- ? )) } { "" "words" (( name vocab -- word )) } { "word-xt" "words" (( word -- start end )) } { "getenv" "kernel.private" (( n -- obj )) } @@ -514,6 +519,7 @@ tuple { "inline-cache-stats" "generic.single" (( -- stats )) } { "optimized?" "words" (( word -- ? )) } { "quot-compiled?" "quotations" (( quot -- ? )) } + { "vm-ptr" "vm" (( -- ptr )) } } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index c7be17e38d..9c84904ff7 100644 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -40,7 +40,7 @@ load-help? off "bootstrap.layouts" require [ - "vocab:bootstrap/stage2.factor" + "resource:basis/bootstrap/stage2.factor" dup exists? [ run-file ] [ diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 906b73934e..57be2fb90f 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -33,6 +33,7 @@ IN: bootstrap.syntax "MAIN:" "MATH:" "MIXIN:" + "NAN:" "OCT:" "P\"" "POSTPONE:" diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor index cbf6acdeed..2e14af27f3 100644 --- a/core/classes/algebra/algebra-docs.factor +++ b/core/classes/algebra/algebra-docs.factor @@ -10,7 +10,6 @@ ARTICLE: "class-operations" "Class operations" { $subsection class-and } { $subsection class-or } { $subsection classes-intersect? } -{ $subsection min-class } "Low-level implementation detail:" { $subsection flatten-class } { $subsection flatten-builtin-class } @@ -37,6 +36,7 @@ $nl "Operations:" { $subsection class< } { $subsection sort-classes } +{ $subsection smallest-class } "Metaclass order:" { $subsection rank-class } ; @@ -73,6 +73,6 @@ HELP: classes-intersect? { $values { "first" class } { "second" class } { "?" "a boolean" } } { $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ; -HELP: min-class -{ $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } } -{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ; +HELP: smallest-class +{ $values { "classes" "a sequence of class words" } { "class/f" { $maybe class } } } +{ $description "Outputs a minimum class from the given sequence." } ; diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index d111d1daa2..855a15b66f 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -4,7 +4,7 @@ tools.test words quotations classes classes.algebra classes.private classes.union classes.mixin classes.predicate vectors source-files compiler.units growable random stack-checker effects kernel.private sbufs math.order -classes.tuple accessors ; +classes.tuple accessors generic.private ; IN: classes.algebra.tests : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ; @@ -150,6 +150,12 @@ UNION: z1 b1 c1 ; ] unit-test ! Test method inlining +[ real ] [ { real sequence } smallest-class ] unit-test +[ real ] [ { sequence real } smallest-class ] unit-test + +: min-class ( class classes -- class/f ) + interesting-classes smallest-class ; + [ f ] [ fixnum { } min-class ] unit-test [ string ] [ diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index df4f8f2563..2d67403f94 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -214,10 +214,10 @@ ERROR: topological-sort-failed ; [ dup largest-class [ over delete-nth ] dip ] produce nip ; -: min-class ( class seq -- class/f ) - over [ classes-intersect? ] curry filter - [ drop f ] [ - [ nip ] [ [ class<= ] with all? ] 2bi [ last ] [ drop f ] if +: smallest-class ( classes -- class/f ) + [ f ] [ + natural-sort + [ ] [ [ class<= ] most ] map-reduce ] if-empty ; GENERIC: (flatten-class) ( class -- ) diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index 0a57ad34f3..626cbd63df 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -99,9 +99,17 @@ GENERIC# boa>object 1 ( class slots -- tuple ) M: tuple-class boa>object swap prefix >tuple ; +ERROR: bad-slot-name class slot ; + +: check-slot-exists ( class initials slot-spec/f index/f name -- class initials slot-spec index ) + over [ drop ] [ nip nip nip bad-slot-name ] if ; + +: slot-named-checked ( class initials name slots -- class initials slot-spec ) + over [ slot-named* ] dip check-slot-exists drop ; + : assoc>object ( class slots values -- tuple ) [ [ [ initial>> ] map ] keep ] dip - swap [ [ slot-named* drop ] curry dip ] curry assoc-map + swap [ [ slot-named-checked ] curry dip ] curry assoc-map [ dup ] dip update boa>object ; : parse-tuple-literal-slots ( class slots -- tuple ) diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 4a7fcea0e6..5d778ba1e4 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -85,7 +85,7 @@ $nl } ; ARTICLE: "spread-combinators" "Spread combinators" -"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading." +"The spread combinators apply multiple quotations to multiple values. In this case, " { $snippet "*" } " suffix signify spreading." $nl "Two quotations:" { $subsection bi* } diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index a63cab1c5c..fc6f50e18f 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -1,9 +1,9 @@ -USING: accessors alien arrays definitions generic generic.standard -generic.math assocs hashtables io kernel math namespaces parser -prettyprint sequences strings tools.test vectors words -quotations classes classes.algebra classes.tuple continuations -layouts classes.union sorting compiler.units eval multiline -io.streams.string ; +USING: accessors alien arrays definitions generic +generic.standard generic.math assocs hashtables io kernel math +math.order namespaces parser prettyprint sequences strings +tools.test vectors words quotations classes classes.algebra +classes.tuple continuations layouts classes.union sorting +compiler.units eval multiline io.streams.string ; IN: generic.tests GENERIC: foobar ( x -- y ) @@ -186,3 +186,20 @@ GENERIC: move-method-generic ( a -- b ) [ ] [ "IN: generic.tests.a" "move-method-test-1" parse-stream drop ] unit-test [ { string } ] [ \ move-method-generic order ] unit-test + +GENERIC: foozul ( a -- b ) +M: reversed foozul ; +M: integer foozul ; +M: slice foozul ; + +[ t ] [ + reversed \ foozul method-for-class + reversed \ foozul method + eq? +] unit-test + +[ t ] [ + fixnum \ <=> method-for-class + real \ <=> method + eq? +] unit-test \ No newline at end of file diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 4b398f6532..fcb7a53731 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -24,20 +24,42 @@ M: generic definition drop f ; : method ( class generic -- method/f ) "methods" word-prop at ; -: order ( generic -- seq ) - "methods" word-prop keys sort-classes ; + + +: method-classes ( generic -- classes ) + "methods" word-prop keys ; + +: order ( generic -- seq ) + method-classes sort-classes ; + +: nearest-class ( class generic -- class/f ) + method-classes interesting-classes smallest-class ; + +: method-for-class ( class generic -- method/f ) + [ nip ] [ nearest-class ] 2bi dup [ swap method ] [ 2drop f ] if ; GENERIC: effective-method ( generic -- method ) \ effective-method t "no-compile" set-word-prop : next-method-class ( class generic -- class/f ) - order [ class<= ] with filter reverse dup length 1 = - [ drop f ] [ second ] if ; + method-classes [ class< ] with filter smallest-class ; : next-method ( class generic -- method/f ) [ next-method-class ] keep method ; diff --git a/core/generic/hook/hook.factor b/core/generic/hook/hook.factor index 5edbc54bd8..5359f473ac 100644 --- a/core/generic/hook/hook.factor +++ b/core/generic/hook/hook.factor @@ -23,4 +23,4 @@ M: hook-combination mega-cache-quot M: hook-generic definer drop \ HOOK: f ; M: hook-generic effective-method - [ "combination" word-prop var>> get ] keep (effective-method) ; \ No newline at end of file + [ "combination" word-prop var>> get ] keep method-for-object ; \ No newline at end of file diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index e0e8b91a2c..297684014b 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -50,7 +50,7 @@ ERROR: no-math-method left right generic ; : object-method ( generic -- quot ) - object bootstrap-word applicable-method ; + object bootstrap-word (math-method) ; : math-method ( word class1 class2 -- quot ) 2dup and [ [ 2array [ declare ] curry nip ] [ math-upgrade nip ] - [ math-class-max over order min-class applicable-method ] + [ math-class-max over nearest-class (math-method) ] 3tri 3append ] [ 2drop object-method diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 8a53368062..9e773fe700 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -42,8 +42,8 @@ M: single-combination next-method-quot* ( class generic combination -- quot ) ] [ 3drop f ] if ] with-combination ; -: (effective-method) ( obj word -- method ) - [ [ order [ instance? ] with find-last nip ] keep method ] +: method-for-object ( obj word -- method ) + [ [ method-classes [ instance? ] with filter smallest-class ] keep method ] [ "default-method" word-prop ] bi or ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 0d1220beac..35d299145d 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -40,7 +40,7 @@ M: standard-combination dispatch# #>> ; M: standard-generic effective-method [ datastack ] dip [ "combination" word-prop #>> swap nth ] keep - (effective-method) ; + method-for-object ; : inline-cache-quot ( word methods miss-word -- quot ) [ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ; diff --git a/core/math/floats/floats-docs.factor b/core/math/floats/floats-docs.factor index ed4947e1f5..6e903a37e2 100644 --- a/core/math/floats/floats-docs.factor +++ b/core/math/floats/floats-docs.factor @@ -69,20 +69,54 @@ HELP: float> ( x y -- ? ) HELP: float>= ( x y -- ? ) { $values { "x" float } { "y" float } { "?" "a boolean" } } -{ $description "Primitive version of " { $link >= } "." } -{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link >= } " instead." } ; +{ $description "Primitive version of " { $link u>= } "." } +{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u>= } " instead." } ; -ARTICLE: "floats" "Floats" -{ $subsection float } -"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximate" } " value. While rationals can grow to any required precision, floating point numbers have limited precision, and manipulating them is usually faster than manipulating ratios or bignums." +HELP: float-u< ( x y -- ? ) +{ $values { "x" float } { "y" float } { "?" "a boolean" } } +{ $description "Primitive version of " { $link u< } "." } +{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u< } " instead." } ; + +HELP: float-u<= ( x y -- ? ) +{ $values { "x" float } { "y" float } { "?" "a boolean" } } +{ $description "Primitive version of " { $link u<= } "." } +{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u<= } " instead." } ; + +HELP: float-u> ( x y -- ? ) +{ $values { "x" float } { "y" float } { "?" "a boolean" } } +{ $description "Primitive version of " { $link u> } "." } +{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u> } " instead." } ; + +HELP: float-u>= ( x y -- ? ) +{ $values { "x" float } { "y" float } { "?" "a boolean" } } +{ $description "Primitive version of " { $link u>= } "." } +{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u>= } " instead." } ; + +ARTICLE: "math.floats.compare" "Floating point comparison operations" +"In mathematics, real numbers are linearly ordered; for any two numbers " { $snippet "a" } " and " { $snippet "b" } ", exactly one of the following is true:" +{ $code + "a < b" + "a = b" + "a > b" +} +"With floating point values, there is a fourth possibility; " { $snippet "a" } " and " { $snippet "b" } " may be " { $emphasis "unordered" } ". This happens if one or both values are Not-a-Number values." $nl -"Introducing a floating point number in a computation forces the result to be expressed in floating point." -{ $example "5/4 1/2 + ." "1+3/4" } -{ $example "5/4 0.5 + ." "1.75" } -"Integers and rationals can be converted to floats:" -{ $subsection >float } -"Two real numbers can be divided yielding a float result:" -{ $subsection /f } +"All comparison operators, including " { $link number= } ", return " { $link f } " in the unordered case (and in particular, this means that a NaN is not equal to itself)." +$nl +"The " { $emphasis "ordered" } " comparison operators set floating point exception flags if the result of the comparison is unordered. The standard comparison operators (" { $link < } ", " { $link <= } ", " { $link > } ", " { $link >= } ") perform ordered comparisons." +$nl +"The " { $link number= } " operation performs an unordered comparison. The following set of operators also perform unordered comparisons:" +{ $subsection u< } +{ $subsection u<= } +{ $subsection u> } +{ $subsection u>= } +"A word to check if two values are unordered with respect to each other:" +{ $subsection unordered? } +"To test for floating point exceptions, use the " { $vocab-link "math.floats.env" } " vocabulary." +$nl +"If neither input to a comparison operator is a floating point value, then " { $link u< } ", " { $link u<= } ", " { $link u> } " and " { $link u>= } " are equivalent to the ordered operators." ; + +ARTICLE: "math.floats.bitwise" "Bitwise operations on floats" "Floating point numbers are represented internally in IEEE 754 double-precision format. This internal representation can be accessed for advanced operations and input/output purposes." { $subsection float>bits } { $subsection double>bits } @@ -100,8 +134,25 @@ $nl { $subsection fp-snan? } { $subsection fp-infinity? } { $subsection fp-nan-payload } -"Comparing two floating point numbers:" +"Comparing two floating point numbers for bitwise equality:" { $subsection fp-bitwise= } -{ $see-also "syntax-floats" } ; +{ $see-also POSTPONE: NAN: } ; + +ARTICLE: "floats" "Floats" +{ $subsection float } +"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximate" } " value. While rationals can grow to any required precision, floating point numbers have limited precision, and manipulating them is usually faster than manipulating ratios or bignums." +$nl +"Introducing a floating point number in a computation forces the result to be expressed in floating point." +{ $example "5/4 1/2 + ." "1+3/4" } +{ $example "5/4 0.5 + ." "1.75" } +"Floating point literal syntax is documented in " { $link "syntax-floats" } "." +$nl +"Integers and rationals can be converted to floats:" +{ $subsection >float } +"Two real numbers can be divided yielding a float result:" +{ $subsection /f } +{ $subsection "math.floats.bitwise" } +{ $subsection "math.floats.compare" } +"The " { $vocab-link "math.floats.env" } " vocabulary provides functionality for controlling floating point exceptions, rounding modes, and denormal behavior." ; ABOUT: "floats" diff --git a/core/math/floats/floats-tests.factor b/core/math/floats/floats-tests.factor index de84346a58..220eb33960 100644 --- a/core/math/floats/floats-tests.factor +++ b/core/math/floats/floats-tests.factor @@ -67,3 +67,11 @@ unit-test [ t ] [ 0/0. 1.0 unordered? ] unit-test [ f ] [ 1.0 1.0 unordered? ] unit-test +[ t ] [ -0.0 fp-sign ] unit-test +[ t ] [ -1.0 fp-sign ] unit-test +[ f ] [ 0.0 fp-sign ] unit-test +[ f ] [ 1.0 fp-sign ] unit-test + +[ t ] [ -0.0 abs 0.0 fp-bitwise= ] unit-test +[ 1.5 ] [ -1.5 abs ] unit-test +[ 1.5 ] [ 1.5 abs ] unit-test diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor index aa55e2d0ee..bc419b94c5 100644 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -3,6 +3,7 @@ USING: kernel math math.private ; IN: math.floats.private +: float-unordered? ( x y -- ? ) [ fp-nan? ] bi@ or ; : float-min ( x y -- z ) [ float< ] most ; foldable : float-max ( x y -- z ) [ float> ] most ; foldable @@ -17,11 +18,17 @@ M: float hashcode* nip float>bits ; inline M: float equal? over float? [ float= ] [ 2drop f ] if ; inline M: float number= float= ; inline -M: float < float< ; inline +M: float < float< ; inline M: float <= float<= ; inline -M: float > float> ; inline +M: float > float> ; inline M: float >= float>= ; inline +M: float unordered? float-unordered? ; inline +M: float u< float-u< ; inline +M: float u<= float-u<= ; inline +M: float u> float-u> ; inline +M: float u>= float-u>= ; inline + M: float + float+ ; inline M: float - float- ; inline M: float * float* ; inline @@ -50,7 +57,7 @@ M: float fp-snan? M: float fp-infinity? dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline -M: float next-float ( m -- n ) +M: float next-float double>bits dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero @@ -58,12 +65,14 @@ M: float next-float ( m -- n ) ] if ] if ; inline -M: float unordered? [ fp-nan? ] bi@ or ; inline - -M: float prev-float ( m -- n ) +M: float prev-float double>bits dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero 1 - bits>double ! positive non-zero ] if ] if ; inline + +M: float fp-sign double>bits 63 bit? ; inline + +M: float abs double>bits 63 2^ bitnot bitand bits>double ; inline diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index ed25e3bfa6..e684b8edfb 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -24,6 +24,11 @@ M: fixnum <= fixnum<= ; inline M: fixnum > fixnum> ; inline M: fixnum >= fixnum>= ; inline +M: fixnum u< fixnum< ; inline +M: fixnum u<= fixnum<= ; inline +M: fixnum u> fixnum> ; inline +M: fixnum u>= fixnum>= ; inline + M: fixnum + fixnum+ ; inline M: fixnum - fixnum- ; inline M: fixnum * fixnum* ; inline @@ -65,6 +70,11 @@ M: bignum <= bignum<= ; inline M: bignum > bignum> ; inline M: bignum >= bignum>= ; inline +M: bignum u< bignum< ; inline +M: bignum u<= bignum<= ; inline +M: bignum u> bignum> ; inline +M: bignum u>= bignum>= ; inline + M: bignum + bignum+ ; inline M: bignum - bignum- ; inline M: bignum * bignum* ; inline diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index ab2a5ab8be..e5de106bbb 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -5,7 +5,9 @@ IN: math HELP: number= { $values { "x" number } { "y" number } { "?" "a boolean" } } { $description "Tests if two numbers have the same numeric value." } -{ $notes "This word differs from " { $link = } " in that it disregards differences in type when comparing numbers." } +{ $notes "This word differs from " { $link = } " in that it disregards differences in type when comparing numbers." +$nl +"This word performs an unordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } { $examples { $example "USING: math prettyprint ;" "3.0 3 number= ." "t" } { $example "USING: kernel math prettyprint ;" "3.0 3 = ." "f" } @@ -13,20 +15,47 @@ HELP: number= HELP: < { $values { "x" real } { "y" real } { "?" boolean } } -{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." } ; +{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." } +{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ; HELP: <= { $values { "x" real } { "y" real } { "?" boolean } } -{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." } ; +{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." } +{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ; HELP: > { $values { "x" real } { "y" real } { "?" boolean } } -{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." } ; +{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." } +{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ; HELP: >= { $values { "x" real } { "y" real } { "?" boolean } } -{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ; +{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } +{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ; +HELP: unordered? +{ $values { "x" real } { "y" real } { "?" boolean } } +{ $description "Tests if " { $snippet "x" } " is unordered with respect to " { $snippet "y" } ". This can only occur if one or both values is a floating-point Not-a-Number value." } ; + +HELP: u< +{ $values { "x" real } { "y" real } { "?" boolean } } +{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." } +{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link < } ". See " { $link "math.floats.compare" } " for an explanation." } ; + +HELP: u<= +{ $values { "x" real } { "y" real } { "?" boolean } } +{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." } +{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link <= } ". See " { $link "math.floats.compare" } " for an explanation." } ; + +HELP: u> +{ $values { "x" real } { "y" real } { "?" boolean } } +{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." } +{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link > } ". See " { $link "math.floats.compare" } " for an explanation." } ; + +HELP: u>= +{ $values { "x" real } { "y" real } { "?" boolean } } +{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } +{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link >= } ". See " { $link "math.floats.compare" } " for an explanation." } ; HELP: + { $values { "x" number } { "y" number } { "z" number } } @@ -277,7 +306,32 @@ HELP: fp-bitwise= { "x" float } { "y" float } { "?" boolean } } -{ $description "Compares two floating point numbers for bit equality." } ; +{ $description "Compares two floating point numbers for bit equality." } +{ $notes "Unlike " { $link = } " or " { $link number= } ", this word will consider NaNs with equal payloads to be equal, and positive zero and negative zero to be not equal." } +{ $examples + "Not-a-number equality:" + { $example + "USING: kernel math prettyprint ;" + "0.0 0.0 / dup number= ." + "f" + } + { $example + "USING: kernel math prettyprint ;" + "0.0 0.0 / dup fp-bitwise= ." + "t" + } + "Signed zero equality:" + { $example + "USING: math prettyprint ;" + "-0.0 0.0 fp-bitwise= ." + "f" + } + { $example + "USING: math prettyprint ;" + "-0.0 0.0 number= ." + "t" + } +} ; HELP: fp-special? { $values { "x" real } { "?" "a boolean" } } @@ -303,6 +357,10 @@ HELP: fp-infinity? { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" } } ; +HELP: fp-sign +{ $values { "x" float } { "?" "a boolean" } } +{ $description "Outputs the sign bit of " { $snippet "x" } ". For ordered non-zero values, this is equivalent to calling " { $snippet "0 <" } ". For zero values, this outputs the zero's sign bit." } ; + HELP: fp-nan-payload { $values { "x" real } { "bits" integer } } { $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ; diff --git a/core/math/math.factor b/core/math/math.factor index 4fb39f93f7..8ef4f38f9a 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2009 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math.private ; IN: math @@ -22,7 +22,12 @@ MATH: < ( x y -- ? ) foldable MATH: <= ( x y -- ? ) foldable MATH: > ( x y -- ? ) foldable MATH: >= ( x y -- ? ) foldable + MATH: unordered? ( x y -- ? ) foldable +MATH: u< ( x y -- ? ) foldable +MATH: u<= ( x y -- ? ) foldable +MATH: u> ( x y -- ? ) foldable +MATH: u>= ( x y -- ? ) foldable M: object unordered? 2drop f ; @@ -99,13 +104,13 @@ GENERIC: fp-qnan? ( x -- ? ) GENERIC: fp-snan? ( x -- ? ) GENERIC: fp-infinity? ( x -- ? ) GENERIC: fp-nan-payload ( x -- bits ) +GENERIC: fp-sign ( x -- ? ) M: object fp-special? drop f ; inline M: object fp-nan? drop f ; inline M: object fp-qnan? drop f ; inline M: object fp-snan? drop f ; inline M: object fp-infinity? drop f ; inline -M: object fp-nan-payload drop f ; inline : ( payload -- nan ) HEX: 7ff0000000000000 bitor bits>double ; inline diff --git a/core/math/order/order-docs.factor b/core/math/order/order-docs.factor index b2c2eeb973..707dd6b79f 100644 --- a/core/math/order/order-docs.factor +++ b/core/math/order/order-docs.factor @@ -44,39 +44,41 @@ HELP: compare } ; HELP: max -{ $values { "x" real } { "y" real } { "z" real } } -{ $description "Outputs the greatest of two real numbers." } ; +{ $values { "x" object } { "y" object } { "z" object } } +{ $description "Outputs the greatest of two ordered values." } +{ $notes "If one value is a floating point positive zero and the other is a negative zero, the result is undefined." } ; HELP: min -{ $values { "x" real } { "y" real } { "z" real } } -{ $description "Outputs the smallest of two real numbers." } ; +{ $values { "x" object } { "y" object } { "z" object } } +{ $description "Outputs the smallest of two ordered values." } +{ $notes "If one value is a floating point positive zero and the other is a negative zero, the result is undefined." } ; HELP: clamp -{ $values { "x" real } { "min" real } { "max" real } { "y" real } } +{ $values { "x" object } { "min" object } { "max" object } { "y" object } } { $description "Outputs " { $snippet "x" } " if contained in the interval " { $snippet "[min,max]" } " or outputs one of the endpoints." } ; HELP: between? -{ $values { "x" real } { "y" real } { "z" real } { "?" "a boolean" } } +{ $values { "x" object } { "y" object } { "z" real } { "?" "a boolean" } } { $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." } { $notes "As per the closed interval notation, the end-points are included in the interval." } ; HELP: before? -{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } } +{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } } { $description "Tests if " { $snippet "obj1" } " comes before " { $snippet "obj2" } " using an intrinsic total order." } { $notes "Implemented using " { $link <=> } "." } ; HELP: after? -{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } } +{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } } { $description "Tests if " { $snippet "obj1" } " comes after " { $snippet "obj2" } " using an intrinsic total order." } { $notes "Implemented using " { $link <=> } "." } ; HELP: before=? -{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } } +{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } } { $description "Tests if " { $snippet "obj1" } " comes before or equals " { $snippet "obj2" } " using an intrinsic total order." } { $notes "Implemented using " { $link <=> } "." } ; HELP: after=? -{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } } +{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } } { $description "Tests if " { $snippet "obj1" } " comes after or equals " { $snippet "obj2" } " using an intrinsic total order." } { $notes "Implemented using " { $link <=> } "." } ; @@ -100,7 +102,7 @@ ARTICLE: "math.order.example" "Linear order example" } ; ARTICLE: "math.order" "Linear order protocol" -"Some classes have an intrinsic order amongst instances:" +"Some classes define an intrinsic order amongst instances. This includes numbers, sequences (in particular, strings), and words." { $subsection <=> } { $subsection >=< } { $subsection compare } @@ -112,6 +114,10 @@ ARTICLE: "math.order" "Linear order protocol" { $subsection before? } { $subsection after=? } { $subsection before=? } +"Minimum, maximum, clamping:" +{ $subsection min } +{ $subsection max } +{ $subsection clamp } "Out of the above generic words, it suffices to implement " { $link <=> } " alone. The others may be provided as an optimization." { $subsection "math.order.example" } { $see-also "sequences-sorting" } ; diff --git a/core/math/parser/parser-docs.factor b/core/math/parser/parser-docs.factor index 1e3ff4f996..c3ee350099 100644 --- a/core/math/parser/parser-docs.factor +++ b/core/math/parser/parser-docs.factor @@ -5,7 +5,7 @@ IN: math.parser ARTICLE: "number-strings" "Converting between numbers and strings" "These words only convert between real numbers and strings. Complex numbers are constructed by the parser (" { $link "parser" } ") and printed by the prettyprinter (" { $link "prettyprint" } ")." $nl -"Note that only integers can be converted to and from strings using a representation other than base 10. Calling a word such as " { $link >oct } " on a float will give a result in base 10." +"Integers can be converted to and from arbitrary bases. Floating point numbers can only be converted to and from base 10 and 16." $nl "Converting numbers to strings:" { $subsection number>string } @@ -61,7 +61,7 @@ HELP: bin> $nl "Outputs " { $link f } " if the string does not represent a number." } ; -{ bin> POSTPONE: BIN: bin> .b } related-words +{ >bin POSTPONE: BIN: bin> .b } related-words HELP: oct> { $values { "str" string } { "n/f" "a real number or " { $link f } } } @@ -69,7 +69,7 @@ HELP: oct> $nl "Outputs " { $link f } " if the string does not represent a number." } ; -{ oct> POSTPONE: OCT: oct> .o } related-words +{ >oct POSTPONE: OCT: oct> .o } related-words HELP: hex> { $values { "str" string } { "n/f" "a real number or " { $link f } } } @@ -77,7 +77,7 @@ HELP: hex> $nl "Outputs " { $link f } " if the string does not represent a number." } ; -{ hex> POSTPONE: HEX: hex> .h } related-words +{ >hex POSTPONE: HEX: hex> .h } related-words HELP: >base { $values { "n" real } { "radix" "an integer between 2 and 36" } { "str" string } } @@ -93,7 +93,19 @@ HELP: >oct HELP: >hex { $values { "n" real } { "str" string } } -{ $description "Outputs a string representation of a number using base 16." } ; +{ $description "Outputs a string representation of a number using base 16." } +{ $examples + { $example + "USING: math.parser prettyprint ;" + "3735928559 >hex ." + "\"deadbeef\"" + } + { $example + "USING: math.parser prettyprint ;" + "-15.5 >hex ." + "\"-1.fp3\"" + } +} ; HELP: string>float ( str -- n/f ) { $values { "str" string } { "n/f" "a real number or " { $link f } } } diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index f2ccb78a06..34bca8a34e 100644 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -129,6 +129,7 @@ unit-test [ "1.0p0" ] [ 1.0 >hex ] unit-test [ "1.8p2" ] [ 6.0 >hex ] unit-test +[ "1.08p2" ] [ 4.125 >hex ] unit-test [ "1.8p-2" ] [ 0.375 >hex ] unit-test [ "-1.8p2" ] [ -6.0 >hex ] unit-test [ "1.8p10" ] [ 1536.0 >hex ] unit-test @@ -137,6 +138,8 @@ unit-test [ "-0.0" ] [ -0.0 >hex ] unit-test [ 1.0 ] [ "1.0" hex> ] unit-test +[ 1.5 ] [ "1.8" hex> ] unit-test +[ 1.03125 ] [ "1.08" hex> ] unit-test [ 15.5 ] [ "f.8" hex> ] unit-test [ 15.53125 ] [ "f.88" hex> ] unit-test [ -15.5 ] [ "-f.8" hex> ] unit-test diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 8e911453ad..a53604ddf9 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -109,9 +109,8 @@ SYMBOL: negative? : base>float ( str base -- n/f ) { - { 10 [ dec>float ] } { 16 [ hex>float ] } - [ "Floats can only be converted from strings in base 10 or 16" throw ] + [ drop dec>float ] } case ; : number-char? ( char -- ? ) @@ -214,7 +213,8 @@ M: ratio >base -0.0 double>bits bitand zero? "" "-" ? ; : float>hex-value ( mantissa -- str ) - 16 >base [ CHAR: 0 = ] trim-tail [ "0" ] [ ] if-empty "1." prepend ; + 16 >base 13 CHAR: 0 pad-head [ CHAR: 0 = ] trim-tail + [ "0" ] [ ] if-empty "1." prepend ; : float>hex-expt ( mantissa -- str ) 10 >base "p" prepend ; @@ -232,9 +232,8 @@ M: ratio >base : float>base ( n base -- str ) { - { 10 [ float>decimal ] } { 16 [ float>hex ] } - [ "Floats can only be converted to strings in base 10 or 16" throw ] + [ drop float>decimal ] } case ; PRIVATE> diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 94eb0a865c..276030d770 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -99,8 +99,11 @@ M: f parse-quotation \ ] parse-until >quotation ; ERROR: bad-number ; +: scan-base ( base -- n ) + scan swap base> [ bad-number ] unless* ; + : parse-base ( parsed base -- parsed ) - scan swap base> [ bad-number ] unless* parsed ; + scan-base parsed ; SYMBOL: bootstrap-syntax diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index fd5590fde1..394ae3f67c 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -59,19 +59,26 @@ ARTICLE: "syntax-ratios" "Ratio syntax" "More information on ratios can be found in " { $link "rationals" } ; ARTICLE: "syntax-floats" "Float syntax" -"Floating point literals must contain a decimal point, and may contain an exponent:" +"Floating point literals can be input in base 10 or 16. Base 10 literals must contain a decimal point, and may contain an exponent after " { $snippet "e" } ":" { $code "10.5" "-3.1456" "7.e13" "1.0e-5" } -"There are three special float values:" +"Base 16 literals use " { $snippet "p" } " instead of " { $snippet "e" } " for the exponent, which is still decimal:" +{ $example + "10.125 HEX: 1.44p3 = ." + "t" +} +"Syntax for special float values:" { $table { "Positive infinity" { $snippet "1/0." } } { "Negative infinity" { $snippet "-1/0." } } { "Not-a-number" { $snippet "0/0." } } } +"A Not-a-number with an arbitrary payload can also be parsed in:" +{ $subsection POSTPONE: NAN: } "More information on floats can be found in " { $link "floats" } "." ; ARTICLE: "syntax-complex-numbers" "Complex number syntax" @@ -586,10 +593,13 @@ HELP: #! { $description "Discards all input until the end of the line." } ; HELP: HEX: -{ $syntax "HEX: integer" } -{ $values { "integer" "hexadecimal digits (0-9, a-f, A-F)" } } -{ $description "Adds an integer read from a hexadecimal literal to the parse tree." } -{ $examples { $example "USE: prettyprint" "HEX: ff ." "255" } } ; +{ $syntax "HEX: NNN" "HEX: NNN.NNNpEEE" } +{ $values { "N" "hexadecimal digit (0-9, a-f, A-F)" } { "pEEE" "decimal exponent value" } } +{ $description "Adds an integer or floating-point value read from a hexadecimal literal to the parse tree." } +{ $examples + { $example "USE: prettyprint" "HEX: ff ." "255" } + { $example "USE: prettyprint" "HEX: 1.8p5 ." "48.0" } +} ; HELP: OCT: { $syntax "OCT: integer" } @@ -603,6 +613,18 @@ HELP: BIN: { $description "Adds an integer read from an binary literal to the parse tree." } { $examples { $example "USE: prettyprint" "BIN: 100 ." "4" } } ; +HELP: NAN: +{ $syntax "NAN: payload" } +{ $values { "payload" "64-bit hexadecimal integer" } } +{ $description "Adds a floating point Not-a-Number literal to the parse tree." } +{ $examples + { $example + "USE: prettyprint" + "NAN: 80000deadbeef ." + "NAN: 80000deadbeef" + } +} ; + HELP: GENERIC: { $syntax "GENERIC: word ( stack -- effect )" } { $values { "word" "a new word to define" } } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index f01f90c027..16645e3342 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -73,6 +73,8 @@ IN: bootstrap.syntax "OCT:" [ 8 parse-base ] define-core-syntax "BIN:" [ 2 parse-base ] define-core-syntax + "NAN:" [ 16 scan-base parsed ] define-core-syntax + "f" [ f parsed ] define-core-syntax "t" "syntax" lookup define-singleton-class diff --git a/extra/alien/inline/inline.factor b/extra/alien/inline/inline.factor index 84c3450102..ee69d954ea 100644 --- a/extra/alien/inline/inline.factor +++ b/extra/alien/inline/inline.factor @@ -41,6 +41,11 @@ SYMBOL: c-strings [ current-vocab name>> % "_" % % ] "" make ; PRIVATE> +: parse-arglist ( parameters return -- types effect ) + [ 2 group unzip [ "," ?tail drop ] map ] + [ [ { } ] [ 1array ] if-void ] + bi* ; + : append-function-body ( prototype-str body -- str ) [ swap % " {\n" % % "\n}\n" % ] "" make ; diff --git a/extra/alien/inline/syntax/syntax-tests.factor b/extra/alien/inline/syntax/syntax-tests.factor index e6a0b8b7d8..c49b2b5aae 100644 --- a/extra/alien/inline/syntax/syntax-tests.factor +++ b/extra/alien/inline/syntax/syntax-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Jeremy Hughes. ! See http://factorcode.org/license.txt for BSD license. USING: alien.inline alien.inline.syntax io.directories io.files -kernel namespaces tools.test alien.c-types alien.structs ; +kernel namespaces tools.test alien.c-types alien.data alien.structs ; IN: alien.inline.syntax.tests DELETE-C-LIBRARY: test diff --git a/extra/alien/inline/types/types.factor b/extra/alien/inline/types/types.factor index 070febc324..ac7f6ae17f 100644 --- a/extra/alien/inline/types/types.factor +++ b/extra/alien/inline/types/types.factor @@ -2,10 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types assocs combinators.short-circuit continuations effects fry kernel math memoize sequences -splitting strings peg.ebnf make ; +splitting strings peg.ebnf make words ; IN: alien.inline.types : cify-type ( str -- str' ) + dup word? [ name>> ] when { { CHAR: - CHAR: space } } substitute ; : factorize-type ( str -- str' ) diff --git a/extra/alien/marshall/marshall-docs.factor b/extra/alien/marshall/marshall-docs.factor index 361753a0d3..5d6ec29912 100644 --- a/extra/alien/marshall/marshall-docs.factor +++ b/extra/alien/marshall/marshall-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Jeremy Hughes. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel quotations sequences -strings alien alien.c-types math byte-arrays ; +strings alien alien.c-types alien.data math byte-arrays ; IN: alien.marshall float short ; SPECIALIZED-ARRAY: bool SPECIALIZED-ARRAY: char SPECIALIZED-ARRAY: double @@ -22,7 +23,7 @@ SPECIALIZED-ARRAY: ushort SPECIALIZED-ARRAY: void* IN: alien.marshall -<< primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ] +<< primitive-types [ [ void* = ] [ bool = ] bi or not ] filter [ define-primitive-marshallers ] each >> TUPLE: alien-wrapper { underlying alien } ; diff --git a/extra/alien/marshall/private/private.factor b/extra/alien/marshall/private/private.factor index c85b722d11..d138282ff3 100644 --- a/extra/alien/marshall/private/private.factor +++ b/extra/alien/marshall/private/private.factor @@ -3,7 +3,7 @@ USING: accessors alien alien.c-types alien.inline arrays combinators fry functors kernel lexer libc macros math sequences specialized-arrays libc.private -combinators.short-circuit ; +combinators.short-circuit alien.data ; SPECIALIZED-ARRAY: void* IN: alien.marshall.private diff --git a/extra/alien/marshall/structs/structs.factor b/extra/alien/marshall/structs/structs.factor index 54bcab45f2..3f9c8e3a7e 100644 --- a/extra/alien/marshall/structs/structs.factor +++ b/extra/alien/marshall/structs/structs.factor @@ -3,7 +3,7 @@ USING: accessors alien.c-types alien.marshall arrays assocs classes.tuple combinators destructors generalizations generic kernel libc locals parser quotations sequences slots words -alien.structs lexer vocabs.parser fry effects ; +alien.structs lexer vocabs.parser fry effects alien.data ; IN: alien.marshall.structs ensured-read* 3append ] [ f ] if* ; : read-riff-chunk ( -- byte-array/f ) - "riff-chunk" heap-size ensured-read* ; + riff-chunk heap-size ensured-read* ; : id= ( chunk id -- ? ) - [ 4 head ] dip sequence= ; + [ 4 head ] dip sequence= ; inline -: check-chunk ( chunk id min-size -- ? ) - [ id= ] [ [ length ] dip >= ] bi-curry* bi and ; +: check-chunk ( chunk id class -- ? ) + heap-size [ id= ] [ [ length ] dip >= ] bi-curry* bi and ; :: read-wav-chunks ( -- fmt data ) f :> fmt! f :> data! [ { [ fmt data and not ] [ read-chunk ] } 0&& dup ] [ { - { [ dup FMT-MAGIC "wav-fmt-chunk" heap-size check-chunk ] [ fmt! ] } - { [ dup DATA-MAGIC "wav-data-chunk" heap-size check-chunk ] [ data! ] } + { [ dup FMT-MAGIC wav-fmt-chunk check-chunk ] [ wav-fmt-chunk memory>struct fmt! ] } + { [ dup DATA-MAGIC wav-data-chunk check-chunk ] [ wav-data-chunk memory>struct data! ] } } cond ] while drop fmt data 2dup and [ invalid-wav-file ] unless ; : verify-wav ( chunk -- ) { [ RIFF-MAGIC id= ] - [ riff-chunk-format 4 memory>byte-array WAVE-MAGIC id= ] + [ riff-chunk memory>struct format>> 4 memory>byte-array WAVE-MAGIC id= ] } 1&& [ invalid-wav-file ] unless ; : (read-wav) ( -- audio ) read-wav-chunks [ - [ wav-fmt-chunk-num-channels 2 memory>byte-array le> ] - [ wav-fmt-chunk-bits-per-sample 2 memory>byte-array le> ] - [ wav-fmt-chunk-sample-rate 4 memory>byte-array le> ] tri + [ num-channels>> 2 memory>byte-array le> ] + [ bits-per-sample>> 2 memory>byte-array le> ] + [ sample-rate>> 4 memory>byte-array le> ] tri ] [ - [ riff-chunk-header-size 4 memory>byte-array le> dup ] - [ wav-data-chunk-body ] bi swap memory>byte-array + [ header>> size>> 4 memory>byte-array le> dup ] + [ body>> >c-ptr ] bi swap memory>byte-array ] bi*