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

basis/alien/inline/inline.factor

@@ -12,28 +12,17 @@ SYMBOL: library-is-c++
 SYMBOL: compiler-args
 SYMBOL: c-strings
 
-: (C-LIBRARY:) ( -- )
-    scan c-library set
-    V{ } clone c-strings set
-    V{ } clone compiler-args set ;
-
-: (C-LINK:) ( -- )
-    "-l" scan append compiler-args get push ;
-
-: (C-FRAMEWORK:) ( -- )
-    "-framework" scan compiler-args get '[ _ push ] bi@ ;
-
 : return-library-function-params ( -- return library function params )
     scan c-library get scan ")" parse-tokens
     [ "(" subseq? not ] filter [
         [ dup CHAR: - = [ drop CHAR: space ] when ] map
     ] 3dip ;
 
-: factor-function ( return library functions params -- )
+: factor-function ( return library function params -- )
     [ dup "const " head? [ 6 tail ] when ] 3dip
     make-function define-declared ;
 
-: (C-FUNCTION:) ( return library function params -- str )
+: c-function-string ( return library function params -- str )
     [ nip ] dip
     " " join "(" prepend ")" append 3array " " join
     library-is-c++ get [ "extern \"C\" " prepend ] when ;
@@ -53,31 +42,47 @@ SYMBOL: c-strings
     compiler-args get
     c-strings get "\n" join
     c-library get compile-to-library ;
-
-: (;C-LIBRARY) ( -- )
-    compile-library? [ compile-library ] when
-    c-library get library-path "cdecl" add-library ;
 PRIVATE>
 
-SYNTAX: C-LIBRARY: (C-LIBRARY:) ;
+: define-c-library ( name -- )
+    c-library set
+    V{ } clone c-strings set
+    V{ } clone compiler-args set ;
 
-SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
+: compile-c-library ( -- )
+    compile-library? [ compile-library ] when
+    c-library get library-path "cdecl" add-library ;
 
-SYNTAX: C-LINK: (C-LINK:) ;
+: define-c-function ( return library function params -- )
-
+    [ factor-function ] 4 nkeep c-function-string
-SYNTAX: C-FRAMEWORK: (C-FRAMEWORK:) ;
-
-SYNTAX: C-LINK/FRAMEWORK:
-    os macosx? [ (C-FRAMEWORK:) ] [ (C-LINK:) ] if ;
-
-SYNTAX: C-INCLUDE:
-    "#include " scan append c-strings get push ;
-
-SYNTAX: C-FUNCTION:
-    return-library-function-params
-    [ factor-function ]
-    4 nkeep (C-FUNCTION:)
     " {\n" append parse-here append "\n}\n" append
     c-strings get push ;
 
-SYNTAX: ;C-LIBRARY (;C-LIBRARY) ;
+: define-c-link ( str -- )
+    "-l" prepend compiler-args get push ;
+
+: define-c-framework ( str -- )
+    "-framework" swap compiler-args get '[ _ push ] bi@ ;
+
+: define-c-link/framework ( str -- )
+    os macosx? [ define-c-framework ] [ define-c-link ] if ;
+
+: define-c-include ( str -- )
+    "#include " prepend c-strings get push ;
+
+SYNTAX: C-LIBRARY: scan define-c-library ;
+
+SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
+
+SYNTAX: C-LINK: scan define-c-link ;
+
+SYNTAX: C-FRAMEWORK: scan define-c-framework ;
+
+SYNTAX: C-LINK/FRAMEWORK: scan define-c-link/framework ;
+
+SYNTAX: C-INCLUDE: scan define-c-include ;
+
+SYNTAX: C-FUNCTION:
+    return-library-function-params define-c-function ;
+
+SYNTAX: ;C-LIBRARY compile-c-library ;

basis/alien/inline/tests/tests.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2009 Jeremy Hughes.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.inline alien.inline.private io.files io.directories kernel ;
+USING: tools.test alien.inline alien.inline.private io.files
+io.directories kernel ;
 IN: alien.inline.tests
 
 C-LIBRARY: const
@@ -42,6 +43,6 @@ C-FUNCTION: char* breakme ( )
     return not a string;
 ;
 
-<< [ (;C-LIBRARY) ] must-fail >>
+<< [ compile-c-library ] must-fail >>
 
 << library-path dup exists? [ delete-file ] [ drop ] if >>

basis/bit-sets/authors.txt

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

basis/bit-sets/bit-sets-tests.factor

@@ -0,0 +1,17 @@
+IN: bit-sets.tests
+USING: bit-sets tools.test bit-arrays ;
+
+[ ?{ t f t f t f } ] [
+    ?{ t f f f t f }
+    ?{ f f t f t f } bit-set-union
+] unit-test
+
+[ ?{ f f f f t f } ] [
+    ?{ t f f f t f }
+    ?{ f f t f t f } bit-set-intersect
+] unit-test
+
+[ ?{ t f t f f f } ] [
+    ?{ t t t f f f }
+    ?{ f t f f t t } bit-set-diff
+] unit-test

basis/bit-sets/bit-sets.factor

@@ -0,0 +1,29 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences byte-arrays bit-arrays math hints ;
+IN: bit-sets
+
+<PRIVATE
+
+: bit-set-map ( seq1 seq2 quot -- seq )
+    [ 2drop length>> ]
+    [
+        [
+            [ [ length ] bi@ assert= ]
+            [ [ underlying>> ] bi@ ] 2bi
+        ] dip 2map
+    ] 3bi bit-array boa ; inline
+
+PRIVATE>
+
+: bit-set-union ( seq1 seq2 -- seq ) [ bitor ] bit-set-map ;
+
+HINTS: bit-set-union bit-array bit-array ;
+
+: bit-set-intersect ( seq1 seq2 -- seq ) [ bitand ] bit-set-map ;
+
+HINTS: bit-set-intersect bit-array bit-array ;
+
+: bit-set-diff ( seq1 seq2 -- seq ) [ bitnot bitand ] bit-set-map ;
+
+HINTS: bit-set-diff bit-array bit-array ;

basis/bit-sets/summary.txt

@@ -0,0 +1 @@
+Efficient bitwise operations on bit arrays

basis/compiler/cfg/branch-folding/branch-folding-tests.factor

@@ -1,8 +1,8 @@
 IN: compiler.cfg.branch-folding.tests
 USING: compiler.cfg.branch-folding compiler.cfg.instructions
 compiler.cfg compiler.cfg.registers compiler.cfg.debugger
-arrays compiler.cfg.phi-elimination
+arrays compiler.cfg.phi-elimination compiler.cfg.dce
-compiler.cfg.predecessors kernel accessors
+compiler.cfg.predecessors kernel accessors assocs
 sequences classes namespaces tools.test cpu.architecture ;
 
 V{ T{ ##branch } } 0 test-bb
@@ -41,4 +41,45 @@ test-diamond
 [ t ] [ 1 get successors>> first 3 get eq? ] unit-test
 
 [ T{ ##copy f V int-regs 3 V int-regs 2 } ] [ 3 get instructions>> second ] unit-test
-[ 2 ] [ 4 get instructions>> length ] unit-test
+[ 2 ] [ 4 get instructions>> length ] unit-test
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f V int-regs 1 D 1 }
+    T{ ##compare-branch f V int-regs 1 V int-regs 1 cc< }
+} 1 test-bb
+
+V{
+    T{ ##copy f V int-regs 2 V int-regs 0 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##phi f V int-regs 3 V{ } }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##replace f V int-regs 3 D 0 }
+    T{ ##return }
+} 4 test-bb
+
+1 get V int-regs 1 2array
+2 get V int-regs 0 2array 2array 3 get instructions>> first (>>inputs)
+
+test-diamond
+
+[ ] [
+    cfg new 0 get >>entry
+    compute-predecessors
+    fold-branches
+    compute-predecessors
+    eliminate-dead-code
+    drop
+] unit-test
+
+[ 1 ] [ 3 get instructions>> first inputs>> assoc-size ] unit-test

basis/compiler/cfg/gc-checks/gc-checks.factor

@@ -1,17 +1,13 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences assocs
-cpu.architecture compiler.cfg.rpo
+compiler.cfg.rpo compiler.cfg.instructions
-compiler.cfg.liveness compiler.cfg.instructions
 compiler.cfg.hats ;
 IN: compiler.cfg.gc-checks
 
 : gc? ( bb -- ? )
     instructions>> [ ##allocation? ] any? ;
 
-: object-pointer-regs ( basic-block -- vregs )
-    live-in keys [ reg-class>> int-regs eq? ] filter ;
-
 : insert-gc-check ( basic-block -- )
     dup gc? [
         [ i i f f \ ##gc new-insn prefix ] change-instructions drop

basis/compiler/cfg/predecessors/predecessors.factor

@@ -1,13 +1,27 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences compiler.cfg.rpo ;
+USING: kernel accessors combinators fry sequences assocs compiler.cfg.rpo
+compiler.cfg.instructions ;
 IN: compiler.cfg.predecessors
 
-: predecessors-step ( bb -- )
+: update-predecessors ( bb -- )
     dup successors>> [ predecessors>> push ] with each ;
 
+: update-phi ( bb ##phi -- )
+    [
+        swap predecessors>>
+        '[ drop _ memq? ] assoc-filter
+    ] change-inputs drop ;
+
+: update-phis ( bb -- )
+    dup instructions>> [
+        dup ##phi? [ update-phi ] [ 2drop ] if
+    ] with each ;
+
 : compute-predecessors ( cfg -- cfg' )
-    [ [ V{ } clone >>predecessors drop ] each-basic-block ]
+    {
-    [ [ predecessors-step ] each-basic-block ]
+        [ [ V{ } clone >>predecessors drop ] each-basic-block ]
-    [ ]
+        [ [ update-predecessors ] each-basic-block ]
-    tri ;
+        [ [ update-phis ] each-basic-block ]
+        [ ]
+    } cleave ;

basis/compiler/cfg/value-numbering/rewrite/rewrite.factor

@@ -70,21 +70,25 @@ M: ##compare-imm-branch rewrite
         dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when
     ] when ;
 
-: flip-comparison? ( insn -- ? )
+: >compare-imm ( insn swap? -- insn' )
-    dup cc>> cc= eq? [ src1>> vreg>expr constant-expr? ] [ drop f ] if ;
+    [
-
+        {
-: flip-comparison ( insn -- insn' )
+            [ dst>> ]
-    [ dst>> ]
+            [ src1>> ]
-    [ src2>> ]
+            [ src2>> ]
-    [ src1>> vreg>constant ] tri
+            [ cc>> ]
-    cc= i \ ##compare-imm new-insn ;
+        } cleave
+    ] dip [ [ swap ] [ ] bi* ] when
+    [ vreg>constant ] dip
+    i \ ##compare-imm new-insn ; inline
 
 M: ##compare rewrite
-    dup flip-comparison? [
+    dup [ src1>> ] [ src2>> ] bi
-        flip-comparison
+    [ vreg>expr constant-expr? ] bi@ 2array {
-        dup number-values
+        { { f t } [ f >compare-imm ] }
-        rewrite
+        { { t f } [ t >compare-imm ] }
-    ] when ;
+        [ drop ]
+    } case ;
 
 : rewrite-redundant-comparison? ( insn -- ? )
     {

basis/math/matrices/matrices.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays columns kernel math math.bits
+USING: accessors arrays columns kernel locals math math.bits
-math.order math.vectors sequences sequences.private fry ;
+math.functions math.order math.vectors sequences
+sequences.private fry ;
 IN: math.matrices
 
 ! Matrices
@@ -12,6 +13,70 @@ IN: math.matrices
     #! Make a nxn identity matrix.
     dup [ [ = 1 0 ? ] with map ] curry map ;
 
+:: rotation-matrix3 ( axis theta -- matrix )
+    theta cos :> c
+    theta sin :> s
+    axis first3 :> z :> y :> x
+    x sq 1.0 x sq - c * +     x y * 1.0 c - * z s * -   x z * 1.0 c - * y s * + 3array
+    x y * 1.0 c - * z s * +   y sq 1.0 y sq - c * +     y z * 1.0 c - * x s * - 3array
+    x z * 1.0 c - * y s * -   y z * 1.0 c - * x s * +   z sq 1.0 z sq - c * +   3array
+    3array ;
+
+:: rotation-matrix4 ( axis theta -- matrix )
+    theta cos :> c
+    theta sin :> s
+    axis first3 :> z :> y :> x
+    x sq 1.0 x sq - c * +     x y * 1.0 c - * z s * -   x z * 1.0 c - * y s * +   0 4array
+    x y * 1.0 c - * z s * +   y sq 1.0 y sq - c * +     y z * 1.0 c - * x s * -   0 4array
+    x z * 1.0 c - * y s * -   y z * 1.0 c - * x s * +   z sq 1.0 z sq - c * +     0 4array
+    { 0.0 0.0 0.0 1.0 } 4array ;
+
+:: translation-matrix4 ( offset -- matrix )
+    offset first3 :> z :> y :> x
+    {
+        { 1.0 0.0 0.0 x   }
+        { 0.0 1.0 0.0 y   }
+        { 0.0 0.0 1.0 z   }
+        { 0.0 0.0 0.0 1.0 }
+    } ;
+
+: >scale-factors ( number/sequence -- x y z )
+    dup number? [ dup dup ] [ first3 ] if ;
+
+:: scale-matrix3 ( factors -- matrix )
+    factors >scale-factors :> z :> y :> x
+    {
+        { x   0.0 0.0 }
+        { 0.0 y   0.0 }
+        { 0.0 0.0 z   }
+    } ;
+
+:: scale-matrix4 ( factors -- matrix )
+    factors >scale-factors :> z :> y :> x
+    {
+        { x   0.0 0.0 0.0 }
+        { 0.0 y   0.0 0.0 }
+        { 0.0 0.0 z   0.0 }
+        { 0.0 0.0 0.0 1.0 }
+    } ;
+
+: ortho-matrix4 ( dim -- matrix )
+    [ recip ] map scale-matrix4 ;
+
+:: frustum-matrix4 ( xy-dim near far -- matrix )
+    xy-dim first2 :> y :> x
+    near x /f :> xf
+    near y /f :> yf
+    near far + near far - /f :> zf
+    2 near far * * near far - /f :> wf
+
+    {
+        { xf  0.0  0.0 0.0 }
+        { 0.0 yf   0.0 0.0 }
+        { 0.0 0.0  zf  wf  }
+        { 0.0 0.0 -1.0 0.0 }
+    } ;
+
 ! Matrix operations
 : mneg ( m -- m ) [ vneg ] map ;
 

basis/ui/tools/listener/history/history-tests.factor

@@ -52,3 +52,16 @@ IN: ui.tools.listener.history.tests
 [ ] [ "h" get history-recall-previous ] unit-test
 
 [ "22" ] [ "d" get doc-string ] unit-test
+
+[ ] [ <document> "d" set ] unit-test
+[ ] [ "d" get <history> "h" set ] unit-test
+
+[ ] [ "aaa" "d" get set-doc-string ] unit-test
+[ T{ input f "aaa" } ] [ "h" get history-add ] unit-test
+
+[ ] [ "" "d" get set-doc-string ] unit-test
+[ T{ input f "" } ] [ "h" get history-add ] unit-test
+[ T{ input f "" } ] [ "h" get history-add ] unit-test
+[ ] [ "   " "d" get set-doc-string ] unit-test
+[ ] [ "h" get history-recall-previous ] unit-test
+

basis/ui/tools/listener/history/history.factor

@@ -16,9 +16,15 @@ TUPLE: history document elements index ;
 
 <PRIVATE
 
+: (save-history) ( input index elements -- )
+    2dup length > [
+        [ [ T{ input f "" } ] dip push ] keep
+        (save-history)
+    ] [ set-nth ] if ;
+
 : save-history ( history -- )
     [ document>> doc-string ] keep
-    '[ <input> _ [ index>> ] [ elements>> ] bi set-nth ]
+    '[ <input> _ [ index>> ] [ elements>> ] bi (save-history) ]
     unless-empty ;
 
 : update-document ( history -- )

extra/variants/variants-docs.factor

@@ -13,7 +13,7 @@ VARIANT: class-name
     .
     .
     ; "> }
-{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined aas a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots are able to recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
+{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined aas a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots can recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
 { $examples { $code <"
 USING: kernel variants ;
 IN: scratchpad
@@ -26,7 +26,7 @@ VARIANT: list
 
 HELP: match
 { $values { "branches" array } }
-{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with an empty stack. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." }
+{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with the underlying stack unchanged. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." }
 { $examples { $example <"
 USING: kernel math prettyprint variants ;
 IN: scratchpad