Merge branch 'master' of git://factorcode.org/git/factor
Daniel Ehrenberg
commit
e53dd8af24
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 >>
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Efficient bitwise operations on bit arrays
|
||||
|
|
@ -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
|
||||
[ 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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 -- ? )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue