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

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)
+	$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
-	$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
 		$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
 
 $(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
-	$(LINKER) $(ENGINE) $(DLL_OBJS)
+	$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
-	$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
 		$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
 
 $(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
 

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

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
+USING: alien alien.strings alien.c-types alien.data alien.accessors
-arrays words sequences math kernel namespaces fry libc cpu.architecture
+arrays words sequences math kernel namespaces fry cpu.architecture
 io.encodings.utf8 accessors ;
 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 <displaced-alien> ] ;
-
-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* utf8 } char* typedef
-"char*" "uchar*" typedef
+char* uchar* typedef
 
+char  char*  "pointer-c-type" set-word-prop
+uchar uchar* "pointer-c-type" set-word-prop

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

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 } <displaced-alien> <void*>

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: <int>
 DEFER: *char
 
-: little-endian? ( -- ? ) 1 <int> *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 )
+PREDICATE: c-type-word < word
-    c-types get-global at dup [
+    "c-type" word-prop ;
-        dup string? [ (c-type) ] when
+
-    ] when ;
+UNION: c-type-name string c-type-word ;
 
 ! C type protocol
 GENERIC: c-type ( name -- type ) foldable
 
-: resolve-pointer-type ( name -- name )
+GENERIC: resolve-pointer-type ( name -- c-type )
-    c-types get at dup string?
+
-    [ "*" append ] [ drop "void*" ] if
+M: word resolve-pointer-type
-    c-type ;
+    dup "pointer-c-type" word-prop
+    [ ] [ drop void* ] ?if ;
+M: string resolve-pointer-type
+    dup "*" append dup c-types get at
+    [ nip ] [
+        drop
+        c-types get at dup c-type-name?
+        [ resolve-pointer-type ] [ drop void* ] if
+    ] if ;
 
 : resolve-typedef ( name -- type )
-    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: <c-array> ( len c-type -- array )
-
-M: string <c-array>
-    c-array-constructor execute( len -- array ) ; inline
-
-GENERIC: (c-array) ( len c-type -- array )
-
-M: string (c-array)
-    c-(array)-constructor execute( len -- array ) ; inline
-
-GENERIC: <c-direct-array> ( alien len c-type -- array )
-
-M: string <c-direct-array>
-    c-direct-array-constructor execute( alien len -- array ) ; inline
-
-: malloc-array ( n type -- alien )
-    [ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
-
-: (malloc-array) ( n type -- alien )
-    [ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
-
 GENERIC: c-type-class ( name -- class )
 
 M: abstract-c-type c-type-class class>> ;
 
-M: string c-type-class c-type c-type-class ;
+M: c-type-name c-type-class c-type c-type-class ;
 
 GENERIC: c-type-boxed-class ( name -- class )
 
 M: abstract-c-type c-type-boxed-class boxed-class>> ;
 
-M: string c-type-boxed-class c-type c-type-boxed-class ;
+M: c-type-name c-type-boxed-class c-type c-type-boxed-class ;
 
 GENERIC: c-type-boxer ( name -- boxer )
 
 M: c-type c-type-boxer boxer>> ;
 
-M: string c-type-boxer c-type c-type-boxer ;
+M: c-type-name c-type-boxer c-type c-type-boxer ;
 
 GENERIC: c-type-boxer-quot ( name -- quot )
 
 M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
 
-M: string c-type-boxer-quot c-type c-type-boxer-quot ;
+M: c-type-name c-type-boxer-quot c-type c-type-boxer-quot ;
 
 GENERIC: c-type-unboxer ( name -- boxer )
 
 M: c-type c-type-unboxer unboxer>> ;
 
-M: string c-type-unboxer c-type c-type-unboxer ;
+M: c-type-name c-type-unboxer c-type c-type-unboxer ;
 
 GENERIC: c-type-unboxer-quot ( name -- quot )
 
 M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
 
-M: string c-type-unboxer-quot c-type c-type-unboxer-quot ;
+M: c-type-name c-type-unboxer-quot c-type c-type-unboxer-quot ;
 
 GENERIC: c-type-rep ( name -- rep )
 
 M: c-type c-type-rep rep>> ;
 
-M: string c-type-rep c-type c-type-rep ;
+M: c-type-name c-type-rep c-type c-type-rep ;
 
 GENERIC: c-type-getter ( name -- quot )
 
 M: c-type c-type-getter getter>> ;
 
-M: string c-type-getter c-type c-type-getter ;
+M: c-type-name c-type-getter c-type c-type-getter ;
 
 GENERIC: c-type-setter ( name -- quot )
 
 M: c-type c-type-setter setter>> ;
 
-M: string c-type-setter c-type c-type-setter ;
+M: c-type-name c-type-setter c-type c-type-setter ;
 
 GENERIC: c-type-align ( name -- n )
 
 M: abstract-c-type c-type-align align>> ;
 
-M: string c-type-align c-type c-type-align ;
+M: c-type-name c-type-align c-type c-type-align ;
 
 GENERIC: c-type-stack-align? ( name -- ? )
 
 M: c-type c-type-stack-align? stack-align?>> ;
 
-M: string c-type-stack-align? c-type c-type-stack-align? ;
+M: c-type-name c-type-stack-align? c-type c-type-stack-align? ;
 
 : c-type-box ( n type -- )
     [ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
@@ -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 <int> *char 1 = ; foldable
+
+GENERIC: heap-size ( type -- size ) foldable
+
+M: c-type-name heap-size c-type heap-size ;
+
+M: abstract-c-type heap-size size>> ;
 
 GENERIC: stack-size ( type -- size ) foldable
 
-M: string stack-size c-type stack-size ;
+M: c-type-name stack-size c-type stack-size ;
 
 M: c-type stack-size size>> cell align ;
 
@@ -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* ;
 
-: <c-object> ( type -- array )
-    heap-size <byte-array> ; inline
-
-: (c-object) ( type -- array )
-    heap-size (byte-array) ; inline
-
-: malloc-object ( type -- alien )
-    1 swap heap-size calloc ; inline
-
-: (malloc-object) ( type -- alien )
-    heap-size malloc ; inline
-
-: malloc-byte-array ( byte-array -- alien )
-    dup byte-length [ nip malloc dup ] 2keep memcpy ;
-
-: memory>byte-array ( alien len -- byte-array )
-    [ nip (byte-array) dup ] 2keep memcpy ;
-
-: malloc-string ( string encoding -- alien )
-    string>alien malloc-byte-array ;
-
-M: memory-stream stream-read
-    [
-        [ index>> ] [ alien>> ] bi <displaced-alien>
-        swap memory>byte-array
-    ] [ [ + ] change-index drop ] 2bi ;
-
-: byte-array>memory ( byte-array base -- )
-    swap dup byte-length memcpy ; inline
-
 : array-accessor ( type quot -- def )
     [
         \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
     ] [ ] make ;
 
-: typedef ( old new -- ) c-types get set-at ;
+GENERIC: typedef ( old new -- )
+
+PREDICATE: typedef-word < c-type-word
+    "c-type" word-prop c-type-name? ;
+
+M: string typedef ( old new -- ) c-types get set-at ;
+M: word typedef ( old new -- )
+    {
+        [ nip define-symbol ]
+        [ name>> typedef ]
+        [ swap "c-type" set-word-prop ]
+        [
+            swap dup c-type-name? [
+                resolve-pointer-type
+                "pointer-c-type" set-word-prop
+            ] [ 2drop ] if
+        ]
+    } 2cleave ;
 
 TUPLE: long-long-type < c-type ;
 
@@ -294,36 +282,33 @@ M: long-long-type box-return ( type -- )
 
 : define-out ( name -- )
     [ "alien.c-types" constructor-word ]
-    [ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ] bi
+    [ dup c-setter '[ _ heap-size <byte-array> [ 0 @ ] keep ] ] bi
     (( value -- c-ptr )) define-inline ;
 
-: >c-bool ( ? -- int ) 1 0 ? ; inline
-
-: c-bool> ( int -- ? ) 0 = not ; inline
-
 : define-primitive-type ( type name -- )
     [ typedef ]
-    [ define-deref ]
+    [ name>> define-deref ]
-    [ define-out ]
+    [ 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"
+        char uchar
-        "short" "ushort"
+        short ushort
-        "int" "uint"
+        int uint
-        "long" "ulong"
+        long ulong
-        "longlong" "ulonglong"
+        longlong ulonglong
-        "float" "double"
+        float double
-        "void*" "bool"
+        void* bool
     }
 
+SYMBOLS:
+    ptrdiff_t intptr_t size_t
+    char* uchar* ;
+
 [
     <c-type>
         c-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
 
     <long-long-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
 
     <long-long-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
 
     <c-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
 
     <c-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
 
     <c-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
 
     <c-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
 
     <c-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
 
     <c-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
 
     <c-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
 
     <c-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
 
     <c-type>
-        [ alien-unsigned-1 c-bool> ] >>getter
+        [ alien-unsigned-1 0 = not ] >>getter
-        [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
+        [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
         1 >>size
         1 >>align
         "box_boolean" >>boxer
         "to_boolean" >>unboxer
-    "bool" define-primitive-type
+    \ bool define-primitive-type
 
     <c-type>
-        float >>class
+        math:float >>class
-        float >>boxed-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
 
     <c-type>
-        float >>class
+        math:float >>class
-        float >>boxed-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 \ ptrdiff_t typedef
-    "long" "intptr_t" typedef
+    \ long \ intptr_t typedef
-    "ulong" "size_t" typedef
+    \ ulong \ size_t typedef
 ] with-compilation-unit
 

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
 

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

basis/alien/data/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

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: <c-array>
+{ $values { "len" "a non-negative integer" } { "c-type" "a C type" } { "array" byte-array } }
+{ $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
+{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
+
+HELP: <c-object>
+{ $values { "type" "a C type" } { "array" byte-array } }
+{ $description "Creates a byte array suitable for holding a value with the given C type." }
+{ $errors "Throws an " { $link no-c-type } " error if the type does not exist." } ;
+
+{ <c-object> malloc-object } related-words
+
+HELP: memory>byte-array
+{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
+{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
+
+HELP: byte-array>memory
+{ $values { "byte-array" byte-array } { "base" c-ptr } }
+{ $description "Writes a byte array to memory starting from the " { $snippet "base" } " address." }
+{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
+
+HELP: malloc-array
+{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } }
+{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-direct-array> } "." }
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." }
+{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
+{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
+
+HELP: malloc-object
+{ $values { "type" "a C type" } { "alien" alien } }
+{ $description "Allocates an unmanaged memory block large enough to hold a value of a C type." }
+{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
+{ $errors "Throws an error if the type does not exist or if memory allocation fails." } ;
+
+HELP: malloc-byte-array
+{ $values { "byte-array" byte-array } { "alien" alien } }
+{ $description "Allocates an unmanaged memory block of the same size as the byte array, and copies the contents of the byte array there." }
+{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
+{ $errors "Throws an error if memory allocation fails." } ;
+
+{ <c-array> <c-direct-array> malloc-array } related-words
+
+{ string>alien alien>string malloc-string } related-words
+
+ARTICLE: "malloc" "Manual memory management"
+"Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case."
+$nl
+"Allocating a C datum with a fixed address:"
+{ $subsection malloc-object }
+{ $subsection malloc-array }
+{ $subsection malloc-byte-array }
+"There is a set of words in the " { $vocab-link "libc" } " vocabulary which directly call C standard library memory management functions:"
+{ $subsection malloc }
+{ $subsection calloc }
+{ $subsection realloc }
+"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
+{ $subsection free }
+"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
+{ $subsection &free }
+{ $subsection |free }
+"The " { $link &free } " and " { $link |free } " words are generated using " { $link "alien.destructors" } "."
+$nl
+"You can unsafely copy a range of bytes from one memory location to another:"
+{ $subsection memcpy }
+"You can copy a range of bytes from memory into a byte array:"
+{ $subsection memory>byte-array }
+"You can copy a byte array to memory unsafely:"
+{ $subsection byte-array>memory } ;
+
+
+ARTICLE: "c-byte-arrays" "Passing data in byte arrays"
+"Instances of the " { $link byte-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array."
+$nl
+"Byte arrays can be allocated directly with a byte count using the " { $link <byte-array> } " word. However in most cases, instead of computing a size in bytes directly, it is easier to use a higher-level word which expects C type and outputs a byte array large enough to hold that type:"
+{ $subsection <c-object> }
+{ $subsection <c-array> }
+{ $warning
+"The Factor garbage collector can move byte arrays around, and code passing byte arrays to C must obey important guidelines. See " { $link "byte-arrays-gc" } "." }
+{ $see-also "c-arrays" } ;
+
+ARTICLE: "c-data" "Passing data between Factor and C"
+"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."
+$nl
+"Furthermore, Factor's garbage collector can move objects in memory; for a discussion of the consequences, see " { $link "byte-arrays-gc" } "."
+{ $subsection "c-types-specs" }
+{ $subsection "c-byte-arrays" }
+{ $subsection "malloc" }
+{ $subsection "c-strings" }
+{ $subsection "c-arrays" }
+{ $subsection "c-out-params" }
+"Important guidelines for passing data in byte arrays:"
+{ $subsection "byte-arrays-gc" }
+"C-style enumerated types are supported:"
+{ $subsection POSTPONE: C-ENUM: }
+"C types can be aliased for convenience and consitency with native library documentation:"
+{ $subsection POSTPONE: TYPEDEF: }
+"New C types can be defined:"
+{ $subsection "c-structs" }
+{ $subsection "c-unions" }
+"A utility for defining " { $link "destructors" } " for deallocating memory:"
+{ $subsection "alien.destructors" }
+{ $see-also "aliens" } ;
+HELP: malloc-string
+{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
+{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
+{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
+{ $errors "Throws an error if one of the following conditions occurs:"
+    { $list
+        "the string contains null code points"
+        "the string contains characters not representable using the encoding specified"
+        "memory allocation fails"
+    }
+} ;
+
+HELP: require-c-array
+{ $values { "c-type" "a C type" } }
+{ $description "Generates a specialized array of " { $snippet "c-type" } " using the " { $link <c-array> } " or " { $link <c-direct-array> } " vocabularies." }
+{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence types loaded." } ;
+
+HELP: <c-direct-array>
+{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } }
+{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." }
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } ;
+
+ARTICLE: "c-strings" "C strings"
+"C string types are arrays with shape " { $snippet "{ char* encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $link char* } " is an alias for " { $snippet "{ char* utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
+$nl
+"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
+$nl
+"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
+$nl
+"Care must be taken if the C function expects a " { $link char* } " with a length in bytes, rather than a null-terminated " { $link char* } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
+$nl
+"Sometimes a C function has a parameter type of " { $link void* } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
+{ $subsection string>alien }
+{ $subsection malloc-string }
+"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
+$nl
+"A word to read strings from arbitrary addresses:"
+{ $subsection alien>string }
+"For example, if a C function returns a " { $link char* } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $link void* } ", and call one of the above words before passing the pointer to " { $link free } "." ;
+

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: <c-array> ( len c-type -- array )
+
+M: c-type-name <c-array>
+    c-array-constructor execute( len -- array ) ; inline
+
+GENERIC: (c-array) ( len c-type -- array )
+
+M: c-type-name (c-array)
+    c-(array)-constructor execute( len -- array ) ; inline
+
+GENERIC: <c-direct-array> ( alien len c-type -- array )
+
+M: c-type-name <c-direct-array>
+    c-direct-array-constructor execute( alien len -- array ) ; inline
+
+: malloc-array ( n type -- alien )
+    [ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
+
+: (malloc-array) ( n type -- alien )
+    [ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
+
+: <c-object> ( type -- array )
+    heap-size <byte-array> ; inline
+
+: (c-object) ( type -- array )
+    heap-size (byte-array) ; inline
+
+: malloc-object ( type -- alien )
+    1 swap heap-size calloc ; inline
+
+: (malloc-object) ( type -- alien )
+    heap-size malloc ; inline
+
+: malloc-byte-array ( byte-array -- alien )
+    dup byte-length [ nip malloc dup ] 2keep memcpy ;
+
+: memory>byte-array ( alien len -- byte-array )
+    [ nip (byte-array) dup ] 2keep memcpy ;
+
+: malloc-string ( string encoding -- alien )
+    string>alien malloc-byte-array ;
+
+: malloc-file-contents ( path -- alien len )
+    binary file-contents [ malloc-byte-array ] [ length ] bi ;
+
+M: memory-stream stream-read
+    [
+        [ index>> ] [ alien>> ] bi <displaced-alien>
+        swap memory>byte-array
+    ] [ [ + ] change-index drop ] 2bi ;
+
+: byte-array>memory ( byte-array base -- )
+    swap dup byte-length memcpy ; inline
+
+: >c-bool ( ? -- int ) 1 0 ? ; inline
+
+: c-bool> ( int -- ? ) 0 = not ; inline
+
+M: value-type c-type-rep drop int-rep ;
+
+M: value-type c-type-getter
+    drop [ swap <displaced-alien> ] ;
+
+M: value-type c-type-setter ( type -- quot )
+    [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
+    '[ @ swap @ _ memcpy ] ;
+

basis/alien/data/summary.txt

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

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

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
+alien.data alien.fortran alien.fortran.private alien.strings
-arrays assocs byte-arrays combinators fry
+classes.struct arrays assocs byte-arrays combinators fry
 generalizations io.encodings.ascii kernel macros
 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
+STRUCT: FORTRAN_TEST_RECORD
-    { "INTEGER"     "FOO" }
+    { FOO int }
-    { "REAL(2)"     "BAR" }
+    { BAR double[2] }
-    { "CHARACTER*4" "BAS" } ;
+    { 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)
 
     [ [

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
+USING: accessors alien alien.c-types alien.complex alien.data grouping
-alien.strings alien.structs alien.syntax arrays ascii assocs
+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* <effect> ;
+
 :: define-fortran-function ( return library function parameters -- )
     function create-in dup reset-generic 
     return library function parameters return [ "void" ] unless* parse-arglist

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
+USING: accessors alien alien.c-types arrays assocs
-parser sequences splitting words fry locals lexer namespaces
+combinators combinators.short-circuit effects grouping
-summary math ;
+kernel parser sequences splitting words fry locals lexer
+namespaces summary math vocabs.parser ;
 IN: alien.parser
 
+: parse-c-type-name ( name -- word/string )
+    [ search ] keep or ;
+
+: parse-c-type ( string -- array )
+    {
+        { [ dup "void" =            ] [ drop void ] }
+        { [ CHAR: ] over member?    ] [ parse-array-type parse-c-type-name prefix ] }
+        { [ dup search c-type-word? ] [ parse-c-type-name ] }
+        { [ dup c-types get at      ] [ ] }
+        { [ "*" ?tail               ] [ parse-c-type-name resolve-pointer-type ] }
+        [ no-c-type ]
+    } cond ;
+
+: scan-c-type ( -- c-type )
+    scan dup "{" =
+    [ drop \ } parse-until >array ]
+    [ parse-c-type ] if ; 
+
+: reset-c-type ( word -- )
+    { "c-type" "pointer-c-type" "callback-effect" "callback-abi" } reset-props ;
+
+: CREATE-C-TYPE ( -- word )
+    scan current-vocab create dup reset-c-type ;
+
 : normalize-c-arg ( type name -- type' name' )
     [ length ]
     [
         [ CHAR: * = ] trim-head
         [ length - CHAR: * <array> append ] keep
-    ] bi ;
+    ] bi
+    [ parse-c-type ] dip ;
 
 : parse-arglist ( parameters return -- types effect )
     [
@@ -29,10 +55,37 @@ IN: alien.parser
     return library function
     parameters return parse-arglist [ function-quot ] dip ;
 
+: parse-arg-tokens ( -- tokens )
+    ";" parse-tokens [ "()" subseq? not ] filter ;
+
 : (FUNCTION:) ( -- word quot effect )
-    scan "c-library" get scan ";" parse-tokens
+    scan "c-library" get scan parse-arg-tokens make-function ;
-    [ "()" subseq? not ] filter
-    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 ;
+

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
+USING: accessors kernel combinators alien alien.strings alien.c-types
-prettyprint.backend prettyprint.custom prettyprint.sections ;
+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 ]
+        [
+            <block "(" text
+            [ def>> fourth ] [ stack-effect in>> ] bi
+            pprint-function-args
+            ")" text block>
+        ]
+    } cleave ;
+
+M: alien-callback-type-word definer
+    "callback-abi" word-prop "stdcall" =
+    \ STDCALL-CALLBACK: \ CALLBACK: ? 
+    f ;
+M: alien-callback-type-word definition drop f ;
+M: alien-callback-type-word synopsis*
+    {
+        [ seeing-word ]
+        [ definer. ]
+        [ def>> first pprint-c-type ]
+        [ pprint-word ]
+        [
+            <block "(" text 
+            [ def>> second ] [ "callback-effect" word-prop in>> ] bi
+            pprint-function-args
+            ")" text block>
+        ]
+    } cleave ;

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
 

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
 

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
 

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

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:"
+    "Here is an example enumeration definition:"
-    { $code "C-ENUM: red green blue ;" ": red 0 ;  : green 1 ;  : blue 2 ;" }
+    { $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

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 <alien> parsed ;
+SYNTAX: ALIEN: 16 scan-base <alien> parsed ;
 
 SYNTAX: BAD-ALIEN <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 )

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

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
+STRUCT: cairo_matrix_t
-    { "double" "xx" }
+    { xx double }
-    { "double" "yx" }
+    { yx double }
-    { "double" "xy" }
+    { xy double }
-    { "double" "yy" }
+    { yy double }
-    { "double" "x0" }
+    { x0 double }
-    { "double" "y0" } ;
+    { y0 double } ;
 
 TYPEDEF: void* cairo_pattern_t
 
 TYPEDEF: void* cairo_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
+STRUCT: cairo_user_data_key_t
-    { "int" "unused" } ;
+    { 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
+STRUCT: cairo_rectangle_t
-    { "double" "x" }
+    { x      double }
-    { "double" "y" }
+    { y      double }
-    { "double" "width" }
+    { width  double }
-    { "double" "height" } ;
+    { height double } ;
     
-C-STRUCT: cairo_rectangle_list_t
+STRUCT: cairo_rectangle_list_t
-    { "cairo_status_t"     "status" }
+    { status         cairo_status_t     }
-    { "cairo_rectangle_t*" "rectangles" }
+    { rectangles     cairo_rectangle_t* }
-    { "int"                "num_rectangles" } ;
+    { num_rectangles int                } ;
 
 FUNCTION: cairo_rectangle_list_t*
 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
+STRUCT: cairo_glyph_t
-  { "ulong"     "index" }
+  { index ulong     }
-  { "double"    "x" }
+  { x     double    }
-  { "double"    "y" } ;
+  { y     double    } ;
 
-C-STRUCT: cairo_text_extents_t
+STRUCT: cairo_text_extents_t
-    { "double" "x_bearing" }
+    { x_bearing double }
-    { "double" "y_bearing" }
+    { y_bearing double }
-    { "double" "width" }
+    { width     double }
-    { "double" "height" }
+    { height    double }
-    { "double" "x_advance" }
+    { x_advance double }
-    { "double" "y_advance" } ;
+    { y_advance double } ;
 
-C-STRUCT: cairo_font_extents_t
+STRUCT: cairo_font_extents_t
-    { "double" "ascent" }
+    { ascent double }
-    { "double" "descent" }
+    { descent double }
-    { "double" "height" }
+    { height double }
-    { "double" "max_x_advance" }
+    { max_x_advance double }
-    { "double" "max_y_advance" } ;
+    { max_y_advance double } ;
 
 TYPEDEF: int cairo_font_slant_t
 C-ENUM:
@@ -648,20 +648,22 @@ C-ENUM:
     CAIRO_PATH_CLOSE_PATH ;
 
 ! NEED TO DO UNION HERE
-C-STRUCT: cairo_path_data_t-point
+STRUCT: cairo_path_data_t-point
-    { "double" "x" }
+    { x double }
-    { "double" "y" } ;
+    { y double } ;
 
-C-STRUCT: cairo_path_data_t-header
+STRUCT: cairo_path_data_t-header
-    { "cairo_path_data_type_t" "type" }
+    { type cairo_path_data_type_t }
-    { "int" "length" } ;
+    { length int } ;
 
-C-UNION: cairo_path_data_t "cairo_path_data_t-point" "cairo_path_data_t-header" ;
+UNION-STRUCT: cairo_path_data_t 
+    { point  cairo_path_data_t-point }
+    { header cairo_path_data_t-header } ;
 
-C-STRUCT: cairo_path_t
+STRUCT: cairo_path_t
-    { "cairo_status_t"      "status" }
+    { status   cairo_status_t      }
-    { "cairo_path_data_t*"  "data" }
+    { data     cairo_path_data_t*  }
-    { "int"                 "num_data" } ;
+    { num_data int                 } ;
 
 FUNCTION: cairo_path_t*
 cairo_copy_path ( cairo_t* cr ) ;

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
+USING: accessors byte-arrays alien.c-types alien.data kernel
-destructors sequences io openssl openssl.libcrypto checksums
+continuations destructors sequences io openssl openssl.libcrypto
-checksums.stream ;
+checksums checksums.stream classes.struct ;
 IN: checksums.openssl
 
 ERROR: unknown-digest name ;
@@ -23,7 +23,7 @@ TUPLE: evp-md-context < disposable handle ;
 
 : <evp-md-context> ( -- ctx )
     evp-md-context new-disposable
-    "EVP_MD_CTX" <c-object> dup EVP_MD_CTX_init >>handle ;
+    EVP_MD_CTX <struct> dup EVP_MD_CTX_init >>handle ;
 
 M: evp-md-context dispose*
     handle>> EVP_MD_CTX_cleanup drop ;

basis/classes/struct/prettyprint/prettyprint.factor

@@ -1,9 +1,9 @@
 ! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types arrays assocs classes
+USING: accessors alien alien.c-types alien.data alien.prettyprint arrays
-classes.struct combinators combinators.short-circuit continuations
+assocs classes classes.struct combinators combinators.short-circuit
-fry kernel libc make math math.parser mirrors prettyprint.backend
+continuations fry kernel libc make math math.parser mirrors
-prettyprint.custom prettyprint.sections see.private sequences
+prettyprint.backend prettyprint.custom prettyprint.sections
-slots strings summary words ;
+see.private sequences slots strings summary words ;
 IN: classes.struct.prettyprint
 
 <PRIVATE
@@ -20,7 +20,7 @@ IN: classes.struct.prettyprint
     <flow \ { pprint-word
     f <inset {
         [ name>> 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 ;
 

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            }
+    { { "x" char } 98            }
-    { { "y" "int"  } HEX: 7F00007F }
+    { { "y" int  } HEX: 7F00007F }
-    { { "z" "bool" } f             }
+    { { "z" bool } f             }
 } ] [
     B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct
     make-mirror >alist
@@ -128,7 +130,7 @@ STRUCT: struct-test-bar
 ] unit-test
 
 UNION-STRUCT: struct-test-float-and-bits
-    { f float }
+    { f c:float }
     { bits uint } ;
 
 [ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
@@ -181,14 +183,14 @@ STRUCT: struct-test-string-ptr
     ] with-scope
 ] unit-test
 
-[ <" USING: classes.struct ;
+[ <" USING: alien.c-types classes.struct ;
 IN: classes.struct.tests
 STRUCT: struct-test-foo
     { x char initial: 0 } { y int initial: 123 } { z bool } ;
 "> ]
 [ [ struct-test-foo see ] with-string-writer ] unit-test
 
-[ <" USING: classes.struct ;
+[ <" USING: alien.c-types classes.struct ;
 IN: classes.struct.tests
 UNION-STRUCT: struct-test-float-and-bits
     { f float initial: 0.0 } { bits uint initial: 0 } ;
@@ -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" }
+        { initial 0 }
-        { reader x>> }
+        { class fixnum }
-        { writer (>>x) }
+        { type char }
     }
-    T{ field-spec
+    T{ struct-slot-spec
         { name "y" }
         { offset 4 }
-        { type "int" }
+        { initial 123 }
-        { reader y>> }
+        { class integer }
-        { writer (>>y) }
+        { type int }
     }
-    T{ field-spec
+    T{ struct-slot-spec
         { name "z" }
         { offset 8 }
-        { type "bool" }
+        { initial f }
-        { reader z>> }
+        { type bool }
-        { writer (>>z) }
+        { class object }
     }
 } ] [ "struct-test-foo" c-type fields>> ] unit-test
 
 [ {
-    T{ field-spec
+    T{ struct-slot-spec
         { name "f" }
         { offset 0 }
-        { type "float" }
+        { type c:float }
-        { reader f>> }
+        { class float }
-        { writer (>>f) }
+        { initial 0.0 }
     }
-    T{ field-spec
+    T{ struct-slot-spec
         { name "bits" }
         { offset 0 }
-        { type "uint" }
+        { type uint }
-        { reader bits>> }
+        { class integer }
-        { writer (>>bits) }
+        { 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
 

basis/classes/struct/struct.factor

@@ -1,14 +1,12 @@
 ! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.structs
+USING: accessors alien alien.c-types alien.data alien.parser arrays
-alien.structs.fields arrays byte-arrays classes classes.parser
+byte-arrays classes classes.parser classes.tuple classes.tuple.parser
-classes.tuple classes.tuple.parser classes.tuple.private
+classes.tuple.private combinators combinators.short-circuit
-combinators combinators.short-circuit combinators.smart
+combinators.smart cpu.architecture definitions functors.backend
-definitions functors.backend fry generalizations generic.parser
+fry generalizations generic.parser kernel kernel.private lexer
-kernel kernel.private lexer libc locals macros make math
+libc locals macros make math math.order parser quotations
-math.order parser quotations sequences slots slots.private
+sequences slots slots.private specialized-arrays vectors words
-specialized-arrays vectors words summary namespaces assocs
+summary namespaces assocs vocabs.parser ;
-compiler.tree.propagation.transforms ;
-FROM: slots => reader-word writer-word ;
 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: <struct-boa> ( 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 ;
+
 <PRIVATE
 : struct-slot-values-quot ( class -- quot )
     struct-slots
@@ -139,63 +170,33 @@ M: struct-class writer-quot
     [ \ clone-underlying swap literalize \ memory>struct [ ] 3sequence ] bi
     define-inline-method ;
 
-: slot>field ( slot -- field )
+: c-type-for-class ( class -- c-type )
-    field-spec new swap {
+    struct-c-type new swap {
-        [ name>> >>name ]
+        [ drop byte-array >>class ]
-        [ offset>> >>offset ]
+        [ >>boxed-class ]
-        [ c-type>> >>type ]
+        [ struct-slots >>fields ]
-        [ name>> reader-word >>reader ]
+        [ "struct-size" word-prop >>size ]
-        [ name>> writer-word >>writer ]
+        [ "struct-align" word-prop >>align ]
-    } 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 ;
-        } cleave drop
-    ] bi ;
     
 : align-offset ( offset class -- offset' )
     c-type-align align ;
 
 : struct-offsets ( slots -- size )
     0 [
-        [ c-type>> align-offset ] keep
+        [ type>> align-offset ] keep
-        [ (>>offset) ] [ c-type>> heap-size + ] 2bi
+        [ (>>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 ;
 : <struct-slot-spec> ( 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* ;
 
 <PRIVATE
-: scan-c-type ( -- c-type )
-    scan dup "{" = [ drop \ } parse-until >array ] when ;
-
 : parse-struct-slot ( -- slot )
     scan scan-c-type \ } parse-until <struct-slot-spec> ;
     
@@ -302,7 +300,7 @@ SYNTAX: S@
 
 <PRIVATE
 : scan-c-type` ( -- c-type/param )
-    scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
+    scan dup "{" = [ drop \ } parse-until >array ] [ search ] if ;
 
 : parse-struct-slot` ( accum -- accum )
     scan-string-param scan-c-type` \ } parse-until

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
+USING: accessors kernel classes.struct cocoa cocoa.runtime cocoa.types alien.data
-locals math sequences vectors fry libc destructors ;
+locals math sequences vectors fry libc destructors specialized-arrays ;
+SPECIALIZED-ARRAY: id
 IN: cocoa.enumeration
 
-<< "id" require-c-array >>
-
 CONSTANT: NS-EACH-BUFFER-SIZE 16
 
 : with-enumeration-buffers ( quot -- )
     '[
         NSFastEnumerationState malloc-struct &free
-        NS-EACH-BUFFER-SIZE "id" malloc-array &free
+        NS-EACH-BUFFER-SIZE id malloc-array &free
         NS-EACH-BUFFER-SIZE
         @
     ] with-destructors ; inline
@@ -19,7 +18,7 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16
 :: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
     object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count
     items-count 0 = [
-        state itemsPtr>> [ items-count "id" <c-direct-array> ] [ stackbuf ] if* :> items
+        state itemsPtr>> [ items-count id <c-direct-array> ] [ stackbuf ] if* :> items
         items-count iota [ items nth quot call ] each
         object quot state stackbuf count (NSFastEnumeration-each)
     ] unless ; inline recursive

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
+combinators alien.c-types alien.data words core-foundation
-core-foundation.data core-foundation.utilities ;
+quotations core-foundation.data core-foundation.utilities ;
 IN: cocoa.plists
 
 : >plist ( value -- plist ) >cf -> autorelease ;

basis/colors/constants/constants.factor

@@ -11,23 +11,23 @@ IN: colors.constants
     [ [ string>number 255 /f ] tri@ 1.0 <rgba> ] 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 ;

basis/colors/constants/factor-colors.txt

@@ -1,6 +1,6 @@
 ! Factor UI theme colors
-243 242 234		FactorLightLightTan
+243 242 234		FactorLightTan
-227 226 219		FactorLightTan
+227 226 219		FactorTan
 172 167 147		FactorDarkTan
  81  91 105		FactorLightSlateBlue
  55  62  72		FactorDarkSlateBlue

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

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

basis/compiler/cfg/builder/builder-tests.factor

@@ -192,6 +192,7 @@ IN: compiler.cfg.builder.tests
     [ [ ##unbox-alien? ] 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? ]
@@ -203,3 +204,4 @@ IN: compiler.cfg.builder.tests
         [ [ ##box-alien? ] contains-insn? ]
         [ [ ##box-float? ] contains-insn? ] bi
     ] unit-test
+] when

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

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 ;

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

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-ordered-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-comparison ] }
+        { math.private:float>= [ drop cc>= emit-float-ordered-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-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 ] }

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 ;

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 <spill-slot> ] unless ;
+    ?at [ spill-slots get ?at [ <spill-slot> ] [ 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 ;
 

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 -- )
+ERROR: already-numbered insn ;
-    linearization-order 0 [
+
-        instructions>> [
+: number-instruction ( n insn -- n' )
-            [ (>>insn#) ] [ drop 2 + ] 2bi
+    [ nip dup insn#>> [ already-numbered ] [ drop ] if ]
-        ] each
+    [ (>>insn#) ]
-    ] reduce drop ;
+    [ drop 2 + ]
+    2tri ;
+
+: number-instructions ( cfg -- )
+    linearization-order
+    0 [ instructions>> [ number-instruction ] each ] reduce
+    drop ;
 
 SYMBOL: check-numbering?
 

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

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>> <reversed> [ loop-nesting-at ] sort-with ;
 
 : process-block ( bb -- )
+    dup visited? [ drop ] [
         [ , ]
         [ visited get conjoin ]
         [ sorted-successors [ process-successor ] each ]
-    tri ;
+        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)

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.

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

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

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
 
@@ -415,3 +416,18 @@ cell 4 = [
 [ 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
+
+! 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

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

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 [ <alien> ] compile-call
+    HEX: 123 [ <alien> ] compile-call
 ] unit-test
 
 [ ALIEN: 123 ] [
-    123 [ { fixnum } declare <alien> ] compile-call
+    HEX: 123 [ { fixnum } declare <alien> ] compile-call
 ] unit-test
 
 [ ALIEN: 123 ] [
-    [ 123 <alien> ] compile-call
+    [ HEX: 123 <alien> ] compile-call
 ] unit-test
 
 [ f ] [
@@ -522,8 +523,8 @@ cell 8 = [
 [ ALIEN: 1234 ALIEN: 2234 ] [
     ALIEN: 234 [
         { c-ptr } declare
-        [ 1000 swap <displaced-alien> ]
+        [ HEX: 1000 swap <displaced-alien> ]
-        [ 2000 swap <displaced-alien> ] bi
+        [ HEX: 2000 swap <displaced-alien> ] bi
     ] compile-call
 ] unit-test
 

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
 

basis/compiler/tests/optimizer.factor

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

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

basis/compiler/tree/comparisons/comparisons.factor

@@ -1,11 +1,11 @@
-! 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=? }
 
@@ -15,6 +15,10 @@ CONSTANT: generic-comparison-ops { before? after? before=? after=? }
         { \ >   [ assume> ] }
         { \ <=  [ assume<= ] }
         { \ >=  [ assume>= ] }
+        { \ u<  [ assume< ] }
+        { \ u>  [ assume> ] }
+        { \ u<= [ assume<= ] }
+        { \ u>= [ assume>= ] }
     } case ;
 
 : interval-comparison ( i1 i2 op -- result )
@@ -23,6 +27,10 @@ CONSTANT: generic-comparison-ops { before? after? before=? after=? }
         { \ >   [ 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' )

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>> <reversed> ] [ [ dispatch# ] keep ] bi*
             [ swap nth value-info class>> dup ] dip
-            specific-method
+            method-for-class
         ] if
     ] if ;
 

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 <class-info> ] 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
+        @
+        <class/interval-info>
+    ] "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

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 [

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

basis/core-foundation/core-foundation.factor

@@ -10,9 +10,14 @@ CONSTANT: kCFAllocatorDefault f
 
 TYPEDEF: bool      Boolean
 TYPEDEF: long      CFIndex
-TYPEDEF: char UInt8
+TYPEDEF: uchar     UInt8
-TYPEDEF: int SInt32
+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
+

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

basis/core-foundation/run-loop/run-loop.factor

@@ -54,11 +54,7 @@ FUNCTION: void CFRunLoopRemoveTimer (
     CFStringRef mode
 ) ;
 
-: CFRunLoopDefaultMode ( -- alien )
+CFSTRING: CFRunLoopDefaultMode "kCFRunLoopDefaultMode"
-    #! Ugly, but we don't have static NSStrings
-    \ CFRunLoopDefaultMode [
-        "kCFRunLoopDefaultMode" <CFString>
-    ] initialize-alien ;
 
 TUPLE: run-loop fds sources timers ;
 

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 (
 
 : <CFStringArray> ( seq -- alien )
     [ [ <CFString> &CFRelease ] map <CFArray> ] with-destructors ;
+
+SYNTAX: CFSTRING: 
+    CREATE scan-object 
+    [ drop ] [ '[ _ [ _ <CFString> ] initialize-alien ] ] 2bi
+    (( -- alien )) define-declared ;

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 ;

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

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
+    EDX n struct-return@ LEA
-    8 [
+    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
+    EDX n stack@ LEA
-    12 [
+    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

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

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

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

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

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
+SYMBOL: (stack-value)
-<< "void*" c-type clone "__stack_value" define-primitive-type
+! The ABI for passing structs by value is pretty great
-stack-params "__stack_value" c-type (>>rep) >>
+<< void* c-type clone \ (stack-value) define-primitive-type
+stack-params \ (stack-value) c-type (>>rep) >>
 
 : struct-types&offset ( struct-type -- pairs )
     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 <repetition> ;
+    cell /i \ (stack-value) c-type <repetition> ;
 
-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 <= ;
 

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

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 ptrdiff_t typedef
-"longlong" "intptr_t" typedef
+longlong intptr_t  typedef
-"int" c-type "long" define-primitive-type
+int  c-type long  define-primitive-type
-"uint" c-type "ulong" define-primitive-type
+uint c-type ulong define-primitive-type
 >>

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

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
+alien.c-types alien.syntax combinators locals init io cpu.x86
-compiler.units accessors ;
+compiler compiler.units accessors ;
 IN: cpu.x86.features
 
 <PRIVATE

basis/cpu/x86/x86.factor

@@ -4,18 +4,17 @@ USING: accessors assocs alien alien.c-types arrays strings
 cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
 cpu.architecture kernel kernel.private math memory namespaces make
 sequences words system layouts combinators math.order fry locals
-compiler.constants byte-arrays
+compiler.constants vm byte-arrays
 compiler.cfg.registers
 compiler.cfg.instructions
 compiler.cfg.intrinsics
 compiler.cfg.comparisons
 compiler.cfg.stack-frame
-compiler.codegen
 compiler.codegen.fixup ;
+FROM: layouts => cell ;
+FROM: math => float ;
 IN: cpu.x86
 
-<< enable-fixnum-log2 >>
-
 ! Add some methods to the assembler to be more useful to the backend
 M: label JMP 0 JMP rc-relative label-fixup ;
 M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
@@ -555,9 +554,13 @@ M: x86 %shl [ SHL ] emit-shift ;
 M: x86 %shr [ SHR ] emit-shift ;
 M: x86 %sar [ SAR ] emit-shift ;
 
+M: x86 %vm-field-ptr ( dst field -- )
+    [ drop 0 MOV rc-absolute-cell rt-vm rel-fixup ]
+    [ vm-field-offset ADD ] 2bi ;
+
 : load-zone-ptr ( reg -- )
     #! Load pointer to start of zone array
-    0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
+    "nursery" %vm-field-ptr ;
 
 : load-allot-ptr ( nursery-ptr allot-ptr -- )
     [ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
@@ -577,18 +580,19 @@ M:: x86 %allot ( dst size class nursery-ptr -- )
     dst class store-tagged
     nursery-ptr size inc-allot-ptr ;
 
+
 M:: x86 %write-barrier ( src card# table -- )
     #! Mark the card pointed to by vreg.
     ! Mark the card
     card# src MOV
     card# card-bits SHR
-    table "cards_offset" f %alien-global
+    table "cards_offset" %vm-field-ptr
     table table [] MOV
     table card# [+] card-mark <byte> MOV
 
     ! Mark the card deck
     card# deck-bits card-bits - SHR
-    table "decks_offset" f %alien-global
+    table "decks_offset" %vm-field-ptr
     table table [] MOV
     table card# [+] card-mark <byte> MOV ;
 
@@ -610,9 +614,9 @@ 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
+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 0 MOV rc-absolute-cell rt-vm rel-fixup
-    temp1 temp1 [] MOV
+    temp1 temp1 "stack_chain" vm-field-offset [+] MOV
     temp2 stack-reg cell neg [+] LEA
     temp1 [] temp2 MOV
     callback-allowed? [
@@ -774,3 +778,4 @@ M: x86 small-enough? ( n -- ? )
     enable-sse3-simd ;
 
 enable-min/max
+enable-fixnum-log2

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 <sqlite-db> swap with-db ;"> }
+    "book.db" temp-file <sqlite-db> 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

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
+alien.data db.types tools.walker ascii splitting math.parser
-libc calendar.format byte-arrays destructors prettyprint
+combinators libc calendar.format byte-arrays destructors
-accessors strings serialize io.encodings.binary io.encodings.utf8
+prettyprint accessors strings serialize io.encodings.binary
-alien.strings io.streams.byte-array summary present urls
+io.encodings.utf8 alien.strings io.streams.byte-array summary
-specialized-arrays db.private ;
+present urls specialized-arrays db.private ;
 SPECIALIZED-ARRAY: uint
 SPECIALIZED-ARRAY: void*
 IN: db.postgresql.lib

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

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

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
+USING: alien alien.c-types alien.data alien.strings
-layouts sequences system unix environment io.encodings.utf8
+alien.syntax kernel layouts sequences system unix
-unix.utilities vocabs.loader combinators alien.accessors ;
+environment io.encodings.utf8 unix.utilities vocabs.loader
+combinators alien.accessors ;
 IN: environment.unix
 
 HOOK: environ os ( -- void* )

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
+splitting windows windows.kernel32 windows.types system
-alien.c-types sequences windows.errors io.streams.memory
+environment alien.data sequences windows.errors
-io.encodings io ;
+io.streams.memory io.encodings io specialized-arrays ;
+SPECIALIZED-ARRAY: TCHAR
 IN: environment.winnt
 
-<< "TCHAR" require-c-array >>
-
 M: winnt os-env ( key -- value )
-    MAX_UNICODE_PATH "TCHAR" <c-array>
+    MAX_UNICODE_PATH TCHAR <c-array>
     [ dup length GetEnvironmentVariable ] keep over 0 = [
         2drop f
     ] [

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

basis/furnace/recaptcha/example/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

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" <sqlite-db> ;
+
+: <recaptcha-challenge> ( -- obj )
+    <page-action>
+        [
+            begin-conversation
+            validate-recaptcha
+            recaptcha-valid? cget
+            "?good" "?bad" ? >url <continue-conversation>
+        ] >>submit
+        { recaptcha-app "example" } >>template ;
+
+: <recaptcha-app> ( -- obj )
+    \ recaptcha-app new-dispatcher
+        <recaptcha-challenge> "" add-responder
+        <recaptcha>
+        "concatenative.org" >>domain
+        "6LeJWQgAAAAAAFlYV7SuBClE9uSpGtV_ZS-qVON7" >>public-key
+        "6LeJWQgAAAAAALh-XJgSSQ6xKygRgJ8-029Ip2Xv" >>private-key
+        recaptcha-db <alloy> ;

basis/furnace/recaptcha/example/example.xml

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

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

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 ;
+
+: <recaptcha> ( responder -- obj )
+    recaptcha new
+        swap >>responder ;
+
+M: recaptcha call-responder*
+    dup \ recaptcha set
+    responder>> call-responder ;
+
+<PRIVATE
+
+: (render-recaptcha) ( private-key -- xml )
+    dup
+[XML <script type="text/javascript"
+   src=<->>
+</script>
+
+<noscript>
+   <iframe src=<->
+       height="300" width="500" frameborder="0"></iframe><br/>
+   <textarea name="recaptcha_challenge_field" rows="3" cols="40">
+   </textarea>
+   <input type="hidden" name="recaptcha_response_field" 
+       value="manual_challenge"/>
+</noscript>
+XML] ;
+
+: recaptcha-url ( secure? -- ? )
+    [ "https://api.recaptcha.net/challenge" ]
+    [ "http://api.recaptcha.net/challenge" ] if
+    recaptcha-error cget [ "?error=" glue ] when* >url ;
+
+: render-recaptcha ( -- xml )
+    secure-connection? recaptcha-url
+    recaptcha get public-key>> "k" set-query-param (render-recaptcha) ;
+
+: parse-recaptcha-response ( string -- valid? error )
+    "\n" split first2 [ "true" = ] dip ;
+
+:: (validate-recaptcha) ( challenge response recaptcha -- valid? error )
+    recaptcha private-key>> :> private-key
+    remote-address get host>> :> remote-ip
+    H{
+        { "challenge" challenge }
+        { "response" response }
+        { "privatekey" private-key }
+        { "remoteip" remote-ip }
+    } URL" http://api-verify.recaptcha.net/verify"
+    <post-request> http-request nip parse-recaptcha-response ;
+
+CHLOE: recaptcha
+    drop [ render-recaptcha ] [xml-code] ;
+
+PRIVATE>
+
+: validate-recaptcha ( -- )
+    {
+        { "recaptcha_challenge_field" [ v-required ] }
+        { "recaptcha_response_field" [ v-required ] }
+    } validate-params
+    "recaptcha_challenge_field" value
+    "recaptcha_response_field" value
+    \ recaptcha get (validate-recaptcha)
+    [ recaptcha-valid? cset ] [ recaptcha-error cset ] bi* ;

basis/furnace/recaptcha/recaptcha.xml

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

basis/furnace/recaptcha/summary.txt

@@ -0,0 +1 @@
+Recaptcha library

basis/furnace/recaptcha/tags.txt

@@ -0,0 +1 @@
+web

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 -- ? )
+: ?device-interface ( dbt-broadcast-hdr -- ? )
-    dbch_devicetype>> DBT_DEVTYP_DEVICEINTERFACE = ;
+    dup dbch_devicetype>> DBT_DEVTYP_DEVICEINTERFACE =
+    [ >c-ptr DEV_BROADCAST_DEVICEW memory>struct ]
+    [ drop f ] if ; inline
 
 : device-arrived ( dbt-broadcast-hdr -- )
-    device-interface? [ find-controllers ] when ;
+    ?device-interface [ find-controllers ] when ; inline
 
 : device-removed ( dbt-broadcast-hdr -- )
-    device-interface? [ find-and-remove-detached-devices ] when ;
+    ?device-interface [ find-and-remove-detached-devices ] when ; inline
+
+: <DEV_BROADCAST_HDR> ( wParam -- struct )
+    <alien> DEV_BROADCAST_HDR memory>struct ;
 
 : handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
     [ 2drop ] 2dip swap {
-        { [ dup DBT_DEVICEARRIVAL = ]         [ drop <alien> device-arrived ] }
+        { [ dup DBT_DEVICEARRIVAL = ]         [ drop <DEV_BROADCAST_HDR> device-arrived ] }
-        { [ dup DBT_DEVICEREMOVECOMPLETE = ]  [ drop <alien> device-removed ] }
+        { [ dup DBT_DEVICEREMOVECOMPLETE = ]  [ drop <DEV_BROADCAST_HDR> device-removed ] }
         [ 2drop ]
     } cond ;
 

basis/game-input/dinput/keys-array/keys-array.factor

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

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

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

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

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

basis/help/vocabs/vocabs.factor

@@ -227,6 +227,18 @@ C: <vocab-author> 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> vocab-author
     first {
         [ describe-help ]
         [ describe-metadata ]
-        [ words $words ]
+        [ describe-words ]
         [ describe-files ]
         [ describe-children ]
     } cleave ;

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