diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 5e235fe74e..8e58071427 100644 --- a/basis/alien/inline/inline.factor +++ b/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:) ; - -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:) +: define-c-function ( return library function params -- ) + [ factor-function ] 4 nkeep c-function-string " {\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 ; diff --git a/basis/alien/inline/tests/tests.factor b/basis/alien/inline/tests/tests.factor index aea41ea8b8..acd2d615cd 100644 --- a/basis/alien/inline/tests/tests.factor +++ b/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 >> diff --git a/basis/bit-sets/authors.txt b/basis/bit-sets/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/bit-sets/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/bit-sets/bit-sets-tests.factor b/basis/bit-sets/bit-sets-tests.factor new file mode 100644 index 0000000000..e77bb43986 --- /dev/null +++ b/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 diff --git a/basis/bit-sets/bit-sets.factor b/basis/bit-sets/bit-sets.factor new file mode 100644 index 0000000000..0e97968965 --- /dev/null +++ b/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 + +> ] + [ + [ + [ [ 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 ; \ No newline at end of file diff --git a/basis/bit-sets/summary.txt b/basis/bit-sets/summary.txt new file mode 100644 index 0000000000..d27503b202 --- /dev/null +++ b/basis/bit-sets/summary.txt @@ -0,0 +1 @@ +Efficient bitwise operations on bit arrays diff --git a/basis/compiler/cfg/branch-folding/branch-folding-tests.factor b/basis/compiler/cfg/branch-folding/branch-folding-tests.factor index 1068954f9d..964620d2d3 100644 --- a/basis/compiler/cfg/branch-folding/branch-folding-tests.factor +++ b/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 -compiler.cfg.predecessors kernel accessors +arrays compiler.cfg.phi-elimination compiler.cfg.dce +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 \ No newline at end of file +[ 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 \ No newline at end of file diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor index 4176914126..090283410f 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks.factor +++ b/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.liveness compiler.cfg.instructions +compiler.cfg.rpo 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 diff --git a/basis/compiler/cfg/predecessors/predecessors.factor b/basis/compiler/cfg/predecessors/predecessors.factor index 54efc53bc4..73ae3ee242 100644 --- a/basis/compiler/cfg/predecessors/predecessors.factor +++ b/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 ] - [ ] - tri ; + { + [ [ V{ } clone >>predecessors drop ] each-basic-block ] + [ [ update-predecessors ] each-basic-block ] + [ [ update-phis ] each-basic-block ] + [ ] + } cleave ; diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index bbfeb3f8bf..9fb6e66e9f 100755 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/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 -- ? ) - dup cc>> cc= eq? [ src1>> vreg>expr constant-expr? ] [ drop f ] if ; - -: flip-comparison ( insn -- insn' ) - [ dst>> ] - [ src2>> ] - [ src1>> vreg>constant ] tri - cc= i \ ##compare-imm new-insn ; +: >compare-imm ( insn swap? -- insn' ) + [ + { + [ dst>> ] + [ src1>> ] + [ src2>> ] + [ cc>> ] + } cleave + ] dip [ [ swap ] [ ] bi* ] when + [ vreg>constant ] dip + i \ ##compare-imm new-insn ; inline M: ##compare rewrite - dup flip-comparison? [ - flip-comparison - dup number-values - rewrite - ] when ; + dup [ src1>> ] [ src2>> ] bi + [ vreg>expr constant-expr? ] bi@ 2array { + { { f t } [ f >compare-imm ] } + { { t f } [ t >compare-imm ] } + [ drop ] + } case ; : rewrite-redundant-comparison? ( insn -- ? ) { diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index d6bee78c14..95a52d4655 100644 --- a/basis/math/matrices/matrices.factor +++ b/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 -math.order math.vectors sequences sequences.private fry ; +USING: accessors arrays columns kernel locals math math.bits +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 ; diff --git a/basis/ui/tools/listener/history/history-tests.factor b/basis/ui/tools/listener/history/history-tests.factor index 5a2e3cf1b5..068673889a 100644 --- a/basis/ui/tools/listener/history/history-tests.factor +++ b/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 + +[ ] [ "d" set ] unit-test +[ ] [ "d" get "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 + diff --git a/basis/ui/tools/listener/history/history.factor b/basis/ui/tools/listener/history/history.factor index 333347dbac..5e03ab21ad 100644 --- a/basis/ui/tools/listener/history/history.factor +++ b/basis/ui/tools/listener/history/history.factor @@ -16,9 +16,15 @@ TUPLE: history document elements index ; [ + [ [ T{ input f "" } ] dip push ] keep + (save-history) + ] [ set-nth ] if ; + : save-history ( history -- ) [ document>> doc-string ] keep - '[ _ [ index>> ] [ elements>> ] bi set-nth ] + '[ _ [ index>> ] [ elements>> ] bi (save-history) ] unless-empty ; : update-document ( history -- ) diff --git a/extra/variants/variants-docs.factor b/extra/variants/variants-docs.factor index 8ba1623f2e..f9b62e11f3 100644 --- a/extra/variants/variants-docs.factor +++ b/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 "" } " 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 "" } " 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