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

.gitignore

@@ -8,7 +8,9 @@ Factor/factor
 *.a
 *.dll
 *.lib
+*.exp
 *.res
+*.RES
 *.image
 *.dylib
 factor

Nmakefile

@@ -61,7 +61,7 @@ DLL_OBJS = vm\os-windows-nt.obj \
 .rs.res:
 	rc $<
 
-all: factor.com factor.exe
+all: factor.com factor.exe libfactor-ffi-test.dll
 
 libfactor-ffi-test.dll: vm/ffi_test.obj
 	link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj

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

@@ -1,6 +1,7 @@
 USING: alien alien.syntax alien.c-types alien.parser
 eval kernel tools.test sequences system libc alien.strings
-io.encodings.utf8 math.constants classes.struct classes ;
+io.encodings.utf8 math.constants classes.struct classes
+accessors compiler.units ;
 IN: alien.c-types.tests
 
 CONSTANT: xyz 123
@@ -100,3 +101,12 @@ DEFER: struct-redefined
     \ struct-redefined class?
 ] unit-test
 
+[
+    "IN: alien.c-types.tests
+    USE: alien.syntax
+    USE: alien.c-types
+    TYPEDEF: int type-redefinition-test
+    TYPEDEF: int type-redefinition-test" eval( -- )
+]
+[ error>> error>> redefine-error? ]
+must-fail-with

basis/alien/c-types/c-types.factor

@@ -78,6 +78,9 @@ M: string resolve-pointer-type
         [ resolve-pointer-type ] [ drop void* ] if
     ] if ;
 
+M: array resolve-pointer-type
+    first resolve-pointer-type ;
+
 : resolve-typedef ( name -- c-type )
     dup void? [ no-c-type ] when
     dup c-type-name? [ c-type ] when ;
@@ -551,9 +554,6 @@ M: ulonglong-2-rep rep-component-type drop ulonglong ;
 M: float-4-rep rep-component-type drop float ;
 M: double-2-rep rep-component-type drop double ;
 
-: rep-length ( rep -- n )
-    16 swap rep-component-type heap-size /i ; foldable
-
 : (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable
 : unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable
 : (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable

basis/alien/fortran/fortran-tests.factor

@@ -3,12 +3,13 @@ USING: accessors alien alien.c-types alien.complex
 alien.data alien.fortran alien.fortran.private alien.strings
 classes.struct arrays assocs byte-arrays combinators fry
 generalizations io.encodings.ascii kernel macros
-macros.expander namespaces sequences shuffle tools.test ;
+macros.expander namespaces sequences shuffle tools.test vocabs.parser ;
+QUALIFIED-WITH: alien.c-types c
 IN: alien.fortran.tests
 
 << intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >>
 LIBRARY: (alien.fortran-tests)
-STRUCT: FORTRAN_TEST_RECORD
+STRUCT: fortran_test_record
     { FOO int }
     { BAR double[2] }
     { BAS char[4] } ;
@@ -23,148 +24,163 @@ intel-unix-abi fortran-abi [
 
     ! fortran-type>c-type
 
-    [ "short" ]
+    [ c:short ]
     [ "integer*2" fortran-type>c-type ] unit-test
 
-    [ "int" ]
+    [ c:int ]
     [ "integer*4" fortran-type>c-type ] unit-test
 
-    [ "int" ]
+    [ c:int ]
     [ "INTEGER" fortran-type>c-type ] unit-test
 
-    [ "longlong" ]
+    [ c:longlong ]
     [ "iNteger*8" fortran-type>c-type ] unit-test
 
-    [ "int[0]" ]
+    [ { c:int 0 } ]
     [ "integer(*)" fortran-type>c-type ] unit-test
 
-    [ "int[0]" ]
+    [ { c:int 0 } ]
     [ "integer(3,*)" fortran-type>c-type ] unit-test
 
-    [ "int[3]" ]
+    [ { c:int 3 } ]
     [ "integer(3)" fortran-type>c-type ] unit-test
 
-    [ "int[6]" ]
+    [ { c:int 6 } ]
     [ "integer(3,2)" fortran-type>c-type ] unit-test
 
-    [ "int[24]" ]
+    [ { c:int 24 } ]
     [ "integer(4,3,2)" fortran-type>c-type ] unit-test
 
-    [ "char" ]
+    [ c:char ]
     [ "character" fortran-type>c-type ] unit-test
 
-    [ "char" ]
+    [ c:char ]
     [ "character*1" fortran-type>c-type ] unit-test
 
-    [ "char[17]" ]
+    [ { c:char 17 } ]
     [ "character*17" fortran-type>c-type ] unit-test
 
-    [ "char[17]" ]
+    [ { c:char 17 } ]
     [ "character(17)" fortran-type>c-type ] unit-test
 
-    [ "int" ]
+    [ c:int ]
     [ "logical" fortran-type>c-type ] unit-test
 
-    [ "float" ]
+    [ c:float ]
     [ "real" fortran-type>c-type ] unit-test
 
-    [ "double" ]
+    [ c:double ]
     [ "double-precision" fortran-type>c-type ] unit-test
 
-    [ "float" ]
+    [ c:float ]
     [ "real*4" fortran-type>c-type ] unit-test
 
-    [ "double" ]
+    [ c:double ]
     [ "real*8" fortran-type>c-type ] unit-test
 
-    [ "complex-float" ]
+    [ complex-float ]
     [ "complex" fortran-type>c-type ] unit-test
 
-    [ "complex-double" ]
+    [ complex-double ]
     [ "double-complex" fortran-type>c-type ] unit-test
 
-    [ "complex-float" ]
+    [ complex-float ]
     [ "complex*8" fortran-type>c-type ] unit-test
 
-    [ "complex-double" ]
+    [ complex-double ]
     [ "complex*16" fortran-type>c-type ] unit-test
 
-    [ "fortran_test_record" ]
+    [ fortran_test_record ]
-    [ "fortran_test_record" fortran-type>c-type ] unit-test
+    [
+        [
+            "alien.fortran.tests" use-vocab
+            "fortran_test_record" fortran-type>c-type
+        ] with-manifest
+    ] unit-test
 
     ! fortran-arg-type>c-type
 
-    [ "int*" { } ]
+    [ c:void* { } ]
     [ "integer" fortran-arg-type>c-type ] unit-test
 
-    [ "int*" { } ]
+    [ c:void* { } ]
     [ "integer(3)" fortran-arg-type>c-type ] unit-test
 
-    [ "int*" { } ]
+    [ c:void* { } ]
     [ "integer(*)" fortran-arg-type>c-type ] unit-test
 
-    [ "fortran_test_record*" { } ]
+    [ c:void* { } ]
-    [ "fortran_test_record" fortran-arg-type>c-type ] unit-test
+    [
+        [
+            "alien.fortran.tests" use-vocab
+            "fortran_test_record" fortran-arg-type>c-type
+        ] with-manifest
+    ] unit-test
 
-    [ "char*" { } ]
+    [ c:char* { } ]
     [ "character" fortran-arg-type>c-type ] unit-test
 
-    [ "char*" { } ]
+    [ c:char* { } ]
     [ "character(1)" fortran-arg-type>c-type ] unit-test
 
-    [ "char*" { "long" } ]
+    [ c:char* { long } ]
     [ "character(17)" fortran-arg-type>c-type ] unit-test
 
     ! fortran-ret-type>c-type
 
-    [ "char" { } ]
+    [ c:char { } ]
     [ "character(1)" fortran-ret-type>c-type ] unit-test
 
-    [ "void" { "char*" "long" } ]
+    [ c:void { c:char* long } ]
     [ "character(17)" fortran-ret-type>c-type ] unit-test
 
-    [ "int" { } ]
+    [ c:int { } ]
     [ "integer" fortran-ret-type>c-type ] unit-test
 
-    [ "int" { } ]
+    [ c:int { } ]
     [ "logical" fortran-ret-type>c-type ] unit-test
 
-    [ "float" { } ]
+    [ c:float { } ]
     [ "real" fortran-ret-type>c-type ] unit-test
 
-    [ "void" { "float*" } ]
+    [ c:void { c:void* } ]
     [ "real(*)" fortran-ret-type>c-type ] unit-test
 
-    [ "double" { } ]
+    [ c:double { } ]
     [ "double-precision" fortran-ret-type>c-type ] unit-test
 
-    [ "void" { "complex-float*" } ]
+    [ c:void { c:void* } ]
     [ "complex" fortran-ret-type>c-type ] unit-test
 
-    [ "void" { "complex-double*" } ]
+    [ c:void { c:void* } ]
     [ "double-complex" fortran-ret-type>c-type ] unit-test
 
-    [ "void" { "int*" } ]
+    [ c:void { c:void* } ]
     [ "integer(*)" fortran-ret-type>c-type ] unit-test
 
-    [ "void" { "fortran_test_record*" } ]
+    [ c:void { c:void* } ]
-    [ "fortran_test_record" fortran-ret-type>c-type ] unit-test
+    [
+        [
+            "alien.fortran.tests" use-vocab
+            "fortran_test_record" fortran-ret-type>c-type
+        ] with-manifest
+    ] unit-test
 
     ! fortran-sig>c-sig
 
-    [ "float" { "int*" "char*" "float*" "double*" "long" } ]
+    [ c:float { c:void* c:char* c:void* c:void* c:long } ]
     [ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
     unit-test
 
-    [ "char" { "char*" "char*" "int*" "long" } ]
+    [ c:char { c:char* c:char* c:void* c:long } ]
     [ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ]
     unit-test
 
-    [ "void" { "char*" "long" "char*" "char*" "int*" "long" } ]
+    [ c:void { c:char* c:long c:char* c:char* c:void* c:long } ]
     [ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
     unit-test
 
-    [ "void" { "complex-float*" "char*" "char*" "int*" "long" } ]
+    [ c:void { c:void* c:char* c:char* c:void* c:long } ]
     [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
     unit-test
 
@@ -184,8 +200,8 @@ intel-unix-abi fortran-abi [
         } 5 ncleave
         ! [fortran-invoke]
         [ 
-            "void" "funpack" "funtimes_"
+            c:void "funpack" "funtimes_"
-            { "char*" "longlong*" "float*" "complex-float*" "short*" "long" }
+            { c:char* c:void* c:void* c:void* c:void* c:long }
             alien-invoke
         ] 6 nkeep
         ! [fortran-results>]
@@ -210,7 +226,7 @@ intel-unix-abi fortran-abi [
             [ { [ drop ] } spread ]
         } 1 ncleave
         ! [fortran-invoke]
-        [ "float" "funpack" "fun_times_" { "float*" } alien-invoke ]
+        [ c:float "funpack" "fun_times_" { void* } alien-invoke ]
         1 nkeep
         ! [fortran-results>]
         shuffle( reta aa -- reta aa ) 
@@ -222,13 +238,13 @@ intel-unix-abi fortran-abi [
 
     [ [
         ! [<fortran-result>]
-        [ "complex-float" <c-object> ] 1 ndip
+        [ complex-float <c-object> ] 1 ndip
         ! [fortran-args>c-args]
         { [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave
         ! [fortran-invoke]
         [
-            "void" "funpack" "fun_times_"
+            c:void "funpack" "fun_times_"
-            { "complex-float*" "float*" } 
+            { void* void* } 
             alien-invoke
         ] 2 nkeep
         ! [fortran-results>]
@@ -244,8 +260,8 @@ intel-unix-abi fortran-abi [
         [ 20 <byte-array> 20 ] 0 ndip
         ! [fortran-invoke]
         [
-            "void" "funpack" "fun_times_"
+            c:void "funpack" "fun_times_"
-            { "char*" "long" } 
+            { c:char* long } 
             alien-invoke
         ] 2 nkeep
         ! [fortran-results>]
@@ -270,8 +286,8 @@ intel-unix-abi fortran-abi [
         } 3 ncleave
         ! [fortran-invoke]
         [
-            "void" "funpack" "fun_times_"
+            c:void "funpack" "fun_times_"
-            { "char*" "long" "char*" "float*" "char*" "long" "long" } 
+            { c:char* long c:char* c:void* c:char* c:long c:long } 
             alien-invoke
         ] 7 nkeep
         ! [fortran-results>]
@@ -302,19 +318,19 @@ intel-windows-abi fortran-abi [
 
 f2c-abi fortran-abi [
 
-    [ "char[1]" ]
+    [ { c:char 1 } ]
     [ "character(1)" fortran-type>c-type ] unit-test
 
-    [ "char*" { "long" } ]
+    [ c:char* { c:long } ]
     [ "character" fortran-arg-type>c-type ] unit-test
 
-    [ "void" { "char*" "long" } ]
+    [ c:void { c:char* c:long } ]
     [ "character" fortran-ret-type>c-type ] unit-test
 
-    [ "double" { } ]
+    [ c:double { } ]
     [ "real" fortran-ret-type>c-type ] unit-test
 
-    [ "void" { "float*" } ]
+    [ c:void { void* } ]
     [ "real(*)" fortran-ret-type>c-type ] unit-test
 
     [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
@@ -325,34 +341,34 @@ f2c-abi fortran-abi [
 
 gfortran-abi fortran-abi [
 
-    [ "float" { } ]
+    [ c:float { } ]
     [ "real" fortran-ret-type>c-type ] unit-test
 
-    [ "void" { "float*" } ]
+    [ c:void { void* } ]
     [ "real(*)" fortran-ret-type>c-type ] unit-test
 
-    [ "complex-float" { } ]
+    [ complex-float { } ]
     [ "complex" fortran-ret-type>c-type ] unit-test
 
-    [ "complex-double" { } ]
+    [ complex-double { } ]
     [ "double-complex" fortran-ret-type>c-type ] unit-test
 
-    [ "char[1]" ]
+    [ { char 1 } ]
     [ "character(1)" fortran-type>c-type ] unit-test
 
-    [ "char*" { "long" } ]
+    [ c:char* { c:long } ]
     [ "character" fortran-arg-type>c-type ] unit-test
 
-    [ "void" { "char*" "long" } ]
+    [ c:void { c:char* c:long } ]
     [ "character" fortran-ret-type>c-type ] unit-test
 
-    [ "complex-float" { } ]
+    [ complex-float { } ]
     [ "complex" fortran-ret-type>c-type ] unit-test
 
-    [ "complex-double" { } ]
+    [ complex-double { } ]
     [ "double-complex" fortran-ret-type>c-type ] unit-test
 
-    [ "void" { "complex-double*" } ]
+    [ c:void { c:void* } ]
     [ "double-complex(3)" fortran-ret-type>c-type ] unit-test
 
 ] with-variable

basis/alien/fortran/fortran.factor

@@ -1,11 +1,12 @@
 ! (c) 2009 Joe Groff, see BSD license
-USING: accessors alien alien.c-types alien.complex alien.data grouping
+USING: accessors alien alien.c-types alien.complex alien.data alien.parser
-alien.strings alien.syntax arrays ascii assocs
+grouping alien.strings alien.syntax arrays ascii assocs
 byte-arrays combinators combinators.short-circuit fry generalizations
 kernel lexer macros math math.parser namespaces parser sequences
 splitting stack-checker vectors vocabs.parser words locals
 io.encodings.ascii io.encodings.string shuffle effects math.ranges
 math.order sorting strings system alien.libraries ;
+QUALIFIED-WITH: alien.c-types c
 IN: alien.fortran
 
 SINGLETONS: f2c-abi g95-abi gfortran-abi intel-unix-abi intel-windows-abi ;
@@ -101,8 +102,7 @@ CONSTANT: fortran>c-types H{
 }
 
 : append-dimensions ( base-c-type type -- c-type )
-    dims>>
+    dims>> [ product 2array ] when* ;
-    [ product number>string "[" "]" surround append ] when* ;
 
 MACRO: size-case-type ( cases -- )
     [ invalid-fortran-type ] suffix
@@ -118,35 +118,35 @@ MACRO: size-case-type ( cases -- )
 
 GENERIC: (fortran-type>c-type) ( type -- c-type )
 
-M: f (fortran-type>c-type) drop "void" ;
+M: f (fortran-type>c-type) drop c:void ;
 
 M: integer-type (fortran-type>c-type)
     {
-        { f [ "int"      ] }
+        { f [ c:int      ] }
-        { 1 [ "char"     ] }
+        { 1 [ c:char     ] }
-        { 2 [ "short"    ] }
+        { 2 [ c:short    ] }
-        { 4 [ "int"      ] }
+        { 4 [ c:int      ] }
-        { 8 [ "longlong" ] }
+        { 8 [ c:longlong ] }
     } size-case-type ;
 M: real-type (fortran-type>c-type)
     {
-        { f [ "float"  ] }
+        { f [ c:float  ] }
-        { 4 [ "float"  ] }
+        { 4 [ c:float  ] }
-        { 8 [ "double" ] }
+        { 8 [ c:double ] }
     } size-case-type ;
 M: real-complex-type (fortran-type>c-type)
     {
-        {  f [ "complex-float"  ] }
+        {  f [ complex-float  ] }
-        {  8 [ "complex-float"  ] }
+        {  8 [ complex-float  ] }
-        { 16 [ "complex-double" ] }
+        { 16 [ complex-double ] }
     } size-case-type ;
 
 M: double-precision-type (fortran-type>c-type)
-    "double" simple-type ;
+    c:double simple-type ;
 M: double-complex-type (fortran-type>c-type)
-    "complex-double" simple-type ;
+    complex-double simple-type ;
 M: misc-type (fortran-type>c-type)
-    dup name>> simple-type ;
+    dup name>> parse-c-type simple-type ;
 
 : single-char? ( character-type -- ? )
     { [ drop character(1)-maps-to-char? ] [ dims>> product 1 = ] } 1&& ;
@@ -158,7 +158,7 @@ M: misc-type (fortran-type>c-type)
     dup single-char? [ f >>dims ] when ;
 
 M: character-type (fortran-type>c-type)
-    fix-character-type "char" simple-type ;
+    fix-character-type c:char simple-type ;
 
 : dimension>number ( string -- number )
     dup "*" = [ drop 0 ] [ string>number ] if ;
@@ -181,13 +181,10 @@ M: character-type (fortran-type>c-type)
 : parse-fortran-type ( fortran-type-string/f -- type/f )
     dup [ (parse-fortran-type) ] when ;
 
-: c-type>pointer ( c-type -- c-type* )
-    "[" split1 drop "*" append ;
-
 GENERIC: added-c-args ( type -- args )
 
 M: fortran-type added-c-args drop { } ;
-M: character-type added-c-args fix-character-type single-char? [ { } ] [ { "long" } ] if ;
+M: character-type added-c-args fix-character-type single-char? [ { } ] [ { c:long } ] if ;
 
 GENERIC: returns-by-value? ( type -- ? )
 
@@ -200,10 +197,10 @@ M: complex-type returns-by-value?
 
 GENERIC: (fortran-ret-type>c-type) ( type -- c-type )
 
-M: f (fortran-ret-type>c-type) drop "void" ;
+M: f (fortran-ret-type>c-type) drop c:void ;
 M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ;
 M: real-type (fortran-ret-type>c-type)
-    drop real-functions-return-double? [ "double" ] [ "float" ] if ;
+    drop real-functions-return-double? [ c:double ] [ c:float ] if ;
 
 GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
 
@@ -354,7 +351,7 @@ M: character-type (<fortran-result>)
 
 : (shuffle-map) ( return parameters -- ret par )
     [
-        fortran-ret-type>c-type length swap "void" = [ 1 + ] unless
+        fortran-ret-type>c-type length swap void? [ 1 + ] unless
         letters swap head [ "ret" swap suffix ] map
     ] [
         [ fortran-arg-type>c-type nip length 1 + ] map letters swap zip
@@ -395,13 +392,13 @@ PRIVATE>
 
 : fortran-arg-type>c-type ( fortran-type -- c-type added-args )
     parse-fortran-type
-    [ (fortran-type>c-type) c-type>pointer ]
+    [ (fortran-type>c-type) resolve-pointer-type ]
     [ added-c-args ] bi ;
 : fortran-ret-type>c-type ( fortran-type -- c-type added-args )
     parse-fortran-type dup returns-by-value?
     [ (fortran-ret-type>c-type) { } ] [
-        "void" swap 
+        c:void swap 
-        [ added-c-args ] [ (fortran-type>c-type) c-type>pointer ] bi prefix
+        [ added-c-args ] [ (fortran-type>c-type) resolve-pointer-type ] bi prefix
     ] if ;
 
 : fortran-arg-types>c-types ( fortran-types -- c-types )
@@ -433,7 +430,7 @@ MACRO: fortran-invoke ( return library function parameters -- )
 
 :: define-fortran-function ( return library function parameters -- )
     function create-in dup reset-generic 
-    return library function parameters return [ "void" ] unless* parse-arglist
+    return library function parameters return [ c:void ] unless* parse-arglist
     [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
 
 SYNTAX: SUBROUTINE: 

basis/alien/syntax/syntax.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2009 Slava Pestov, Alex Chapman.
+! Copyright (C) 2005, 2010 Slava Pestov, Alex Chapman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays alien alien.c-types
 alien.arrays alien.strings kernel math namespaces parser
@@ -22,7 +22,7 @@ SYNTAX: CALLBACK:
     (CALLBACK:) define-inline ;
 
 SYNTAX: TYPEDEF:
-    scan-c-type CREATE-C-TYPE typedef ;
+    scan-c-type CREATE-C-TYPE dup save-location typedef ;
 
 SYNTAX: C-ENUM:
     ";" parse-tokens

basis/binary-search/binary-search-docs.factor

@@ -8,7 +8,21 @@ $nl
 "If the sequence is non-empty, outputs the index and value of the closest match, which is either an element for which the quotation output " { $link +eq+ } ", or failing that, least element for which the quotation output " { $link +lt+ } "."
 $nl
 "If the sequence is empty, outputs " { $link f } " " { $link f } "." }
-{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link find } "." } ;
+{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link find } "." }
+{ $examples
+    "Searching for an integer in a sorted array:"
+    { $example
+        "USING: binary-search math.order prettyprint ;"
+        "{ -13 -4 1 9 16 17 28 } [ 5 >=< ] search . ."
+        "1\n2"
+    }
+    "Frequently, the quotation passed to " { $link search } " is constructed by " { $link curry } " or " { $link with } " in order to make the search key a parameter:"
+    { $example
+        "USING: binary-search kernel math.order prettyprint ;"
+        "5 { -13 -4 1 9 16 17 28 } [ <=> ] with search . ."
+        "1\n2"
+    }
+} ;
 
 { find find-from find-last find-last find-last-from search } related-words
 

basis/bootstrap/compiler/compiler.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors cpu.architecture vocabs.loader system
 sequences namespaces parser kernel kernel.private classes
@@ -33,6 +33,7 @@ enable-optimizer
 gc
 
 : compile-unoptimized ( words -- )
+    [ [ subwords ] map ] keep suffix concat
     [ optimized? not ] filter compile ;
 
 "debug-compiler" get [
@@ -102,7 +103,7 @@ gc
     "." write flush
 
     {
-        lines prefix suffix unclip new-assoc update
+        lines prefix suffix unclip new-assoc assoc-union!
         word-prop set-word-prop 1array 2array 3array ?nth
     } compile-unoptimized
 

basis/bootstrap/image/download/download.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: http.client checksums checksums.md5 splitting assocs
 kernel io.files bootstrap.image sequences io urls ;
@@ -19,9 +19,11 @@ CONSTANT: url URL" http://factorcode.org/images/latest/"
     ] [ drop t ] if ;
 
 : download-image ( arch -- )
-    boot-image-name dup need-new-image? [
+    url swap boot-image-name >url derive-url download ;
-        "Downloading " write dup write "..." print
+
-         url over >url derive-url download
+: maybe-download-image ( arch -- )
+    dup boot-image-name need-new-image? [
+         dup download-image
          need-new-image? [
              "Boot image corrupt, or checksums.txt on server out of date" throw
          ] when
@@ -30,6 +32,6 @@ CONSTANT: url URL" http://factorcode.org/images/latest/"
         drop
     ] if ;
 
-: download-my-image ( -- ) my-arch download-image ;
+: download-my-image ( -- ) my-arch maybe-download-image ;
 
 MAIN: download-my-image

basis/bootstrap/image/image.factor

@@ -545,7 +545,7 @@ M: quotation '
     \ c-to-factor c-to-factor-word set
     \ lazy-jit-compile lazy-jit-compile-word set
     \ unwind-native-frames unwind-native-frames-word set
-    [ undefined ] undefined-quot set ;
+    undefined-def undefined-quot set ;
 
 : emit-special-objects ( -- )
     special-objects get keys [ emit-special-object ] each ;

basis/collada/viewer/viewer.factor

@@ -1,195 +0,0 @@
-! Copyright (C) 2010 Erik Charlebois
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays classes.struct combinators
-combinators.short-circuit game.loop game.worlds gpu gpu.buffers
-gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state
-gpu.textures gpu.util grouping http.client images images.loader
-io io.encodings.ascii io.files io.files.temp kernel locals math
-math.matrices math.vectors.simd math.parser math.vectors
-method-chains namespaces sequences splitting threads ui ui.gadgets
-ui.gadgets.worlds ui.pixel-formats specialized-arrays
-specialized-vectors literals collada fry xml xml.traversal sequences.deep
-
-opengl.gl
-prettyprint ;
-FROM: alien.c-types => float ;
-SPECIALIZED-ARRAY: float
-SPECIALIZED-VECTOR: uint
-IN: collada.viewer
-
-GLSL-SHADER: collada-vertex-shader vertex-shader
-uniform mat4 mv_matrix, p_matrix;
-uniform vec3 light_position;
-
-attribute vec3 POSITION;
-attribute vec3 NORMAL;
-
-void main()
-{
-    vec4 position = mv_matrix * vec4(POSITION, 1.0);
-    gl_Position = p_matrix * position;
-}
-;
-
-GLSL-SHADER: collada-fragment-shader fragment-shader
-void main()
-{
-    gl_FragColor = vec4(1, 1, 0, 1);
-}
-;
-
-GLSL-PROGRAM: collada-program
-    collada-vertex-shader collada-fragment-shader ;
-
-GLSL-SHADER: debug-vertex-shader vertex-shader
-uniform mat4 mv_matrix, p_matrix;
-uniform vec3 light_position;
-
-attribute vec3 POSITION;
-attribute vec3 COLOR;
-varying vec4 color;
-
-void main()
-{
-    gl_Position = p_matrix * mv_matrix * vec4(POSITION, 1.0);
-    color = vec4(COLOR, 1);
-}
-;
-
-GLSL-SHADER: debug-fragment-shader fragment-shader
-varying vec4 color;
-void main()
-{
-    gl_FragColor = color;
-}
-;
-
-GLSL-PROGRAM: debug-program debug-vertex-shader debug-fragment-shader ;
-
-UNIFORM-TUPLE: collada-uniforms < mvp-uniforms
-    { "light-position" vec3-uniform  f } ;
-
-TUPLE: collada-state
-    models
-    vertex-arrays
-    index-vectors ;
-
-TUPLE: collada-world < wasd-world
-    { collada collada-state } ;
-
-VERTEX-FORMAT: collada-vertex
-    { "POSITION" float-components 3 f }
-    { "NORMAL"   float-components 3 f } ;
-
-VERTEX-FORMAT: debug-vertex
-    { "POSITION" float-components 3 f }
-    { "COLOR"    float-components 3 f } ;
-
-: <collada-buffers> ( models -- buffers )
-!    drop
-!    float-array{ -0.5 0 0 1 0 0 0 1 0 0 1 0 0.5 0 0 0 0 1 }
-!    uint-array{ 0 1 2 }
-!    f model boa 1array
-    [
-        [ attribute-buffer>> underlying>> static-upload draw-usage vertex-buffer byte-array>buffer ]
-        [ index-buffer>> underlying>> static-upload draw-usage index-buffer byte-array>buffer ]
-        [ index-buffer>> length ] tri 3array
-    ] map ;
-
-: fill-collada-state ( collada-state -- )
-    dup models>> <collada-buffers>
-    [
-        [
-            first collada-program <program-instance> collada-vertex buffer>vertex-array
-        ] map >>vertex-arrays drop
-    ]
-    [
-        [
-            [ second ] [ third ] bi
-            '[ _ 0 <buffer-ptr> _ uint-indexes <index-elements> ] call
-        ] map >>index-vectors drop
-    ] 2bi ;
-    
-: <collada-state> ( -- collada-state )
-    collada-state new
-    #! "C:/Users/erikc/Downloads/mech.dae"
-    "/Users/erikc/Documents/mech.dae"
-    file>xml "mesh" deep-tags-named [ mesh>models ] map flatten >>models ;
-
-M: collada-world begin-game-world
-    init-gpu
-    { 0.0 0.0 2.0 } 0 0 set-wasd-view
-    <collada-state> [ fill-collada-state drop ] [ >>collada drop ] 2bi ;
-
-: <collada-uniforms> ( world -- uniforms )
-    [ wasd-mv-matrix ] [ wasd-p-matrix ] bi
-    { -10000.0 10000.0 10000.0 } ! light position
-    collada-uniforms boa ;
-
-: draw-line ( world from to color -- )
-    [ 3 head ] tri@ dup -rot append -rot append swap append >float-array
-    underlying>> stream-upload draw-usage vertex-buffer byte-array>buffer
-    debug-program <program-instance> debug-vertex buffer>vertex-array
-    
-    { 0 1 } >uint-array stream-upload draw-usage index-buffer byte-array>buffer
-    2 '[ _ 0 <buffer-ptr> _ uint-indexes <index-elements> ] call
-    
-    rot <collada-uniforms>
-
-    {
-        { "primitive-mode"     [ 3drop lines-mode ] }
-        { "uniforms"           [ nip nip ] }
-        { "vertex-array"       [ drop drop ] }
-        { "indexes"            [ drop nip ] }
-    } 3<render-set> render ;
-
-: draw-lines ( world lines -- )
-    3 <groups> [ first3 draw-line ] with each ; inline
-
-: draw-axes ( world -- )
-    { { 0 0 0 } { 1 0 0 } { 1 0 0 }
-      { 0 0 0 } { 0 1 0 } { 0 1 0 }
-      { 0 0 0 } { 0 0 1 } { 0 0 1 } } draw-lines ;
-          
-: draw-collada ( world -- )
-    GL_COLOR_BUFFER_BIT glClear
-
-    [
-        triangle-lines dup t <triangle-state> set-gpu-state
-        [ collada>> vertex-arrays>> ]
-        [ collada>> index-vectors>> ]
-        [ <collada-uniforms> ]
-        tri
-        [
-            {
-                { "primitive-mode"     [ 3drop triangles-mode ] }
-                { "uniforms"           [ nip nip ] }
-                { "vertex-array"       [ drop drop ] }
-                { "indexes"            [ drop nip ] }
-            } 3<render-set> render
-        ] curry 2each
-    ]
-    [
-        draw-axes
-    ]
-    bi ;
-
-M: collada-world draw-world*
-    draw-collada ;
-
-M: collada-world wasd-movement-speed drop 1/16. ;
-M: collada-world wasd-near-plane drop 1/32. ;
-M: collada-world wasd-far-plane drop 1024.0 ;
-
-GAME: collada-game {
-        { world-class collada-world }
-        { title "Collada Viewer" }
-        { pixel-format-attributes {
-            windowed
-            double-buffered
-        } }
-        { grab-input? t }
-        { use-game-input? t }
-        { pref-dim { 1024 768 } }
-        { tick-interval-micros $[ 60 fps ] }
-    } ;

basis/combinators/short-circuit/short-circuit-tests.factor

@@ -1,4 +1,4 @@
-USING: kernel math tools.test combinators.short-circuit ;
+USING: kernel math tools.test combinators.short-circuit accessors ;
 IN: combinators.short-circuit.tests
 
 [ 3 ] [ { [ 1 ] [ 2 ] [ 3 ] } 0&& ] unit-test
@@ -23,3 +23,18 @@ IN: combinators.short-circuit.tests
 
 [ 30 ] [ 10 20 compiled-|| ] unit-test
 [ 2 ] [ 1 1 compiled-|| ] unit-test
+
+! && and || should be row-polymorphic both when compiled and when interpreted
+
+: row-&& ( -- ? )
+    f t { [ drop dup ] } 1&& nip ;
+
+[ f ] [ row-&& ] unit-test
+[ f ] [ \ row-&& def>> call ] unit-test
+
+: row-|| ( -- ? )
+    f t { [ drop dup ] } 1|| nip ;
+
+[ f ] [ row-|| ] unit-test
+[ f ] [ \ row-|| def>> call ] unit-test
+

basis/combinators/short-circuit/short-circuit.factor

@@ -1,11 +1,19 @@
 USING: kernel combinators quotations arrays sequences assocs
-generalizations macros fry ;
+generalizations macros fry math ;
 IN: combinators.short-circuit
 
+<PRIVATE
+
+MACRO: keeping ( n quot -- quot' )
+    swap dup 1 +
+    '[ _ _ nkeep _ nrot ] ;
+
+PRIVATE>
+
 MACRO: n&& ( quots n -- quot )
     [
         [ [ f ] ] 2dip swap [
-            [ '[ drop _ ndup @ dup not ] ]
+            [ '[ drop _ _ keeping dup not ] ]
             [ drop '[ drop _ ndrop f ] ]
             2bi 2array
         ] with map
@@ -27,7 +35,7 @@ PRIVATE>
 MACRO: n|| ( quots n -- quot )
     [
         [ [ f ] ] 2dip swap [
-            [ '[ drop _ ndup @ dup ] ]
+            [ '[ drop _ _ keeping dup ] ]
             [ drop '[ _ nnip ] ]
             2bi 2array
         ] with map

basis/combinators/smart/smart.factor

@@ -53,4 +53,4 @@ MACRO: smart-if ( pred true false -- )
     '[ _ preserving _ _ if ] ;
 
 MACRO: smart-apply ( quot n -- )
-    [ dup inputs ] dip '[ _ _ mnapply ] ;
+    [ dup inputs ] dip '[ _ _ _ mnapply ] ;

basis/compiler/codegen/codegen.factor

@@ -5,7 +5,7 @@ kernel kernel.private layouts assocs words summary arrays
 combinators classes.algebra alien alien.c-types
 alien.strings alien.arrays alien.complex alien.libraries sets libc
 continuations.private fry cpu.architecture classes classes.struct locals
-source-files.errors slots parser generic.parser
+source-files.errors slots parser generic.parser strings
 compiler.errors
 compiler.alien
 compiler.constants
@@ -24,24 +24,12 @@ H{ } clone insn-counts set-global
 
 GENERIC: generate-insn ( insn -- )
 
-TUPLE: asm label code calls ;
-
-SYMBOL: calls
-
-: add-call ( word -- )
-    #! Compile this word later.
-    calls get push ;
-
 ! Mapping _label IDs to label instances
 SYMBOL: labels
 
-: init-generator ( -- )
+: generate ( mr -- code )
-    H{ } clone labels set
-    V{ } clone calls set ;
-
-: generate-insns ( asm -- code )
     dup label>> [
-        init-generator
+        H{ } clone labels set
         instructions>> [
             [ class insn-counts get inc-at ]
             [ generate-insn ]
@@ -49,22 +37,12 @@ SYMBOL: labels
         ] each
     ] with-fixup ;
 
-: generate ( mr -- asm )
-    [
-        [ label>> ] [ generate-insns ] bi calls get
-        asm boa
-    ] with-scope ;
-
 : lookup-label ( id -- label )
     labels get [ drop <label> ] cache ;
 
 ! Special cases
 M: ##no-tco generate-insn drop ;
 
-M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
-
-M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
-
 M: _dispatch-label generate-insn
     label>> lookup-label
     cell 0 <repetition> %
@@ -104,6 +82,8 @@ CODEGEN: ##peek %peek
 CODEGEN: ##replace %replace
 CODEGEN: ##inc-d %inc-d
 CODEGEN: ##inc-r %inc-r
+CODEGEN: ##call %call
+CODEGEN: ##jump %jump
 CODEGEN: ##return %return
 CODEGEN: ##slot %slot
 CODEGEN: ##slot-imm %slot-imm
@@ -409,20 +389,28 @@ M: c-type-name flatten-value-type c-type flatten-value-type ;
 : box-return* ( node -- )
     return>> [ ] [ box-return %push-stack ] if-void ;
 
+GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
+
+M: string dlsym-valid? dlsym ;
+
+M: array dlsym-valid? '[ _ dlsym ] any? ;
+
 : check-dlsym ( symbols dll -- )
     dup dll-valid? [
-        dupd '[ _ dlsym ] any?
+        dupd dlsym-valid?
         [ drop ] [ compiling-word get no-such-symbol ] if
     ] [
         dll-path compiling-word get no-such-library drop
     ] if ;
 
-: stdcall-mangle ( symbol params -- symbol )
+: stdcall-mangle ( params -- symbols )
-    parameters>> parameter-offsets drop number>string "@" glue ;
+    [ function>> ] [ parameters>> parameter-offsets drop number>string ] bi
+    [ drop ] [ "@" glue ] [ "@" glue "_" prepend ] 2tri
+    3array ;
 
 : alien-invoke-dlsym ( params -- symbols dll )
-    [ [ function>> dup ] keep stdcall-mangle 2array ]
+    [ dup abi>> "stdcall" = [ stdcall-mangle ] [ function>> ] if ]
-    [ library>> library dup [ dll>> ] when ]
+    [ library>> load-library ]
     bi 2dup check-dlsym ;
 
 M: ##alien-invoke generate-insn

basis/compiler/compiler-docs.factor

@@ -1,7 +1,7 @@
 USING: assocs compiler.cfg.builder compiler.cfg.optimizer
 compiler.errors compiler.tree.builder compiler.tree.optimizer
-compiler.units help.markup help.syntax io parser quotations
+compiler.units compiler.codegen help.markup help.syntax io
-sequences words ;
+parser quotations sequences words ;
 IN: compiler
 
 HELP: enable-optimizer
@@ -21,8 +21,6 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler"
 ARTICLE: "compiler-impl" "Compiler implementation"
 "The " { $vocab-link "compiler" } "vocabulary, in addition to providing the user-visible words of the compiler, implements the main compilation loop."
 $nl
-"Words are added to the " { $link compile-queue } " variable as needed and compiled."
-{ $subsections compile-queue }
 "Once compiled, a word is added to the assoc stored in the " { $link compiled } " variable. When compilation is complete, this assoc is passed to " { $link modify-code-heap } "."
 $nl
 "The " { $link compile-word } " word performs the actual task of compiling an individual word. The process proceeds as follows:"
@@ -30,7 +28,7 @@ $nl
   { "The " { $link frontend } " word calls " { $link build-tree } ". If this fails, the error is passed to " { $link deoptimize } ". The logic for ignoring certain compile errors generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." }
   { "If the word contains a breakpoint, compilation ends here. Otherwise, all remaining steps execute until machine code is generated. Any further errors thrown by the compiler are not reported as compile errors, but instead are ordinary exceptions. This is because they indicate bugs in the compiler, not errors in user code." }
   { "The " { $link frontend } " word then calls " { $link optimize-tree } ". This produces the final optimized tree IR, and this stage of the compiler is complete." }
-  { "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link compile-dependency } "." }
+  { "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link generate } "." }
 }
 "If compilation fails, the word is stored in the " { $link compiled } " assoc with a value of " { $link f } ". This causes the VM to compile the word with the non-optimizing compiler."
 $nl

basis/compiler/compiler.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces arrays sequences io words fry
-continuations vocabs assocs dlists definitions math graphs generic
+continuations vocabs assocs definitions math graphs generic
-generic.single combinators deques search-deques macros
+generic.single combinators combinators.smart macros
 source-files.errors combinators.short-circuit classes.algebra
 
 stack-checker stack-checker.dependencies stack-checker.inlining
@@ -21,29 +21,15 @@ compiler.cfg.mr
 compiler.codegen ;
 IN: compiler
 
-SYMBOL: compile-queue
 SYMBOL: compiled
 
 : compile? ( word -- ? )
     #! Don't attempt to compile certain words.
     {
         [ "forgotten" word-prop ]
-        [ compiled get key? ]
         [ inlined-block? ]
     } 1|| not ;
 
-: queue-compile ( word -- )
-    dup compile? [ compile-queue get push-front ] [ drop ] if ;
-
-: recompile-callers? ( word -- ? )
-    changed-effects get key? ;
-
-: recompile-callers ( word -- )
-    #! If a word's stack effect changed, recompile all words
-    #! that have compiled calls to it.
-    dup recompile-callers?
-    [ effect-dependencies-of keys [ queue-compile ] each ] [ drop ] if ;
-
 : compiler-message ( string -- )
     "trace-compilation" get [ global [ print flush ] bind ] [ drop ] if ;
 
@@ -54,7 +40,7 @@ SYMBOL: compiled
 
 GENERIC: no-compile? ( word -- ? )
 
-M: method-body no-compile? "method-generic" word-prop no-compile? ;
+M: method no-compile? "method-generic" word-prop no-compile? ;
 
 M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
 
@@ -63,7 +49,7 @@ M: word no-compile?
 
 GENERIC: combinator? ( word -- ? )
 
-M: method-body combinator? "method-generic" word-prop combinator? ;
+M: method combinator? "method-generic" word-prop combinator? ;
 
 M: predicate-engine-word combinator? "owner-generic" word-prop combinator? ;
 
@@ -81,7 +67,6 @@ M: word combinator? inline? ;
     #! Recompile callers if the word's stack effect changed, then
     #! save the word's dependencies so that if they change, the
     #! word can get recompiled too.
-    [ recompile-callers ]
     [ compiled-unxref ]
     [
         dup crossref? [
@@ -89,7 +74,7 @@ M: word combinator? inline? ;
             [ conditional-dependencies get set-dependency-checks ]
             bi
         ] [ drop ] if
-    ] tri ;
+    ] bi ;
 
 : deoptimize-with ( word def -- * )
     #! If the word failed to infer, compile it with the
@@ -138,29 +123,10 @@ M: word combinator? inline? ;
         contains-breakpoints? [ nip deoptimize* ] [ drop ] if
     ] [ deoptimize* ] if ;
 
-: compile-dependency ( word -- )
-    #! If a word calls an unoptimized word, try to compile the callee.
-    dup optimized? [ drop ] [ queue-compile ] if ;
-
-! Only switch this off for debugging.
-SYMBOL: compile-dependencies?
-
-t compile-dependencies? set-global
-
-: compile-dependencies ( asm -- )
-    compile-dependencies? get
-    [ calls>> [ compile-dependency ] each ] [ drop ] if ;
-
-: save-asm ( asm -- )
-    [ [ code>> ] [ label>> ] bi compiled get set-at ]
-    [ compile-dependencies ]
-    bi ;
-
 : backend ( tree word -- )
     build-cfg [
         [ optimize-cfg build-mr ] with-cfg
-        generate
+        [ generate ] [ label>> ] bi compiled get set-at
-        save-asm
     ] each ;
 
 : compile-word ( word -- )
@@ -175,36 +141,31 @@ t compile-dependencies? set-global
         } cleave
     ] with-return ;
 
-: compile-loop ( deque -- )
-    [ compile-word yield-hook get call( -- ) ] slurp-deque ;
-
 SINGLETON: optimizing-compiler
 
 M: optimizing-compiler update-call-sites ( class generic -- words )
     #! Words containing call sites with inferred type 'class'
     #! which inlined a method on 'generic'
-    compiled-generic-usage swap '[
+    generic-call-sites-of swap '[
-        nip dup classoid?
+        nip _ 2dup [ classoid? ] both?
-        [ _ classes-intersect? ] [ drop f ] if
+        [ classes-intersect? ] [ 2drop f ] if
     ] assoc-filter keys ;
 
 M: optimizing-compiler recompile ( words -- alist )
-    [
+    H{ } clone compiled [
-        <hashed-dlist> compile-queue set
+        [ compile? ] filter
-        H{ } clone compiled set
+        [ compile-word yield-hook get call( -- ) ] each
-        [
-            [ queue-compile ]
-            [ subwords [ compile-dependency ] each ] bi
-        ] each
-        compile-queue get compile-loop
         compiled get >alist
-    ] with-scope
+    ] with-variable
     "--- compile done" compiler-message ;
 
 M: optimizing-compiler to-recompile ( -- words )
-    changed-definitions get compiled-usages
+    [
-    maybe-changed get outdated-conditional-usages
+        changed-effects get new-words get assoc-diff outdated-effect-usages
-    append assoc-combine keys ;
+        changed-definitions get new-words get assoc-diff outdated-definition-usages
+        maybe-changed get new-words get assoc-diff outdated-conditional-usages
+        changed-definitions get [ drop word? ] assoc-filter 1array
+    ] append-outputs assoc-combine keys ;
 
 M: optimizing-compiler process-forgotten-words
     [ delete-compiled-xref ] each ;

basis/compiler/crossref/crossref.factor

@@ -9,9 +9,9 @@ SYMBOL: compiled-crossref
 
 compiled-crossref [ H{ } clone ] initialize
 
-SYMBOL: compiled-generic-crossref
+SYMBOL: generic-call-site-crossref
 
-compiled-generic-crossref [ H{ } clone ] initialize
+generic-call-site-crossref [ H{ } clone ] initialize
 
 : effect-dependencies-of ( word -- assoc )
     compiled-crossref get at ;
@@ -22,9 +22,13 @@ compiled-generic-crossref [ H{ } clone ] initialize
 : conditional-dependencies-of ( word -- assoc )
     effect-dependencies-of [ nip conditional-dependency dependency>= ] assoc-filter ;
 
-: compiled-usages ( assoc -- assocs )
+: outdated-definition-usages ( assoc -- assocs )
     [ drop word? ] assoc-filter
-    [ [ drop definition-dependencies-of ] { } assoc>map ] keep suffix ;
+    [ drop definition-dependencies-of ] { } assoc>map ;
+
+: outdated-effect-usages ( assoc -- assocs )
+    [ drop word? ] assoc-filter
+    [ drop effect-dependencies-of ] { } assoc>map ;
 
 : dependencies-satisfied? ( word cache -- ? )
     [ "dependency-checks" word-prop ] dip
@@ -37,14 +41,14 @@ compiled-generic-crossref [ H{ } clone ] initialize
         [ drop _ dependencies-satisfied? not ] assoc-filter
     ] { } assoc>map ;
 
-: compiled-generic-usage ( word -- assoc )
+: generic-call-sites-of ( word -- assoc )
-    compiled-generic-crossref get at ;
+    generic-call-site-crossref get at ;
 
 : only-xref ( assoc -- assoc' )
     [ drop crossref? ] { } assoc-filter-as ;
 
-: set-compiled-generic-uses ( word alist -- )
+: set-generic-call-sites ( word alist -- )
-    concat f like "compiled-generic-uses" set-word-prop ;
+    concat f like "generic-call-sites" set-word-prop ;
 
 : split-dependencies ( assoc -- effect-deps cond-deps def-deps )
     [ nip effect-dependency eq? ] assoc-partition
@@ -59,12 +63,12 @@ compiled-generic-crossref [ H{ } clone ] initialize
     [ (store-dependencies) ] tri-curry@ tri-curry* tri ;
 
 : (compiled-xref) ( word dependencies generic-dependencies -- )
-    compiled-crossref compiled-generic-crossref
+    compiled-crossref generic-call-site-crossref
     [ get add-vertex* ] bi-curry@ bi-curry* bi ;
 
 : compiled-xref ( word dependencies generic-dependencies -- )
     [ only-xref ] bi@
-    [ nip set-compiled-generic-uses ]
+    [ nip set-generic-call-sites ]
     [ drop store-dependencies ]
     [ (compiled-xref) ]
     3tri ;
@@ -88,23 +92,23 @@ compiled-generic-crossref [ H{ } clone ] initialize
 : (compiled-unxref) ( word dependencies variable -- )
     get remove-vertex* ;
 
-: compiled-generic-uses ( word -- alist )
+: generic-call-sites ( word -- alist )
-    "compiled-generic-uses" word-prop 2 <groups> ;
+    "generic-call-sites" word-prop 2 <groups> ;
 
 : compiled-unxref ( word -- )
     {
         [ dup load-dependencies compiled-crossref (compiled-unxref) ]
-        [ dup compiled-generic-uses compiled-generic-crossref (compiled-unxref) ]
+        [ dup generic-call-sites generic-call-site-crossref (compiled-unxref) ]
         [ "effect-dependencies" remove-word-prop ]
         [ "conditional-dependencies" remove-word-prop ]
         [ "definition-dependencies" remove-word-prop ]
-        [ "compiled-generic-uses" remove-word-prop ]
+        [ "generic-call-sites" remove-word-prop ]
     } cleave ;
 
 : delete-compiled-xref ( word -- )
     [ compiled-unxref ]
     [ compiled-crossref get delete-at ]
-    [ compiled-generic-crossref get delete-at ]
+    [ generic-call-site-crossref get delete-at ]
     tri ;
 
 : set-dependency-checks ( word deps -- )

basis/compiler/test/test.factor

@@ -5,7 +5,7 @@ sequences vocabs words tools.test tools.test.private ;
 IN: compiler.test
 
 : decompile ( word -- )
-    dup def>> 2array 1array modify-code-heap ;
+    dup def>> 2array 1array t t modify-code-heap ;
 
 : recompile-all ( -- )
     all-words compile ;

basis/compiler/tests/alien.factor

@@ -556,6 +556,9 @@ FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
 
 [ ] [ stack-frame-bustage 2drop ] unit-test
 
+! C99 tests
+os windows? [
+
 FUNCTION: complex-float ffi_test_45 ( int x ) ;
 
 [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
@@ -585,6 +588,8 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
     ffi_test_48
 ] unit-test
 
+] unless
+
 ! Regression: calling an undefined function would raise a protection fault
 FUNCTION: void this_does_not_exist ( ) ;
 

basis/compiler/tests/low-level-ir.factor

@@ -8,8 +8,8 @@ IN: compiler.tests.low-level-ir
 
 : compile-cfg ( cfg -- word )
     gensym
-    [ build-mr generate code>> ] dip
+    [ build-mr generate ] dip
-    [ associate >alist modify-code-heap ] keep ;
+    [ associate >alist t t modify-code-heap ] keep ;
 
 : compile-test-cfg ( -- word )
     cfg new 0 get >>entry

basis/compiler/tests/redefine0.factor

@@ -77,8 +77,8 @@ M: integer test-7 + ;
 ! Indirect dependency on an unoptimized word
 : test-9 ( -- ) ;
 << SYMBOL: quot
-[ test-9 ] quot set-global >>
+[ test-9 ] quot set-global
-MACRO: test-10 ( -- quot ) quot get ;
+MACRO: test-10 ( -- quot ) quot get ; >>
 : test-11 ( -- ) test-10 ;
 
 [ ] [ test-11 ] unit-test

basis/compiler/tests/redefine13.factor

@@ -3,7 +3,7 @@ IN: compiler.tests.redefine13
 
 : breakage-word ( a b -- c ) + ;
 
-MACRO: breakage-macro ( a -- ) '[ _ breakage-word ] ;
+<< MACRO: breakage-macro ( a -- ) '[ _ breakage-word ] ; >>
 
 GENERIC: breakage-caller ( a -- c )
 

basis/compiler/tests/redefine21.factor

@@ -0,0 +1,10 @@
+USING: kernel tools.test definitions compiler.units ;
+IN: compiler.tests.redefine21
+
+[ ] [ : a ( -- ) ; << : b ( quot -- ) call a ; inline >> [ ] b ] unit-test
+
+[ ] [ [ { a b } forget-all ] with-compilation-unit ] unit-test
+
+[ ] [ : A ( -- ) ; << : B ( -- ) A ; inline >> B ] unit-test
+
+[ ] [ [ { A B } forget-all ] with-compilation-unit ] unit-test

basis/compiler/tests/stack-trace.factor

@@ -5,7 +5,7 @@ IN: compiler.tests.stack-trace
 
 : symbolic-stack-trace ( -- newseq )
     error-continuation get call>> callstack>array
-    2 group flip first ;
+    3 group flip first ;
 
 : foo ( -- * ) 3 throw 7 ;
 : bar ( -- * ) foo 4 ;

basis/compiler/tree/debugger/debugger.factor

@@ -162,7 +162,7 @@ SYMBOL: node-count
                 word>> {
                     { [ dup "intrinsic" word-prop ] [ intrinsics-called ] }
                     { [ dup generic? ] [ generics-called ] }
-                    { [ dup method-body? ] [ methods-called ] }
+                    { [ dup method? ] [ methods-called ] }
                     [ words-called ]
                 } cond get inc-at
             ] [ drop ] if

basis/compiler/tree/escape-analysis/simple/simple.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences classes.tuple
 classes.tuple.private arrays math math.private slots.private
@@ -50,7 +50,10 @@ DEFER: record-literal-allocation
     if* ;
 
 M: #push escape-analysis*
-    [ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
+    dup literal>> layout-up-to-date?
+    [ [ out-d>> first ] [ literal>> ] bi record-literal-allocation ]
+    [ out-d>> unknown-allocations ]
+    if ;
 
 : record-unknown-allocation ( #call -- )
     [ in-d>> add-escaping-values ]

basis/compiler/tree/propagation/call-effect/call-effect-tests.factor

@@ -78,7 +78,7 @@ TUPLE: a-tuple x ;
 
 [ ] [ "IN: compiler.tree.propagation.call-effect.tests USE: math : call(-redefine-test ( a -- c ) 1 + ;" eval( -- ) ] unit-test
 
-[ 1 3 test-quotatation inline-cache-invalidation-test ] [ T{ wrong-values f (( a b -- c )) } = ] must-fail-with
+[ 1 3 test-quotatation inline-cache-invalidation-test ] [ T{ wrong-values f [ call(-redefine-test ] (( a b -- c )) } = ] must-fail-with
 
 ! See if redefining a tuple class bumps effect counter
 TUPLE: my-tuple a b c ;

basis/compiler/tree/propagation/call-effect/call-effect.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009, 2010 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators combinators.private effects
-fry kernel kernel.private make sequences continuations
+fry kernel kernel.private make namespaces sequences continuations
 quotations words math stack-checker stack-checker.dependencies
 combinators.short-circuit stack-checker.transforms
 compiler.tree.propagation.info
@@ -63,7 +63,11 @@ M: compose cached-effect
     [ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
 
 : safe-infer ( quot -- effect )
-    [ [ infer ] [ 2drop +unknown+ ] recover ] without-dependencies ;
+    ! Save and restore error variables here, so that we don't
+    ! pollute words such as :error and :c for the user.
+    error get-global error-continuation get-global
+    [ [ [ infer ] [ 2drop +unknown+ ] recover ] without-dependencies ] 2dip
+    [ error set-global ] [ error-continuation set-global ] bi* ;
 
 : cached-effect-valid? ( quot -- ? )
     cache-counter>> effect-counter eq? ; inline
@@ -81,17 +85,9 @@ M: quotation cached-effect
     over +unknown+ eq?
     [ 2drop f ] [ [ { effect } declare ] dip effect<= ] if ; inline
 
-: (call-effect-slow>quot) ( in out effect -- quot )
-    [
-        [ [ datastack ] dip dip ] %
-        [ [ , ] bi@ \ check-datastack , ] dip
-        '[ _ wrong-values ] , \ unless ,
-    ] [ ] make ;
-
 : call-effect-slow>quot ( effect -- quot )
-    [ in>> length ] [ out>> length ] [ ] tri
+    [ \ call-effect def>> curry ] [ add-effect-input ] bi
-    [ (call-effect-slow>quot) ] keep add-effect-input
+    '[ _ _ call-effect-unsafe ] ;
-    [ call-effect-unsafe ] 2curry ;
 
 : call-effect-slow ( quot effect -- ) drop call ;
 
@@ -118,7 +114,10 @@ M: quotation cached-effect
     [ '[ _ execute ] ] dip call-effect-slow ; inline
 
 : execute-effect-unsafe? ( word effect -- ? )
-    over optimized? [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
+    over optimized?
+    [ [ stack-effect { effect } declare ] dip effect<= ]
+    [ 2drop f ]
+    if ; inline
 
 : execute-effect-fast ( word effect inline-cache -- )
     2over execute-effect-unsafe?

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -79,14 +79,6 @@ M: callable splicing-nodes splicing-body ;
 : inline-math-method ( #call word -- ? )
     dupd inlining-math-method eliminate-dispatch ;
 
-: inlining-math-partial ( #call word -- class/f quot/f )
-    [ "derived-from" word-prop first inlining-math-method ]
-    [ nip 1quotation ] 2bi
-    [ = not ] [ drop ] 2bi and ;
-
-: inline-math-partial ( #call word -- ? )
-    dupd inlining-math-partial eliminate-dispatch ;
-
 ! Method body inlining
 SYMBOL: history
 

basis/compiler/tree/propagation/slots/slots.factor

@@ -1,9 +1,10 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry assocs arrays byte-arrays strings accessors sequences
 kernel slots classes.algebra classes.tuple classes.tuple.private
-words math math.private combinators sequences.private namespaces
+combinators.short-circuit words math math.private combinators
-slots.private classes compiler.tree.propagation.info ;
+sequences.private namespaces slots.private classes
+compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.slots
 
 ! Propagation of immutable slots and array lengths
@@ -52,8 +53,18 @@ UNION: fixed-length-sequence array byte-array string ;
     dup [ read-only>> ] when ;
 
 : literal-info-slot ( slot object -- info/f )
-    2dup class read-only-slot?
+    #! literal-info-slot makes an unsafe call to 'slot'.
-    [ swap slot <literal-info> ] [ 2drop f ] if ;
+    #! Check that the layout is up to date to avoid accessing the
+    #! wrong slot during a compilation unit where reshaping took
+    #! place. This could happen otherwise because the "slots" word
+    #! property would reflect the new layout, but instances in the
+    #! heap would use the old layout since instances are updated
+    #! immediately after compilation.
+    {
+        [ class read-only-slot? ]
+        [ nip layout-up-to-date? ]
+        [ swap slot <literal-info> ]
+    } 2&& ;
 
 : length-accessor? ( slot info -- ? )
     [ 1 = ] [ length>> ] bi* and ;

basis/compression/lzw/lzw.factor

@@ -26,9 +26,11 @@ TUPLE: gif-lzw < lzw ;
     dup end-of-information-code>> 1 + initial-uncompress-table >>table
     dup initial-code-size>> >>code-size ;
 
+ERROR: code-size-zero ;
+
 : <lzw-uncompress> ( input code-size class -- obj )
     new
-        swap >>code-size
+        swap [ code-size-zero ] when-zero >>code-size
         dup code-size>> >>initial-code-size
         dup code-size>> 1 - 2^ >>clear-code
         dup clear-code>> 1 + >>end-of-information-code

basis/core-foundation/arrays/arrays-tests.factor

@@ -0,0 +1,11 @@
+IN: core-foundation.arrays.tests
+USING: core-foundation core-foundation.arrays
+core-foundation.strings destructors sequences tools.test ;
+
+[ { "1" "2" "3" } ] [
+    [
+        { "1" "2" "3" }
+        [ <CFString> &CFRelease ] map
+        <CFArray> CF>string-array
+    ] with-destructors
+] unit-test

basis/core-foundation/arrays/arrays.factor

@@ -15,7 +15,8 @@ FUNCTION: void CFArraySetValueAtIndex ( CFArrayRef array, CFIndex index, void* v
 FUNCTION: CFIndex CFArrayGetCount ( CFArrayRef array ) ;
 
 : CF>array ( alien -- array )
-    dup CFArrayGetCount [ CFArrayGetValueAtIndex ] with map ;
+    dup CFArrayGetCount
+    [ CFArrayGetValueAtIndex ] with { } map-integers ;
 
 : <CFArray> ( seq -- alien )
     f over length &: kCFTypeArrayCallBacks CFArrayCreateMutable

basis/cpu/architecture/architecture.factor

@@ -169,6 +169,19 @@ M: uint-scalar-rep rep-size drop 4 ;
 M: longlong-scalar-rep rep-size drop 8 ;
 M: ulonglong-scalar-rep rep-size drop 8 ;
 
+GENERIC: rep-length ( rep -- n ) foldable
+
+M: char-16-rep rep-length drop 16 ;
+M: uchar-16-rep rep-length drop 16 ;
+M: short-8-rep rep-length drop 8 ;
+M: ushort-8-rep rep-length drop 8 ;
+M: int-4-rep rep-length drop 4 ;
+M: uint-4-rep rep-length drop 4 ;
+M: longlong-2-rep rep-length drop 2 ;
+M: ulonglong-2-rep rep-length drop 2 ;
+M: float-4-rep rep-length drop 4 ;
+M: double-2-rep rep-length drop 2 ;
+
 GENERIC: rep-component-type ( rep -- n )
 
 ! Methods defined in alien.c-types
@@ -434,6 +447,7 @@ HOOK: %set-alien-double    cpu ( ptr offset value -- )
 HOOK: %set-alien-vector    cpu ( ptr offset value rep -- )
 
 HOOK: %alien-global cpu ( dst symbol library -- )
+HOOK: %vm-field cpu ( dst fieldname -- )
 HOOK: %vm-field-ptr cpu ( dst fieldname -- )
 
 HOOK: %allot cpu ( dst size class temp -- )

basis/cpu/ppc/bootstrap.factor

@@ -97,11 +97,11 @@ CONSTANT: ctx-reg 16
     rs-reg ctx-reg context-retainstack-offset LWZ ;
 
 [
-    0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel
+    0 12 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel
-    11 3 profile-count-offset LWZ
+    11 12 profile-count-offset LWZ
     11 11 1 tag-fixnum ADDI
-    11 3 profile-count-offset STW
+    11 12 profile-count-offset STW
-    11 3 word-code-offset LWZ
+    11 12 word-code-offset LWZ
     11 11 compiled-header-size ADDI
     11 MTCTR
     BCTR

basis/cpu/ppc/ppc.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs sequences kernel combinators make math
 math.order math.ranges system namespaces locals layouts words
@@ -57,10 +57,11 @@ CONSTANT: vm-reg 15
 
 : %load-vm-addr ( reg -- ) vm-reg MR ;
 
-: %load-vm-field-addr ( reg symbol -- )
+M: ppc %vm-field ( dst field -- )
-    [ vm-reg ] dip vm-field-offset ADDI ;
+    [ vm-reg ] dip vm-field-offset LWZ ;
 
-M: ppc %vm-field-ptr ( dst field -- ) %load-vm-field-addr ;
+M: ppc %vm-field-ptr ( dst field -- )
+    [ vm-reg ] dip vm-field-offset ADDI ;
 
 GENERIC: loc-reg ( loc -- reg )
 
@@ -383,7 +384,7 @@ M: ppc %set-alien-float -rot STFS ;
 M: ppc %set-alien-double -rot STFD ;
 
 : load-zone-ptr ( reg -- )
-    "nursery" %load-vm-field-addr ;
+    "nursery" %vm-field-ptr ;
 
 : load-allot-ptr ( nursery-ptr allot-ptr -- )
     [ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
@@ -601,26 +602,19 @@ M: ppc %push-stack ( -- )
     ds-reg ds-reg 4 ADDI
     int-regs return-reg ds-reg 0 STW ;
 
-:: %load-context-datastack ( dst -- )
-    ! Load context struct
-    dst "ctx" %vm-field-ptr
-    dst dst 0 LWZ
-    ! Load context datastack pointer
-    dst dst "datastack" context-field-offset ADDI ;
-
 M: ppc %push-context-stack ( -- )
-    11 %load-context-datastack
+    11 "ctx" %vm-field
-    12 11 0 LWZ
+    12 11 "datastack" context-field-offset LWZ
     12 12 4 ADDI
-    12 11 0 STW
+    12 11 "datastack" context-field-offset STW
     int-regs return-reg 12 0 STW ;
 
 M: ppc %pop-context-stack ( -- )
-    11 %load-context-datastack
+    11 "ctx" %vm-field
-    12 11 0 LWZ
+    12 11 "datastack" context-field-offset LWZ
     int-regs return-reg 12 0 LWZ
     12 12 4 SUBI
-    12 11 0 STW ;
+    12 11 "datastack" context-field-offset STW ;
 
 M: ppc %unbox ( n rep func -- )
     ! Value must be in r3
@@ -682,19 +676,17 @@ M: ppc %box-large-struct ( n c-type -- )
     "from_value_struct" f %alien-invoke ;
 
 M:: ppc %restore-context ( temp1 temp2 -- )
-    temp1 "ctx" %load-vm-field-addr
+    temp1 "ctx" %vm-field
-    temp1 temp1 0 LWZ
     temp2 1 stack-frame get total-size>> ADDI
     temp2 temp1 "callstack-bottom" context-field-offset STW
-    ds-reg temp1 8 LWZ
+    ds-reg temp1 "datastack" context-field-offset LWZ
-    rs-reg temp1 12 LWZ ;
+    rs-reg temp1 "retainstack" context-field-offset LWZ ;
 
 M:: ppc %save-context ( temp1 temp2 -- )
-    temp1 "ctx" %load-vm-field-addr
+    temp1 "ctx" %vm-field
-    temp1 temp1 0 LWZ
+    1 temp1 "callstack-top" context-field-offset STW
-    1 temp1 0 STW
+    ds-reg temp1 "datastack" context-field-offset STW
-    ds-reg temp1 8 STW
+    rs-reg temp1 "retainstack" context-field-offset STW ;
-    rs-reg temp1 12 STW ;
 
 M: ppc %alien-invoke ( symbol dll -- )
     [ 11 ] 2dip %alien-global 11 MTLR BLRL ;

basis/cpu/x86/32/32.factor

@@ -27,6 +27,9 @@ M: x86.32 temp-reg ECX ;
 M: x86.32 %mov-vm-ptr ( reg -- )
     0 MOV 0 rc-absolute-cell rel-vm ;
 
+M: x86.32 %vm-field ( dst field -- )
+    [ 0 [] MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
+
 M: x86.32 %vm-field-ptr ( dst field -- )
     [ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
 
@@ -102,6 +105,9 @@ M: x86.32 %prologue ( n -- )
     0 PUSH rc-absolute-cell rel-this
     3 cells - decr-stack-reg ;
 
+M: x86.32 %prepare-jump
+    pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
+
 M: x86.32 %load-param-reg
     stack-params assert=
     [ [ EAX ] dip local@ MOV ] dip
@@ -160,10 +166,10 @@ M: x86.32 %pop-stack ( n -- )
     EAX swap ds-reg reg-stack MOV ;
 
 M: x86.32 %pop-context-stack ( -- )
-    temp-reg %load-context-datastack
+    temp-reg "ctx" %vm-field
-    EAX temp-reg [] MOV
+    EAX temp-reg "datastack" context-field-offset [+] MOV
     EAX EAX [] MOV
-    temp-reg [] bootstrap-cell SUB ;
+    temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
 
 : call-unbox-func ( func -- )
     4 save-vm-ptr
@@ -287,6 +293,15 @@ M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
     func "libm" load-library %alien-invoke
     dst float-function-return ;
 
+: stdcall? ( params -- ? )
+    abi>> "stdcall" = ;
+
+: funny-large-struct-return? ( params -- ? )
+    #! MINGW ABI incompatibility disaster
+    [ return>> large-struct? ]
+    [ abi>> "mingw" = os windows? not or ]
+    bi and ;
+
 M: x86.32 %cleanup ( params -- )
     #! a) If we just called an stdcall function in Windows, it
     #! cleaned up the stack frame for us. But we don't want that
@@ -294,13 +309,8 @@ M: x86.32 %cleanup ( params -- )
     #! b) If we just called a function returning a struct, we
     #! have to fix ESP.
     {
-        {
+        { [ dup stdcall? ] [ drop ESP stack-frame get params>> SUB ] }
-            [ dup abi>> "stdcall" = ]
+        { [ dup funny-large-struct-return? ] [ drop EAX PUSH ] }
-            [ drop ESP stack-frame get params>> SUB ]
-        } {
-            [ dup return>> large-struct? ]
-            [ drop EAX PUSH ]
-        }
         [ drop ]
     } cond ;
 
@@ -323,11 +333,8 @@ M: x86.32 callback-return-rewind ( params -- n )
     #! b) If the callback is returning a large struct, we have
     #! to fix ESP.
     {
-        { [ dup abi>> "stdcall" = ] [
+        { [ dup stdcall? ] [ <alien-stack-frame> [ params>> ] [ return>> ] bi + ] }
-            <alien-stack-frame>
+        { [ dup funny-large-struct-return? ] [ drop 4 ] }
-            [ params>> ] [ return>> ] bi +
-        ] }
-        { [ dup return>> large-struct? ] [ drop 4 ] }
         [ drop 0 ]
     } cond ;
 

basis/cpu/x86/32/bootstrap.factor

@@ -36,6 +36,11 @@ IN: bootstrap.x86
     ESP stack-frame-size 3 bootstrap-cells - SUB
 ] jit-prolog jit-define
 
+[
+    temp3 0 MOV rc-absolute-cell rt-here jit-rel
+    0 JMP rc-relative rt-entry-point-pic-tail jit-rel
+] jit-word-jump jit-define
+
 : jit-load-vm ( -- )
     vm-reg 0 MOV 0 rc-absolute-cell jit-vm ;
 

basis/cpu/x86/64/64.factor

@@ -42,17 +42,23 @@ M: x86.64 machine-registers
 M: x86.64 %mov-vm-ptr ( reg -- )
     vm-reg MOV ;
 
+M: x86.64 %vm-field ( dst field -- )
+    [ vm-reg ] dip vm-field-offset [+] MOV ;
+
 M: x86.64 %vm-field-ptr ( dst field -- )
     [ vm-reg ] dip vm-field-offset [+] LEA ;
 
 : param@ ( n -- op ) reserved-stack-space + stack@ ;
 
 M: x86.64 %prologue ( n -- )
-    temp-reg 0 MOV rc-absolute-cell rel-this
+    temp-reg -7 [] LEA
     dup PUSH
     temp-reg PUSH
     stack-reg swap 3 cells - SUB ;
 
+M: x86.64 %prepare-jump
+    pic-tail-reg xt-tail-pic-offset [] LEA ;
+
 : load-cards-offset ( dst -- )
     0 MOV rc-absolute-cell rel-cards-offset ;
 
@@ -104,10 +110,10 @@ M: x86.64 %pop-stack ( n -- )
     param-reg-0 swap ds-reg reg-stack MOV ;
 
 M: x86.64 %pop-context-stack ( -- )
-    temp-reg %load-context-datastack
+    temp-reg "ctx" %vm-field
-    param-reg-0 temp-reg [] MOV
+    param-reg-0 temp-reg "datastack" context-field-offset [+] MOV
     param-reg-0 param-reg-0 [] MOV
-    temp-reg [] bootstrap-cell SUB ;
+    temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
 
 M:: x86.64 %unbox ( n rep func -- )
     param-reg-1 %mov-vm-ptr

basis/cpu/x86/64/bootstrap.factor

@@ -37,6 +37,11 @@ IN: bootstrap.x86
     RSP stack-frame-size 3 bootstrap-cells - SUB
 ] jit-prolog jit-define
 
+[
+    temp3 5 [] LEA
+    0 JMP rc-relative rt-entry-point-pic-tail jit-rel
+] jit-word-jump jit-define
+
 : jit-load-context ( -- )
     ctx-reg vm-reg vm-context-offset [+] MOV ;
 

basis/cpu/x86/bootstrap.factor

@@ -56,15 +56,15 @@ big-endian off
 
 [
     ! Load word
-    temp0 0 MOV rc-absolute-cell rt-literal jit-rel
+    safe-reg 0 MOV rc-absolute-cell rt-literal jit-rel
     ! Bump profiling counter
-    temp0 profile-count-offset [+] 1 tag-fixnum ADD
+    safe-reg profile-count-offset [+] 1 tag-fixnum ADD
     ! Load word->code
-    temp0 temp0 word-code-offset [+] MOV
+    safe-reg safe-reg word-code-offset [+] MOV
     ! Compute word entry point
-    temp0 compiled-header-size ADD
+    safe-reg compiled-header-size ADD
     ! Jump to entry point
-    temp0 JMP
+    safe-reg JMP
 ] jit-profiling jit-define
 
 [
@@ -76,11 +76,6 @@ big-endian off
     ds-reg [] temp0 MOV
 ] jit-push jit-define
 
-[
-    temp3 0 MOV rc-absolute-cell rt-here jit-rel
-    0 JMP rc-relative rt-entry-point-pic-tail jit-rel
-] jit-word-jump jit-define
-
 [
     0 CALL rc-relative rt-entry-point-pic jit-rel
 ] jit-word-call jit-define

basis/cpu/x86/x86.factor

@@ -88,8 +88,10 @@ M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
     #! See the comment in vm/cpu-x86.hpp
     4 1 + ; inline
 
+HOOK: %prepare-jump cpu ( -- )
+
 M: x86 %jump ( word -- )
-    pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here
+    %prepare-jump
     0 JMP rc-relative rel-word-pic-tail ;
 
 M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
@@ -474,17 +476,10 @@ M: x86 %push-stack ( -- )
     ds-reg cell ADD
     ds-reg [] int-regs return-reg MOV ;
 
-:: %load-context-datastack ( dst -- )
-    ! Load context struct
-    dst "ctx" %vm-field-ptr
-    dst dst [] MOV
-    ! Load context datastack pointer
-    dst "datastack" context-field-offset ADD ;
-
 M: x86 %push-context-stack ( -- )
-    temp-reg %load-context-datastack
+    temp-reg "ctx" %vm-field
-    temp-reg [] bootstrap-cell ADD
+    temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD
-    temp-reg temp-reg [] MOV
+    temp-reg temp-reg "datastack" context-field-offset [+] MOV
     temp-reg [] int-regs return-reg MOV ;
 
 M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
@@ -1409,8 +1404,7 @@ M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
 M:: x86 %restore-context ( temp1 temp2 -- )
     #! Load Factor stack pointers on entry from C to Factor.
     #! Also save callstack bottom!
-    temp1 "ctx" %vm-field-ptr
+    temp1 "ctx" %vm-field
-    temp1 temp1 [] MOV
     temp2 stack-reg stack-frame get total-size>> cell - [+] LEA
     temp1 "callstack-bottom" context-field-offset [+] temp2 MOV
     ds-reg temp1 "datastack" context-field-offset [+] MOV
@@ -1420,8 +1414,7 @@ M:: x86 %save-context ( temp1 temp2 -- )
     #! Save Factor stack pointers in case the C code calls a
     #! callback which does a GC, which must reliably trace
     #! all roots.
-    temp1 "ctx" %vm-field-ptr
+    temp1 "ctx" %vm-field
-    temp1 temp1 [] MOV
     temp2 stack-reg cell neg [+] LEA
     temp1 "callstack-top" context-field-offset [+] temp2 MOV
     temp1 "datastack" context-field-offset [+] ds-reg MOV

basis/db/errors/errors.factor

@@ -4,36 +4,36 @@ USING: accessors kernel continuations fry words ;
 IN: db.errors
 
 ERROR: db-error ;
-ERROR: sql-error location ;
+TUPLE: sql-error location ;
 
 ERROR: bad-schema ;
 
-ERROR: sql-unknown-error < sql-error message ;
+TUPLE: sql-unknown-error < sql-error message ;
 : <sql-unknown-error> ( message -- error )
     \ sql-unknown-error new
         swap >>message ;
 
-ERROR: sql-table-exists < sql-error table ;
+TUPLE: sql-table-exists < sql-error table ;
 : <sql-table-exists> ( table -- error )
     \ sql-table-exists new
         swap >>table ;
 
-ERROR: sql-table-missing < sql-error table ;
+TUPLE: sql-table-missing < sql-error table ;
 : <sql-table-missing> ( table -- error )
     \ sql-table-missing new
         swap >>table ;
 
-ERROR: sql-syntax-error < sql-error message ;
+TUPLE: sql-syntax-error < sql-error message ;
 : <sql-syntax-error> ( message -- error )
     \ sql-syntax-error new
         swap >>message ;
 
-ERROR: sql-function-exists < sql-error message ;
+TUPLE: sql-function-exists < sql-error message ;
 : <sql-function-exists> ( message -- error )
     \ sql-function-exists new
         swap >>message ;
 
-ERROR: sql-function-missing < sql-error message ;
+TUPLE: sql-function-missing < sql-error message ;
 : <sql-function-missing> ( message -- error )
     \ sql-function-missing new
         swap >>message ;

basis/db/errors/postgresql/postgresql.factor

@@ -34,7 +34,7 @@ PostgresqlSqlError = (TableError | FunctionError | SyntaxError | UnknownError)
 ;EBNF
 
 
-ERROR: parse-postgresql-location column line text ;
+TUPLE: parse-postgresql-location column line text ;
 C: <parse-postgresql-location> parse-postgresql-location
 
 EBNF: parse-postgresql-line-error

basis/db/sqlite/lib/lib.factor

@@ -11,17 +11,12 @@ IN: db.sqlite.lib
 ERROR: sqlite-error < db-error n string ;
 ERROR: sqlite-sql-error < sql-error n string ;
 
-: <sqlite-sql-error> ( n string -- error )
-    \ sqlite-sql-error new
-        swap >>string
-        swap >>n ;
-
 : throw-sqlite-error ( n -- * )
     dup sqlite-error-messages nth sqlite-error ;
 
 : sqlite-statement-error ( -- * )
     SQLITE_ERROR
-    db-connection get handle>> sqlite3_errmsg <sqlite-sql-error> throw ;
+    db-connection get handle>> sqlite3_errmsg sqlite-sql-error ;
 
 : sqlite-check-result ( n -- )
     {

basis/debugger/debugger.factor

@@ -236,7 +236,10 @@ M: redefine-error error.
     def>> . ;
 
 M: undefined summary
-    drop "Calling a deferred word before it has been defined" ;
+    word>> undefined?
+    "Cannot execute a deferred word before it has been defined"
+    "Cannot execute a word before it has been compiled"
+    ? ;
 
 M: no-compilation-unit error.
     "Attempting to define " write
@@ -336,7 +339,7 @@ M: check-mixin-class summary drop "Not a mixin class" ;
 
 M: not-found-in-roots summary drop "Cannot resolve vocab: path" ;
 
-M: wrong-values summary drop "Quotation called with wrong stack effect" ;
+M: wrong-values summary drop "Quotation's stack effect does not match call site" ;
 
 M: stack-effect-omits-dashes summary drop "Stack effect must contain “--”" ;
 

basis/delegate/delegate.factor

@@ -39,7 +39,7 @@ TUPLE: consultation group class quot loc ;
     [ class>> swap first create-method dup fake-definition ] keep
     [ drop ] [ "consultation" set-word-prop ] 2bi ;
 
-PREDICATE: consult-method < method-body "consultation" word-prop ;
+PREDICATE: consult-method < method "consultation" word-prop ;
 
 M: consult-method reset-word
     [ call-next-method ] [ f "consultation" set-word-prop ] bi ;

basis/eval/eval-docs.factor

@@ -37,7 +37,7 @@ ARTICLE: "eval-vocabs" "Evaluating strings with a different vocabulary search pa
     (eval)
     with-file-vocabs
 }
-"Code in the listener tool starts out with a different initial search path, with more vocabularies are available by default. Strings of code can be evaluated in this search path by using " { $link (eval) } " with a different combinator:"
+"Code in the listener tool starts out with a different initial search path, with more vocabularies available by default. Strings of code can be evaluated in this search path by using " { $link (eval) } " with a different combinator:"
 { $subsections
     with-interactive-vocabs
 }

basis/ftp/server/server.factor

@@ -58,7 +58,7 @@ C: <ftp-disconnect> ftp-disconnect
     send-response ;
 
 : serving? ( path -- ? )
-    normalize-path server get serving-directory>> head? ;
+    resolve-symlinks server get serving-directory>> head? ;
 
 : can-serve-directory? ( path -- ? )
     { [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ;
@@ -343,7 +343,7 @@ M: ftp-server handle-client* ( server -- )
 : <ftp-server> ( directory port -- server )
     latin1 ftp-server new-threaded-server
         swap >>insecure
-        swap normalize-path >>serving-directory
+        swap resolve-symlinks >>serving-directory
         "ftp.server" >>name
         5 minutes >>timeout ;
 

basis/functors/functors.factor

@@ -37,7 +37,7 @@ M: array (fake-quotations>)
     [ [ (fake-quotations>) ] each ] { } make , ;
 
 M: fake-call-next-method (fake-quotations>)
-    drop method-body get literalize , \ (call-next-method) , ;
+    drop \ method get literalize , \ (call-next-method) , ;
 
 M: object (fake-quotations>) , ;
 
@@ -74,7 +74,7 @@ FUNCTOR-SYNTAX: MIXIN:
 FUNCTOR-SYNTAX: M:
     scan-param suffix!
     scan-param suffix!
-    [ create-method-in dup method-body set ] append! 
+    [ create-method-in dup \ method set ] append!
     parse-definition*
     \ define* suffix! ;
 

basis/furnace/actions/actions.factor

@@ -28,10 +28,10 @@ TUPLE: action rest init authorize display validate submit ;
     action new-action ;
 
 : merge-forms ( form -- )
-    form get
+    [ form get ] dip
-    [ [ errors>> ] bi@ push-all ]
+    [ [ errors>> ] bi@ append! drop ]
-    [ [ values>> ] bi@ swap update ]
+    [ [ values>> ] bi@ assoc-union! drop ]
-    [ swap validation-failed>> >>validation-failed drop ]
+    [ validation-failed>> >>validation-failed drop ]
     2tri ;
 
 : set-nested-form ( form name -- )

basis/furnace/asides/asides.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces assocs kernel sequences accessors hashtables
 urls db.types db.tuples math.parser fry logging combinators
@@ -51,7 +51,7 @@ SYMBOL: aside-id
     set-aside ;
 
 M: asides call-responder*
-    [ init-asides ] [ asides set ] [ call-next-method ] tri ;
+    [ init-asides ] [ call-next-method ] bi ;
 
 : touch-aside ( aside -- )
     asides get touch-state ;
@@ -65,14 +65,13 @@ M: asides call-responder*
     [ touch-aside ] [ insert-tuple ] [ set-aside ] tri ;
 
 : end-aside-post ( aside -- response )
-    [ url>> ] [ post-data>> ] bi
     request [
         clone
-            swap >>post-data
+            over post-data>> >>post-data
-            over >>url
+            over url>> >>url
     ] change
-    [ url set ] [ path>> split-path ] bi
+    [ [ post-data>> params>> params set ] [ url>> url set ] bi ]
-    asides get responder>> call-responder ;
+    [ url>> path>> split-path asides get responder>> call-responder ] bi ;
 
 \ end-aside-post DEBUG add-input-logging
 

basis/furnace/chloe-tags/chloe-tags.factor

@@ -136,7 +136,7 @@ CHLOE: form
     XML> body>> clone ;
 
 : add-tag-attrs ( attrs tag -- )
-    attrs>> swap update ;
+    attrs>> swap assoc-union! drop ;
 
 CHLOE: button
     button-tag-markup

basis/generalizations/generalizations-tests.factor

@@ -113,3 +113,12 @@ IN: generalizations.tests
 
 [ { 1 2 3 } { 4 5 6 } ]
 [ 1 2 3 4 5 6 [ 3array ] 3 2 mnapply ] unit-test
+
+[ { 1 2 3 } { 4 5 6 } ]
+[ 1 2 3 4 5 6 [ 3array ] [ 3array ] 3 2 nspread* ] unit-test
+
+[ ]
+[ [ 2array ] 2 0 mnapply ] unit-test
+
+[ ]
+[ 2 0 nspread* ] unit-test

basis/generalizations/generalizations.factor

@@ -3,7 +3,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel kernel.private sequences sequences.private math
 combinators macros math.order math.ranges quotations fry effects
-memoize.private ;
+memoize.private arrays ;
 IN: generalizations
 
 <<
@@ -100,10 +100,20 @@ MACRO: nspread ( quots n -- )
 
 MACRO: spread* ( n -- )
     [ [ ] ] [
-        1 swap [a,b) [ '[ [ [ _ ndip ] curry ] dip compose ] ] map [ ] concat-as
+        [1,b) [ '[ [ [ _ ndip ] curry ] dip compose ] ] map [ ] concat-as
         [ call ] compose
     ] if-zero ;
 
+MACRO: nspread* ( m n -- )
+    [ drop [ ] ] [
+        [ * 0 ] [ drop neg ] 2bi
+        <range> rest >array dup length iota <reversed>
+        [
+            '[ [ [ _ ndip ] curry ] _ ndip ]
+        ] 2map dup rest-slice [ [ compose ] compose ] map! drop
+        [ ] concat-as [ call ] compose
+    ] if-zero ;
+
 MACRO: cleave* ( n -- )
     [ [ ] ]
     [ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ] 
@@ -112,6 +122,9 @@ MACRO: cleave* ( n -- )
 : napply ( quot n -- )
     [ dupn ] [ spread* ] bi ; inline
 
+: mnapply ( quot m n -- )
+    [ nip dupn ] [ nspread* ] 2bi ; inline
+
 : apply-curry ( ...a quot n -- )
     [ [curry] ] dip napply ; inline
 
@@ -124,10 +137,6 @@ MACRO: cleave* ( n -- )
 MACRO: mnswap ( m n -- )
     1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
 
-MACRO: mnapply ( quot m n -- )
-    swap
-    [ swap '[ _ ] replicate ] dip '[ _ _ nspread ] ;
-
 MACRO: nweave ( n -- )
     [ dup iota <reversed> [ '[ _ _ mnswap ] ] with map ] keep
     '[ _ _ ncleave ] ;

basis/help/apropos/apropos.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs fry help.markup help.topics io
 kernel make math math.parser namespaces sequences sorting
@@ -19,6 +19,8 @@ TUPLE: more-completions seq ;
 
 CONSTANT: max-completions 5
 
+M: more-completions valid-article? drop t ;
+
 M: more-completions article-title
     seq>> length number>string " results" append ;
 
@@ -60,6 +62,8 @@ TUPLE: apropos search ;
 
 C: <apropos> apropos
 
+M: apropos valid-article? drop t ;
+
 M: apropos article-title
     search>> "Search results for “" "”" surround ;
 

basis/help/handbook/handbook.factor

@@ -51,6 +51,7 @@ $nl
 { $table
     { "General form" "Description" "Examples" }
     { { $snippet { $emphasis "foo" } "?" } "outputs a boolean" { { $link empty? } } }
+    { { $snippet { $emphasis "foo" } "!" } { "a variant of " { $snippet "foo" } " which mutates one of its arguments" } { { $link append! } } }
     { { $snippet "?" { $emphasis "foo" } } { "conditionally performs " { $snippet { $emphasis "foo" } } } { { $links ?nth } } }
     { { $snippet "<" { $emphasis "foo" } ">" } { "creates a new " { $snippet "foo" } } { { $link <array> } } }
     { { $snippet ">" { $emphasis "foo" } } { "converts the top of the stack into a " { $snippet "foo" } } { { $link >array } } }

basis/help/help.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays io io.styles kernel namespaces make
 parser prettyprint sequences words words.symbol assocs
@@ -48,6 +48,8 @@ M: predicate word-help* drop \ $predicate ;
 : all-errors ( -- seq )
     all-words [ error? ] filter sort-articles ;
 
+M: word valid-article? drop t ;
+
 M: word article-name name>> ;
 
 M: word article-title

basis/help/home/home.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays compiler.units fry hashtables help.topics io
 kernel math namespaces sequences sets help.vocabs
@@ -21,7 +21,8 @@ M: apropos add-recent-where recent-searches ;
 M: object add-recent-where f ;
 
 : $recent ( element -- )
-    first get reverse [ nl ] [ 1array $pretty-link ] interleave ;
+    first get [ valid-article? ] filter <reversed>
+    [ nl ] [ 1array $pretty-link ] interleave ;
 
 : $recent-searches ( element -- )
     drop recent-searches get [ <$link> ] map $list ;

basis/help/topics/topics.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.x
 USING: accessors arrays definitions generic assocs
 io kernel namespaces make prettyprint prettyprint.sections
@@ -38,6 +38,7 @@ SYMBOL: article-xref
 
 article-xref [ H{ } clone ] initialize
 
+GENERIC: valid-article? ( topic -- ? )
 GENERIC: article-name ( topic -- string )
 GENERIC: article-title ( topic -- string )
 GENERIC: article-content ( topic -- content )
@@ -49,6 +50,7 @@ TUPLE: article title content loc ;
 : <article> ( title content -- article )
     f \ article boa ;
 
+M: article valid-article? drop t ;
 M: article article-name title>> ;
 M: article article-title title>> ;
 M: article article-content content>> ;
@@ -61,12 +63,14 @@ M: no-article summary
 : article ( name -- article )
     articles get ?at [ no-article ] unless ;
 
+M: object valid-article? articles get key? ;
 M: object article-name article article-name ;
 M: object article-title article article-title ;
 M: object article-content article article-content ;
 M: object article-parent article-xref get at ;
 M: object set-article-parent article-xref get set-at ;
 
+M: link valid-article? name>> valid-article? ;
 M: link article-name name>> article-name ;
 M: link article-title name>> article-title ;
 M: link article-content name>> article-content ;
@@ -74,6 +78,7 @@ M: link article-parent name>> article-parent ;
 M: link set-article-parent name>> set-article-parent ;
 
 ! Special case: f help
+M: f valid-article? drop t ;
 M: f article-name drop \ f article-name ;
 M: f article-title drop \ f article-title ;
 M: f article-content drop \ f article-content ;

basis/help/vocabs/vocabs.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs classes classes.builtin
 classes.intersection classes.mixin classes.predicate
@@ -278,6 +278,8 @@ INSTANCE: vocab topic
 
 INSTANCE: vocab-link topic
 
+M: vocab-spec valid-article? drop t ;
+
 M: vocab-spec article-title vocab-name " vocabulary" append ;
 
 M: vocab-spec article-name vocab-name ;
@@ -289,6 +291,8 @@ M: vocab-spec article-parent drop "vocab-index" ;
 
 M: vocab-tag >link ;
 
+M: vocab-tag valid-article? drop t ;
+
 M: vocab-tag article-title
     name>> "Vocabularies tagged “" "”" surround ;
 
@@ -303,6 +307,8 @@ M: vocab-tag summary article-title ;
 
 M: vocab-author >link ;
 
+M: vocab-author valid-article? drop t ;
+
 M: vocab-author article-title
     name>> "Vocabularies by " prepend ;
 

basis/hints/hints.factor

@@ -3,7 +3,7 @@
 USING: accessors arrays assocs byte-arrays byte-vectors classes
 combinators definitions effects fry generic generic.single
 generic.standard hashtables io.binary io.streams.string kernel
-kernel.private math math.integers.private math.parser math.parser.private
+kernel.private math math.integers.private math.parser
 namespaces parser sbufs sequences splitting splitting.private strings
 vectors words ;
 IN: hints
@@ -52,7 +52,7 @@ M: object specializer-declaration class ;
     specializer [ specialize-quot ] when* ;
 
 : standard-method? ( method -- ? )
-    dup method-body? [
+    dup method? [
         "method-generic" word-prop standard-generic?
     ] [ drop f ] if ;
 
@@ -130,10 +130,4 @@ M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-pr
 
 M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop
 
-\ dec>float { string } "specializer" set-word-prop
-
-\ hex>float { string } "specializer" set-word-prop
-
-\ string>integer { string fixnum } "specializer" set-word-prop
-
 \ bignum/f { { bignum bignum } { bignum fixnum } { fixnum bignum } { fixnum fixnum } } "specializer" set-word-prop

basis/html/forms/forms.factor

@@ -35,10 +35,10 @@ M: form clone
     [ [ value ] keep ] dip ; inline
 
 : from-object ( object -- )
-    [ values ] [ make-mirror ] bi* update ;
+    [ values ] [ make-mirror ] bi* assoc-union! drop ;
 
 : to-object ( destination names -- )
-    [ make-mirror ] [ values extract-keys ] bi* update ;
+    [ make-mirror ] [ values extract-keys ] bi* assoc-union! drop ;
 
 : with-each-value ( name quot -- )
     [ value ] dip '[

basis/images/tga/tga.factor

@@ -238,7 +238,7 @@ ERROR: bad-tga-unsupported ;
         ] unless
     ] ignore-errors
 
-    #! Only 24-bit uncompressed RGB and 32-bit uncompressed ARGB are supported.
+    #! Only 24-bit uncompressed BGR and 32-bit uncompressed BGRA are supported.
     #! Other formats would need to be converted to work within the image class.
     map-type 0 = [ bad-tga-unsupported ] unless 
     image-type 2 = [ bad-tga-unsupported ] unless
@@ -247,7 +247,7 @@ ERROR: bad-tga-unsupported ;
     
     #! Create image instance
     image new
-    alpha-bits 0 = [ RGB ] [ ARGB ] if >>component-order
+    alpha-bits 0 = [ BGR ] [ BGRA ] if >>component-order
     { image-width image-height }       >>dim
     pixel-order 0 =                    >>upside-down?
     image-data                         >>bitmap
@@ -259,7 +259,7 @@ M: tga-image stream>image
 M: tga-image image>stream
     drop
     [
-        component-order>> { RGB ARGB } member? [ bad-tga-unsupported ] unless
+        component-order>> { BGRA BGRA } member? [ bad-tga-unsupported ] unless
     ] keep
 
     B{ 0 }         write #! id-length
@@ -272,15 +272,15 @@ M: tga-image image>stream
         [ dim>> second 2 >le write ]
         [ component-order>>
           {
-              {  RGB [ B{ 24 } write ] }
+              {  BGR [ B{ 24 } write ] }
-              { ARGB [ B{ 32 } write ] }
+              { BGRA [ B{ 32 } write ] }
           } case
         ]
         [
             dup component-order>>
             {
-                {  RGB [ 0 ] }
+                {  BGR [ 0 ] }
-                { ARGB [ 8 ] }
+                { BGRA [ 8 ] }
             } case swap
             upside-down?>> [ 0 ] [ 2 ] if 3 shift bitor
             1 >le write

basis/io/directories/directories-docs.factor

@@ -142,11 +142,6 @@ ARTICLE: "io.directories.create" "Creating directories"
 } ;
 
 ARTICLE: "delete-move-copy" "Deleting, moving, and copying files"
-"Operations for deleting and copying files come in two forms:"
-{ $list
-    { "Words named " { $snippet { $emphasis "operation" } "-file" } " which work on regular files only." }
-    { "Words named " { $snippet { $emphasis "operation" } "-tree" } " works on directory trees recursively, and also accepts regular files." }
-}
 "The operations for moving and copying files come in three flavors:"
 { $list
     { "A word named " { $snippet { $emphasis "operation" } } " which takes a source and destination path." }
@@ -175,7 +170,7 @@ $nl
 "On most operating systems, files can only be moved within the same file system. To move files between file systems, use " { $link copy-file } " followed by " { $link delete-file } " on the old name." ;
 
 ARTICLE: "io.directories" "Directory manipulation"
-"The " { $vocab-link "io.directories" } " vocabulary defines words for inspecting and manipulating directory trees."
+"The " { $vocab-link "io.directories" } " vocabulary defines words for inspecting and manipulating directories."
 { $subsections
     home
     "current-directory"

basis/io/directories/hierarchy/hierarchy-docs.factor

@@ -26,6 +26,11 @@ HELP: copy-trees-into
 ARTICLE: "io.directories.hierarchy" "Directory hierarchy manipulation"
 "The " { $vocab-link "io.directories.hierarchy" } " vocabulary defines words for operating on directory hierarchies recursively."
 $nl
+"There is a naming scheme used by " { $vocab-link "io.directories" } " and " { $vocab-link "io.directories.hierarchy" } ". Operations for deleting and copying files come in two forms:"
+{ $list
+    { "Words named " { $snippet { $emphasis "operation" } "-file" } " which work on regular files only." }
+    { "Words named " { $snippet { $emphasis "operation" } "-tree" } " works on directory trees recursively, and also accepts regular files." }
+}
 "Deleting directory trees recursively:"
 { $subsections delete-tree }
 "Copying directory trees recursively:"

basis/io/launcher/unix/unix-tests.factor

@@ -3,7 +3,7 @@ USING: io.files io.files.temp io.directories io.pathnames
 tools.test io.launcher arrays io namespaces continuations math
 io.encodings.binary io.encodings.ascii accessors kernel
 sequences io.encodings.utf8 destructors io.streams.duplex locals
-concurrency.promises threads unix.process calendar ;
+concurrency.promises threads unix.process calendar unix ;
 
 [ ] [
     [ "launcher-test-1" temp-file delete-file ] ignore-errors
@@ -134,7 +134,7 @@ concurrency.promises threads unix.process calendar ;
             [ p fulfill ] [ wait-for-process s fulfill ] bi
         ] in-thread
 
-        p 1 seconds ?promise-timeout handle>> 9 kill drop
+        p 1 seconds ?promise-timeout handle>> kill-process*
         s ?promise 0 =
     ]
 ] unit-test

basis/io/launcher/unix/unix.factor

@@ -91,7 +91,7 @@ M: unix kill-process* ( pid -- )
 TUPLE: signal n ;
 
 : code>status ( code -- obj )
-    dup WIFEXITED [ WEXITSTATUS ] [ WTERMSIG signal boa ] if ;
+    dup WIFSIGNALED [ WTERMSIG signal boa ] [ WEXITSTATUS ] if ;
 
 M: unix wait-for-processes ( -- ? )
     0 <int> -1 over WNOHANG waitpid

basis/io/launcher/windows/windows.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
+! Copyright (C) 2007, 2010 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays continuations io
 io.backend.windows io.pipes.windows.nt io.pathnames libc
@@ -6,7 +6,8 @@ io.ports windows.types math windows.kernel32 namespaces make
 io.launcher kernel sequences windows.errors splitting system
 threads init strings combinators io.backend accessors
 concurrency.flags io.files assocs io.files.private windows
-destructors classes classes.struct specialized-arrays ;
+destructors classes classes.struct specialized-arrays
+debugger prettyprint ;
 SPECIALIZED-ARRAY: ushort
 SPECIALIZED-ARRAY: void*
 IN: io.launcher.windows
@@ -127,7 +128,16 @@ M: wince fill-redirection 2drop ;
 M: windows current-process-handle ( -- handle )
     GetCurrentProcessId ;
 
+ERROR: launch-error process error ;
+
+M: launch-error error.
+    "Launching failed with error:" print
+    dup error>> error. nl
+    "Launch descriptor:" print nl
+    process>> . ;
+
 M: windows run-process* ( process -- handle )
+    [
         [
             current-directory get absolute-path cd
     
@@ -135,7 +145,8 @@ M: windows run-process* ( process -- handle )
             [ fill-redirection ] keep
             dup call-CreateProcess
             lpProcessInformation>>
-    ] with-destructors ;
+        ] with-destructors
+    ] [ launch-error ] recover ;
 
 M: windows kill-process* ( handle -- )
     hProcess>> 255 TerminateProcess win32-error=0/f ;

basis/io/styles/styles-docs.factor

@@ -204,7 +204,7 @@ HELP: foreground
 { $description "Character style. An instance of " { $link color } ". See " { $link "colors" } "." } 
 { $examples
     { $code
-        "10 ["
+        "10 iota ["
             "    \"Hello world\\n\""
             "    swap 10 / 1 <gray> foreground associate format"
         "] each"
@@ -215,9 +215,9 @@ HELP: background
 { $description "Character style. An instance of " { $link color } ". See " { $link "colors" } "." }
 { $examples
     { $code
-        "10 ["
+        "10 iota ["
             "    \"Hello world\\n\""
-            "    swap 10 / 1 1 over - over 1 <rgba>"
+            "    swap 10 / 1 over - over 1 <rgba>"
             "    background associate format nl"
         "] each"
     }

basis/json/json.factor

@@ -1,7 +1,15 @@
+USING: kernel vocabs.loader ;
 IN: json
-USE: vocabs.loader
 
 SINGLETON: json-null
 
+: if-json-null ( x if-null else -- )
+    [ dup json-null? ]
+    [ [ drop ] prepose ]
+    [ ] tri* if ; inline
+
+: when-json-null ( x if-null -- ) [ ] if-json-null ; inline
+: unless-json-null ( x else -- ) [ ] swap if-json-null ; inline
+
 "json.reader" require
 "json.writer" require

basis/json/reader/reader.factor

@@ -1,18 +1,13 @@
 ! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs combinators io io.streams.string json
-kernel math math.parser prettyprint
+kernel math math.parser prettyprint sequences strings vectors ;
-sequences strings vectors ;
 IN: json.reader
 
 <PRIVATE
 : value ( char -- num char )
     1string " \t\r\n,:}]" read-until
-    [
+    [ append string>number ] dip ;
-        append
-        [ string>float ]
-        [ [ "eE." index ] any? [ >integer ] unless ] bi
-    ] dip ;
 
 DEFER: j-string
 

basis/libc/libc.factor

@@ -9,8 +9,14 @@ IN: libc
 : errno ( -- int )
     int "factor" "err_no" { } alien-invoke ;
 
+: set-errno ( int -- )
+    void "factor" "set_err_no" { int } alien-invoke ;
+
 : clear-errno ( -- )
-    void "factor" "clear_err_no" { } alien-invoke ;
+    0 set-errno ;
+
+: preserve-errno ( quot -- )
+    errno [ call ] dip set-errno ; inline
 
 <PRIVATE
 

basis/listener/listener.factor

@@ -48,7 +48,7 @@ SYMBOL: error-hook
 
 : call-error-hook ( error -- )
     error-continuation get error-hook get
-    call( error continuation -- ) ;
+    call( continuation error -- ) ;
 
 [ drop print-error-and-restarts ] error-hook set-global
 
@@ -131,7 +131,6 @@ SYMBOL: interactive-vocabs
     "arrays"
     "assocs"
     "combinators"
-    "compiler"
     "compiler.errors"
     "compiler.units"
     "continuations"
@@ -173,6 +172,7 @@ SYMBOL: interactive-vocabs
     "tools.test"
     "tools.threads"
     "tools.time"
+    "tools.walker"
     "vocabs"
     "vocabs.loader"
     "vocabs.refresh"

basis/locals/definitions/definitions.factor

@@ -24,7 +24,7 @@ M: lambda-macro definition
 M: lambda-macro reset-word
     [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
 
-INTERSECTION: lambda-method method-body lambda-word ;
+INTERSECTION: lambda-method method lambda-word ;
 
 M: lambda-method definer drop \ M:: \ ; ;
 

basis/locals/locals-docs.factor

@@ -14,9 +14,9 @@ HELP: [let
 
 HELP: :>
 { $syntax ":> var" ":> var!" ":> ( var-1 var-2 ... )" }
-{ $description "Binds one or more new lexical variables. In the " { $snippet ":> var" } " form, the value on the top of the datastack to a new lexical variable named " { $snippet "var" } " and scoped to the enclosing quotation, " { $link POSTPONE: [let } " form, or " { $link POSTPONE: :: } " definition."
+{ $description "Binds one or more new lexical variables. In the " { $snippet ":> var" } " form, the value on the top of the datastack is bound to a new lexical variable named " { $snippet "var" } " and is scoped to the enclosing quotation, " { $link POSTPONE: [let } " form, or " { $link POSTPONE: :: } " definition."
 $nl
-"The " { $snippet ":> ( var-1 ... )" } " form binds multiple variables to the top values off the datastack in left to right order. These two snippets have the same effect:"
+"The " { $snippet ":> ( var-1 ... )" } " form binds multiple variables to the top values of the datastack in right to left order, with the last variable bound to the top of the datastack. These two snippets have the same effect:"
 { $code ":> c :> b :> a" }
 { $code ":> ( a b c )" }
 $nl
@@ -112,7 +112,7 @@ $nl
 $nl
 
 { $heading "Mutable bindings" }
-"This next example demonstrates closures and mutable variable bindings. The " { $snippet "make-counter" } " word outputs a tuple containing a pair of quotations that respectively increment and decrement an internal counter in the mutable " { $snippet "value" } " variable and then return the new value. The quotations close over the counter, so each invocation of the word gives new quotations with a new internal counter."
+"This next example demonstrates closures and mutable variable bindings. The " { $snippet "<counter>" } " word outputs a tuple containing a pair of quotations that respectively increment and decrement an internal counter in the mutable " { $snippet "value" } " variable and then return the new value. The quotations close over the counter, so each invocation of the word gives new quotations with a new internal counter."
 { $example
 """USING: locals kernel math ;
 IN: scratchpad

basis/macros/macros-tests.factor

@@ -1,6 +1,7 @@
-IN: macros.tests
 USING: tools.test macros math kernel arrays
-vectors io.streams.string prettyprint parser eval see ;
+vectors io.streams.string prettyprint parser eval see
+stack-checker compiler.units definitions vocabs ;
+IN: macros.tests
 
 MACRO: see-test ( a b -- quot ) + ;
 
@@ -19,7 +20,21 @@ unit-test
 
 [ f ] [ \ see-test macro? ] unit-test
 
-[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test
+[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ;" eval( -- ) ] unit-test
+[ ] [ "USING: macros kernel ; IN: hanging-macro : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test
+
+[ ] [ [ "hanging-macro" forget-vocab ] with-compilation-unit ] unit-test
 
 [ ] [ "IN: macros.tests USE: macros MACRO: foo ( -- x ) [ ] ;" eval( -- ) ] unit-test
     [ "IN: macros.tests USE: macros MACRO: foo ( -- x ) [ ] ; inline" eval( -- ) ] must-fail
+
+! The macro expander code should infer
+MACRO: bad-macro ( a -- b ) 1 2 3 [ ] ;
+
+! Must fail twice, and not memoize a bad result
+[ [ 0 bad-macro ] call ] must-fail
+[ [ 0 bad-macro ] call ] must-fail
+
+[ [ 0 bad-macro ] infer ] must-fail
+
+[ ] [ [ \ bad-macro forget ] with-compilation-unit ] unit-test

basis/macros/macros.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: parser kernel sequences words effects combinators assocs
-definitions quotations namespaces memoize accessors
+definitions quotations namespaces memoize accessors fry
 compiler.units ;
 IN: macros
 
@@ -14,7 +14,11 @@ PRIVATE>
 
 : define-macro ( word definition effect -- )
     real-macro-effect {
-        [ [ memoize-quot [ call ] append ] keep define-declared ]
+        [
+            [ '[ _ _ call-effect ] ] keep
+            [ memoize-quot '[ @ call ] ] keep
+            define-declared
+        ]
         [ drop "macro" set-word-prop ]
         [ 2drop changed-effect ]
     } 3cleave ;

basis/math/functions/functions.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel math.constants math.private math.bits
-math.libm combinators math.order sequences ;
+math.libm combinators fry math.order sequences ;
 IN: math.functions
 
 : >fraction ( a/b -- a b )
@@ -13,12 +13,13 @@ IN: math.functions
 GENERIC: sqrt ( x -- y ) foldable
 
 M: real sqrt
-    >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; inline
+    >float dup 0.0 <
+    [ neg fsqrt [ 0.0 ] dip rect> ] [ fsqrt ] if ; inline
 
 : factor-2s ( n -- r s )
     #! factor an integer into 2^r * s
     dup 0 = [ 1 ] [
-        0 swap [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while
+        [ 0 ] dip [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while
     ] if ; inline
 
 <PRIVATE
@@ -26,13 +27,13 @@ M: real sqrt
 GENERIC# ^n 1 ( z w -- z^w ) foldable
 
 : (^n) ( z w -- z^w )
-    make-bits 1 [ [ dupd * ] when [ sq ] dip ] reduce nip ; inline
+    make-bits 1 [ [ over * ] when [ sq ] dip ] reduce nip ; inline
 
 M: integer ^n
     [ factor-2s ] dip [ (^n) ] keep rot * shift ;
 
 M: ratio ^n
-    [ >fraction ] dip [ ^n ] curry bi@ / ;
+    [ >fraction ] dip '[ _ ^n ] bi@ / ;
 
 M: float ^n (^n) ;
 
@@ -62,7 +63,7 @@ M: float exp fexp ; inline
 
 M: real exp >float exp ; inline
 
-M: complex exp >rect swap exp swap polar> ; inline
+M: complex exp >rect [ exp ] dip polar> ; inline
 
 <PRIVATE
 
@@ -84,10 +85,9 @@ M: complex exp >rect swap exp swap polar> ; inline
 : 0^ ( x -- z )
     [ 0/0. ] [ 0 < 1/0. 0 ? ] if-zero ; inline
 
-: (^mod) ( n x y -- z )
+: (^mod) ( x y n -- z )
-    make-bits 1 [
+    [ make-bits 1 ] dip dup
-        [ dupd * pick mod ] when [ sq over mod ] dip
+    '[ [ over * _ mod ] when [ sq _ mod ] dip ] reduce nip ; inline
-    ] reduce 2nip ; inline
 
 : (gcd) ( b a x y -- a d )
     over zero? [
@@ -125,11 +125,8 @@ ERROR: non-trivial-divisor n ;
     [ non-trivial-divisor ] if ; foldable
 
 : ^mod ( x y n -- z )
-    over 0 < [
+    over 0 <
-        [ [ neg ] dip ^mod ] keep mod-inv
+    [ [ [ neg ] dip ^mod ] keep mod-inv ] [ (^mod) ] if ; foldable
-    ] [
-        -rot (^mod)
-    ] if ; foldable
 
 GENERIC: absq ( x -- y ) foldable
 

basis/math/polynomials/polynomials-docs.factor

@@ -11,6 +11,7 @@ ARTICLE: "polynomials" "Polynomials"
     p-
     p*
     p-sq
+    p^
     powers
     n*p
     p/mod
@@ -74,6 +75,11 @@ HELP: p-sq
 { $description "Squares a polynomial." }
 { $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 2 0 } p-sq ." "{ 1 4 4 0 0 }" } } ;
 
+HELP: p^
+{ $values { "p" "a polynomial" } { "n" number } { "p^n" "a polynomial" } }
+{ $description "Computes " { $snippet "p" } " to the power of " { $snippet "n" } "." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 2 0 } 3 p^ ." "{ 1 6 12 8 0 0 0 }" } } ;
+
 HELP: p/mod
 { $values { "p" "a polynomial" } { "q" "a polynomial" } { "z" "a polynomial" } { "w" "a polynomial" } }
 { $description "Computes to quotient " { $snippet "z" } " and remainder " { $snippet "w" } " of dividing " { $snippet "p" } " by " { $snippet "q" } "." }

basis/math/polynomials/polynomials-tests.factor

@@ -15,6 +15,9 @@ IN: math.polynomials.tests
 [ { 0 0 0 } ] [ { 0 0 0 } { 0 0 0 } p- ] unit-test
 [ { 0 0 0 } ] [ 4 { 0 0 0 } n*p ] unit-test
 [ { 4 8 0 12 } ] [ 4 { 1 2 0 3 } n*p ] unit-test
+[ { 1 4 4 0 0 } ] [ { 1 2 0 } p-sq ] unit-test
+[ { 1 6 12 8 0 0 0 } ] [ { 1 2 0 } 3 p^ ] unit-test
+[ { 1 } ] [ { 1 2 0 } 0 p^ ] unit-test
 [ { 1 4 7 6 0 0 0 0 0 } ] [ { 1 2 3 0 0 0 } { 1 2 0 0 } p* ] unit-test
 [ V{ 7 -2 1 } V{ -20 0 0 } ] [ { 1 1 1 1 } { 3 1 } p/mod ] unit-test
 [ V{ 0 0 } V{ 1 1 } ] [ { 1 1 } { 1 1 1 1 } p/mod ] unit-test

basis/math/polynomials/polynomials.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel make math math.order math.vectors sequences
-    splitting vectors macros combinators ;
+splitting vectors macros combinators math.bits ;
 IN: math.polynomials
 
 <PRIVATE
@@ -38,6 +38,16 @@ PRIVATE>
 : p-sq ( p -- p^2 )
     dup p* ;
 
+ERROR: negative-power-polynomial p n ;
+
+: (p^) ( p n  -- p^n )
+    make-bits { 1 } [ [ over p* ] when [ p-sq ] dip ] reduce nip ;
+
+: p^ ( p n -- p^n )
+    dup 0 >=
+    [ (p^) ]
+    [ negative-power-polynomial ] if ;
+
 <PRIVATE
 
 : p/mod-setup ( p p -- p p n )

basis/math/quaternions/quaternions-docs.factor

@@ -4,17 +4,17 @@ IN: math.quaternions
 HELP: q+
 { $values { "u" "a quaternion" } { "v" "a quaternion" } { "u+v" "a quaternion" } }
 { $description "Add quaternions." }
-{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q+ ." "{ C{ 0 1 } 1 }" } } ;
+{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 0 1 0 0 } { 0 0 1 0 } q+ ." "{ 0 1 1 0 }" } } ;
 
 HELP: q-
 { $values { "u" "a quaternion" } { "v" "a quaternion" } { "u-v" "a quaternion" } }
 { $description "Subtract quaternions." }
-{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q- ." "{ C{ 0 1 } -1 }" } } ;
+{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 0 1 0 0 } { 0 0 1 0 } q- ." "{ 0 1 -1 0 }" } } ;
 
 HELP: q*
 { $values { "u" "a quaternion" } { "v" "a quaternion" } { "u*v" "a quaternion" } }
 { $description "Multiply quaternions." }
-{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q* ." "{ 0 C{ 0 1 } }" } } ;
+{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 0 1 0 0 } { 0 0 1 0 } q* ." "{ 0 0 0 1 }" } } ;
 
 HELP: qconjugate
 { $values { "u" "a quaternion" } { "u'" "a quaternion" } }
@@ -27,28 +27,17 @@ HELP: qrecip
 HELP: q/
 { $values { "u" "a quaternion" } { "v" "a quaternion" } { "u/v" "a quaternion" } }
 { $description "Divide quaternions." }
-{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 0 C{ 0 1 } } { 0 1 } q/ ." "{ C{ 0 1 } 0 }" } } ;
+{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 0 0 0 1 } { 0 0 1 0 } q/ ." "{ 0 1 0 0 }" } } ;
 
 HELP: q*n
-{ $values { "q" "a quaternion" } { "n" number } { "q" "a quaternion" } }
+{ $values { "q" "a quaternion" } { "n" real } { "q" "a quaternion" } }
-{ $description "Multiplies each element of " { $snippet "q" } " by " { $snippet "n" } "." }
+{ $description "Multiplies each element of " { $snippet "q" } " by real value " { $snippet "n" } "." }
-{ $notes "You will get the wrong result if you try to multiply a quaternion by a complex number on the right using " { $link v*n } ". Use this word instead."
+{ $notes "To multiply a quaternion with a complex value, use " { $link c>q } " " { $link q* } "." } ;
-    $nl "Note that " { $link v*n } " with a quaternion and a real is okay." } ;
 
 HELP: c>q
 { $values { "c" number } { "q" "a quaternion" } }
 { $description "Turn a complex number into a quaternion." }
-{ $examples { $example "USING: math.quaternions prettyprint ;" "C{ 0 1 } c>q ." "{ C{ 0 1 } 0 }" } } ;
+{ $examples { $example "USING: math.quaternions prettyprint ;" "C{ 0 1 } c>q ." "{ 0 1 0 0 }" } } ;
-
-HELP: v>q
-{ $values { "v" vector } { "q" "a quaternion" } }
-{ $description "Turn a 3-vector into a quaternion with real part 0." }
-{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 1 0 0 } v>q ." "{ C{ 0 1 } 0 }" } } ;
-
-HELP: q>v
-{ $values { "q" "a quaternion" } { "v" vector } }
-{ $description "Get the vector part of a quaternion, discarding the real part." }
-{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } q>v ." "{ 1 0 0 }" } } ;
 
 HELP: euler
 { $values { "phi" number } { "theta" number } { "psi" number } { "q" "a quaternion" } }

basis/math/quaternions/quaternions-tests.factor

@@ -2,6 +2,12 @@ IN: math.quaternions.tests
 USING: tools.test math.quaternions kernel math.vectors
 math.constants ;
 
+CONSTANT: q0 { 0 0 0 0 }
+CONSTANT: q1 { 1 0 0 0 }
+CONSTANT: qi { 0 1 0 0 }
+CONSTANT: qj { 0 0 1 0 }
+CONSTANT: qk { 0 0 0 1 }
+
 [ 1.0 ] [ qi norm ] unit-test
 [ 1.0 ] [ qj norm ] unit-test
 [ 1.0 ] [ qk norm ] unit-test
@@ -10,18 +16,13 @@ math.constants ;
 [ t ] [ qi qj q* qk = ] unit-test
 [ t ] [ qj qk q* qi = ] unit-test
 [ t ] [ qk qi q* qj = ] unit-test
-[ t ] [ qi qi q* q1 v+ q0 = ] unit-test
+[ t ] [ qi qi q* q1 q+ q0 = ] unit-test
-[ t ] [ qj qj q* q1 v+ q0 = ] unit-test
+[ t ] [ qj qj q* q1 q+ q0 = ] unit-test
-[ t ] [ qk qk q* q1 v+ q0 = ] unit-test
+[ t ] [ qk qk q* q1 q+ q0 = ] unit-test
-[ t ] [ qi qj qk q* q* q1 v+ q0 = ] unit-test
+[ t ] [ qi qj qk q* q* q1 q+ q0 = ] unit-test
-[ t ] [ C{ 0 1 } qj n*v qk = ] unit-test
-[ t ] [ qj C{ 0 1 } q*n qk v+ q0 = ] unit-test
 [ t ] [ qk qj q/ qi = ] unit-test
 [ t ] [ qi qk q/ qj = ] unit-test
 [ t ] [ qj qi q/ qk = ] unit-test
-[ t ] [ qi q>v v>q qi = ] unit-test
-[ t ] [ qj q>v v>q qj = ] unit-test
-[ t ] [ qk q>v v>q qk = ] unit-test
 [ t ] [ 1 c>q q1 = ] unit-test
 [ t ] [ C{ 0 1 } c>q qi = ] unit-test
 [ t ] [ qi qi q+ qi 2 q*n = ] unit-test

basis/math/quaternions/quaternions.factor

@@ -1,72 +1,76 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.functions math.vectors sequences ;
+USING: arrays combinators kernel locals math math.functions
+math.libm math.order math.vectors sequences ;
 IN: math.quaternions
 
-! Everybody's favorite non-commutative skew field, the quaternions!
+: q+ ( u v -- u+v )
+    v+ ; inline
 
-! Quaternions are represented as pairs of complex numbers, using the
+: q- ( u v -- u-v )
-! identity: (a+bi)+(c+di)j = a+bi+cj+dk.
+    v- ; inline
 
 <PRIVATE
 
-: ** ( x y -- z ) conjugate * ; inline
+GENERIC: (q*sign) ( q -- q' )
-
+M: object (q*sign) { -1 1 1 1 } v* ; inline
-: 2q ( u v -- u' u'' v' v'' ) [ first2 ] bi@ ; inline
-
-: q*a ( u v -- a ) 2q swapd ** [ * ] dip - ; inline
-
-: q*b ( u v -- b ) 2q [ ** swap ] dip * + ; inline
 
 PRIVATE>
 
-: q+ ( u v -- u+v )
-    v+ ;
-
-: q- ( u v -- u-v )
-    v- ;
-
 : q* ( u v -- u*v )
-    [ q*a ] [ q*b ] 2bi 2array ;
+    {
+        [ [ { 1 0 0 0 } vshuffle ] [ { 1 1 2 3 } vshuffle ] bi* v*    ]
+        [ [ { 2 1 2 3 } vshuffle ] [ { 2 0 0 0 } vshuffle ] bi* v* v+ ]
+        [ [ { 3 2 3 1 } vshuffle ] [ { 3 3 1 2 } vshuffle ] bi* v* v+ ]
+        [ [ { 0 3 1 2 } vshuffle ] [ { 0 2 3 1 } vshuffle ] bi* v* v- ]
+    } 2cleave (q*sign) ; inline
 
-: qconjugate ( u -- u' )
+GENERIC: qconjugate ( u -- u' )
-    first2 [ conjugate ] [ neg  ] bi* 2array ;
+M: object qconjugate ( u -- u' )
+    { 1 -1 -1 -1 } v* ; inline
 
 : qrecip ( u -- 1/u )
-    qconjugate dup norm-sq v/n ;
+    qconjugate dup norm-sq v/n ; inline
 
 : q/ ( u v -- u/v )
-    qrecip q* ;
+    qrecip q* ; inline
+
+: n*q ( q n -- q )
+    v*n ; inline
 
 : q*n ( q n -- q )
-    conjugate v*n ;
+    v*n ; inline
+
+: n>q ( n -- q )
+    0 0 0 4array ; inline
+
+: n>q-like ( c exemplar -- q )
+    [ 0 0 0 ] dip 4sequence ; inline
 
 : c>q ( c -- q )
-    0 2array ;
+    >rect 0 0 4array ; inline
 
-: v>q ( v -- q )
+: c>q-like ( c exemplar -- q )
-    first3 rect> [ 0 swap rect> ] dip 2array ;
+    [ >rect 0 0 ] dip 4sequence ; inline
-
-: q>v ( q -- v )
-    first2 [ imaginary-part ] dip >rect 3array ;
-
-! Zero
-CONSTANT: q0 { 0 0 }
-
-! Units
-CONSTANT: q1 { 1 0 }
-CONSTANT: qi { C{ 0 1 } 0 }
-CONSTANT: qj { 0 1 }
-CONSTANT: qk { 0 C{ 0 1 } }
 
 ! Euler angles
 
 <PRIVATE
 
-: (euler) ( theta unit -- q )
+: (euler) ( theta exemplar shuffle -- q )
-    [ -0.5 * [ cos c>q ] [ sin ] bi ] dip n*v v- ;
+    swap
+    [ 0.5 * [ fcos ] [ fsin ] bi 0.0 0.0 ] [ call ] [ 4sequence ] tri* ; inline
 
 PRIVATE>
 
+: euler-like ( phi theta psi exemplar -- q )
+    [ [ ] (euler) ] [ [ swapd ] (euler) ] [ [ rot ] (euler) ] tri-curry tri* q* q* ; inline
+
 : euler ( phi theta psi -- q )
-  [ qi (euler) ] [ qj (euler) ] [ qk (euler) ] tri* q* q* ;
+    { } euler-like ; inline
+
+:: slerp ( q0 q1 t -- qt )
+    q0 q1 v. -1.0 1.0 clamp :> dot
+    dot facos t * :> omega
+    q1 dot q0 n*v v- normalize :> qt'
+    omega fcos q0 n*v omega fsin qt' n*v v+ ; inline

basis/math/ranges/ranges.factor

@@ -45,3 +45,5 @@ PRIVATE>
 : [1,b] ( b -- range ) 1 swap [a,b] ; inline
 
 : [0,b) ( b -- range ) 0 swap [a,b) ; inline
+
+: [1,b) ( b -- range ) 1 swap [a,b) ; inline

basis/math/ratios/ratios-tests.factor

@@ -95,13 +95,14 @@ unit-test
 [ "-10/2" string>number ]
 unit-test
 
-[ -5 ]
+[ f ]
 [ "10/-2" string>number ]
 unit-test
 
-[ 5 ]
+[ f ]
 [ "-10/-2" string>number ]
 unit-test
+
 [ "33/100" ]
 [ "66/200" string>number number>string ]
 unit-test

basis/math/statistics/statistics-docs.factor

@@ -84,7 +84,7 @@ HELP: histogram
 }
 { $description "Returns a hashtable where the keys are the elements of the sequence and the values are the number of times they appeared in that sequence." } ;
 
-HELP: histogram*
+HELP: histogram!
 { $values
     { "hashtable" hashtable } { "seq" sequence }
     { "hashtable" hashtable }
@@ -92,7 +92,7 @@ HELP: histogram*
 { $examples 
     { $example "! Count the number of times the elements of two sequences appear."
                "USING: prettyprint math.statistics ;"
-               "\"aaabc\" histogram \"aaaaaabc\" histogram* ."
+               "\"aaabc\" histogram \"aaaaaabc\" histogram! ."
                "H{ { 97 9 } { 98 2 } { 99 2 } }"
     }
 }
@@ -125,7 +125,7 @@ HELP: sequence>assoc
 }
 { $description "Iterates over a sequence, allowing elements of the sequence to be added to a newly created " { $snippet "assoc" } " according to the passed quotation." } ;
 
-HELP: sequence>assoc*
+HELP: sequence>assoc!
 { $values
     { "assoc" assoc } { "seq" sequence } { "quot" quotation }
     { "assoc" assoc }
@@ -133,7 +133,7 @@ HELP: sequence>assoc*
 { $examples 
     { $example "! Iterate over a sequence and add the counts to an existing assoc"
                "USING: assocs prettyprint math.statistics kernel ;"
-               "H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ inc-at ] sequence>assoc* ."
+               "H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ inc-at ] sequence>assoc! ."
                "H{ { 97 5 } { 98 2 } { 99 1 } }"
     }
 }
@@ -157,13 +157,13 @@ ARTICLE: "histogram" "Computing histograms"
 "Counting elements in a sequence:"
 { $subsections
     histogram
-    histogram*
+    histogram!
     sorted-histogram
 }
 "Combinators for implementing histogram:"
 { $subsections
     sequence>assoc
-    sequence>assoc*
+    sequence>assoc!
     sequence>hashtable
 } ;
 

basis/math/statistics/statistics.factor

@@ -64,7 +64,7 @@ IN: math.statistics
 
 PRIVATE>
 
-: sequence>assoc* ( assoc seq quot: ( obj assoc -- ) -- assoc )
+: sequence>assoc! ( assoc seq quot: ( obj assoc -- ) -- assoc )
     rot (sequence>assoc) ; inline
 
 : sequence>assoc ( seq quot: ( obj assoc -- ) exemplar -- assoc )
@@ -73,8 +73,8 @@ PRIVATE>
 : sequence>hashtable ( seq quot: ( obj hashtable -- ) -- hashtable )
     H{ } sequence>assoc ; inline
 
-: histogram* ( hashtable seq -- hashtable )
+: histogram! ( hashtable seq -- hashtable )
-    [ inc-at ] sequence>assoc* ;
+    [ inc-at ] sequence>assoc! ;
 
 : histogram ( seq -- hashtable )
     [ inc-at ] sequence>hashtable ;

basis/opengl/gl/gl.factor

@@ -2251,3 +2251,17 @@ CONSTANT: GL_LUMINANCE_ALPHA_INTEGER_EXT  HEX: 8D9D
 GL-FUNCTION: void glClearColorIiEXT { } ( GLint r, GLint g, GLint b, GLint a ) ;
 GL-FUNCTION: void glClearColorIuiEXT { } ( GLuint r, GLuint g, GLuint b, GLuint a ) ;
 
+! GL_EXT_texture_compression_s3tc, GL_EXT_texture_compression_dxt1
+
+CONSTANT: GL_COMPRESSED_RGB_S3TC_DXT1_EXT  HEX: 83F0
+CONSTANT: GL_COMPRESSED_RGBA_S3TC_DXT1_EXT HEX: 83F1
+CONSTANT: GL_COMPRESSED_RGBA_S3TC_DXT3_EXT HEX: 83F2
+CONSTANT: GL_COMPRESSED_RGBA_S3TC_DXT5_EXT HEX: 83F3
+
+! GL_EXT_texture_compression_latc
+
+CONSTANT: GL_COMPRESSED_LUMINANCE_LATC1_EXT              HEX: 8C70
+CONSTANT: GL_COMPRESSED_SIGNED_LUMINANCE_LATC1_EXT       HEX: 8C71
+CONSTANT: GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT        HEX: 8C72
+CONSTANT: GL_COMPRESSED_SIGNED_LUMINANCE_ALPHA_LATC2_EXT HEX: 8C73
+

basis/prettyprint/backend/backend.factor

@@ -37,7 +37,7 @@ M: parsing-word pprint*
 M: word pprint*
     [ pprint-word ] [ ?start-group ] [ ?end-group ] tri ;
 
-M: method-body pprint*
+M: method pprint*
     [
         [
             [ "M\\ " % "method-class" word-prop word-name* % ]
@@ -229,7 +229,7 @@ M: compose pprint* pprint-object ;
 
 M: wrapper pprint*
     {
-        { [ dup wrapped>> method-body? ] [ wrapped>> pprint* ] }
+        { [ dup wrapped>> method? ] [ wrapped>> pprint* ] }
         { [ dup wrapped>> word? ] [ <block \ \ pprint-word wrapped>> pprint-word block> ] }
         [ pprint-object ]
     } cond ;

basis/prettyprint/prettyprint.factor

@@ -1,10 +1,10 @@
-! Copyright (C) 2003, 2009 Slava Pestov.
+! Copyright (C) 2003, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays accessors assocs colors combinators grouping io
 io.streams.string io.styles kernel make math math.parser namespaces
 parser prettyprint.backend prettyprint.config prettyprint.custom
 prettyprint.sections quotations sequences sorting strings vocabs
-vocabs.prettyprint words sets ;
+vocabs.prettyprint words sets generic ;
 IN: prettyprint
 
 : with-use ( obj quot -- )
@@ -72,24 +72,55 @@ SYMBOL: ->
     ] [ ] make ;
 
 : remove-breakpoints ( quot pos -- quot' )
-    over quotation? [
+    1 + short cut [ (remove-breakpoints) ] bi@ [ -> ] glue ;
-        1 + short cut [ (remove-breakpoints) ] bi@
+
-        [ -> ] glue
+: optimized-frame? ( triple -- ? ) second word? ;
-    ] [
+
-        drop
+: frame-word? ( triple -- ? )
-    ] if ;
+    first word? ;
+
+: frame-word. ( triple -- )
+    first {
+        { [ dup method? ] [ "Method: " write pprint ] }
+        { [ dup word? ] [ "Word: " write pprint ] }
+        [ drop ]
+    } cond ;
+
+: optimized-frame. ( triple -- )
+    [
+        [ "(O)" write ] with-cell
+        [ frame-word. ] with-cell
+    ] with-row ;
+
+: unoptimized-frame. ( triple -- )
+    [
+        [ "(U)" write ] with-cell
+        [
+            "Quotation: " write
+            dup [ second ] [ third ] bi remove-breakpoints
+            [
+                3 nesting-limit set
+                100 length-limit set
+                pprint
+            ] with-scope
+        ] with-cell
+    ] with-row
+    dup frame-word? [
+        [
+            [ ] with-cell
+            [ frame-word. ] with-cell
+        ] with-row
+    ] [ drop ] if ;
+
+: callframe. ( triple -- )
+    dup optimized-frame?
+    [ optimized-frame. ] [ unoptimized-frame. ] if ;
 
 PRIVATE>
 
 : callstack. ( callstack -- )
-    callstack>array 2 <groups> [
+    callstack>array 3 <groups>
-        remove-breakpoints
+    { { table-gap { 5 5 } } } [ [ callframe. ] each ] tabular-output nl ;
-        [
-            3 nesting-limit set
-            100 length-limit set
-            .
-        ] with-scope
-    ] assoc-each ;
 
 : .c ( -- ) callstack callstack. ;
 

basis/random/random-docs.factor

@@ -86,7 +86,8 @@ HELP: sample
 }
 { $description "Takes " { $snippet "n" } " samples at random without replacement from a sequence. Throws an error if " { $snippet "n" } " is longer than the sequence." }
 { $examples
-    { $unchecked-example "USING: random prettyprint ; { 1 2 3 } 2 sample ."
+    { $unchecked-example "USING: random prettyprint ;"
+    "{ 1 2 3 } 2 sample ."
     "{ 3 2 }"
     }
 } ;

basis/random/random.factor

@@ -1,9 +1,10 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types assocs byte-arrays byte-vectors
+USING: accessors alien.c-types arrays assocs byte-arrays
-combinators fry io.backend io.binary kernel locals math
+byte-vectors combinators fry io.backend io.binary kernel locals
-math.bitwise math.constants math.functions math.ranges
+math math.bitwise math.constants math.functions math.order
-namespaces sequences sets summary system vocabs.loader ;
+math.ranges namespaces sequences sets summary system
+vocabs.loader ;
 IN: random
 
 SYMBOL: system-random-generator
@@ -61,29 +62,20 @@ M: sequence random
 
 : random-32 ( -- n ) random-generator get random-32* ;
 
-: randomize ( seq -- seq )
+: randomize-n-last ( seq n -- seq ) 
-    dup length [ dup 1 > ]
+    [ dup length dup ] dip - 1 max '[ dup _ > ] 
     [ [ random ] [ 1 - ] bi [ pick exchange ] keep ]
     while drop ;
 
+: randomize ( seq -- seq ) 
+    dup length randomize-n-last ;
+
 ERROR: too-many-samples seq n ;
 
-<PRIVATE
-
-:: next-sample ( length n seq hashtable -- elt )
-    n hashtable key? [
-        length n 1 + length mod seq hashtable next-sample
-    ] [
-        n hashtable conjoin
-        n seq nth
-    ] if ;
-
-PRIVATE>
-
 : sample ( seq n -- seq' )
     2dup [ length ] dip < [ too-many-samples ] when
-    swap [ length ] [ ] bi H{ } clone 
+    [ [ length iota >array ] dip [ randomize-n-last ] keep tail-slice* ]
-    '[ _ dup random _ _ next-sample ] replicate ;
+    [ drop ] 2bi nths ;
 
 : delete-random ( seq -- elt )
     [ length random-integer ] keep [ nth ] 2keep remove-nth! drop ;

basis/random/sfmt/sfmt.factor

@@ -111,7 +111,7 @@ M:: sfmt generate ( sfmt -- )
 
 : <sfmt-array> ( sfmt -- uint-array uint-4-array )
     state>>
-    [ n>> 4 * 1 swap [a,b] >uint-array ] [ seed>> ] bi
+    [ n>> 4 * [1,b] >uint-array ] [ seed>> ] bi
     [
         [
             [ -30 shift ] [ ] bi bitxor

basis/regexp/negation/negation.factor

@@ -44,7 +44,7 @@ CONSTANT: fail-state -1
     unify-final-state renumber-states box-transitions 
     [ start-state>> ]
     [ final-states>> keys first ]
-    [ nfa-table get [ transitions>> ] bi@ swap update ] tri ;
+    [ nfa-table get [ transitions>> ] bi@ swap assoc-union! drop ] tri ;
 
 : ast>dfa ( parse-tree -- minimal-dfa )
     construct-nfa disambiguate construct-dfa minimize ;

basis/see/see.factor

@@ -76,7 +76,7 @@ M: hook-generic synopsis*
         [ stack-effect. ]
     } cleave ;
 
-M: method-body synopsis*
+M: method synopsis*
     [ definer. ]
     [ "method-class" word-prop pprint-word ]
     [ "method-generic" word-prop pprint-word ] tri ;

basis/serialize/serialize.factor

@@ -236,7 +236,7 @@ SYMBOL: deserialized
 : deserialize-hashtable ( -- hashtable )
     H{ } clone
     [ intern-object ]
-    [ (deserialize) update ]
+    [ (deserialize) assoc-union! drop ]
     [ ] tri ;
 
 : copy-seq-to-tuple ( seq tuple -- )