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

Conflicts:

	extra/delegate/delegate.factor
	extra/unicode/data/data.factor

.gitignore

@@ -2,6 +2,7 @@
 _darcs
 *.obj
 *.o
+*.s
 *.exe
 Factor/factor
 *.a

build-support/factor.sh

@@ -439,7 +439,7 @@ install_build_system_port() {
 }
 
 usage() {
-    echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|net-bootstrap|make-target"
+    echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|dlls|net-bootstrap|make-target"
     echo "If you are behind a firewall, invoke as:"
     echo "env GIT_PROTOCOL=http $0 <command>"
 }

core/alien/alien.factor

@@ -28,12 +28,6 @@ M: f expired? drop t ;
 : <alien> ( address -- alien )
     f <displaced-alien> { simple-c-ptr } declare ; inline
 
-: alien>native-string ( alien -- string )
-    os windows? [ alien>u16-string ] [ alien>char-string ] if ;
-
-: dll-path ( dll -- string )
-    (dll-path) alien>native-string ;
-
 M: alien equal?
     over alien? [
         2dup [ expired? ] either? [

core/alien/arrays/arrays-docs.factor

@@ -18,7 +18,6 @@ ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays"
 { $subsection >c-ushort-array    }
 { $subsection >c-void*-array     }
 { $subsection c-bool-array>      }
-{ $subsection c-char*-array>     }
 { $subsection c-char-array>      }
 { $subsection c-double-array>    }
 { $subsection c-float-array>     }
@@ -30,7 +29,6 @@ ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays"
 { $subsection c-uint-array>      }
 { $subsection c-ulong-array>     }
 { $subsection c-ulonglong-array> }
-{ $subsection c-ushort*-array>   }
 { $subsection c-ushort-array>    }
 { $subsection c-void*-array>     } ;
 
@@ -61,9 +59,7 @@ ARTICLE: "c-arrays-get/set" "Reading and writing elements in C arrays"
 { $subsection double-nth }
 { $subsection set-double-nth }
 { $subsection void*-nth }
-{ $subsection set-void*-nth }
+{ $subsection set-void*-nth } ;
-{ $subsection char*-nth }
-{ $subsection ushort*-nth } ;
 
 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" } "."

core/alien/arrays/arrays.factor

@@ -1,8 +1,7 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien arrays alien.c-types alien.structs
-sequences math kernel generator.registers
+sequences math kernel namespaces libc cpu.architecture ;
-namespaces libc ;
 IN: alien.arrays
 
 UNION: value-type array struct-type ;
@@ -27,7 +26,9 @@ M: array stack-size drop "void*" stack-size ;
 
 M: value-type c-type-reg-class drop int-regs ;
 
-M: value-type c-type-prep drop f ;
+M: value-type c-type-boxer-quot drop f ;
+
+M: value-type c-type-unboxer-quot drop f ;
 
 M: value-type c-type-getter
     drop [ swap <displaced-alien> ] ;

core/alien/c-types/c-types-docs.factor

@@ -62,28 +62,6 @@ HELP: <c-object>
 
 { <c-object> malloc-object } related-words
 
-HELP: string>char-alien ( string -- array )
-{ $values { "string" string } { "array" byte-array } }
-{ $description "Copies the string to a new byte array, converting it to 8-bit ASCII and adding a trailing null byte." }
-{ $errors "Throws an error if the string contains null characters, or characters beyond the 8-bit range." } ;
-
-{ string>char-alien alien>char-string malloc-char-string } related-words
-
-HELP: alien>char-string ( c-ptr -- string )
-{ $values { "c-ptr" c-ptr } { "string" string } }
-{ $description "Reads a null-terminated 8-bit C string from the specified address." } ;
-
-HELP: string>u16-alien ( string -- array )
-{ $values { "string" string } { "array" byte-array } }
-{ $description "Copies the string to a new byte array in UCS-2 format with a trailing null byte." }
-{ $errors "Throws an error if the string contains null characters." } ;
-
-{ string>u16-alien alien>u16-string malloc-u16-string } related-words
-
-HELP: alien>u16-string ( c-ptr -- string )
-{ $values { "c-ptr" c-ptr } { "string" string } }
-{ $description "Reads a null-terminated UCS-2 string from the specified address." } ;
-
 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." } ;
@@ -111,18 +89,6 @@ HELP: malloc-byte-array
 { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
 { $errors "Throws an error if memory allocation fails." } ;
 
-HELP: malloc-char-string
-{ $values { "string" string } { "alien" c-ptr } }
-{ $description "Allocates an unmanaged memory block, and stores a string in 8-bit ASCII encoding with a trailing null byte to the block." }
-{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
-{ $errors "Throws an error if memory allocation fails." } ;
-
-HELP: malloc-u16-string
-{ $values { "string" string } { "alien" c-ptr } }
-{ $description "Allocates an unmanaged memory block, and stores a string in UCS2 encoding with a trailing null character to the block." }
-{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
-{ $errors "Throws an error if memory allocation fails." } ;
-
 HELP: define-nth
 { $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
 { $description "Defines a word " { $snippet { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( n c-ptr -- value )" } " for reading the value with C type " { $snippet "name" } " stored at an alien pointer, displaced by a multiple of the C type's size." }
@@ -202,8 +168,6 @@ $nl
 { $subsection *float }
 { $subsection *double }
 { $subsection *void* }
-{ $subsection *char* }
-{ $subsection *ushort* }
 "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"
@@ -267,26 +231,6 @@ $nl
 "A wrapper for temporarily allocating a block of memory:"
 { $subsection with-malloc } ;
 
-ARTICLE: "c-strings" "C strings"
-"The C library interface defines two types of C strings:"
-{ $table
-    { "C type" "Notes" }
-    { { $snippet "char*" } "8-bit per character null-terminated ASCII" }
-    { { $snippet "ushort*" } "16-bit per character null-terminated UCS-2" }
-}
-"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. 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."
-"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>char-alien }
-{ $subsection string>u16-alien }
-{ $subsection malloc-char-string }
-{ $subsection malloc-u16-string }
-"The first two allocate " { $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
-"Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:"
-{ $subsection alien>char-string }
-{ $subsection alien>u16-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: "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

core/alien/c-types/c-types-tests.factor

@@ -1,30 +1,6 @@
 IN: alien.c-types.tests
 USING: alien alien.syntax alien.c-types kernel tools.test
-sequences system libc ;
+sequences system libc alien.strings io.encodings.utf8 ;
-
-[ "\u0000ff" ]
-[ "\u0000ff" string>char-alien alien>char-string ]
-unit-test
-
-[ "hello world" ]
-[ "hello world" string>char-alien alien>char-string ]
-unit-test
-
-[ "hello\u00abcdworld" ]
-[ "hello\u00abcdworld" string>u16-alien alien>u16-string ]
-unit-test
-
-[ t ] [ f expired? ] unit-test
-
-[ "hello world" ] [
-    "hello world" malloc-char-string
-    dup alien>char-string swap free
-] unit-test
-
-[ "hello world" ] [
-    "hello world" malloc-u16-string
-    dup alien>u16-string swap free
-] unit-test
 
 : foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
 
@@ -67,7 +43,7 @@ TYPEDEF: int* MyIntArray
 
 TYPEDEF: uchar* MyLPBYTE
 
-[ t ] [ "char*" c-type "MyLPBYTE" c-type eq? ] unit-test
+[ t ] [ { "char*" utf8 } c-type "MyLPBYTE" c-type = ] unit-test
 
 [
     0 B{ 1 2 3 4 } <displaced-alien> <void*>

core/alien/c-types/c-types.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bit-arrays byte-arrays float-arrays arrays
-generator.registers assocs kernel kernel.private libc math
+assocs kernel kernel.private libc math
 namespaces parser sequences strings words assocs splitting
 math.parser cpu.architecture alien alien.accessors quotations
 layouts system compiler.units io.files io.encodings.binary
@@ -14,7 +14,7 @@ DEFER: *char
 : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
 
 TUPLE: c-type
-boxer prep unboxer
+boxer boxer-quot unboxer unboxer-quot
 getter setter
 reg-class size align stack-align? ;
 
@@ -149,23 +149,12 @@ M: float-array byte-length length "double" heap-size * ;
 : malloc-byte-array ( byte-array -- alien )
     dup length dup malloc [ -rot memcpy ] keep ;
 
-: malloc-char-string ( string -- alien )
-    string>char-alien malloc-byte-array ;
-
-: malloc-u16-string ( string -- alien )
-    string>u16-alien malloc-byte-array ;
-
 : memory>byte-array ( alien len -- byte-array )
     dup <byte-array> [ -rot memcpy ] keep ;
 
 : byte-array>memory ( byte-array base -- )
     swap dup length memcpy ;
 
-DEFER: >c-ushort-array
-
-: string>u16-memory ( string base -- )
-    >r >c-ushort-array r> byte-array>memory ;
-
 : (define-nth) ( word type quot -- )
     >r heap-size [ rot * ] swap prefix r> append define-inline ;
 
@@ -378,7 +367,7 @@ M: long-long-type box-return ( type -- )
         "box_float" >>boxer
         "to_float" >>unboxer
         single-float-regs >>reg-class
-        [ >float ] >>prep
+        [ >float ] >>unboxer-quot
     "float" define-primitive-type
 
     <c-type>
@@ -389,30 +378,8 @@ M: long-long-type box-return ( type -- )
         "box_double" >>boxer
         "to_double" >>unboxer
         double-float-regs >>reg-class
-        [ >float ] >>prep
+        [ >float ] >>unboxer-quot
     "double" define-primitive-type
 
-    <c-type>
-        [ alien-cell alien>char-string ] >>getter
-        [ set-alien-cell ] >>setter
-        bootstrap-cell >>size
-        bootstrap-cell >>align
-        "box_char_string" >>boxer
-        "alien_offset" >>unboxer
-        [ string>char-alien ] >>prep
-    "char*" define-primitive-type
-
-    "char*" "uchar*" typedef
-
-    <c-type>
-        [ alien-cell alien>u16-string ] >>getter
-        [ set-alien-cell ] >>setter
-        4 >>size
-        4 >>align
-        "box_u16_string" >>boxer
-        "alien_offset" >>unboxer
-        [ string>u16-alien ] >>prep
-    "ushort*" define-primitive-type
-
     os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
 ] with-compilation-unit

core/alien/compiler/compiler-tests.factor

@@ -1,367 +1,375 @@
-IN: alien.compiler.tests
+IN: alien.compiler.tests
-USING: alien alien.c-types alien.syntax compiler kernel
+USING: alien alien.c-types alien.syntax compiler kernel
-namespaces namespaces tools.test sequences inference words
+namespaces namespaces tools.test sequences inference words
-arrays parser quotations continuations inference.backend effects
+arrays parser quotations continuations inference.backend effects
-namespaces.private io io.streams.string memory system threads
+namespaces.private io io.streams.string memory system threads
-tools.test math ;
+tools.test math ;
-
+
-FUNCTION: void ffi_test_0 ;
+FUNCTION: void ffi_test_0 ;
-[ ] [ ffi_test_0 ] unit-test
+[ ] [ ffi_test_0 ] unit-test
-
+
-FUNCTION: int ffi_test_1 ;
+FUNCTION: int ffi_test_1 ;
-[ 3 ] [ ffi_test_1 ] unit-test
+[ 3 ] [ ffi_test_1 ] unit-test
-
+
-FUNCTION: int ffi_test_2 int x int y ;
+FUNCTION: int ffi_test_2 int x int y ;
-[ 5 ] [ 2 3 ffi_test_2 ] unit-test
+[ 5 ] [ 2 3 ffi_test_2 ] unit-test
-[ "hi" 3 ffi_test_2 ] must-fail
+[ "hi" 3 ffi_test_2 ] must-fail
-
+
-FUNCTION: int ffi_test_3 int x int y int z int t ;
+FUNCTION: int ffi_test_3 int x int y int z int t ;
-[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
+[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
-
+
-FUNCTION: float ffi_test_4 ;
+FUNCTION: float ffi_test_4 ;
-[ 1.5 ] [ ffi_test_4 ] unit-test
+[ 1.5 ] [ ffi_test_4 ] unit-test
-
+
-FUNCTION: double ffi_test_5 ;
+FUNCTION: double ffi_test_5 ;
-[ 1.5 ] [ ffi_test_5 ] unit-test
+[ 1.5 ] [ ffi_test_5 ] unit-test
-
+
-FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
+FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
-[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
+[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
-[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
+[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
-[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
+[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
-
+
-C-STRUCT: foo
+C-STRUCT: foo
-    { "int" "x" }
+    { "int" "x" }
-    { "int" "y" }
+    { "int" "y" }
-;
+;
-
+
-: make-foo ( x y -- foo )
+: make-foo ( x y -- foo )
-    "foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
+    "foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
-
+
-FUNCTION: int ffi_test_11 int a foo b int c ;
+FUNCTION: int ffi_test_11 int a foo b int c ;
-
+
-[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
+[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
-
+
-FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
+FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
-
+
-[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
+[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
-
+
-FUNCTION: foo ffi_test_14 int x int y ;
+FUNCTION: foo ffi_test_14 int x int y ;
-
+
-[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
+[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
-
+
-FUNCTION: char* ffi_test_15 char* x char* y ;
+FUNCTION: char* ffi_test_15 char* x char* y ;
-
+
-[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
+[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
-[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
+[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
-[ 1 2 ffi_test_15 ] must-fail
+[ 1 2 ffi_test_15 ] must-fail
-
+
-C-STRUCT: bar
+C-STRUCT: bar
-    { "long" "x" }
+    { "long" "x" }
-    { "long" "y" }
+    { "long" "y" }
-    { "long" "z" }
+    { "long" "z" }
-;
+;
-
+
-FUNCTION: bar ffi_test_16 long x long y long z ;
+FUNCTION: bar ffi_test_16 long x long y long z ;
-
+
-[ 11 6 -7 ] [
+[ 11 6 -7 ] [
-    11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
+    11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
-] unit-test
+] unit-test
-
+
-C-STRUCT: tiny
+C-STRUCT: tiny
-    { "int" "x" }
+    { "int" "x" }
-;
+;
-
+
-FUNCTION: tiny ffi_test_17 int x ;
+FUNCTION: tiny ffi_test_17 int x ;
-
+
-[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
+[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
-
+
-[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
+[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
-
+
-: indirect-test-1
+: indirect-test-1
-    "int" { } "cdecl" alien-indirect ;
+    "int" { } "cdecl" alien-indirect ;
-
+
-{ 1 1 } [ indirect-test-1 ] must-infer-as
+{ 1 1 } [ indirect-test-1 ] must-infer-as
-
+
-[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
+[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
-
+
-[ -1 indirect-test-1 ] must-fail
+[ -1 indirect-test-1 ] must-fail
-
+
-: indirect-test-2
+: indirect-test-2
-    "int" { "int" "int" } "cdecl" alien-indirect gc ;
+    "int" { "int" "int" } "cdecl" alien-indirect gc ;
-
+
-{ 3 1 } [ indirect-test-2 ] must-infer-as
+{ 3 1 } [ indirect-test-2 ] must-infer-as
-
+
-[ 5 ]
+[ 5 ]
-[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
+[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
-unit-test
+unit-test
-
+
-: indirect-test-3
+: indirect-test-3
-    "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
+    "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
-    gc ;
+    gc ;
-
+
-<< "f-stdcall" f "stdcall" add-library >>
+<< "f-stdcall" f "stdcall" add-library >>
-
+
-[ f ] [ "f-stdcall" load-library ] unit-test
+[ f ] [ "f-stdcall" load-library ] unit-test
-[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test
+[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test
-
+
-: ffi_test_18 ( w x y z -- int )
+: ffi_test_18 ( w x y z -- int )
-    "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
+    "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
-    alien-invoke gc ;
+    alien-invoke gc ;
-
+
-[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
+[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
-
+
-: ffi_test_19 ( x y z -- bar )
+: ffi_test_19 ( x y z -- bar )
-    "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
+    "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
-    alien-invoke gc ;
+    alien-invoke gc ;
-
+
-[ 11 6 -7 ] [
+[ 11 6 -7 ] [
-    11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
+    11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
-] unit-test
+] unit-test
-
+
-FUNCTION: double ffi_test_6 float x float y ;
+FUNCTION: double ffi_test_6 float x float y ;
-[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
+[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
-[ "a" "b" ffi_test_6 ] must-fail
+[ "a" "b" ffi_test_6 ] must-fail
-
+
-FUNCTION: double ffi_test_7 double x double y ;
+FUNCTION: double ffi_test_7 double x double y ;
-[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
+[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
-
+
-FUNCTION: double ffi_test_8 double x float y double z float t int w ;
+FUNCTION: double ffi_test_8 double x float y double z float t int w ;
-[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
+[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
-
+
-FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
+FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
-[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
+[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
-
+
-FUNCTION: void ffi_test_20 double x1, double x2, double x3,
+FUNCTION: void ffi_test_20 double x1, double x2, double x3,
-    double y1, double y2, double y3,
+    double y1, double y2, double y3,
-    double z1, double z2, double z3 ;
+    double z1, double z2, double z3 ;
-
+
-[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
+[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
-
+
-! Make sure XT doesn't get clobbered in stack frame
+! Make sure XT doesn't get clobbered in stack frame
-
+
-: ffi_test_31
+: ffi_test_31
-    "void"
+    "void"
-    f "ffi_test_31"
+    f "ffi_test_31"
-    { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
+    { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
-    alien-invoke gc 3 ;
+    alien-invoke gc 3 ;
-
+
-[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
+[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
-
+
-FUNCTION: longlong ffi_test_21 long x long y ;
+FUNCTION: longlong ffi_test_21 long x long y ;
-
+
-[ 121932631112635269 ]
+[ 121932631112635269 ]
-[ 123456789 987654321 ffi_test_21 ] unit-test
+[ 123456789 987654321 ffi_test_21 ] unit-test
-
+
-FUNCTION: long ffi_test_22 long x longlong y longlong z ;
+FUNCTION: long ffi_test_22 long x longlong y longlong z ;
-
+
-[ 987655432 ]
+[ 987655432 ]
-[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
+[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
-
+
-[ 1111 f 123456789 ffi_test_22 ] must-fail
+[ 1111 f 123456789 ffi_test_22 ] must-fail
-
+
-C-STRUCT: rect
+C-STRUCT: rect
-    { "float" "x" }
+    { "float" "x" }
-    { "float" "y" }
+    { "float" "y" }
-    { "float" "w" }
+    { "float" "w" }
-    { "float" "h" }
+    { "float" "h" }
-;
+;
-
+
-: <rect>
+: <rect>
-    "rect" <c-object>
+    "rect" <c-object>
-    [ set-rect-h ] keep
+    [ set-rect-h ] keep
-    [ set-rect-w ] keep
+    [ set-rect-w ] keep
-    [ set-rect-y ] keep
+    [ set-rect-y ] keep
-    [ set-rect-x ] keep ;
+    [ set-rect-x ] keep ;
-
+
-FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
+FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
-
+
-[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
+[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
-
+
-[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
+[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
-
+
-FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
+FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
-
+
-[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test
+[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test
-
+
-! Test odd-size structs
+! Test odd-size structs
-C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
+C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
-
+
-FUNCTION: test-struct-1 ffi_test_24 ;
+FUNCTION: test-struct-1 ffi_test_24 ;
-
+
-[ B{ 1 } ] [ ffi_test_24 ] unit-test
+[ B{ 1 } ] [ ffi_test_24 ] unit-test
-
+
-C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
+C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
-
+
-FUNCTION: test-struct-2 ffi_test_25 ;
+FUNCTION: test-struct-2 ffi_test_25 ;
-
+
-[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
+[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
-
+
-C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
+C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
-
+
-FUNCTION: test-struct-3 ffi_test_26 ;
+FUNCTION: test-struct-3 ffi_test_26 ;
-
+
-[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
+[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
-
+
-C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
+C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
-
+
-FUNCTION: test-struct-4 ffi_test_27 ;
+FUNCTION: test-struct-4 ffi_test_27 ;
-
+
-[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
+[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
-
+
-C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
+C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
-
+
-FUNCTION: test-struct-5 ffi_test_28 ;
+FUNCTION: test-struct-5 ffi_test_28 ;
-
+
-[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
+[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
-
+
-C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
+C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
-
+
-FUNCTION: test-struct-6 ffi_test_29 ;
+FUNCTION: test-struct-6 ffi_test_29 ;
-
+
-[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
+[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
-
+
-C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
+C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
-
+
-FUNCTION: test-struct-7 ffi_test_30 ;
+FUNCTION: test-struct-7 ffi_test_30 ;
-
+
-[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
+[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
-
+
-C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
+C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
-
+
-FUNCTION: double ffi_test_32 test-struct-8 x int y ;
+FUNCTION: double ffi_test_32 test-struct-8 x int y ;
-
+
-[ 9.0 ] [
+[ 9.0 ] [
-    "test-struct-8" <c-object>
+    "test-struct-8" <c-object>
-    1.0 over set-test-struct-8-x
+    1.0 over set-test-struct-8-x
-    2.0 over set-test-struct-8-y
+    2.0 over set-test-struct-8-y
-    3 ffi_test_32
+    3 ffi_test_32
-] unit-test
+] unit-test
-
+
-C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
+C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
-
+
-FUNCTION: double ffi_test_33 test-struct-9 x int y ;
+FUNCTION: double ffi_test_33 test-struct-9 x int y ;
-
+
-[ 9.0 ] [
+[ 9.0 ] [
-    "test-struct-9" <c-object>
+    "test-struct-9" <c-object>
-    1.0 over set-test-struct-9-x
+    1.0 over set-test-struct-9-x
-    2.0 over set-test-struct-9-y
+    2.0 over set-test-struct-9-y
-    3 ffi_test_33
+    3 ffi_test_33
-] unit-test
+] unit-test
-
+
-C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
+C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
-
+
-FUNCTION: double ffi_test_34 test-struct-10 x int y ;
+FUNCTION: double ffi_test_34 test-struct-10 x int y ;
-
+
-[ 9.0 ] [
+[ 9.0 ] [
-    "test-struct-10" <c-object>
+    "test-struct-10" <c-object>
-    1.0 over set-test-struct-10-x
+    1.0 over set-test-struct-10-x
-    2 over set-test-struct-10-y
+    2 over set-test-struct-10-y
-    3 ffi_test_34
+    3 ffi_test_34
-] unit-test
+] unit-test
-
+
-C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
+C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
-
+
-FUNCTION: double ffi_test_35 test-struct-11 x int y ;
+FUNCTION: double ffi_test_35 test-struct-11 x int y ;
-
+
-[ 9.0 ] [
+[ 9.0 ] [
-    "test-struct-11" <c-object>
+    "test-struct-11" <c-object>
-    1 over set-test-struct-11-x
+    1 over set-test-struct-11-x
-    2 over set-test-struct-11-y
+    2 over set-test-struct-11-y
-    3 ffi_test_35
+    3 ffi_test_35
-] unit-test
+] unit-test
-
+
-C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
+C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
-
+
-: make-struct-12
+: make-struct-12
-    "test-struct-12" <c-object>
+    "test-struct-12" <c-object>
-    [ set-test-struct-12-x ] keep ;
+    [ set-test-struct-12-x ] keep ;
-
+
-FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
+FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
-
+
-[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
+[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
-
+
-! Test callbacks
+FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
-
+
-: callback-1 "void" { } "cdecl" [ ] alien-callback ;
+[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
-
+
-[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
+! Test callbacks
-
+
-[ t ] [ callback-1 alien? ] unit-test
+: callback-1 "void" { } "cdecl" [ ] alien-callback ;
-
+
-: callback_test_1 "void" { } "cdecl" alien-indirect ;
+[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
-
+
-[ ] [ callback-1 callback_test_1 ] unit-test
+[ t ] [ callback-1 alien? ] unit-test
-
+
-: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
+: callback_test_1 "void" { } "cdecl" alien-indirect ;
-
+
-[ ] [ callback-2 callback_test_1 ] unit-test
+[ ] [ callback-1 callback_test_1 ] unit-test
-
+
-: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
+: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
-
+
-[ t ] [ 
+[ ] [ callback-2 callback_test_1 ] unit-test
-    namestack*
+
-    3 "x" set callback-3 callback_test_1
+: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
-    namestack* eq?
+
-] unit-test
+[ t ] [
-
+    namestack*
-[ 5 ] [ 
+    3 "x" set callback-3 callback_test_1
-    [
+    namestack* eq?
-        3 "x" set callback-3 callback_test_1 "x" get
+] unit-test
-    ] with-scope
+
-] unit-test
+[ 5 ] [
-
+    [
-: callback-4
+        3 "x" set callback-3 callback_test_1 "x" get
-    "void" { } "cdecl" [ "Hello world" write ] alien-callback
+    ] with-scope
-    gc ;
+] unit-test
-
+
-[ "Hello world" ] [ 
+: callback-4
-    [ callback-4 callback_test_1 ] with-string-writer
+    "void" { } "cdecl" [ "Hello world" write ] alien-callback
-] unit-test
+    gc ;
-
+
-: callback-5
+[ "Hello world" ] [
-    "void" { } "cdecl" [ gc ] alien-callback ;
+    [ callback-4 callback_test_1 ] with-string-writer
-
+] unit-test
-[ "testing" ] [
+
-    "testing" callback-5 callback_test_1
+: callback-5
-] unit-test
+    "void" { } "cdecl" [ gc ] alien-callback ;
-
+
-: callback-5a
+[ "testing" ] [
-    "void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
+    "testing" callback-5 callback_test_1
-
+] unit-test
-! Hack; if we're on ARM, we probably don't have much RAM, so
+
-! skip this test.
+: callback-5a
-! cpu "arm" = [
+    "void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
-!     [ "testing" ] [
+
-!         "testing" callback-5a callback_test_1
+! Hack; if we're on ARM, we probably don't have much RAM, so
-!     ] unit-test
+! skip this test.
-! ] unless
+! cpu "arm" = [
-
+!     [ "testing" ] [
-: callback-6
+!         "testing" callback-5a callback_test_1
-    "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
+!     ] unit-test
-
+! ] unless
-[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
+
-
+: callback-6
-: callback-7
+    "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
-    "void" { } "cdecl" [ 1000 sleep ] alien-callback ;
+
-
+[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
-[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
+
-
+: callback-7
-[ f ] [ namespace global eq? ] unit-test
+    "void" { } "cdecl" [ 1000 sleep ] alien-callback ;
-
+
-: callback-8
+[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
-    "void" { } "cdecl" [
+
-        [ continue ] callcc0
+[ f ] [ namespace global eq? ] unit-test
-    ] alien-callback ;
+
-
+: callback-8
-[ ] [ callback-8 callback_test_1 ] unit-test
+    "void" { } "cdecl" [
-
+        [ continue ] callcc0
-: callback-9
+    ] alien-callback ;
-    "int" { "int" "int" "int" } "cdecl" [
+
-        + + 1+
+[ ] [ callback-8 callback_test_1 ] unit-test
-    ] alien-callback ;
+
-
+: callback-9
-FUNCTION: int ffi_test_37 ( void* func ) ;
+    "int" { "int" "int" "int" } "cdecl" [
-
+        + + 1+
-[ 1 ] [ callback-9 ffi_test_37 ] unit-test
+    ] alien-callback ;
-
+
-[ 7 ] [ callback-9 ffi_test_37 ] unit-test
+FUNCTION: void ffi_test_36_point_5 ( ) ;
+
+[ ] [ ffi_test_36_point_5 ] unit-test
+
+FUNCTION: int ffi_test_37 ( void* func ) ;
+
+[ 1 ] [ callback-9 ffi_test_37 ] unit-test
+
+[ 7 ] [ callback-9 ffi_test_37 ] unit-test

core/alien/compiler/compiler.factor

@@ -3,10 +3,11 @@
 USING: arrays generator generator.registers generator.fixup
 hashtables kernel math namespaces sequences words
 inference.state inference.backend inference.dataflow system
-math.parser classes alien.arrays alien.c-types alien.structs
+math.parser classes alien.arrays alien.c-types alien.strings
-alien.syntax cpu.architecture alien inspector quotations assocs
+alien.structs alien.syntax cpu.architecture alien inspector
-kernel.private threads continuations.private libc combinators
+quotations assocs kernel.private threads continuations.private
-compiler.errors continuations layouts accessors ;
+libc combinators compiler.errors continuations layouts accessors
+;
 IN: alien.compiler
 
 TUPLE: #alien-node < node return parameters abi ;
@@ -20,9 +21,7 @@ TUPLE: #alien-invoke < #alien-node library function ;
 : large-struct? ( ctype -- ? )
     dup c-struct? [
         heap-size struct-small-enough? not
-    ] [
+    ] [ drop f ] if ;
-        drop f
-    ] if ;
 
 : alien-node-parameters* ( node -- seq )
     dup parameters>>
@@ -162,17 +161,16 @@ M: long-long-type flatten-value-type ( type -- )
     dup return>> "void" = 0 1 ?
     swap produce-values ;
 
-: (make-prep-quot) ( parameters -- )
+: (param-prep-quot) ( parameters -- )
     dup empty? [
         drop
     ] [
-        unclip c-type c-type-prep %
+        unclip c-type c-type-unboxer-quot %
-        \ >r , (make-prep-quot) \ r> ,
+        \ >r , (param-prep-quot) \ r> ,
     ] if ;
 
-: make-prep-quot ( node -- quot )
+: param-prep-quot ( node -- quot )
-    parameters>>
+    parameters>> [ <reversed> (param-prep-quot) ] [ ] make ;
-    [ <reversed> (make-prep-quot) ] [ ] make ;
 
 : unbox-parameters ( offset node -- )
     parameters>> [
@@ -200,6 +198,20 @@ M: long-long-type flatten-value-type ( type -- )
 : box-return* ( node -- )
     return>> [ ] [ box-return ] if-void ;
 
+: (return-prep-quot) ( parameters -- )
+    dup empty? [
+        drop
+    ] [
+        unclip c-type c-type-boxer-quot %
+        \ >r , (return-prep-quot) \ r> ,
+    ] if ;
+
+: callback-prep-quot ( node -- quot )
+    parameters>> [ <reversed> (return-prep-quot) ] [ ] make ;
+
+: return-prep-quot ( node -- quot )
+    [ return>> [ ] [ 1array (return-prep-quot) ] if-void ] [ ] make ;
+
 M: alien-invoke-error summary
     drop
     "Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ;
@@ -258,15 +270,15 @@ M: no-such-symbol compiler-error-type
     pop-literal nip >>library
     pop-literal nip >>return
     ! Quotation which coerces parameters to required types
-    dup make-prep-quot recursive-state get infer-quot
+    dup param-prep-quot recursive-state get infer-quot
     ! Set ABI
-    dup library>>
+    dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
-    library [ abi>> ] [ "cdecl" ] if*
-    >>abi
     ! Add node to IR
     dup node,
     ! Magic #: consume exactly the number of inputs
-    0 alien-invoke-stack
+    dup 0 alien-invoke-stack
+    ! Quotation which coerces return value to required type
+    return-prep-quot recursive-state get infer-quot
 ] "infer" set-word-prop
 
 M: #alien-invoke generate-node
@@ -294,11 +306,13 @@ M: alien-indirect-error summary
     pop-parameters >>parameters
     pop-literal nip >>return
     ! Quotation which coerces parameters to required types
-    dup make-prep-quot [ dip ] curry recursive-state get infer-quot
+    dup param-prep-quot [ dip ] curry recursive-state get infer-quot
     ! Add node to IR
     dup node,
     ! Magic #: consume the function pointer, too
-    1 alien-invoke-stack
+    dup 1 alien-invoke-stack
+    ! Quotation which coerces return value to required type
+    return-prep-quot recursive-state get infer-quot
 ] "infer" set-word-prop
 
 M: #alien-indirect generate-node
@@ -371,16 +385,18 @@ TUPLE: callback-context ;
     slip
     wait-to-return ; inline
 
-: prepare-callback-return ( ctype -- quot )
+: callback-return-quot ( ctype -- quot )
     return>> {
         { [ dup "void" = ] [ drop [ ] ] }
         { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
-        [ c-type c-type-prep ]
+        [ c-type c-type-unboxer-quot ]
     } cond ;
 
 : wrap-callback-quot ( node -- quot )
     [
-        [ quot>> ] [ prepare-callback-return ] bi append ,
+        [ callback-prep-quot ]
+        [ quot>> ]
+        [ callback-return-quot ] tri 3append ,
         [ callback-context new do-callback ] %
     ] [ ] make ;
 
@@ -405,9 +421,10 @@ TUPLE: callback-context ;
         init-templates
         %prologue-later
         dup alien-stack-frame [
-            dup registers>objects
+            [ registers>objects ]
-            dup wrap-callback-quot %alien-callback
+            [ wrap-callback-quot %alien-callback ]
-            %callback-return
+            [ %callback-return ]
+            tri
         ] with-stack-frame
     ] with-generator ;
 

core/alien/remote-control/remote-control.factor

@@ -1,12 +1,12 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types parser threads words kernel.private
+USING: alien alien.c-types alien.strings parser threads words
-kernel ;
+kernel.private kernel io.encodings.utf8 ;
 IN: alien.remote-control
 
 : eval-callback
     "void*" { "char*" } "cdecl"
-    [ eval>string malloc-char-string ] alien-callback ;
+    [ eval>string utf8 malloc-string ] alien-callback ;
 
 : yield-callback
     "void" { } "cdecl" [ yield ] alien-callback ;

core/alien/strings/strings-docs.factor

@@ -0,0 +1,52 @@
+USING: help.markup help.syntax strings byte-arrays alien libc
+debugger ;
+IN: alien.strings
+
+HELP: string>alien
+{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
+{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." }
+{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ;
+
+{ string>alien alien>string malloc-string } related-words
+
+HELP: alien>string
+{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } }
+{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ;
+
+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: string>symbol
+{ $values { "str" string } { "alien" alien } }
+{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
+$nl
+"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
+
+HELP: utf16n
+{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
+{ $see-also "encodings-introduction" } ;
+
+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. 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
+"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 } "." ;
+
+ABOUT: "c-strings"

core/alien/strings/strings-tests.factor

@@ -0,0 +1,30 @@
+USING: alien.strings tools.test kernel libc
+io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
+io.encodings.ascii alien ;
+IN: alien.strings.tests
+
+[ "\u0000ff" ]
+[ "\u0000ff" latin1 string>alien latin1 alien>string ]
+unit-test
+
+[ "hello world" ]
+[ "hello world" latin1 string>alien latin1 alien>string ]
+unit-test
+
+[ "hello\u00abcdworld" ]
+[ "hello\u00abcdworld" utf16le string>alien utf16le alien>string ]
+unit-test
+
+[ t ] [ f expired? ] unit-test
+
+[ "hello world" ] [
+    "hello world" ascii malloc-string
+    dup ascii alien>string swap free
+] unit-test
+
+[ "hello world" ] [
+    "hello world" utf16n malloc-string
+    dup utf16n alien>string swap free
+] unit-test
+
+[ f ] [ f utf8 alien>string ] unit-test

core/alien/strings/strings.factor

@@ -0,0 +1,111 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays sequences kernel accessors math alien.accessors
+alien.c-types byte-arrays words io io.encodings
+io.streams.byte-array io.streams.memory io.encodings.utf8
+io.encodings.utf16 system alien strings cpu.architecture ;
+IN: alien.strings
+
+GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
+
+M: c-ptr alien>string
+    >r <memory-stream> r> <decoder>
+    "\0" swap stream-read-until drop ;
+
+M: f alien>string
+    drop ;
+
+ERROR: invalid-c-string string ;
+
+: check-string ( string -- )
+    0 over memq? [ invalid-c-string ] [ drop ] if ;
+
+GENERIC# string>alien 1 ( string encoding -- byte-array )
+
+M: c-ptr string>alien drop ;
+
+M: string string>alien
+    over check-string
+    <byte-writer>
+    [ stream-write ]
+    [ 0 swap stream-write1 ]
+    [ stream>> >byte-array ]
+    tri ;
+
+: malloc-string ( string encoding -- alien )
+    string>alien malloc-byte-array ;
+
+PREDICATE: string-type < pair
+    first2 [ "char*" = ] [ word? ] bi* and ;
+
+M: string-type c-type ;
+
+M: string-type heap-size
+    drop "void*" heap-size ;
+
+M: string-type c-type-align
+    drop "void*" c-type-align ;
+
+M: string-type c-type-stack-align?
+    drop "void*" c-type-stack-align? ;
+
+M: string-type unbox-parameter
+    drop "void*" unbox-parameter ;
+
+M: string-type unbox-return
+    drop "void*" unbox-return ;
+
+M: string-type box-parameter
+    drop "void*" box-parameter ;
+
+M: string-type box-return
+    drop "void*" box-return ;
+
+M: string-type stack-size
+    drop "void*" stack-size ;
+
+M: string-type c-type-reg-class
+    drop int-regs ;
+
+M: string-type c-type-boxer
+    drop "void*" c-type-boxer ;
+
+M: string-type c-type-unboxer
+    drop "void*" c-type-unboxer ;
+
+M: string-type c-type-boxer-quot
+    second [ alien>string ] curry [ ] like ;
+
+M: string-type c-type-unboxer-quot
+    second [ string>alien ] curry [ ] like ;
+
+M: string-type c-type-getter
+    drop [ alien-cell ] ;
+
+M: string-type c-type-setter
+    drop [ set-alien-cell ] ;
+
+TUPLE: utf16n ;
+
+! Native-order UTF-16
+
+: utf16n ( -- descriptor )
+    little-endian? utf16le utf16be ? ; foldable
+
+M: utf16n <decoder> drop utf16n <decoder> ;
+
+M: utf16n <encoder> drop utf16n <encoder> ;
+
+: alien>native-string ( alien -- string )
+    os windows? [ utf16n ] [ utf8 ] if alien>string ;
+
+: dll-path ( dll -- string )
+    (dll-path) alien>native-string ;
+
+: string>symbol ( str -- alien )
+    [ os wince? [ utf16n ] [ utf8 ] if string>alien ]
+    over string? [ call ] [ map ] if ;
+
+{ "char*" utf8 } "char*" typedef
+{ "char*" utf16n } "wchar_t*" typedef
+"char*" "uchar*" typedef

core/alien/structs/structs-tests.factor

@@ -1,6 +1,6 @@
 IN: alien.structs.tests
 USING: alien alien.syntax alien.c-types kernel tools.test
-sequences system libc words vocabs namespaces ;
+sequences system libc words vocabs namespaces layouts ;
 
 C-STRUCT: bar
     { "int" "x" }
@@ -9,20 +9,20 @@ C-STRUCT: bar
 [ 36 ] [ "bar" heap-size ] unit-test
 [ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test
 
-! This was actually only correct on Windows/x86:
+C-STRUCT: align-test
+    { "int" "x" }
+    { "double" "y" } ;
 
-! C-STRUCT: align-test
+os winnt? cpu x86? and [
-!     { "int" "x" }
+    [ 16 ] [ "align-test" heap-size ] unit-test
-!     { "double" "y" } ;
+    
-! 
+    cell 4 = [
-! [ 16 ] [ "align-test" heap-size ] unit-test
+        C-STRUCT: one
-! 
+        { "long" "a" } { "double" "b" } { "int" "c" } ;
-! cell 4 = [
+    
-!     C-STRUCT: one
+        [ 24 ] [ "one" heap-size ] unit-test
-!     { "long" "a" } { "double" "b" } { "int" "c" } ;
+    ] when
-! 
+] when
-!     [ 24 ] [ "one" heap-size ] unit-test
-! ] when
 
 : MAX_FOOS 30 ;
 

core/alien/structs/structs.factor

@@ -20,14 +20,19 @@ IN: alien.structs
 
 : define-getter ( type spec -- )
     [ set-reader-props ] keep
-    dup slot-spec-reader
+    [ ]
-    over slot-spec-type c-getter
+    [ slot-spec-reader ]
+    [
+        slot-spec-type
+        [ c-getter ] [ c-type c-type-boxer-quot ] bi append
+    ] tri
     define-struct-slot-word ;
 
 : define-setter ( type spec -- )
     [ set-writer-props ] keep
-    dup slot-spec-writer
+    [ ]
-    over slot-spec-type c-setter
+    [ slot-spec-writer ]
+    [ slot-spec-type c-setter ] tri
     define-struct-slot-word ;
 
 : define-field ( type spec -- )

core/alien/syntax/syntax.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays alien alien.c-types alien.structs alien.arrays
-kernel math namespaces parser sequences words quotations
+alien.strings kernel math namespaces parser sequences words
-math.parser splitting effects prettyprint prettyprint.sections
+quotations math.parser splitting effects prettyprint
-prettyprint.backend assocs combinators ;
+prettyprint.sections prettyprint.backend assocs combinators ;
 IN: alien.syntax
 
 <PRIVATE
@@ -40,7 +40,7 @@ PRIVATE>
 
 : FUNCTION:
     scan "c-library" get scan ";" parse-tokens
-    [ "()" subseq? not ] subset
+    [ "()" subseq? not ] filter
     define-function ; parsing
 
 : TYPEDEF:

core/assocs/assocs-docs.factor

@@ -96,7 +96,7 @@ $nl
 { $subsection assoc-each }
 { $subsection assoc-map }
 { $subsection assoc-push-if }
-{ $subsection assoc-subset }
+{ $subsection assoc-filter }
 { $subsection assoc-contains? }
 { $subsection assoc-all? }
 "Three additional combinators:"
@@ -203,7 +203,7 @@ HELP: assoc-push-if
 { $values { "accum" "a resizable mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" object } { "value" object } }
 { $description "If the quotation yields true when applied to the key/value pair, adds the key/value pair at the end of " { $snippet "accum" } "." } ;
 
-HELP: assoc-subset
+HELP: assoc-filter
 { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } }
 { $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
 
@@ -281,7 +281,7 @@ HELP: assoc-union
 
 HELP: assoc-diff
 { $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } }
-{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " whose key is not contained in " { $snippet "assoc1" } "." } 
+{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc1" } " whose key is not contained in " { $snippet "assoc2" } "." } 
 ;
 HELP: remove-all
 { $values { "assoc" assoc } { "seq" "a sequence" } { "subseq" "a new sequence" } }

core/assocs/assocs-tests.factor

@@ -30,10 +30,10 @@ continuations ;
 [ t ] [ H{ { 1 1 } { 2 2 } } [ = ] assoc-all? ] unit-test
 [ f ] [ H{ { 1 2 } { 2 2 } } [ = ] assoc-all? ] unit-test
 
-[ H{ } ] [ H{ { t f } { f t } } [ 2drop f ] assoc-subset ] unit-test
+[ H{ } ] [ H{ { t f } { f t } } [ 2drop f ] assoc-filter ] unit-test
 [ H{ { 3 4 } { 4 5 } { 6 7 } } ] [
     H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } }
-    [ drop 3 >= ] assoc-subset
+    [ drop 3 >= ] assoc-filter
 ] unit-test
 
 [ 21 ] [

core/assocs/assocs.factor

@@ -50,7 +50,7 @@ M: assoc assoc-find
 : assoc-pusher ( quot -- quot' accum )
     V{ } clone [ [ assoc-push-if ] 2curry ] keep ; inline
 
-: assoc-subset ( assoc quot -- subassoc )
+: assoc-filter ( assoc quot -- subassoc )
     over >r assoc-pusher >r assoc-each r> r> assoc-like ; inline
 
 : assoc-contains? ( assoc quot -- ? )
@@ -110,7 +110,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
     ] { } assoc>map hashcode* ;
 
 : assoc-intersect ( assoc1 assoc2 -- intersection )
-    swap [ nip key? ] curry assoc-subset ;
+    swap [ nip key? ] curry assoc-filter ;
 
 : update ( assoc1 assoc2 -- )
     swap [ swapd set-at ] curry assoc-each ;
@@ -120,10 +120,10 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
     [ rot update ] keep [ swap update ] keep ;
 
 : assoc-diff ( assoc1 assoc2 -- diff )
-    swap [ nip key? not ] curry assoc-subset ;
+    [ nip key? not ] curry assoc-filter ;
 
 : remove-all ( assoc seq -- subseq )
-    swap [ key? not ] curry subset ;
+    swap [ key? not ] curry filter ;
 
 : (substitute)
     [ dupd at* [ nip ] [ drop ] if ] curry ; inline

core/bootstrap/compiler/compiler.factor

@@ -5,7 +5,7 @@ namespaces parser kernel kernel.private classes classes.private
 arrays hashtables vectors classes.tuple sbufs inference.dataflow
 hashtables.private sequences.private math classes.tuple.private
 growable namespaces.private assocs words generator command-line
-vocabs io prettyprint libc compiler.units ;
+vocabs io prettyprint libc compiler.units math.order ;
 IN: bootstrap.compiler
 
 ! Don't bring this in when deploying, since it will store a
@@ -18,6 +18,8 @@ IN: bootstrap.compiler
 
 enable-compiler
 
+: compile-uncompiled [ compiled? not ] filter compile ;
+
 nl
 "Compiling..." write flush
 
@@ -42,38 +44,38 @@ nl
     find-pair-next namestack*
 
     bitand bitor bitxor bitnot
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
-    + 1+ 1- 2/ < <= > >= shift min
+    + 1+ 1- 2/ < <= > >= shift
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
     new-sequence nth push pop peek
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
     hashcode* = get set
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
     . lines
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
     malloc calloc free memcpy
-} compile
+} compile-uncompiled
 
-vocabs [ words [ compiled? not ] subset compile "." write flush ] each
+vocabs [ words compile-uncompiled "." write flush ] each
 
 " done" print flush

core/bootstrap/image/image-tests.factor

@@ -1,5 +1,22 @@
 IN: bootstrap.image.tests
-USING: bootstrap.image bootstrap.image.private tools.test ;
+USING: bootstrap.image bootstrap.image.private tools.test
+kernel math ;
 
 \ ' must-infer
 \ write-image must-infer
+
+[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
+
+[ t ] [ [ 1 2 3 ] [ 1 2 3 ] eql? ] unit-test
+
+[ f ] [ [ 2drop 0 ] [ 2drop 0.0 ] eql? ] unit-test
+
+[ t ] [ [ 2drop 0 ] [ 2drop 0 ] eql? ] unit-test
+
+[ f ] [ \ + [ 2drop 0 ] eql? ] unit-test
+
+[ f ] [ 3 [ 0 1 2 ] eql? ] unit-test
+
+[ f ] [ 3 3.0 eql? ] unit-test
+
+[ t ] [ 4.0 4.0 eql? ] unit-test

core/bootstrap/image/image.factor

@@ -8,7 +8,7 @@ splitting growable classes classes.builtin classes.tuple
 classes.tuple.private words.private io.binary io.files vocabs
 vocabs.loader source-files definitions debugger float-arrays
 quotations.private sequences.private combinators
-io.encodings.binary ;
+io.encodings.binary math.order accessors ;
 IN: bootstrap.image
 
 : my-arch ( -- arch )
@@ -31,6 +31,43 @@ IN: bootstrap.image
 
 <PRIVATE
 
+! Object cache; we only consider numbers equal if they have the
+! same type
+TUPLE: id obj ;
+
+C: <id> id
+
+M: id hashcode* obj>> hashcode* ;
+
+GENERIC: (eql?) ( obj1 obj2 -- ? )
+
+: eql? ( obj1 obj2 -- ? )
+    [ (eql?) ] [ [ class ] bi@ = ] 2bi and ;
+
+M: integer (eql?) = ;
+
+M: sequence (eql?)
+    over sequence? [
+        2dup [ length ] bi@ =
+        [ [ eql? ] 2all? ] [ 2drop f ] if
+    ] [ 2drop f ] if ;
+
+M: object (eql?) = ;
+
+M: id equal?
+    over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
+
+SYMBOL: objects
+
+: (objects) <id> objects get ; inline
+
+: lookup-object ( obj -- n/f ) (objects) at ;
+
+: put-object ( n obj -- ) (objects) set-at ;
+
+: cache-object ( obj quot -- value )
+    >r (objects) r> [ obj>> ] prepose cache ; inline
+
 ! Constants
 
 : image-magic HEX: 0f0e0d0c ; inline
@@ -61,9 +98,6 @@ IN: bootstrap.image
 ! The image being constructed; a vector of word-size integers
 SYMBOL: image
 
-! Object cache
-SYMBOL: objects
-
 ! Image output format
 SYMBOL: big-endian
 
@@ -187,7 +221,9 @@ GENERIC: ' ( obj -- ptr )
     2tri ;
 
 M: bignum '
-    bignum tag-number dup [ emit-bignum ] emit-object ;
+    [
+        bignum tag-number dup [ emit-bignum ] emit-object
+    ] cache-object ;
 
 ! Fixnums
 
@@ -202,9 +238,11 @@ M: fixnum '
 ! Floats
 
 M: float '
-    float tag-number dup [
+    [
-        align-here double>bits emit-64
+        float tag-number dup [
-    ] emit-object ;
+            align-here double>bits emit-64
+        ] emit-object
+    ] cache-object ;
 
 ! Special objects
 
@@ -243,7 +281,7 @@ M: f '
         ] bi
         \ word type-number object tag-number
         [ emit-seq ] emit-object
-    ] keep objects get set-at ;
+    ] keep put-object ;
 
 : word-error ( word msg -- * )
     [ % dup word-vocabulary % " " % word-name % ] "" make throw ;
@@ -252,7 +290,7 @@ M: f '
     [ target-word ] keep or ;
 
 : fixup-word ( word -- offset )
-    transfer-word dup objects get at
+    transfer-word dup lookup-object
     [ ] [ "Not in image: " word-error ] ?if ;
 
 : fixup-words ( -- )
@@ -286,7 +324,7 @@ M: wrapper '
 M: string '
     #! We pool strings so that each string is only written once
     #! to the image
-    objects get [ emit-string ] cache ;
+    [ emit-string ] cache-object ;
 
 : assert-empty ( seq -- )
     length 0 assert= ;
@@ -305,18 +343,18 @@ M: float-array ' float-array emit-dummy-array ;
 
 ! Tuples
 : (emit-tuple) ( tuple -- pointer )
-    [ tuple>array 1 tail-slice ]
+    [ tuple>array rest-slice ]
     [ class transfer-word tuple-layout ] bi prefix [ ' ] map
     tuple type-number dup [ emit-seq ] emit-object ;
 
 : emit-tuple ( tuple -- pointer )
     dup class word-name "tombstone" =
-    [ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ;
+    [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
 
 M: tuple ' emit-tuple ;
 
 M: tuple-layout '
-    objects get [
+    [
         [
             {
                 [ layout-hashcode , ]
@@ -328,12 +366,12 @@ M: tuple-layout '
         ] { } make [ ' ] map
         \ tuple-layout type-number
         object tag-number [ emit-seq ] emit-object
-    ] cache ;
+    ] cache-object ;
 
 M: tombstone '
     delegate
     "((tombstone))" "((empty))" ? "hashtables.private" lookup
-    word-def first objects get [ emit-tuple ] cache ;
+    word-def first [ emit-tuple ] cache-object ;
 
 ! Arrays
 M: array '
@@ -343,7 +381,7 @@ M: array '
 ! Quotations
 
 M: quotation '
-    objects get [
+    [
         quotation-array '
         quotation type-number object tag-number [
             emit ! array
@@ -351,7 +389,7 @@ M: quotation '
             0 emit ! xt
             0 emit ! code
         ] emit-object
-    ] cache ;
+    ] cache-object ;
 
 ! End of the image
 

core/bootstrap/primitives.factor

@@ -58,16 +58,13 @@ num-types get f <array> builtins set
     "alien.accessors"
     "arrays"
     "bit-arrays"
-    "bit-vectors"
     "byte-arrays"
-    "byte-vectors"
     "classes.private"
     "classes.tuple"
     "classes.tuple.private"
     "compiler.units"
     "continuations.private"
     "float-arrays"
-    "float-vectors"
     "generator"
     "growable"
     "hashtables"
@@ -160,7 +157,7 @@ num-types get f <array> builtins set
 
 ! Catch-all class for providing a default method.
 "object" "kernel" create
-[ f builtins get [ ] subset union-class define-class ]
+[ f builtins get [ ] filter union-class define-class ]
 [ [ drop t ] "predicate" set-word-prop ]
 bi
 
@@ -455,54 +452,6 @@ tuple
     }
 } define-tuple-class
 
-"byte-vector" "byte-vectors" create
-tuple
-{
-    {
-        { "byte-array" "byte-arrays" }
-        "underlying"
-        { "underlying" "growable" }
-        { "set-underlying" "growable" }
-    } {
-        { "array-capacity" "sequences.private" }
-        "fill"
-        { "length" "sequences" }
-        { "set-fill" "growable" }
-    }
-} define-tuple-class
-
-"bit-vector" "bit-vectors" create
-tuple
-{
-    {
-        { "bit-array" "bit-arrays" }
-        "underlying"
-        { "underlying" "growable" }
-        { "set-underlying" "growable" }
-    } {
-        { "array-capacity" "sequences.private" }
-        "fill"
-        { "length" "sequences" }
-        { "set-fill" "growable" }
-    }
-} define-tuple-class
-
-"float-vector" "float-vectors" create
-tuple
-{
-    {
-        { "float-array" "float-arrays" }
-        "underlying"
-        { "underlying" "growable" }
-        { "set-underlying" "growable" }
-    } {
-        { "array-capacity" "sequences.private" }
-        "fill"
-        { "length" "sequences" }
-        { "set-fill" "growable" }
-    }
-} define-tuple-class
-
 "curry" "kernel" create
 tuple
 {
@@ -689,10 +638,6 @@ tuple
     { "set-alien-double" "alien.accessors" }
     { "alien-cell" "alien.accessors" }
     { "set-alien-cell" "alien.accessors" }
-    { "alien>char-string" "alien" }
-    { "string>char-alien" "alien" }
-    { "alien>u16-string" "alien" }
-    { "string>u16-alien" "alien" }
     { "(throw)" "kernel.private" }
     { "alien-address" "alien" }
     { "slot" "slots.private" }

core/bootstrap/stage2.factor

@@ -22,13 +22,13 @@ SYMBOL: bootstrap-time
     xref-sources ;
 
 : load-components ( -- )
-    "exclude" "include"
+    "include" "exclude"
-    [ get-global " " split [ empty? not ] subset ] bi@
+    [ get-global " " split [ empty? not ] filter ] bi@
     diff
     [ "bootstrap." prepend require ] each ;
 
 : count-words ( pred -- )
-    all-words swap subset length number>string write ;
+    all-words swap filter length number>string write ;
 
 : print-report ( time -- )
     1000 /i

core/bootstrap/syntax.factor

@@ -14,16 +14,13 @@ IN: bootstrap.syntax
     ";"
     "<PRIVATE"
     "?{"
-    "?V{"
     "BIN:"
     "B{"
-    "BV{"
     "C:"
     "CHAR:"
     "DEFER:"
     "ERROR:"
     "F{"
-    "FV{"
     "FORGET:"
     "GENERIC#"
     "GENERIC:"

core/classes/algebra/algebra-tests.factor

@@ -4,7 +4,7 @@ kernel math namespaces parser prettyprint sequences strings
 tools.test vectors words quotations classes classes.algebra
 classes.private classes.union classes.mixin classes.predicate
 vectors definitions source-files compiler.units growable
-random inference effects kernel.private ;
+random inference effects kernel.private sbufs ;
 
 : class= [ class< ] 2keep swap class< and ;
 
@@ -144,6 +144,48 @@ UNION: z1 b1 c1 ;
 
 [ f ] [ null class-not null class= ] unit-test
 
+[ t ] [
+    fixnum class-not
+    fixnum fixnum class-not class-or
+    class<
+] unit-test
+
+! Test method inlining
+[ f ] [ fixnum { } min-class ] unit-test
+
+[ string ] [
+    \ string
+    [ integer string array reversed sbuf
+    slice vector quotation ]
+    sort-classes min-class
+] unit-test
+
+[ fixnum ] [
+    \ fixnum
+    [ fixnum integer object ]
+    sort-classes min-class
+] unit-test
+
+[ integer ] [
+    \ fixnum
+    [ integer float object ]
+    sort-classes min-class
+] unit-test
+
+[ object ] [
+    \ word
+    [ integer float object ]
+    sort-classes min-class
+] unit-test
+
+[ reversed ] [
+    \ reversed
+    [ integer reversed slice ]
+    sort-classes min-class
+] unit-test
+
+[ f ] [ null { number fixnum null } min-class ] unit-test
+
 ! Test for hangs?
 : random-class classes random ;
 

core/classes/algebra/algebra.factor

@@ -77,10 +77,10 @@ C: <anonymous-complement> anonymous-complement
         { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }
         { [ over anonymous-union? ] [ left-anonymous-union< ] }
         { [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }
-        { [ over anonymous-complement? ] [ 2drop f ] }
         { [ over members ] [ left-union-class< ] }
         { [ dup anonymous-union? ] [ right-anonymous-union< ] }
         { [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }
+        { [ over anonymous-complement? ] [ 2drop f ] }
         { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
         { [ dup members ] [ right-union-class< ] }
         { [ over superclass ] [ superclass< ] }
@@ -183,7 +183,7 @@ C: <anonymous-complement> anonymous-complement
 : largest-class ( seq -- n elt )
     dup [
         [ 2dup class< >r swap class< not r> and ]
-        with subset empty?
+        with filter empty?
     ] curry find [ "Topological sort failed" throw ] unless* ;
 
 : sort-classes ( seq -- newseq )
@@ -193,9 +193,8 @@ C: <anonymous-complement> anonymous-complement
     [ ] unfold nip ;
 
 : min-class ( class seq -- class/f )
-    [ dupd classes-intersect? ] subset dup empty? [
+    over [ classes-intersect? ] curry filter
-        2drop f
+    dup empty? [ 2drop f ] [
-    ] [
         tuck [ class< ] with all? [ peek ] [ drop f ] if
     ] if ;
 

core/classes/classes-docs.factor

@@ -55,7 +55,7 @@ HELP: class
 { $values { "object" object } { "class" class } }
 { $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." }
 { $class-description "The class of all class words." }
-{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
+{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
 
 HELP: classes
 { $values { "seq" "a sequence of class words" } }
@@ -63,7 +63,7 @@ HELP: classes
 
 HELP: tuple-class
 { $class-description "The class of tuple class words." }
-{ $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
+{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
 
 HELP: update-map
 { $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;

core/classes/classes.factor

@@ -33,7 +33,7 @@ PREDICATE: class < word
 PREDICATE: tuple-class < class
     "metaclass" word-prop tuple-class eq? ;
 
-: classes ( -- seq ) all-words [ class? ] subset ;
+: classes ( -- seq ) all-words [ class? ] filter ;
 
 : predicate-word ( word -- predicate )
     [ word-name "?" append ] keep word-vocabulary create ;

core/classes/mixin/mixin.factor

@@ -31,7 +31,7 @@ TUPLE: check-mixin-class mixin ;
     >r >r check-mixin-class 2dup members memq? r> r> if ; inline
 
 : change-mixin-class ( class mixin quot -- )
-    [ members swap bootstrap-word ] swap compose keep
+    [ members swap bootstrap-word ] prepose keep
     swap redefine-mixin-class ; inline
 
 : add-mixin-instance ( class mixin -- )

core/classes/singleton/singleton-docs.factor

@@ -18,7 +18,7 @@ HELP: SINGLETON:
     "Defines a new singleton class. The class word itself is the sole instance of the singleton class."
 }
 { $examples
-    { $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
+    { $example "USING: classes.singleton kernel io ;" "IN: scratchpad" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
 } ;
 
 HELP: define-singleton-class

core/classes/tuple/tuple-docs.factor

@@ -341,6 +341,7 @@ HELP: new
 { $examples
     { $example
         "USING: kernel prettyprint ;"
+        "IN: scratchpad"
         "TUPLE: employee number name department ;"
         "employee new ."
         "T{ employee f f f f }"

core/classes/tuple/tuple-tests.factor

@@ -3,7 +3,8 @@ math.constants parser sequences tools.test words assocs
 namespaces quotations sequences.private classes continuations
 generic.standard effects classes.tuple classes.tuple.private
 arrays vectors strings compiler.units accessors classes.algebra
-calendar prettyprint io.streams.string splitting inspector ;
+calendar prettyprint io.streams.string splitting inspector
+columns math.order ;
 IN: classes.tuple.tests
 
 TUPLE: rect x y w h ;
@@ -87,7 +88,7 @@ C: <empty> empty
 [ t length ] [ object>> t eq? ] must-fail-with
 
 [ "<constructor-test>" ]
-[ "TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
+[ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
 
 TUPLE: size-test a b c d ;
 

core/classes/tuple/tuple.factor

@@ -166,7 +166,7 @@ M: tuple-class update-class
     3tri ;
 
 : subclasses ( class -- classes )
-    class-usages keys [ tuple-class? ] subset ;
+    class-usages keys [ tuple-class? ] filter ;
 
 : each-subclass ( class quot -- )
     >r subclasses r> each ; inline

core/combinators/combinators-docs.factor

@@ -95,7 +95,7 @@ HELP: case
     "If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied."
     $nl
     "The following two phrases are equivalent:"
-    { $code "{ { X [ Y ] } { Y [ T ] } } case" }
+    { $code "{ { X [ Y ] } { Z [ T ] } } case" }
     { $code "dup X = [ drop Y ] [ dup Z = [ drop T ] [ no-case ] if ] if" }
 }
 { $examples

core/combinators/combinators.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: combinators
 USING: arrays sequences sequences.private math.private
 kernel kernel.private math assocs quotations vectors
-hashtables sorting words sets ;
+hashtables sorting words sets math.order ;
+IN: combinators
 
 : cleave ( x seq -- )
     [ call ] with each ;
@@ -150,7 +150,7 @@ M: hashtable hashcode*
         drop
     ] [
         dup length 4 <=
-        over keys [ word? ] contains? or
+        over keys [ [ word? ] [ wrapper? ] bi or ] contains? or
         [
             linear-case-quot
         ] [

core/command-line/command-line.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2003, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: command-line
 USING: init continuations debugger hashtables io kernel
 kernel.private namespaces parser sequences strings system
 splitting io.files ;
+IN: command-line
 
 : run-bootstrap-init ( -- )
     "user-init" get [
@@ -54,7 +54,7 @@ SYMBOL: main-vocab-hook
     "none" "run" set-global ;
 
 : parse-command-line ( -- )
-    cli-args [ cli-arg ] subset
+    cli-args [ cli-arg ] filter
     "script" get [ script-mode ] when
     ignore-cli-args? [ drop ] [ [ run-file ] each ] if
     "e" get [ eval ] when* ;

core/compiler/errors/errors.factor

@@ -27,7 +27,7 @@ SYMBOL: with-compiler-errors?
 : errors-of-type ( type -- assoc )
     compiler-errors get-global
     swap [ >r nip compiler-error-type r> eq? ] curry
-    assoc-subset ;
+    assoc-filter ;
 
 : compiler-errors. ( type -- )
     errors-of-type >alist sort-keys

core/compiler/tests/intrinsics.factor

@@ -1,11 +1,11 @@
-IN: compiler.tests
 USING: arrays compiler.units kernel kernel.private math
 math.constants math.private sequences strings tools.test words
 continuations sequences.private hashtables.private byte-arrays
 strings.private system random layouts vectors.private
-sbufs.private strings.private slots.private alien
+sbufs.private strings.private slots.private alien math.order
-alien.accessors alien.c-types alien.syntax namespaces libc
+alien.accessors alien.c-types alien.syntax alien.strings
-sequences.private ;
+namespaces libc sequences.private io.encodings.ascii ;
+IN: compiler.tests
 
 ! Make sure that intrinsic ops compile to correct code.
 [ ] [ 1 [ drop ] compile-call ] unit-test
@@ -361,11 +361,11 @@ cell 8 = [
     [ ] [ "b" get free ] unit-test
 ] when
 
-[ ] [ "hello world" malloc-char-string "s" set ] unit-test
+[ ] [ "hello world" ascii malloc-string "s" set ] unit-test
 
 "s" get [
-    [ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call alien>char-string ] unit-test
+    [ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call ascii alien>string ] unit-test
-    [ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call alien>char-string ] unit-test
+    [ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call ascii alien>string ] unit-test
 
     [ ] [ "s" get free ] unit-test
 ] when

core/compiler/tests/simple.factor

@@ -1,6 +1,6 @@
 USING: compiler.units tools.test kernel kernel.private
 sequences.private math.private math combinators strings
-alien arrays memory ;
+alien arrays memory vocabs parser ;
 IN: compiler.tests
 
 ! Test empty word
@@ -230,3 +230,11 @@ M: f single-combination-test-2 single-combination-test-4 ;
 
 ! Regression
 [ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test
+
+! Regression
+10 [
+    [ "compiler.tests.foo" forget-vocab ] with-compilation-unit
+    [ t ] [
+        "USING: prettyprint words ; IN: compiler.tests.foo : (recursive) (  -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled?" eval
+    ] unit-test
+] times

core/compiler/tests/stack-trace.factor

@@ -13,11 +13,11 @@ words splitting sorting ;
 [ baz ] [ 3 = ] must-fail-with
 [ t ] [
     symbolic-stack-trace
-    [ word? ] subset
+    [ word? ] filter
     { baz bar foo throw } tail?
 ] unit-test
 
-: bleh [ 3 + ] map [ 0 > ] subset ;
+: bleh [ 3 + ] map [ 0 > ] filter ;
 
 : stack-trace-contains? symbolic-stack-trace memq? ;
 

core/compiler/tests/templates-early.factor

@@ -2,7 +2,8 @@
 IN: compiler.tests
 USING: compiler generator generator.registers
 generator.registers.private tools.test namespaces sequences
-words kernel math effects definitions compiler.units accessors ;
+words kernel math effects definitions compiler.units accessors
+cpu.architecture ;
 
 : <int-vreg> ( n -- vreg ) int-regs <vreg> ;
 

core/compiler/units/units.factor

@@ -53,7 +53,7 @@ GENERIC: definitions-changed ( assoc obj -- )
     [ definitions-changed ] with each ;
 
 : changed-vocabs ( assoc -- vocabs )
-    [ drop word? ] assoc-subset
+    [ drop word? ] assoc-filter
     [ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ;
 
 : updated-definitions ( -- assoc )
@@ -73,7 +73,7 @@ SYMBOL: outdated-tuples
 SYMBOL: update-tuples-hook
 
 : call-recompile-hook ( -- )
-    changed-definitions get keys [ word? ] subset
+    changed-definitions get keys [ word? ] filter
     compiled-usages recompile-hook get call ;
 
 : call-update-tuples-hook ( -- )

core/cpu/architecture/architecture.factor

@@ -1,10 +1,17 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic kernel kernel.private math memory
 namespaces sequences layouts system hashtables classes alien
 byte-arrays bit-arrays float-arrays combinators words sets ;
 IN: cpu.architecture
 
+! Register classes
+SINGLETON: int-regs
+SINGLETON: single-float-regs
+SINGLETON: double-float-regs
+UNION: float-regs single-float-regs double-float-regs ;
+UNION: reg-class int-regs float-regs ;
+
 ! A pseudo-register class for parameters spilled on the stack
 SINGLETON: stack-params
 
@@ -187,6 +194,9 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- )
 
 HOOK: %box-alien cpu ( dst src -- )
 
+! GC check
+HOOK: %gc cpu
+
 : operand ( var -- op ) get v>operand ; inline
 
 : unique-operands ( operands quot -- )

core/cpu/ppc/allot/allot.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel cpu.ppc.architecture cpu.ppc.assembler
 kernel.private namespaces math sequences generic arrays
@@ -7,7 +7,7 @@ cpu.architecture alien ;
 IN: cpu.ppc.allot
 
 : load-zone-ptr ( reg -- )
-    "nursery" f pick %load-dlsym dup 0 LWZ ;
+    >r "nursery" f r> %load-dlsym ;
 
 : %allot ( header size -- )
     #! Store a pointer to 'size' bytes allocated from the
@@ -25,6 +25,19 @@ IN: cpu.ppc.allot
 : %store-tagged ( reg tag -- )
     >r dup fresh-object v>operand 11 r> tag-number ORI ;
 
+M: ppc %gc
+    "end" define-label
+    12 load-zone-ptr
+    11 12 cell LWZ ! nursery.here -> r11
+    12 12 3 cells LWZ ! nursery.end -> r12
+    11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
+    11 0 12 CMP ! is here >= end?
+    "end" get BLE
+    0 frame-required
+    %prepare-alien-invoke
+    "minor_gc" f %alien-invoke
+    "end" resolve-label ;
+
 : %allot-float ( reg -- )
     #! exits with tagged ptr to object in r12, untagged in r11
     float 16 %allot

core/cpu/ppc/architecture/architecture.factor

@@ -4,7 +4,7 @@ USING: alien.c-types cpu.ppc.assembler cpu.architecture generic
 kernel kernel.private math memory namespaces sequences words
 assocs generator generator.registers generator.fixup system
 layouts classes words.private alien combinators
-compiler.constants ;
+compiler.constants math.order ;
 IN: cpu.ppc.architecture
 
 ! PowerPC register assignments

core/cpu/ppc/assembler/assembler.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: generator.fixup generic kernel memory namespaces
+words math math.bitfields math.order io.binary ;
 IN: cpu.ppc.assembler
-USING: generator.fixup generic kernel math memory namespaces
-words math.bitfields io.binary ;
 
 ! See the Motorola or IBM documentation for details. The opcode
 ! names are standard, and the operand order is the same as in

core/cpu/x86/32/32.factor

@@ -17,6 +17,8 @@ M: x86.32 ds-reg ESI ;
 M: x86.32 rs-reg EDI ;
 M: x86.32 stack-reg ESP ;
 M: x86.32 stack-save-reg EDX ;
+M: x86.32 temp-reg-1 EAX ;
+M: x86.32 temp-reg-2 ECX ;
 
 M: temp-reg v>operand drop EBX ;
 

core/cpu/x86/64/64.factor

@@ -12,6 +12,8 @@ M: x86.64 ds-reg R14 ;
 M: x86.64 rs-reg R15 ;
 M: x86.64 stack-reg RSP ;
 M: x86.64 stack-save-reg RSI ;
+M: x86.64 temp-reg-1 RAX ;
+M: x86.64 temp-reg-2 RCX ;
 
 M: temp-reg v>operand drop RBX ;
 
@@ -179,7 +181,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >>
 : split-struct ( pairs -- seq )
     [
         [ 8 mod zero? [ t , ] when , ] assoc-each
-    ] { } make { t } split [ empty? not ] subset ;
+    ] { } make { t } split [ empty? not ] filter ;
 
 : flatten-large-struct ( type -- )
     heap-size cell align

core/cpu/x86/allot/allot.factor

@@ -16,12 +16,12 @@ IN: cpu.x86.allot
 
 : object@ ( n -- operand ) cells (object@) ;
 
-: load-zone-ptr ( -- )
+: load-zone-ptr ( reg -- )
     #! Load pointer to start of zone array
-    "nursery" f allot-reg %alien-global ;
+    0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
 
 : load-allot-ptr ( -- )
-    load-zone-ptr
+    allot-reg load-zone-ptr
     allot-reg PUSH
     allot-reg dup cell [+] MOV ;
 
@@ -29,6 +29,19 @@ IN: cpu.x86.allot
     allot-reg POP
     allot-reg cell [+] swap 8 align ADD ;
 
+M: x86 %gc ( -- )
+    "end" define-label
+    temp-reg-1 load-zone-ptr
+    temp-reg-2 temp-reg-1 cell [+] MOV
+    temp-reg-2 1024 ADD
+    temp-reg-1 temp-reg-1 3 cells [+] MOV
+    temp-reg-2 temp-reg-1 CMP
+    "end" get JLE
+    0 frame-required
+    %prepare-alien-invoke
+    "minor_gc" f %alien-invoke
+    "end" resolve-label ;
+
 : store-header ( header -- )
     0 object@ swap type-number tag-fixnum MOV ;
 

core/cpu/x86/architecture/architecture.factor

@@ -3,7 +3,8 @@
 USING: alien alien.c-types alien.compiler arrays
 cpu.x86.assembler cpu.architecture kernel kernel.private math
 memory namespaces sequences words generator generator.registers
-generator.fixup system layouts combinators compiler.constants ;
+generator.fixup system layouts combinators compiler.constants
+math.order ;
 IN: cpu.x86.architecture
 
 HOOK: ds-reg cpu
@@ -34,6 +35,10 @@ GENERIC: push-return-reg ( reg-class -- )
 GENERIC: load-return-reg ( stack@ reg-class -- )
 GENERIC: store-return-reg ( stack@ reg-class -- )
 
+! Only used by inline allocation
+HOOK: temp-reg-1 cpu
+HOOK: temp-reg-2 cpu
+
 HOOK: address-operand cpu ( address -- operand )
 
 HOOK: fixnum>slot@ cpu

core/cpu/x86/assembler/assembler.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generator.fixup io.binary kernel
 combinators kernel.private math namespaces parser sequences
-words system layouts ;
+words system layouts math.order ;
 IN: cpu.x86.assembler
 
 ! A postfix assembler for x86 and AMD64.

core/debugger/debugger.factor

@@ -6,7 +6,8 @@ strings io.styles vectors words system splitting math.parser
 classes.tuple continuations continuations.private combinators
 generic.math io.streams.duplex classes.builtin classes
 compiler.units generic.standard vocabs threads threads.private
-init kernel.private libc io.encodings accessors ;
+init kernel.private libc io.encodings mirrors accessors
+math.order ;
 IN: debugger
 
 GENERIC: error. ( error -- )
@@ -96,10 +97,10 @@ M: relative-overflow summary
 
 : assert-depth ( quot -- )
     >r datastack r> swap slip >r datastack r>
-    2dup [ length ] compare sgn {
+    2dup [ length ] compare {
-        { -1 [ trim-datastacks nip relative-underflow ] }
+        { +lt+ [ trim-datastacks nip relative-underflow ] }
-        { 0 [ 2drop ] }
+        { +eq+ [ 2drop ] }
-        { 1 [ trim-datastacks drop relative-overflow ] }
+        { +gt+ [ trim-datastacks drop relative-overflow ] }
     } case ; inline
 
 : expired-error. ( obj -- )
@@ -289,6 +290,12 @@ M: encode-error summary drop "Character encoding error" ;
 
 M: decode-error summary drop "Character decoding error" ;
 
+M: no-such-slot summary drop "No such slot" ;
+
+M: immutable-slot summary drop "Slot is immutable" ;
+
+M: bad-create summary drop "Bad parameters to create" ;
+
 <PRIVATE
 
 : init-debugger ( -- )

core/definitions/definitions-tests.factor

@@ -1,6 +1,6 @@
-IN: definitions.tests
 USING: tools.test generic kernel definitions sequences
 compiler.units words ;
+IN: definitions.tests
 
 GENERIC: some-generic ( a -- b )
 

core/dlists/dlists-tests.factor

@@ -79,7 +79,7 @@ IN: dlists.tests
         [ dlist-push-all ] keep
         [ dlist-delete-all ] keep
         dlist>array
-    ] 2keep diff assert-same-elements
+    ] 2keep swap diff assert-same-elements
 ] unit-test
 
 [ ] [

core/dlists/dlists.factor

@@ -153,7 +153,7 @@ PRIVATE>
     drop ;
 
 : dlist-each ( dlist quot -- )
-    [ obj>> ] swap compose dlist-each-node ; inline
+    [ obj>> ] prepose dlist-each-node ; inline
 
 : dlist-slurp ( dlist quot -- )
     over dlist-empty?

core/generator/fixup/fixup-docs.factor

@@ -13,12 +13,6 @@ HELP: add-literal
 { $values { "obj" object } { "n" integer } }
 { $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
 
-HELP: string>symbol
-{ $values { "str" string } { "alien" alien } }
-{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
-$nl
-"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
-
 HELP: rel-dlsym
 { $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
 { $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."

core/generator/fixup/fixup.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic assocs hashtables
 kernel kernel.private math namespaces sequences words
-quotations strings alien layouts system combinators
+quotations strings alien.strings layouts system combinators
-math.bitfields words.private cpu.architecture ;
+math.bitfields words.private cpu.architecture math.order ;
 IN: generator.fixup
 
 : no-stack-frame -1 ; inline
@@ -110,10 +110,6 @@ SYMBOL: literal-table
 
 : add-literal ( obj -- n ) literal-table get push-new* ;
 
-: string>symbol ( str -- alien )
-    [ os wince? [ string>u16-alien ] [ string>char-alien ] if ]
-    over string? [ call ] [ map ] if ;
-
 : add-dlsym-literals ( symbol dll -- )
     >r string>symbol r> 2array literal-table get push-all ;
 

core/generator/generator.factor

@@ -40,16 +40,16 @@ SYMBOL: current-label-start
     compiled-stack-traces?
     compiling-word get f ?
     1vector literal-table set
-    f compiling-word get compiled get set-at ;
+    f compiling-label get compiled get set-at ;
 
-: finish-compiling ( literals relocation labels code -- )
+: save-machine-code ( literals relocation labels code -- )
     4array compiling-label get compiled get set-at ;
 
 : with-generator ( node word label quot -- )
     [
         >r begin-compiling r>
         { } make fixup
-        finish-compiling
+        save-machine-code
     ] with-scope ; inline
 
 GENERIC: generate-node ( node -- next )
@@ -73,6 +73,7 @@ GENERIC: generate-node ( node -- next )
 : word-dataflow ( word -- effect dataflow )
     [
         dup "no-effect" word-prop [ no-effect ] when
+        dup "no-compile" word-prop [ no-effect ] when
         dup specialized-def over dup 2array 1array infer-quot
         finish-word
     ] with-infer ;

core/generator/registers/registers.factor

@@ -4,7 +4,7 @@ USING: arrays assocs classes classes.private classes.algebra
 combinators cpu.architecture generator.fixup hashtables kernel
 layouts math namespaces quotations sequences system vectors
 words effects alien byte-arrays bit-arrays float-arrays
-accessors sets ;
+accessors sets math.order ;
 IN: generator.registers
 
 SYMBOL: +input+
@@ -13,13 +13,6 @@ SYMBOL: +scratch+
 SYMBOL: +clobber+
 SYMBOL: known-tag
 
-! Register classes
-SINGLETON: int-regs
-SINGLETON: single-float-regs
-SINGLETON: double-float-regs
-UNION: float-regs single-float-regs double-float-regs ;
-UNION: reg-class int-regs float-regs ;
-
 <PRIVATE
 
 ! Value protocol
@@ -321,7 +314,7 @@ M: phantom-retainstack finalize-height
 : (live-locs) ( phantom -- seq )
     #! Discard locs which haven't moved
     [ phantom-locs* ] [ stack>> ] bi zip
-    [ live-loc? ] assoc-subset
+    [ live-loc? ] assoc-filter
     values ;
 
 : live-locs ( -- seq )
@@ -379,7 +372,7 @@ M: value (lazy-load)
 : (compute-free-vregs) ( used class -- vector )
     #! Find all vregs in 'class' which are not in 'used'.
     [ vregs length reverse ] keep
-    [ <vreg> ] curry map diff
+    [ <vreg> ] curry map swap diff
     >vector ;
 
 : compute-free-vregs ( -- )
@@ -468,11 +461,6 @@ M: loc lazy-store
 : finalize-contents ( -- )
     finalize-locs finalize-vregs reset-phantoms ;
 
-: %gc ( -- )
-    0 frame-required
-    %prepare-alien-invoke
-    "simple_gc" f %alien-invoke ;
-
 ! Loading stacks to vregs
 : free-vregs? ( int# float# -- ? )
     double-float-regs free-vregs length <=
@@ -496,7 +484,7 @@ M: loc lazy-store
 
 : substitute-vregs ( values vregs -- )
     [ vreg-substitution ] 2map
-    [ substitute-vreg? ] assoc-subset >hashtable
+    [ substitute-vreg? ] assoc-filter >hashtable
     [ >r stack>> r> substitute-here ] curry each-phantom ;
 
 : set-operand ( value var -- )

core/generic/generic-tests.factor

@@ -143,7 +143,7 @@ GENERIC: generic-forget-test-1
 M: integer generic-forget-test-1 / ;
 
 [ t ] [
-    \ / usage [ word? ] subset
+    \ / usage [ word? ] filter
     [ word-name "generic-forget-test-1/integer" = ] contains?
 ] unit-test
 
@@ -152,7 +152,7 @@ M: integer generic-forget-test-1 / ;
 ] unit-test
 
 [ f ] [
-    \ / usage [ word? ] subset
+    \ / usage [ word? ] filter
     [ word-name "generic-forget-test-1/integer" = ] contains?
 ] unit-test
 
@@ -161,7 +161,7 @@ GENERIC: generic-forget-test-2
 M: sequence generic-forget-test-2 = ;
 
 [ t ] [
-    \ = usage [ word? ] subset
+    \ = usage [ word? ] filter
     [ word-name "generic-forget-test-2/sequence" = ] contains?
 ] unit-test
 
@@ -170,7 +170,7 @@ M: sequence generic-forget-test-2 = ;
 ] unit-test
 
 [ f ] [
-    \ = usage [ word? ] subset
+    \ = usage [ word? ] filter
     [ word-name "generic-forget-test-2/sequence" = ] contains?
 ] unit-test
 

core/generic/generic.factor

@@ -29,10 +29,13 @@ PREDICATE: method-spec < pair
 : order ( generic -- seq )
     "methods" word-prop keys sort-classes ;
 
+: specific-method ( class word -- class )
+    order min-class ;
+
 GENERIC: effective-method ( ... generic -- method )
 
 : next-method-class ( class generic -- class/f )
-    order [ class< ] with subset reverse dup length 1 =
+    order [ class< ] with filter reverse dup length 1 =
     [ drop f ] [ second ] if ;
 
 : next-method ( class generic -- class/f )
@@ -134,7 +137,7 @@ M: method-body forget*
     all-words [
         "methods" word-prop keys
         swap [ key? ] curry contains?
-    ] with subset ;
+    ] with filter ;
 
 : implementors ( class -- seq )
     dup associate implementors* ;

core/generic/math/math.factor

@@ -3,7 +3,7 @@
 USING: arrays generic hashtables kernel kernel.private
 math namespaces sequences words quotations layouts combinators
 sequences.private classes classes.builtin classes.algebra
-definitions ;
+definitions math.order ;
 IN: generic.math
 
 PREDICATE: math-class < class
@@ -23,7 +23,7 @@ PREDICATE: math-class < class
     } cond ;
     
 : math-class-max ( class class -- class )
-    [ [ math-precedence ] compare 0 > ] most ;
+    [ [ math-precedence ] compare +gt+ eq? ] most ;
 
 : (math-upgrade) ( max class -- quot )
     dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;

core/generic/standard/engines/engines.factor

@@ -26,8 +26,8 @@ M: method-body engine>quot 1quotation ;
     alist>quot ;
 
 : split-methods ( assoc class -- first second )
-    [ [ nip class< not ] curry assoc-subset ]
+    [ [ nip class< not ] curry assoc-filter ]
-    [ [ nip class<     ] curry assoc-subset ] 2bi ;
+    [ [ nip class<     ] curry assoc-filter ] 2bi ;
 
 : convert-methods ( assoc class word -- assoc' )
     over >r >r split-methods dup assoc-empty? [

core/generic/standard/engines/predicate/predicate.factor

@@ -17,8 +17,8 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
     {
         { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
         { [ dup length 1 = ] [ first second { } ] }
-        { [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] }
+        { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
-        [ [ first second ] [ 1 tail-slice ] bi ]
+        [ [ first second ] [ rest-slice ] bi ]
     } cond ;
 
 : sort-methods ( assoc -- assoc' )

core/generic/standard/standard-tests.factor

@@ -3,7 +3,7 @@ USING: tools.test math math.functions math.constants
 generic.standard strings sequences arrays kernel accessors
 words float-arrays byte-arrays bit-arrays parser namespaces
 quotations inference vectors growable hashtables sbufs
-prettyprint ;
+prettyprint byte-vectors bit-vectors float-vectors ;
 
 GENERIC: lo-tag-test
 

core/hashtables/hashtables-tests.factor

@@ -10,7 +10,7 @@ continuations ;
 [ ] [ 1000 [ dup sq ] H{ } map>assoc "testhash" set ] unit-test
 
 [ V{ } ]
-[ 1000 [ dup sq swap "testhash" get at = not ] subset ]
+[ 1000 [ dup sq swap "testhash" get at = not ] filter ]
 unit-test
 
 [ t ]

core/heaps/heaps-docs.factor

@@ -1,4 +1,5 @@
-USING: heaps.private help.markup help.syntax kernel math assocs ;
+USING: heaps.private help.markup help.syntax kernel math assocs
+math.order ;
 IN: heaps
 
 ARTICLE: "heaps" "Heaps"

core/heaps/heaps-tests.factor

@@ -3,7 +3,7 @@
 
 USING: arrays kernel math namespaces tools.test
 heaps heaps.private math.parser random assocs sequences sorting
-accessors ;
+accessors math.order ;
 IN: heaps.tests
 
 [ <min-heap> heap-pop ] must-fail

core/heaps/heaps.factor

@@ -2,7 +2,7 @@
 ! Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math sequences arrays assocs sequences.private
-growable accessors ;
+growable accessors math.order ;
 IN: heaps
 
 MIXIN: priority-queue
@@ -92,11 +92,11 @@ M: priority-queue heap-size ( heap -- n )
 
 GENERIC: heap-compare ( pair1 pair2 heap -- ? )
 
-: (heap-compare) drop [ entry-key ] compare 0 ; inline
+: (heap-compare) drop [ entry-key ] compare ; inline
 
-M: min-heap heap-compare (heap-compare) > ;
+M: min-heap heap-compare (heap-compare) +gt+ eq? ;
 
-M: max-heap heap-compare (heap-compare) < ;
+M: max-heap heap-compare (heap-compare) +lt+ eq? ;
 
 : heap-bounds-check? ( m heap -- ? )
     heap-size >= ; inline

core/inference/backend/backend-docs.factor

@@ -48,10 +48,6 @@ HELP: no-effect
 { $description "Throws a " { $link no-effect } " error." }
 { $error-description "Thrown when inference encounters a call to a word which is already known not to have a static stack effect, due to a prior inference attempt failing." } ;
 
-HELP: collect-recursion
-{ $values { "#label" "a " { $link #label } " node" } { "seq" "a new sequence" } }
-{ $description "Collect the input stacks of all child " { $link #call-label } " nodes that call the given label." } ;
-
 HELP: inline-word
 { $values { "word" word } }
 { $description "Called during inference to infer stack effects of inline words."

core/inference/backend/backend.factor

@@ -4,7 +4,7 @@ USING: inference.dataflow inference.state arrays generic io
 io.streams.string kernel math namespaces parser prettyprint
 sequences strings vectors words quotations effects classes
 continuations debugger assocs combinators compiler.errors
-generic.standard.engines.tuple accessors ;
+generic.standard.engines.tuple accessors math.order ;
 IN: inference.backend
 
 : recursive-label ( word -- label/f )
@@ -60,7 +60,7 @@ M: object value-literal \ literal-expected inference-warning ;
 : value-vector ( n -- vector ) [ drop <computed> ] V{ } map-as ;
 
 : add-inputs ( seq stack -- n stack )
-    tuck [ length ] compare dup 0 >
+    tuck [ length ] bi@ - dup 0 >
     [ dup value-vector [ swapd push-all ] keep ]
     [ drop 0 swap ] if ;
 
@@ -261,7 +261,7 @@ TUPLE: cannot-unify-specials ;
 
 : balanced? ( in out -- ? )
     [ dup [ length - ] [ 2drop f ] if ] 2map
-    [ ] subset all-equal? ;
+    [ ] filter all-equal? ;
 
 TUPLE: unbalanced-branches-error quots in out ;
 
@@ -281,7 +281,7 @@ TUPLE: unbalanced-branches-error quots in out ;
     2dup balanced? [
         over supremum -rot
         [ >r dupd r> unify-inputs ] 2map
-        [ ] subset unify-stacks
+        [ ] filter unify-stacks
         rot drop
     ] [
         unbalanced-branches-error
@@ -409,6 +409,25 @@ TUPLE: recursive-declare-error word ;
         \ recursive-declare-error inference-error
     ] if* ;
 
+GENERIC: collect-label-info* ( label node -- )
+
+M: node collect-label-info* 2drop ;
+
+: (collect-label-info) ( label node vector -- )
+    >r tuck [ param>> ] bi@ eq? r> [ push ] curry [ drop ] if ;
+    inline
+
+M: #call-label collect-label-info*
+    over calls>> (collect-label-info) ;
+
+M: #return collect-label-info*
+    over returns>> (collect-label-info) ;
+
+: collect-label-info ( #label -- )
+    V{ } clone >>calls
+    V{ } clone >>returns
+    dup [ collect-label-info* ] with each-node ;
+
 : nest-node ( -- ) #entry node, ;
 
 : unnest-node ( new-node -- new-node )
@@ -419,27 +438,17 @@ TUPLE: recursive-declare-error word ;
 
 : <inlined-block> gensym dup t "inlined-block" set-word-prop ;
 
-: inline-block ( word -- node-block data )
+: inline-block ( word -- #label data )
     [
         copy-inference nest-node
         dup word-def swap <inlined-block>
         [ infer-quot-recursive ] 2keep
         #label unnest-node
+        dup collect-label-info
     ] H{ } make-assoc ;
 
-GENERIC: collect-recursion* ( label node -- )
+: join-values ( #label -- )
-
+    calls>> [ node-in-d ] map meta-d get suffix
-M: node collect-recursion* 2drop ;
-
-M: #call-label collect-recursion*
-    tuck node-param eq? [ , ] [ drop ] if ;
-
-: collect-recursion ( #label -- seq )
-    dup node-param
-    [ [ swap collect-recursion* ] curry each-node ] { } make ;
-
-: join-values ( node -- )
-    collect-recursion [ node-in-d ] map meta-d get suffix
     unify-lengths unify-stacks
     meta-d [ length tail* ] change ;
 
@@ -460,7 +469,7 @@ M: #call-label collect-recursion*
         drop join-values inline-block apply-infer
         r> over set-node-in-d
         dup node,
-        collect-recursion [
+        calls>> [
             [ flatten-curries ] modify-values
         ] each
     ] [

core/inference/class/class-tests.factor

@@ -4,7 +4,12 @@ inference.dataflow optimizer tools.test kernel.private generic
 sequences words inference.class quotations alien
 alien.c-types strings sbufs sequences.private
 slots.private combinators definitions compiler.units
-system layouts vectors ;
+system layouts vectors optimizer.math.partial accessors
+optimizer.inlining math.order ;
+
+[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
+
+[ f ] [ T{ literal-constraint f 1 3 } T{ literal-constraint f 1 2 } equal? ] unit-test
 
 ! Make sure these compile even though this is invalid code
 [ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
@@ -13,9 +18,15 @@ system layouts vectors ;
 ! Ensure type inference works as it is supposed to by checking
 ! if various methods get inlined
 
-: inlined? ( quot word -- ? )
+: inlined? ( quot seq/word -- ? )
+    dup word? [ 1array ] when
     swap dataflow optimize
-    [ node-param eq? ] with node-exists? not ;
+    [ node-param swap member? ] with node-exists? not ;
+
+[ f ] [
+    [ { integer } declare >fixnum ]
+    \ >fixnum inlined?
+] unit-test
 
 GENERIC: mynot ( x -- y )
 
@@ -109,12 +120,17 @@ M: object xyz ;
     [ { fixnum } declare [ ] times ] \ fixnum+ inlined?
 ] unit-test
 
-[ f ] [
+[ t ] [
     [ { integer fixnum } declare dupd < [ 1 + ] when ]
     \ + inlined?
 ] unit-test
 
-[ f ] [ [ dup 0 < [ neg ] when ] \ neg inlined? ] unit-test
+[ f ] [
+    [ { integer fixnum } declare dupd < [ 1 + ] when ]
+    \ +-integer-fixnum inlined?
+] unit-test
+
+[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
 
 [ f ] [
     [
@@ -137,13 +153,13 @@ M: object xyz ;
 
 DEFER: blah
 
-[ t ] [
+[ ] [
     [
         \ blah
         [ dup V{ } eq? [ foo ] when ] dup second dup push define
     ] with-compilation-unit
 
-    \ blah compiled?
+    \ blah word-def dataflow optimize drop
 ] unit-test
 
 GENERIC: detect-fx ( n -- n )
@@ -158,14 +174,20 @@ M: fixnum detect-fx ;
     ] \ detect-fx inlined?
 ] unit-test
 
+[ t ] [
+    [
+        1000000000000000000000000000000000 [ ] times
+    ] \ + inlined?
+] unit-test
 [ f ] [
     [
         1000000000000000000000000000000000 [ ] times
-    ] \ 1+ inlined?
+    ] \ +-integer-fixnum inlined?
 ] unit-test
 
 [ f ] [
-    [ { bignum } declare [ ] times ] \ 1+ inlined?
+    [ { bignum } declare [ ] times ]
+    \ +-integer-fixnum inlined?
 ] unit-test
 
 
@@ -251,19 +273,24 @@ M: float detect-float ;
     [ 3 + = ] \ equal? inlined?
 ] unit-test
 
-[ t ] [
+[ f ] [
     [ { fixnum fixnum } declare 7 bitand neg shift ]
-    \ shift inlined?
+    \ fixnum-shift-fast inlined?
 ] unit-test
 
 [ t ] [
     [ { fixnum fixnum } declare 7 bitand neg shift ]
-    \ fixnum-shift inlined?
+    { shift fixnum-shift } inlined?
 ] unit-test
 
 [ t ] [
     [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
-    \ fixnum-shift inlined?
+    { shift fixnum-shift } inlined?
+] unit-test
+
+[ f ] [
+    [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
+    { fixnum-shift-fast } inlined?
 ] unit-test
 
 cell-bits 32 = [
@@ -278,6 +305,11 @@ cell-bits 32 = [
     ] unit-test
 ] when
 
+[ f ] [
+    [ { integer } declare -63 shift 4095 bitand ]
+    \ shift inlined?
+] unit-test
+
 [ t ] [
     [ B{ 1 0 } *short 0 number= ]
     \ number= inlined?
@@ -323,3 +355,228 @@ cell-bits 32 = [
         ] when
     ] \ + inlined?
 ] unit-test
+
+[ f ] [
+    [
+        256 mod
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ f ] [
+    [
+        dup 0 >= [ 256 mod ] when
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare dup 0 >= [ 256 mod ] when
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare 256 rem
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare [ 256 rem ] map
+    ] { mod fixnum-mod rem } inlined?
+] unit-test
+
+[ t ] [
+    [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
+] unit-test
+
+: rec ( a -- b )
+    dup 0 > [ 1 - rec ] when ; inline
+
+[ t ] [
+    [ { fixnum } declare rec 1 + ]
+    { > - + } inlined?
+] unit-test
+
+: fib ( m -- n )
+    dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline
+
+[ t ] [
+    [ 27.0 fib ] { < - + } inlined?
+] unit-test
+
+[ f ] [
+    [ 27.0 fib ] { +-integer-integer } inlined?
+] unit-test
+
+[ t ] [
+    [ 27 fib ] { < - + } inlined?
+] unit-test
+
+[ t ] [
+    [ 27 >bignum fib ] { < - + } inlined?
+] unit-test
+
+[ f ] [
+    [ 27/2 fib ] { < - } inlined?
+] unit-test
+
+: hang-regression ( m n -- x )
+    over 0 number= [
+        nip
+    ] [
+        dup [
+            drop 1 hang-regression
+        ] [
+            dupd hang-regression hang-regression
+        ] if
+    ] if ; inline
+
+[ t ] [
+    [ dup fixnum? [ 3 over hang-regression ] [ 3 over hang-regression ] if
+] { } inlined? ] unit-test
+
+: detect-null ( a -- b ) dup drop ;
+
+\ detect-null {
+    { [ dup dup in-d>> first node-class null eq? ] [ [ ] f splice-quot ] }
+} define-optimizers
+
+[ t ] [
+    [ { null } declare detect-null ] \ detect-null inlined?
+] unit-test
+
+[ t ] [
+    [ { null null } declare + detect-null ] \ detect-null inlined?
+] unit-test
+
+[ f ] [
+    [ { null fixnum } declare + detect-null ] \ detect-null inlined?
+] unit-test
+
+GENERIC: detect-integer ( a -- b )
+
+M: integer detect-integer ;
+
+[ t ] [
+    [ { null fixnum } declare + detect-integer ] \ detect-integer inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
+] unit-test
+
+[ f ] [
+    [ { integer } declare 10 [ -1 shift ] times ] \ shift inlined?
+] unit-test
+
+[ f ] [
+    [ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
+    \ fixnum-bitand inlined?
+] unit-test
+
+[ t ] [
+    [ { integer } declare 127 bitand 3 + ]
+    { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
+] unit-test
+
+[ f ] [
+    [ { integer } declare 127 bitand 3 + ]
+    { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare [ drop ] each-integer ]
+    { < <-integer-fixnum +-integer-fixnum + } inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare length [ drop ] each-integer ]
+    { < <-integer-fixnum +-integer-fixnum + } inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare [ drop ] each ]
+    { < <-integer-fixnum +-integer-fixnum + } inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare 0 [ + ] reduce ]
+    { < <-integer-fixnum } inlined?
+] unit-test
+
+[ f ] [
+    [ { fixnum } declare 0 [ + ] reduce ]
+    \ +-integer-fixnum inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare
+        dup 0 >= [
+            615949 * 797807 + 20 2^ mod dup 19 2^ -
+        ] [ dup ] if
+    ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { fixnum } declare
+        615949 * 797807 + 20 2^ mod dup 19 2^ -
+    ] { >fixnum } inlined?
+] unit-test
+
+[ f ] [
+    [
+        { integer } declare [ ] map
+    ] \ >fixnum inlined?
+] unit-test
+
+[ f ] [
+    [
+        { integer } declare { } set-nth-unsafe
+    ] \ >fixnum inlined?
+] unit-test
+
+[ f ] [
+    [
+        { integer } declare 1 + { } set-nth-unsafe
+    ] \ >fixnum inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare 0 swap
+        [
+            drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
+        ] map
+    ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { fixnum } declare 0 swap
+        [
+            drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
+        ] map
+    ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ { integer } declare bitnot detect-integer ]
+    \ detect-integer inlined?
+] unit-test
+
+! Later
+
+! [ t ] [
+!     [
+!         { integer } declare [ 256 mod ] map
+!     ] { mod fixnum-mod } inlined?
+! ] unit-test
+! 
+! [ t ] [
+!     [
+!         { integer } declare [ 0 >= ] map
+!     ] { >= fixnum>= } inlined?
+! ] unit-test

core/inference/class/class.factor

@@ -1,9 +1,9 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic assocs hashtables inference kernel
 math namespaces sequences words parser math.intervals
 effects classes classes.algebra inference.dataflow
-inference.backend combinators ;
+inference.backend combinators accessors ;
 IN: inference.class
 
 ! Class inference
@@ -25,12 +25,10 @@ C: <literal-constraint> literal-constraint
 
 M: literal-constraint equal?
     over literal-constraint? [
-        2dup
+        [ [ literal>> ] bi@ eql? ]
-        [ literal-constraint-literal ] bi@ eql? >r
+        [ [ value>>   ] bi@ =    ]
-        [ literal-constraint-value ] bi@ = r> and
+        2bi and
-    ] [
+    ] [ 2drop f ] if ;
-        2drop f
-    ] if ;
 
 TUPLE: class-constraint class value ;
 
@@ -43,8 +41,8 @@ C: <interval-constraint> interval-constraint
 GENERIC: apply-constraint ( constraint -- )
 GENERIC: constraint-satisfied? ( constraint -- ? )
 
-: `input node get node-in-d nth ;
+: `input node get in-d>> nth ;
-: `output node get node-out-d nth ;
+: `output node get out-d>> nth ;
 : class, <class-constraint> , ;
 : literal, <literal-constraint> , ;
 : interval, <interval-constraint> , ;
@@ -84,14 +82,12 @@ SYMBOL: value-classes
     set-value-interval* ;
 
 M: interval-constraint apply-constraint
-    dup interval-constraint-interval
+    [ interval>> ] [ value>> ] bi intersect-value-interval ;
-    swap interval-constraint-value intersect-value-interval ;
 
 : set-class-interval ( class value -- )
     over class? [
-        over "interval" word-prop [
+        >r "interval" word-prop r> over
-            >r "interval" word-prop r> set-value-interval*
+        [ set-value-interval* ] [ 2drop ] if
-        ] [ 2drop ] if
     ] [ 2drop ] if ;
 
 : value-class* ( value -- class )
@@ -110,18 +106,21 @@ M: interval-constraint apply-constraint
     [ value-class* class-and ] keep set-value-class* ;
 
 M: class-constraint apply-constraint
-    dup class-constraint-class
+    [ class>> ] [ value>> ] bi intersect-value-class ;
-    swap class-constraint-value intersect-value-class ;
+
+: literal-interval ( value -- interval/f )
+    dup real? [ [a,a] ] [ drop f ] if ;
 
 : set-value-literal* ( literal value -- )
-    over class over set-value-class*
+    {
-    over real? [ over [a,a] over set-value-interval* ] when
+        [ >r class r> set-value-class* ]
-    2dup <literal-constraint> assume
+        [ >r literal-interval r> set-value-interval* ]
-    value-literals get set-at ;
+        [ <literal-constraint> assume ]
+        [ value-literals get set-at ]
+    } 2cleave ;
 
 M: literal-constraint apply-constraint
-    dup literal-constraint-literal
+    [ literal>> ] [ value>> ] bi set-value-literal* ;
-    swap literal-constraint-value set-value-literal* ;
 
 ! For conditionals, an assoc of child node # --> constraint
 GENERIC: child-constraints ( node -- seq )
@@ -133,19 +132,18 @@ GENERIC: infer-classes-around ( node -- )
 M: node infer-classes-before drop ;
 
 M: node child-constraints
-    node-children length
+    children>> length
     dup zero? [ drop f ] [ f <repetition> ] if ;
 
 : value-literal* ( value -- obj ? )
     value-literals get at* ;
 
 M: literal-constraint constraint-satisfied?
-    dup literal-constraint-value value-literal*
+    dup value>> value-literal*
-    [ swap literal-constraint-literal eql? ] [ 2drop f ] if ;
+    [ swap literal>> eql? ] [ 2drop f ] if ;
 
 M: class-constraint constraint-satisfied?
-    dup class-constraint-value value-class*
+    [ value>> value-class* ] [ class>> ] bi class< ;
-    swap class-constraint-class class< ;
 
 M: pair apply-constraint
     first2 2dup constraints get set-at
@@ -154,19 +152,18 @@ M: pair apply-constraint
 M: pair constraint-satisfied?
     first constraint-satisfied? ;
 
-: extract-keys ( assoc seq -- newassoc )
+: extract-keys ( seq assoc -- newassoc )
-    dup length <hashtable> swap [
+    [ dupd at ] curry H{ } map>assoc [ nip ] assoc-filter f assoc-like ;
-        dup >r pick at* [ r> pick set-at ] [ r> 2drop ] if
-    ] each nip f assoc-like ;
 
 : annotate-node ( node -- )
     #! Annotate the node with the currently-inferred set of
     #! value classes.
-    dup node-values
+    dup node-values {
-    value-intervals get over extract-keys pick set-node-intervals
+        [ value-intervals get extract-keys >>intervals ]
-    value-classes get over extract-keys pick set-node-classes
+        [ value-classes   get extract-keys >>classes   ]
-    value-literals get over extract-keys pick set-node-literals
+        [ value-literals  get extract-keys >>literals  ]
-    2drop ;
+        [ 2drop ]
+    } cleave ;
 
 : intersect-classes ( classes values -- )
     [ intersect-value-class ] 2each ;
@@ -190,31 +187,29 @@ M: pair constraint-satisfied?
     ] 2bi ;
 
 : compute-constraints ( #call -- )
-    dup node-param "constraints" word-prop [
+    dup param>> "constraints" word-prop [
         call
     ] [
-        dup node-param "predicating" word-prop dup
+        dup param>> "predicating" word-prop dup
         [ swap predicate-constraints ] [ 2drop ] if
     ] if* ;
 
 : compute-output-classes ( node word -- classes intervals )
-    dup node-param "output-classes" word-prop
+    dup param>> "output-classes" word-prop
     dup [ call ] [ 2drop f f ] if ;
 
 : output-classes ( node -- classes intervals )
     dup compute-output-classes >r
-    [ ] [ node-param "default-output-classes" word-prop ] ?if
+    [ ] [ param>> "default-output-classes" word-prop ] ?if
     r> ;
 
 M: #call infer-classes-before
-    dup compute-constraints
+    [ compute-constraints ] keep
-    dup node-out-d swap output-classes
+    [ output-classes ] [ out-d>> ] bi
-    >r over intersect-classes
+    tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
-    r> swap intersect-intervals ;
 
 M: #push infer-classes-before
-    node-out-d
+    out-d>> [ [ value-literal ] keep set-value-literal* ] each ;
-    [ [ value-literal ] keep set-value-literal* ] each ;
 
 M: #if child-constraints
     [
@@ -224,19 +219,17 @@ M: #if child-constraints
 
 M: #dispatch child-constraints
     dup [
-        node-children length [
+        children>> length [ 0 `input literal, ] each
-            0 `input literal,
-        ] each
     ] make-constraints ;
 
 M: #declare infer-classes-before
-    dup node-param swap node-in-d
+    [ param>> ] [ in-d>> ] bi
     [ intersect-value-class ] 2each ;
 
 DEFER: (infer-classes)
 
 : infer-children ( node -- )
-    dup node-children swap child-constraints [
+    [ children>> ] [ child-constraints ] bi [
         [
             value-classes [ clone ] change
             value-literals [ clone ] change
@@ -251,27 +244,27 @@ DEFER: (infer-classes)
     >r dup [ length ] map supremum r> [ pad-left ] 2curry map ;
 
 : (merge-classes) ( nodes -- seq )
-    [ node-input-classes ] map
+    dup length 1 = [
-    null pad-all flip [ null [ class-or ] reduce ] map ;
+        first node-input-classes
+    ] [
+        [ node-input-classes ] map null pad-all flip
+        [ null [ class-or ] reduce ] map
+    ] if ;
 
 : set-classes ( seq node -- )
-    node-out-d [ set-value-class* ] 2reverse-each ;
+    out-d>> [ set-value-class* ] 2reverse-each ;
 
 : merge-classes ( nodes node -- )
     >r (merge-classes) r> set-classes ;
 
-: (merge-intervals) ( nodes quot -- seq )
-    >r
-    [ node-input-intervals ] map
-    f pad-all flip
-    r> map ; inline
-
 : set-intervals ( seq node -- )
-    node-out-d [ set-value-interval* ] 2reverse-each ;
+    out-d>> [ set-value-interval* ] 2reverse-each ;
 
 : merge-intervals ( nodes node -- )
-    >r [ dup first [ interval-union ] reduce ]
+    >r
-    (merge-intervals) r> set-intervals ;
+    [ node-input-intervals ] map f pad-all flip
+    [ dup first [ interval-union ] reduce ] map
+    r> set-intervals ;
 
 : annotate-merge ( nodes #merge/#entry -- )
     [ merge-classes ] [ merge-intervals ] 2bi ;
@@ -280,28 +273,68 @@ DEFER: (infer-classes)
     dup node-successor dup #merge? [
         swap active-children dup empty?
         [ 2drop ] [ swap annotate-merge ] if
-    ] [
+    ] [ 2drop ] if ;
-        2drop
+
-    ] if ;
+: classes= ( inferred current -- ? )
+    2dup min-length [ tail* ] curry bi@ sequence= ;
+
+SYMBOL: fixed-point?
+
+SYMBOL: nested-labels
 
 : annotate-entry ( nodes #label -- )
-    node-child merge-classes ;
+    >r (merge-classes) r> node-child
+    2dup node-output-classes classes=
+    [ 2drop ] [ set-classes fixed-point? off ] if ;
+
+: init-recursive-calls ( #label -- )
+    #! We set recursive calls to output the empty type, then
+    #! repeat inference until a fixed point is reached.
+    #! Hopefully, our type functions are monotonic so this
+    #! will always converge.
+    returns>> [ dup in-d>> [ null ] { } map>assoc >>classes drop ] each ;
 
 M: #label infer-classes-before ( #label -- )
-    #! First, infer types under the hypothesis which hold on
+    [ init-recursive-calls ]
-    #! entry to the recursive label.
+    [ [ 1array ] keep annotate-entry ] bi ;
-    [ 1array ] keep annotate-entry ;
+
+: infer-label-loop ( #label -- )
+    fixed-point? on
+    dup node-child (infer-classes)
+    dup [ calls>> ] [ suffix ] [ annotate-entry ] tri
+    fixed-point? get [ drop ] [ infer-label-loop ] if ;
 
 M: #label infer-classes-around ( #label -- )
     #! Now merge the types at every recursion point with the
     #! entry types.
-    {
+    [
-        [ annotate-node ]
+        {
-        [ infer-classes-before ]
+            [ nested-labels get push ]
-        [ infer-children ]
+            [ annotate-node ]
-        [ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ]
+            [ infer-classes-before ]
-        [ node-child (infer-classes) ]
+            [ infer-label-loop ]
-    } cleave ;
+            [ drop nested-labels get pop* ]
+        } cleave
+    ] with-scope ;
+
+: find-label ( param -- #label )
+    param>> nested-labels get [ param>> eq? ] with find nip ;
+
+M: #call-label infer-classes-before ( #call-label -- )
+    [ find-label returns>> (merge-classes) ] [ out-d>> ] bi
+    [ set-value-class* ] 2each ;
+
+M: #return infer-classes-around
+    nested-labels get length 0 > [
+        dup param>> nested-labels get peek param>> eq? [
+            [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
+            classes= not [
+                fixed-point? off
+                [ in-d>> value-classes get extract-keys ] keep
+                set-node-classes
+            ] [ drop ] if
+        ] [ call-next-method ] if
+    ] [ call-next-method ] if ;
 
 M: object infer-classes-around
     {
@@ -314,11 +347,13 @@ M: object infer-classes-around
 : (infer-classes) ( node -- )
     [
         [ infer-classes-around ]
-        [ node-successor (infer-classes) ] bi
+        [ node-successor ] bi
+        (infer-classes)
     ] when* ;
 
 : infer-classes-with ( node classes literals intervals -- )
     [
+        V{ } clone nested-labels set
         H{ } assoc-like value-intervals set
         H{ } assoc-like value-literals set
         H{ } assoc-like value-classes set
@@ -326,13 +361,11 @@ M: object infer-classes-around
         (infer-classes)
     ] with-scope ;
 
-: infer-classes ( node -- )
+: infer-classes ( node -- node )
-    f f f infer-classes-with ;
+    dup f f f infer-classes-with ;
 
 : infer-classes/node ( node existing -- )
     #! Infer classes, using the existing node's class info as a
     #! starting point.
-    dup node-classes
+    [ classes>> ] [ literals>> ] [ intervals>> ] tri
-    over node-literals
-    rot node-intervals
     infer-classes-with ;

core/inference/dataflow/dataflow.factor

@@ -90,7 +90,7 @@ M: object flatten-curry , ;
 
 : node-child node-children first ;
 
-TUPLE: #label < node word loop? ;
+TUPLE: #label < node word loop? returns calls ;
 
 : #label ( word label -- node )
     \ #label param-node swap >>word ;
@@ -290,6 +290,9 @@ SYMBOL: node-stack
 : node-input-classes ( node -- seq )
     dup in-d>> [ node-class ] with map ;
 
+: node-output-classes ( node -- seq )
+    dup out-d>> [ node-class ] with map ;
+
 : node-input-intervals ( node -- seq )
     dup in-d>> [ node-interval ] with map ;
 
@@ -297,7 +300,7 @@ SYMBOL: node-stack
     dup in-d>> first node-class ;
 
 : active-children ( node -- seq )
-    children>> [ last-node ] map [ #terminate? not ] subset ;
+    children>> [ last-node ] map [ #terminate? not ] filter ;
 
 DEFER: #tail?
 

core/inference/known-words/known-words.factor

@@ -92,6 +92,8 @@ M: object infer-call
     peek-d infer-call
 ] "infer" set-word-prop
 
+\ call t "no-compile" set-word-prop
+
 \ execute [
     1 ensure-values
     pop-literal nip
@@ -471,18 +473,6 @@ set-primitive-effect
 
 \ set-alien-cell { c-ptr c-ptr integer } { } <effect> set-primitive-effect
 
-\ alien>char-string { c-ptr } { string } <effect> set-primitive-effect
-\ alien>char-string make-flushable
-
-\ string>char-alien { string } { byte-array } <effect> set-primitive-effect
-\ string>char-alien make-flushable
-
-\ alien>u16-string { c-ptr } { string } <effect> set-primitive-effect
-\ alien>u16-string make-flushable
-
-\ string>u16-alien { string } { byte-array } <effect> set-primitive-effect
-\ string>u16-alien make-flushable
-
 \ alien-address { alien } { integer } <effect> set-primitive-effect
 \ alien-address make-flushable
 

core/inspector/inspector.factor

@@ -96,7 +96,7 @@ SYMBOL: +editable+
 
 : namestack. ( seq -- )
     [
-        [ global eq? not ] subset
+        [ global eq? not ] filter
         [ keys ] map concat prune
     ] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ;
 

core/io/encodings/encodings-docs.factor

@@ -41,12 +41,13 @@ $low-level-note ;
 
 ARTICLE: "encodings-descriptors" "Encoding descriptors"
 "An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:"
-{ $vocab-subsection "ASCII" "io.encodings.ascii" }
+{ $subsection "io.encodings.binary" }
-{ $vocab-subsection "Binary" "io.encodings.binary" }
+{ $subsection "io.encodings.utf8" }
+{ $subsection "io.encodings.utf16" }
 { $vocab-subsection "Strict encodings" "io.encodings.strict" }
+"Legacy encodings:"
 { $vocab-subsection "8-bit encodings" "io.encodings.8-bit" }
-{ $vocab-subsection "UTF-8" "io.encodings.utf8" }
+{ $vocab-subsection "ASCII" "io.encodings.ascii" }
-{ $vocab-subsection "UTF-16" "io.encodings.utf16" }
 { $see-also "encodings-introduction" } ;
 
 ARTICLE: "encodings-protocol" "Encoding protocol"

core/io/encodings/utf16/utf16-docs.factor

@@ -5,8 +5,7 @@ ARTICLE: "io.encodings.utf16" "UTF-16"
 "The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:"
 { $subsection utf16 }
 { $subsection utf16le }
-{ $subsection utf16be }
+{ $subsection utf16be } ;
-{ $subsection utf16n } ;
 
 ABOUT: "io.encodings.utf16"
 
@@ -22,8 +21,4 @@ HELP: utf16
 { $class-description "The encoding descriptor for UTF-16, that is, UTF-16 with a byte order mark. This is the most useful for general input and output in UTF-16. Streams can be made which read or write wth this encoding." }
 { $see-also "encodings-introduction" } ;
 
-HELP: utf16n
+{ utf16 utf16le utf16be } related-words
-{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
-{ $see-also "encodings-introduction" } ;
-
-{ utf16 utf16le utf16be utf16n } related-words

core/io/encodings/utf16/utf16-tests.factor

@@ -1,6 +1,6 @@
 USING: kernel tools.test io.encodings.utf16 arrays sbufs
 io.streams.byte-array sequences io.encodings io unicode
-io.encodings.string alien.c-types accessors classes ;
+io.encodings.string alien.c-types alien.strings accessors classes ;
 IN: io.encodings.utf16.tests
 
 [ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test

core/io/encodings/utf16/utf16.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2006, 2008 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel sequences sbufs vectors namespaces io.binary
-io.encodings combinators splitting io byte-arrays inspector
+io.encodings combinators splitting io byte-arrays inspector ;
-alien.c-types ;
 IN: io.encodings.utf16
 
 TUPLE: utf16be ;
@@ -11,8 +10,6 @@ TUPLE: utf16le ;
 
 TUPLE: utf16 ;
 
-TUPLE: utf16n ;
-
 <PRIVATE
 
 ! UTF-16BE decoding
@@ -124,13 +121,4 @@ M: utf16 <decoder> ( stream utf16 -- decoder )
 M: utf16 <encoder> ( stream utf16 -- encoder )
     drop bom-le over stream-write utf16le <encoder> ;
 
-! Native-order UTF-16
-
-: native-utf16 ( -- descriptor )
-    little-endian? utf16le utf16be ? ;
-
-M: utf16n <decoder> drop native-utf16 <decoder> ;
-
-M: utf16n <encoder> drop native-utf16 <encoder> ;
-
 PRIVATE>

core/io/files/files-tests.factor

@@ -135,13 +135,13 @@ strings accessors io.encodings.utf8 ;
 
 [ { { "kernel" t } } ] [
     "core" resource-path [
-        "." directory [ first "kernel" = ] subset
+        "." directory [ first "kernel" = ] filter
     ] with-directory
 ] unit-test
 
 [ { { "kernel" t } } ] [
     "resource:core" [
-        "." directory [ first "kernel" = ] subset
+        "." directory [ first "kernel" = ] filter
     ] with-directory
 ] unit-test
 

core/io/files/files.factor

@@ -3,7 +3,7 @@
 USING: io.backend io.files.private io hashtables kernel math
 memory namespaces sequences strings assocs arrays definitions
 system combinators splitting sbufs continuations io.encodings
-io.encodings.binary init accessors ;
+io.encodings.binary init accessors math.order ;
 IN: io.files
 
 HOOK: (file-reader) io-backend ( path -- stream )
@@ -54,7 +54,7 @@ HOOK: (file-appender) io-backend ( path -- stream )
     [ path-separator? ] left-trim ;
 
 : last-path-separator ( path -- n ? )
-    [ length 1- ] keep [ path-separator? ] find-last* ;
+    [ length 1- ] keep [ path-separator? ] find-last-from ;
 
 HOOK: root-directory? io-backend ( path -- ? )
 
@@ -92,7 +92,7 @@ ERROR: no-parent-directory path ;
 : append-path-empty ( path1 path2 -- path' )
     {
         { [ dup head.? ] [
-            1 tail left-trim-separators append-path-empty
+            rest left-trim-separators append-path-empty
         ] }
         { [ dup head..? ] [ drop no-parent-directory ] }
         [ nip ]
@@ -122,7 +122,7 @@ PRIVATE>
         { [ over empty? ] [ append-path-empty ] }
         { [ dup empty? ] [ drop ] }
         { [ dup absolute-path? ] [ nip ] }
-        { [ dup head.? ] [ 1 tail left-trim-separators append-path ] }
+        { [ dup head.? ] [ rest left-trim-separators append-path ] }
         { [ dup head..? ] [
             2 tail left-trim-separators
             >r parent-directory r> append-path
@@ -232,7 +232,7 @@ HOOK: make-directory io-backend ( path -- )
         dup string?
         [ tuck append-path directory? 2array ] [ nip ] if
     ] with map
-    [ first { "." ".." } member? not ] subset ;
+    [ first { "." ".." } member? not ] filter ;
 
 : directory ( path -- seq )
     normalize-directory dup (directory) fixup-directory ;

core/io/streams/memory/memory.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors alien.accessors math io ;
+IN: io.streams.memory
+
+TUPLE: memory-stream alien index ;
+
+: <memory-stream> ( alien -- stream )
+    0 memory-stream boa ;
+
+M: memory-stream stream-read1
+    [ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
+    [ [ 1+ ] change-index drop ] bi ;

core/io/streams/string/string.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io kernel math namespaces sequences sbufs strings
 generic splitting growable continuations io.streams.plain
-io.encodings io.encodings.private ;
+io.encodings io.encodings.private math.order ;
 IN: io.streams.string
 
 M: growable dispose drop ;

core/kernel/kernel-docs.factor

@@ -1,7 +1,7 @@
 USING: generic help.markup help.syntax math memory
-namespaces sequences kernel.private layouts sorting classes
+namespaces sequences kernel.private layouts classes
 kernel.private vectors combinators quotations strings words
-assocs arrays ;
+assocs arrays math.order ;
 IN: kernel
 
 ARTICLE: "shuffle-words" "Shuffle words"
@@ -241,7 +241,7 @@ ARTICLE: "conditionals" "Conditionals and logic"
 "See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
 { $see-also "booleans" "bitwise-arithmetic" both? either? } ;
 
-ARTICLE: "equality" "Equality and comparison testing"
+ARTICLE: "equality" "Equality"
 "There are two distinct notions of ``sameness'' when it comes to objects. You can test if two references point to the same object (" { $emphasis "identity comparison" } "), or you can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "). Both notions of equality are equality relations in the mathematical sense."
 $nl
 "Identity comparison:"
@@ -250,15 +250,8 @@ $nl
 { $subsection = }
 "Custom value comparison methods:"
 { $subsection equal? }
+"Utility class:"
 { $subsection identity-tuple }
-"Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":"
-{ $subsection <=> }
-{ $subsection compare }
-"Utilities for comparing objects:"
-{ $subsection after? }
-{ $subsection before? }
-{ $subsection after=? }
-{ $subsection before=? }
 "An object can be cloned; the clone has distinct identity but equal value:"
 { $subsection clone } ;
 
@@ -393,29 +386,6 @@ HELP: identity-tuple
     { $unchecked-example "T{ foo } dup clone = ." "f" }
 } ;
 
-HELP: <=>
-{ $values { "obj1" object } { "obj2" object } { "n" real } }
-{ $contract
-    "Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings."
-    $nl
-    "The output value is one of the following:"
-    { $list
-        { "positive - indicating that " { $snippet "obj1" } " follows " { $snippet "obj2" } }
-        { "zero - indicating that " { $snippet "obj1" } " is equal to " { $snippet "obj2" } }
-        { "negative - indicating that " { $snippet "obj1" } " precedes " { $snippet "obj2" } }
-    }
-    "The default implementation treats the two objects as sequences, and recursively compares their elements. So no extra work is required to compare sequences lexicographically."
-} ;
-
-{ <=> compare natural-sort sort-keys sort-values } related-words
-
-HELP: compare
-{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "n" integer } }
-{ $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." }
-{ $examples
-    { $example "USING: kernel prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "3" }
-} ;
-
 HELP: clone
 { $values { "obj" object } { "cloned" "a new object" } }
 { $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;

core/kernel/kernel.factor

@@ -133,8 +133,6 @@ M: identity-tuple equal? 2drop f ;
 : = ( obj1 obj2 -- ? )
     2dup eq? [ 2drop t ] [ equal? ] if ; inline
 
-GENERIC: <=> ( obj1 obj2 -- n )
-
 GENERIC: clone ( obj -- cloned )
 
 M: object clone ;
@@ -158,6 +156,9 @@ M: callstack clone (clone) ;
 : with ( param obj quot -- obj curry )
     swapd [ swapd call ] 2curry ; inline
 
+: prepose ( quot1 quot2 -- curry )
+    swap compose ; inline
+
 : 3compose ( quot1 quot2 quot3 -- curry )
     compose compose ; inline
 
@@ -176,8 +177,6 @@ M: callstack clone (clone) ;
 
 : either? ( x y quot -- ? ) bi@ or ; inline
 
-: compare ( obj1 obj2 quot -- n ) bi@ <=> ; inline
-
 : most ( x y quot -- z )
     >r 2dup r> call [ drop ] [ nip ] if ; inline
 

core/layouts/layouts.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces math words kernel assocs classes
-kernel.private ;
+math.order kernel.private ;
 IN: layouts
 
 SYMBOL: tag-mask

core/math/floats/floats.factor

@@ -6,8 +6,6 @@ IN: math.floats.private
 M: fixnum >float fixnum>float ;
 M: bignum >float bignum>float ;
 
-M: float zero? dup 0.0 float= swap -0.0 float= or ;
-
 M: float >fixnum float>fixnum ;
 M: float >bignum float>bignum ;
 M: float >float ;
@@ -22,4 +20,7 @@ M: float + float+ ;
 M: float - float- ;
 M: float * float* ;
 M: float / float/f ;
+M: float /f float/f ;
 M: float mod float-mod ;
+
+M: real abs dup 0 < [ neg ] when ;

core/math/integers/integers-tests.factor

@@ -1,5 +1,5 @@
-USING: kernel math namespaces prettyprint
+USING: kernel math math.functions namespaces prettyprint
-math.private continuations tools.test sequences ;
+math.private continuations tools.test sequences random ;
 IN: math.integers.tests
 
 [ "-8" ] [ -8 unparse ] unit-test
@@ -184,3 +184,38 @@ unit-test
 [ HEX: 988a259c3433f237 ] [
     B{ HEX: 37 HEX: f2 HEX: 33 HEX: 34 HEX: 9c HEX: 25 HEX: 8a HEX: 98 } byte-array>bignum
 ] unit-test
+
+[ t ] [ 256 power-of-2? ] unit-test
+[ f ] [ 123 power-of-2? ] unit-test
+
+[ f ] [ -128 power-of-2? ] unit-test
+[ f ] [ 0 power-of-2? ] unit-test
+[ t ] [ 1 power-of-2? ] unit-test
+
+: ratio>float [ >bignum ] bi@ /f ;
+
+[ 5. ] [ 5 1 ratio>float ] unit-test
+[ 4. ] [ 4 1 ratio>float ] unit-test
+[ 2. ] [ 2 1 ratio>float ] unit-test
+[ .5 ] [ 1 2 ratio>float ] unit-test
+[ .75 ] [ 3 4 ratio>float ] unit-test
+[ 1. ] [ 2000 2^ 2000 2^ 1+ ratio>float ] unit-test
+[ -1. ] [ 2000 2^ neg 2000 2^ 1+ ratio>float ] unit-test
+[ 0.4 ] [ 6 15 ratio>float ] unit-test
+
+[ HEX: 3fe553522d230931 ]
+[ 61967020039 92984792073 ratio>float double>bits ] unit-test
+
+: random-integer
+    32 random-bits
+    1 random zero? [ neg ] when
+    1 random zero? [ >bignum ] when ;
+
+[ t ] [
+    1000 [
+        drop
+        random-integer
+        random-integer
+        [ >float / ] [ /f ] 2bi 0.1 ~
+    ] all?
+] unit-test

core/math/integers/integers.factor

@@ -1,4 +1,5 @@
 ! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2008, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel kernel.private sequences
 sequences.private math math.private combinators ;
@@ -22,6 +23,8 @@ M: fixnum + fixnum+ ;
 M: fixnum - fixnum- ;
 M: fixnum * fixnum* ;
 M: fixnum /i fixnum/i ;
+M: fixnum /f >r >float r> >float float/f ;
+
 M: fixnum mod fixnum-mod ;
 
 M: fixnum /mod fixnum/mod ;
@@ -67,4 +70,57 @@ M: bignum bitnot bignum-bitnot ;
 M: bignum bit? bignum-bit? ;
 M: bignum (log2) bignum-log2 ;
 
-M: integer zero? 0 number= ;
+! Converting ratios to floats. Based on FLOAT-RATIO from
+! sbcl/src/code/float.lisp, which has the following license:
+
+! "The software is in the public domain and is
+! provided with absolutely no warranty."
+
+! First step: pre-scaling
+: twos ( x -- y ) dup 1- bitxor log2 ; inline
+
+: scale-denonimator ( den -- scaled-den scale' )
+    dup twos neg [ shift ] keep ; inline
+
+: pre-scale ( num den -- scale shifted-num scaled-den )
+    2dup [ log2 ] bi@ -
+    tuck [ neg 54 + shift ] [ >r scale-denonimator r> + ] 2bi*
+    -rot ; inline
+
+! Second step: loop
+: shift-mantissa ( scale mantissa -- scale' mantissa' )
+    [ 1+ ] [ 2/ ] bi* ; inline
+
+: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
+    [ 2dup /i log2 53 > ]
+    [ >r shift-mantissa r> ]
+    [ ] while /mod ; inline
+
+! Third step: post-scaling
+: unscaled-float ( mantissa -- n )
+    52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline
+
+: scale-float ( scale mantissa -- float' )
+    >r dup 0 < [ neg 2^ recip ] [ 2^ ] if r> * ; inline
+
+: post-scale ( scale mantissa -- n )
+    2/ dup log2 52 > [ shift-mantissa ] when
+    unscaled-float scale-float ; inline
+
+! Main word
+: /f-abs ( m n -- f )
+    over zero? [
+        2drop 0.0
+    ] [
+        dup zero? [
+            2drop 1.0/0.0
+        ] [
+            pre-scale
+            /f-loop over odd?
+            [ zero? [ 1+ ] unless ] [ drop ] if
+            post-scale
+        ] if
+    ] if ; inline
+
+M: bignum /f ( m n -- f )
+    [ [ abs ] bi@ /f-abs ] [ [ 0 < ] bi@ xor ] 2bi [ neg ] when ;

core/math/intervals/intervals-docs.factor

@@ -1,4 +1,4 @@
-USING: help.markup help.syntax math ;
+USING: help.markup help.syntax math math.order ;
 IN: math.intervals
 
 ARTICLE: "math-intervals-new" "Creating intervals"

core/math/intervals/intervals-tests.factor

@@ -1,5 +1,5 @@
-USING: math.intervals kernel sequences words math arrays
+USING: math.intervals kernel sequences words math math.order
-prettyprint tools.test random vocabs combinators ;
+arrays prettyprint tools.test random vocabs combinators ;
 IN: math.intervals.tests
 
 [ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test

core/math/intervals/intervals.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 ! Based on Slate's src/unfinished/interval.slate by Brian Rice.
-USING: kernel sequences arrays math combinators ;
+USING: kernel sequences arrays math combinators math.order ;
 IN: math.intervals
 
 TUPLE: interval from to ;
@@ -96,6 +96,8 @@ C: <interval> interval
 
 : interval-bitnot ( i1 -- i2 ) interval-neg interval-1- ;
 
+: interval-sq ( i1 -- i2 ) dup interval* ;
+
 : make-interval ( from to -- int )
     over first over first {
         { [ 2dup > ] [ 2drop 2drop f ] }

core/math/math-docs.factor

@@ -1,5 +1,5 @@
 USING: help.markup help.syntax kernel sequences quotations
-math.private math.functions ;
+math.private ;
 IN: math
 
 ARTICLE: "division-by-zero" "Division by zero"
@@ -26,17 +26,13 @@ $nl
 { $subsection < }
 { $subsection <= }
 { $subsection > }
-{ $subsection >= }
+{ $subsection >= } ;
-"Inexact comparison:"
-{ $subsection ~ } ;
 
 ARTICLE: "modular-arithmetic" "Modular arithmetic"
 { $subsection mod }
 { $subsection rem }
 { $subsection /mod }
 { $subsection /i }
-{ $subsection mod-inv }
-{ $subsection ^mod }
 { $see-also "integer-functions" } ;
 
 ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
@@ -83,28 +79,6 @@ HELP: >=
 { $values { "x" real } { "y" real } { "?" "a boolean" } }
 { $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ;
 
-HELP: before?
-{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "obj1" } " comes before " { $snippet "obj2" } " using an intrinsic total order." }
-{ $notes "Implemented using " { $link <=> } "." } ;
-
-HELP: after?
-{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "obj1" } " comes after " { $snippet "obj2" } " using an intrinsic total order." }
-{ $notes "Implemented using " { $link <=> } "." } ;
-
-HELP: before=?
-{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "obj1" } " comes before or equals " { $snippet "obj2" } " using an intrinsic total order." }
-{ $notes "Implemented using " { $link <=> } "." } ;
-
-HELP: after=?
-{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "obj1" } " comes after or equals " { $snippet "obj2" } " using an intrinsic total order." }
-{ $notes "Implemented using " { $link <=> } "." } ;
-
-{ before? after? before=? after=? } related-words
-
 
 HELP: +
 { $values { "x" number } { "y" number } { "z" number } }
@@ -279,19 +253,6 @@ HELP: recip
 { $description "Computes a number's multiplicative inverse." }
 { $errors "Throws an error if " { $snippet "x" } " is the integer 0." } ;
 
-HELP: max
-{ $values { "x" real } { "y" real } { "z" real } }
-{ $description "Outputs the greatest of two real numbers." } ;
-
-HELP: min
-{ $values { "x" real } { "y" real } { "z" real } }
-{ $description "Outputs the smallest of two real numbers." } ;
-
-HELP: between?
-{ $values { "x" real } { "y" real } { "z" real } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." }
-{ $notes "As per the closed interval notation, the end-points are included in the interval." } ;
-
 HELP: rem
 { $values { "x" integer } { "y" integer } { "z" integer } }
 { $description
@@ -337,10 +298,6 @@ HELP: times
 { $description "Calls the quotation " { $snippet "n" } " times." }
 { $notes "If you need to pass the current index to the quotation, use " { $link each } "." } ;
 
-HELP: [-]
-{ $values { "x" real } { "y" real } { "z" real } }
-{ $description "Subtracts " { $snippet "y" } " from " { $snippet "x" } ". If the result is less than zero, outputs zero." } ;
-
 HELP: fp-nan?
 { $values { "x" real } { "?" "a boolean" } }
 { $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
@@ -363,6 +320,10 @@ HELP: next-power-of-2
 { $values { "m" "a non-negative integer" } { "n" "an integer" } }
 { $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 1." } ;
 
+HELP: power-of-2?
+{ $values { "n" integer } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "n" } " is a power of 2." } ;
+
 HELP: each-integer
 { $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- )" } } }
 { $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } "." }