Merge branch 'master' of git://factorcode.org/git/factor
commit
e53dd8af24
|
@ -12,28 +12,17 @@ SYMBOL: library-is-c++
|
||||||
SYMBOL: compiler-args
|
SYMBOL: compiler-args
|
||||||
SYMBOL: c-strings
|
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 )
|
: return-library-function-params ( -- return library function params )
|
||||||
scan c-library get scan ")" parse-tokens
|
scan c-library get scan ")" parse-tokens
|
||||||
[ "(" subseq? not ] filter [
|
[ "(" subseq? not ] filter [
|
||||||
[ dup CHAR: - = [ drop CHAR: space ] when ] map
|
[ dup CHAR: - = [ drop CHAR: space ] when ] map
|
||||||
] 3dip ;
|
] 3dip ;
|
||||||
|
|
||||||
: factor-function ( return library functions params -- )
|
: factor-function ( return library function params -- )
|
||||||
[ dup "const " head? [ 6 tail ] when ] 3dip
|
[ dup "const " head? [ 6 tail ] when ] 3dip
|
||||||
make-function define-declared ;
|
make-function define-declared ;
|
||||||
|
|
||||||
: (C-FUNCTION:) ( return library function params -- str )
|
: c-function-string ( return library function params -- str )
|
||||||
[ nip ] dip
|
[ nip ] dip
|
||||||
" " join "(" prepend ")" append 3array " " join
|
" " join "(" prepend ")" append 3array " " join
|
||||||
library-is-c++ get [ "extern \"C\" " prepend ] when ;
|
library-is-c++ get [ "extern \"C\" " prepend ] when ;
|
||||||
|
@ -53,31 +42,47 @@ SYMBOL: c-strings
|
||||||
compiler-args get
|
compiler-args get
|
||||||
c-strings get "\n" join
|
c-strings get "\n" join
|
||||||
c-library get compile-to-library ;
|
c-library get compile-to-library ;
|
||||||
|
|
||||||
: (;C-LIBRARY) ( -- )
|
|
||||||
compile-library? [ compile-library ] when
|
|
||||||
c-library get library-path "cdecl" add-library ;
|
|
||||||
PRIVATE>
|
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
|
" {\n" append parse-here append "\n}\n" append
|
||||||
c-strings get push ;
|
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.
|
! Copyright (C) 2009 Jeremy Hughes.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
IN: alien.inline.tests
|
||||||
|
|
||||||
C-LIBRARY: const
|
C-LIBRARY: const
|
||||||
|
@ -42,6 +43,6 @@ C-FUNCTION: char* breakme ( )
|
||||||
return not a string;
|
return not a string;
|
||||||
;
|
;
|
||||||
|
|
||||||
<< [ (;C-LIBRARY) ] must-fail >>
|
<< [ compile-c-library ] must-fail >>
|
||||||
|
|
||||||
<< library-path dup exists? [ delete-file ] [ drop ] if >>
|
<< 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
|
IN: compiler.cfg.branch-folding.tests
|
||||||
USING: compiler.cfg.branch-folding compiler.cfg.instructions
|
USING: compiler.cfg.branch-folding compiler.cfg.instructions
|
||||||
compiler.cfg compiler.cfg.registers compiler.cfg.debugger
|
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 ;
|
sequences classes namespaces tools.test cpu.architecture ;
|
||||||
|
|
||||||
V{ T{ ##branch } } 0 test-bb
|
V{ T{ ##branch } } 0 test-bb
|
||||||
|
@ -41,4 +41,45 @@ test-diamond
|
||||||
[ t ] [ 1 get successors>> first 3 get eq? ] unit-test
|
[ 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
|
[ 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.
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors kernel sequences assocs
|
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 ;
|
compiler.cfg.hats ;
|
||||||
IN: compiler.cfg.gc-checks
|
IN: compiler.cfg.gc-checks
|
||||||
|
|
||||||
: gc? ( bb -- ? )
|
: gc? ( bb -- ? )
|
||||||
instructions>> [ ##allocation? ] any? ;
|
instructions>> [ ##allocation? ] any? ;
|
||||||
|
|
||||||
: object-pointer-regs ( basic-block -- vregs )
|
|
||||||
live-in keys [ reg-class>> int-regs eq? ] filter ;
|
|
||||||
|
|
||||||
: insert-gc-check ( basic-block -- )
|
: insert-gc-check ( basic-block -- )
|
||||||
dup gc? [
|
dup gc? [
|
||||||
[ i i f f \ ##gc new-insn prefix ] change-instructions drop
|
[ i i f f \ ##gc new-insn prefix ] change-instructions drop
|
||||||
|
|
|
@ -1,13 +1,27 @@
|
||||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
IN: compiler.cfg.predecessors
|
||||||
|
|
||||||
: predecessors-step ( bb -- )
|
: update-predecessors ( bb -- )
|
||||||
dup successors>> [ predecessors>> push ] with each ;
|
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' )
|
: 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 ;
|
||||||
|
|
|
@ -70,21 +70,25 @@ M: ##compare-imm-branch rewrite
|
||||||
dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when
|
dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when
|
||||||
] 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
|
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 -- ? )
|
: rewrite-redundant-comparison? ( insn -- ? )
|
||||||
{
|
{
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
IN: math.matrices
|
||||||
|
|
||||||
! Matrices
|
! Matrices
|
||||||
|
@ -12,6 +13,70 @@ IN: math.matrices
|
||||||
#! Make a nxn identity matrix.
|
#! Make a nxn identity matrix.
|
||||||
dup [ [ = 1 0 ? ] with map ] curry map ;
|
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
|
! Matrix operations
|
||||||
: mneg ( m -- m ) [ vneg ] map ;
|
: mneg ( m -- m ) [ vneg ] map ;
|
||||||
|
|
||||||
|
|
|
@ -52,3 +52,16 @@ IN: ui.tools.listener.history.tests
|
||||||
[ ] [ "h" get history-recall-previous ] unit-test
|
[ ] [ "h" get history-recall-previous ] unit-test
|
||||||
|
|
||||||
[ "22" ] [ "d" get doc-string ] 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
|
<PRIVATE
|
||||||
|
|
||||||
|
: (save-history) ( input index elements -- )
|
||||||
|
2dup length > [
|
||||||
|
[ [ T{ input f "" } ] dip push ] keep
|
||||||
|
(save-history)
|
||||||
|
] [ set-nth ] if ;
|
||||||
|
|
||||||
: save-history ( history -- )
|
: save-history ( history -- )
|
||||||
[ document>> doc-string ] keep
|
[ document>> doc-string ] keep
|
||||||
'[ <input> _ [ index>> ] [ elements>> ] bi set-nth ]
|
'[ <input> _ [ index>> ] [ elements>> ] bi (save-history) ]
|
||||||
unless-empty ;
|
unless-empty ;
|
||||||
|
|
||||||
: update-document ( history -- )
|
: 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 <"
|
{ $examples { $code <"
|
||||||
USING: kernel variants ;
|
USING: kernel variants ;
|
||||||
IN: scratchpad
|
IN: scratchpad
|
||||||
|
@ -26,7 +26,7 @@ VARIANT: list
|
||||||
|
|
||||||
HELP: match
|
HELP: match
|
||||||
{ $values { "branches" array } }
|
{ $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 <"
|
{ $examples { $example <"
|
||||||
USING: kernel math prettyprint variants ;
|
USING: kernel math prettyprint variants ;
|
||||||
IN: scratchpad
|
IN: scratchpad
|
||||||
|
|
Loading…
Reference in New Issue