Merge branch 'master' of git://factorcode.org/git/factor
William Schlieper
commit
e09eef0822
|
|
@ -85,8 +85,16 @@ SYMBOL: objects
|
||||||
: 1-offset 8 ; inline
|
: 1-offset 8 ; inline
|
||||||
: -1-offset 9 ; inline
|
: -1-offset 9 ; inline
|
||||||
|
|
||||||
|
SYMBOL: sub-primitives
|
||||||
|
|
||||||
|
: make-jit ( quot rc rt offset -- quad )
|
||||||
|
{ [ { } make ] [ ] [ ] [ ] } spread 4array ; inline
|
||||||
|
|
||||||
: jit-define ( quot rc rt offset name -- )
|
: jit-define ( quot rc rt offset name -- )
|
||||||
>r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ;
|
>r make-jit r> set ; inline
|
||||||
|
|
||||||
|
: define-sub-primitive ( quot rc rt offset word -- )
|
||||||
|
>r make-jit r> sub-primitives get set-at ;
|
||||||
|
|
||||||
! The image being constructed; a vector of word-size integers
|
! The image being constructed; a vector of word-size integers
|
||||||
SYMBOL: image
|
SYMBOL: image
|
||||||
|
|
@ -118,29 +126,7 @@ SYMBOL: jit-dispatch
|
||||||
SYMBOL: jit-epilog
|
SYMBOL: jit-epilog
|
||||||
SYMBOL: jit-return
|
SYMBOL: jit-return
|
||||||
SYMBOL: jit-profiling
|
SYMBOL: jit-profiling
|
||||||
SYMBOL: jit-tag
|
|
||||||
SYMBOL: jit-tag-word
|
|
||||||
SYMBOL: jit-eq?
|
|
||||||
SYMBOL: jit-eq?-word
|
|
||||||
SYMBOL: jit-slot
|
|
||||||
SYMBOL: jit-slot-word
|
|
||||||
SYMBOL: jit-declare-word
|
SYMBOL: jit-declare-word
|
||||||
SYMBOL: jit-drop
|
|
||||||
SYMBOL: jit-drop-word
|
|
||||||
SYMBOL: jit-dup
|
|
||||||
SYMBOL: jit-dup-word
|
|
||||||
SYMBOL: jit->r
|
|
||||||
SYMBOL: jit->r-word
|
|
||||||
SYMBOL: jit-r>
|
|
||||||
SYMBOL: jit-r>-word
|
|
||||||
SYMBOL: jit-swap
|
|
||||||
SYMBOL: jit-swap-word
|
|
||||||
SYMBOL: jit-over
|
|
||||||
SYMBOL: jit-over-word
|
|
||||||
SYMBOL: jit-fixnum-fast
|
|
||||||
SYMBOL: jit-fixnum-fast-word
|
|
||||||
SYMBOL: jit-fixnum>=
|
|
||||||
SYMBOL: jit-fixnum>=-word
|
|
||||||
|
|
||||||
! Default definition for undefined words
|
! Default definition for undefined words
|
||||||
SYMBOL: undefined-quot
|
SYMBOL: undefined-quot
|
||||||
|
|
@ -163,29 +149,7 @@ SYMBOL: undefined-quot
|
||||||
{ jit-epilog 33 }
|
{ jit-epilog 33 }
|
||||||
{ jit-return 34 }
|
{ jit-return 34 }
|
||||||
{ jit-profiling 35 }
|
{ jit-profiling 35 }
|
||||||
{ jit-tag 36 }
|
|
||||||
{ jit-tag-word 37 }
|
|
||||||
{ jit-eq? 38 }
|
|
||||||
{ jit-eq?-word 39 }
|
|
||||||
{ jit-slot 40 }
|
|
||||||
{ jit-slot-word 41 }
|
|
||||||
{ jit-declare-word 42 }
|
{ jit-declare-word 42 }
|
||||||
{ jit-drop 43 }
|
|
||||||
{ jit-drop-word 44 }
|
|
||||||
{ jit-dup 45 }
|
|
||||||
{ jit-dup-word 46 }
|
|
||||||
{ jit->r 47 }
|
|
||||||
{ jit->r-word 48 }
|
|
||||||
{ jit-r> 49 }
|
|
||||||
{ jit-r>-word 50 }
|
|
||||||
{ jit-swap 51 }
|
|
||||||
{ jit-swap-word 52 }
|
|
||||||
{ jit-over 53 }
|
|
||||||
{ jit-over-word 54 }
|
|
||||||
{ jit-fixnum-fast 55 }
|
|
||||||
{ jit-fixnum-fast-word 56 }
|
|
||||||
{ jit-fixnum>= 57 }
|
|
||||||
{ jit-fixnum>=-word 58 }
|
|
||||||
{ undefined-quot 60 }
|
{ undefined-quot 60 }
|
||||||
} at header-size + ;
|
} at header-size + ;
|
||||||
|
|
||||||
|
|
@ -305,6 +269,9 @@ M: f '
|
||||||
|
|
||||||
! Words
|
! Words
|
||||||
|
|
||||||
|
: word-sub-primitive ( word -- obj )
|
||||||
|
global [ target-word ] bind sub-primitives get at ;
|
||||||
|
|
||||||
: emit-word ( word -- )
|
: emit-word ( word -- )
|
||||||
[
|
[
|
||||||
[ subwords [ emit-word ] each ]
|
[ subwords [ emit-word ] each ]
|
||||||
|
|
@ -316,12 +283,13 @@ M: f '
|
||||||
[ vocabulary>> , ]
|
[ vocabulary>> , ]
|
||||||
[ def>> , ]
|
[ def>> , ]
|
||||||
[ props>> , ]
|
[ props>> , ]
|
||||||
|
[ drop f , ]
|
||||||
|
[ drop 0 , ] ! count
|
||||||
|
[ word-sub-primitive , ]
|
||||||
|
[ drop 0 , ] ! xt
|
||||||
|
[ drop 0 , ] ! code
|
||||||
|
[ drop 0 , ] ! profiling
|
||||||
} cleave
|
} cleave
|
||||||
f ,
|
|
||||||
0 , ! count
|
|
||||||
0 , ! xt
|
|
||||||
0 , ! code
|
|
||||||
0 , ! profiling
|
|
||||||
] { } make [ ' ] map
|
] { } make [ ' ] map
|
||||||
] bi
|
] bi
|
||||||
\ word type-number object tag-number
|
\ word type-number object tag-number
|
||||||
|
|
@ -460,18 +428,7 @@ M: quotation '
|
||||||
\ if jit-if-word set
|
\ if jit-if-word set
|
||||||
\ dispatch jit-dispatch-word set
|
\ dispatch jit-dispatch-word set
|
||||||
\ do-primitive jit-primitive-word set
|
\ do-primitive jit-primitive-word set
|
||||||
\ tag jit-tag-word set
|
|
||||||
\ eq? jit-eq?-word set
|
|
||||||
\ slot jit-slot-word set
|
|
||||||
\ declare jit-declare-word set
|
\ declare jit-declare-word set
|
||||||
\ drop jit-drop-word set
|
|
||||||
\ dup jit-dup-word set
|
|
||||||
\ >r jit->r-word set
|
|
||||||
\ r> jit-r>-word set
|
|
||||||
\ swap jit-swap-word set
|
|
||||||
\ over jit-over-word set
|
|
||||||
\ fixnum-fast jit-fixnum-fast-word set
|
|
||||||
\ fixnum>= jit-fixnum>=-word set
|
|
||||||
[ undefined ] undefined-quot set
|
[ undefined ] undefined-quot set
|
||||||
{
|
{
|
||||||
jit-code-format
|
jit-code-format
|
||||||
|
|
@ -488,29 +445,7 @@ M: quotation '
|
||||||
jit-epilog
|
jit-epilog
|
||||||
jit-return
|
jit-return
|
||||||
jit-profiling
|
jit-profiling
|
||||||
jit-tag
|
|
||||||
jit-tag-word
|
|
||||||
jit-eq?
|
|
||||||
jit-eq?-word
|
|
||||||
jit-slot
|
|
||||||
jit-slot-word
|
|
||||||
jit-declare-word
|
jit-declare-word
|
||||||
jit-drop
|
|
||||||
jit-drop-word
|
|
||||||
jit-dup
|
|
||||||
jit-dup-word
|
|
||||||
jit->r
|
|
||||||
jit->r-word
|
|
||||||
jit-r>
|
|
||||||
jit-r>-word
|
|
||||||
jit-swap
|
|
||||||
jit-swap-word
|
|
||||||
jit-over
|
|
||||||
jit-over-word
|
|
||||||
jit-fixnum-fast
|
|
||||||
jit-fixnum-fast-word
|
|
||||||
jit-fixnum>=
|
|
||||||
jit-fixnum>=-word
|
|
||||||
undefined-quot
|
undefined-quot
|
||||||
} [ emit-userenv ] each ;
|
} [ emit-userenv ] each ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -13,6 +13,8 @@ IN: bootstrap.primitives
|
||||||
|
|
||||||
crossref off
|
crossref off
|
||||||
|
|
||||||
|
H{ } clone sub-primitives set
|
||||||
|
|
||||||
"resource:core/bootstrap/syntax.factor" parse-file
|
"resource:core/bootstrap/syntax.factor" parse-file
|
||||||
|
|
||||||
"resource:core/cpu/" architecture get {
|
"resource:core/cpu/" architecture get {
|
||||||
|
|
@ -256,6 +258,7 @@ bi
|
||||||
"props"
|
"props"
|
||||||
{ "compiled" read-only }
|
{ "compiled" read-only }
|
||||||
{ "counter" { "fixnum" "math" } }
|
{ "counter" { "fixnum" "math" } }
|
||||||
|
{ "sub-primitive" read-only }
|
||||||
} define-builtin
|
} define-builtin
|
||||||
|
|
||||||
"byte-array" "byte-arrays" create { } define-builtin
|
"byte-array" "byte-arrays" create { } define-builtin
|
||||||
|
|
@ -323,14 +326,55 @@ tuple
|
||||||
[ tuple-layout [ <tuple-boa> ] curry ] tri
|
[ tuple-layout [ <tuple-boa> ] curry ] tri
|
||||||
(( quot1 quot2 -- compose )) define-declared
|
(( quot1 quot2 -- compose )) define-declared
|
||||||
|
|
||||||
|
! Sub-primitive words
|
||||||
|
: make-sub-primitive ( word vocab -- )
|
||||||
|
create
|
||||||
|
dup reset-word
|
||||||
|
dup 1quotation define ;
|
||||||
|
|
||||||
|
{
|
||||||
|
{ "(execute)" "words.private" }
|
||||||
|
{ "(call)" "kernel.private" }
|
||||||
|
{ "fixnum+fast" "math.private" }
|
||||||
|
{ "fixnum-fast" "math.private" }
|
||||||
|
{ "fixnum*fast" "math.private" }
|
||||||
|
{ "fixnum-bitand" "math.private" }
|
||||||
|
{ "fixnum-bitor" "math.private" }
|
||||||
|
{ "fixnum-bitxor" "math.private" }
|
||||||
|
{ "fixnum-bitnot" "math.private" }
|
||||||
|
{ "fixnum<" "math.private" }
|
||||||
|
{ "fixnum<=" "math.private" }
|
||||||
|
{ "fixnum>" "math.private" }
|
||||||
|
{ "fixnum>=" "math.private" }
|
||||||
|
{ "drop" "kernel" }
|
||||||
|
{ "2drop" "kernel" }
|
||||||
|
{ "3drop" "kernel" }
|
||||||
|
{ "dup" "kernel" }
|
||||||
|
{ "2dup" "kernel" }
|
||||||
|
{ "3dup" "kernel" }
|
||||||
|
{ "rot" "kernel" }
|
||||||
|
{ "-rot" "kernel" }
|
||||||
|
{ "dupd" "kernel" }
|
||||||
|
{ "swapd" "kernel" }
|
||||||
|
{ "nip" "kernel" }
|
||||||
|
{ "2nip" "kernel" }
|
||||||
|
{ "tuck" "kernel" }
|
||||||
|
{ "over" "kernel" }
|
||||||
|
{ "pick" "kernel" }
|
||||||
|
{ "swap" "kernel" }
|
||||||
|
{ ">r" "kernel" }
|
||||||
|
{ "r>" "kernel" }
|
||||||
|
{ "eq?" "kernel" }
|
||||||
|
{ "tag" "kernel.private" }
|
||||||
|
{ "slot" "slots.private" }
|
||||||
|
} [ make-sub-primitive ] assoc-each
|
||||||
|
|
||||||
! Primitive words
|
! Primitive words
|
||||||
: make-primitive ( word vocab n -- )
|
: make-primitive ( word vocab n -- )
|
||||||
>r create dup reset-word r>
|
>r create dup reset-word r>
|
||||||
[ do-primitive ] curry [ ] like define ;
|
[ do-primitive ] curry [ ] like define ;
|
||||||
|
|
||||||
{
|
{
|
||||||
{ "(execute)" "words.private" }
|
|
||||||
{ "(call)" "kernel.private" }
|
|
||||||
{ "bignum>fixnum" "math.private" }
|
{ "bignum>fixnum" "math.private" }
|
||||||
{ "float>fixnum" "math.private" }
|
{ "float>fixnum" "math.private" }
|
||||||
{ "fixnum>bignum" "math.private" }
|
{ "fixnum>bignum" "math.private" }
|
||||||
|
|
@ -346,24 +390,13 @@ tuple
|
||||||
{ "bits>double" "math" }
|
{ "bits>double" "math" }
|
||||||
{ "<complex>" "math.private" }
|
{ "<complex>" "math.private" }
|
||||||
{ "fixnum+" "math.private" }
|
{ "fixnum+" "math.private" }
|
||||||
{ "fixnum+fast" "math.private" }
|
|
||||||
{ "fixnum-" "math.private" }
|
{ "fixnum-" "math.private" }
|
||||||
{ "fixnum-fast" "math.private" }
|
|
||||||
{ "fixnum*" "math.private" }
|
{ "fixnum*" "math.private" }
|
||||||
{ "fixnum*fast" "math.private" }
|
|
||||||
{ "fixnum/i" "math.private" }
|
{ "fixnum/i" "math.private" }
|
||||||
{ "fixnum-mod" "math.private" }
|
{ "fixnum-mod" "math.private" }
|
||||||
{ "fixnum/mod" "math.private" }
|
{ "fixnum/mod" "math.private" }
|
||||||
{ "fixnum-bitand" "math.private" }
|
|
||||||
{ "fixnum-bitor" "math.private" }
|
|
||||||
{ "fixnum-bitxor" "math.private" }
|
|
||||||
{ "fixnum-bitnot" "math.private" }
|
|
||||||
{ "fixnum-shift" "math.private" }
|
{ "fixnum-shift" "math.private" }
|
||||||
{ "fixnum-shift-fast" "math.private" }
|
{ "fixnum-shift-fast" "math.private" }
|
||||||
{ "fixnum<" "math.private" }
|
|
||||||
{ "fixnum<=" "math.private" }
|
|
||||||
{ "fixnum>" "math.private" }
|
|
||||||
{ "fixnum>=" "math.private" }
|
|
||||||
{ "bignum=" "math.private" }
|
{ "bignum=" "math.private" }
|
||||||
{ "bignum+" "math.private" }
|
{ "bignum+" "math.private" }
|
||||||
{ "bignum-" "math.private" }
|
{ "bignum-" "math.private" }
|
||||||
|
|
@ -395,25 +428,6 @@ tuple
|
||||||
{ "float>=" "math.private" }
|
{ "float>=" "math.private" }
|
||||||
{ "<word>" "words" }
|
{ "<word>" "words" }
|
||||||
{ "word-xt" "words" }
|
{ "word-xt" "words" }
|
||||||
{ "drop" "kernel" }
|
|
||||||
{ "2drop" "kernel" }
|
|
||||||
{ "3drop" "kernel" }
|
|
||||||
{ "dup" "kernel" }
|
|
||||||
{ "2dup" "kernel" }
|
|
||||||
{ "3dup" "kernel" }
|
|
||||||
{ "rot" "kernel" }
|
|
||||||
{ "-rot" "kernel" }
|
|
||||||
{ "dupd" "kernel" }
|
|
||||||
{ "swapd" "kernel" }
|
|
||||||
{ "nip" "kernel" }
|
|
||||||
{ "2nip" "kernel" }
|
|
||||||
{ "tuck" "kernel" }
|
|
||||||
{ "over" "kernel" }
|
|
||||||
{ "pick" "kernel" }
|
|
||||||
{ "swap" "kernel" }
|
|
||||||
{ ">r" "kernel" }
|
|
||||||
{ "r>" "kernel" }
|
|
||||||
{ "eq?" "kernel" }
|
|
||||||
{ "getenv" "kernel.private" }
|
{ "getenv" "kernel.private" }
|
||||||
{ "setenv" "kernel.private" }
|
{ "setenv" "kernel.private" }
|
||||||
{ "(exists?)" "io.files.private" }
|
{ "(exists?)" "io.files.private" }
|
||||||
|
|
@ -433,7 +447,6 @@ tuple
|
||||||
{ "code-room" "memory" }
|
{ "code-room" "memory" }
|
||||||
{ "os-env" "system" }
|
{ "os-env" "system" }
|
||||||
{ "millis" "system" }
|
{ "millis" "system" }
|
||||||
{ "tag" "kernel.private" }
|
|
||||||
{ "modify-code-heap" "compiler.units" }
|
{ "modify-code-heap" "compiler.units" }
|
||||||
{ "dlopen" "alien" }
|
{ "dlopen" "alien" }
|
||||||
{ "dlsym" "alien" }
|
{ "dlsym" "alien" }
|
||||||
|
|
@ -468,7 +481,6 @@ tuple
|
||||||
{ "set-alien-cell" "alien.accessors" }
|
{ "set-alien-cell" "alien.accessors" }
|
||||||
{ "(throw)" "kernel.private" }
|
{ "(throw)" "kernel.private" }
|
||||||
{ "alien-address" "alien" }
|
{ "alien-address" "alien" }
|
||||||
{ "slot" "slots.private" }
|
|
||||||
{ "set-slot" "slots.private" }
|
{ "set-slot" "slots.private" }
|
||||||
{ "string-nth" "strings.private" }
|
{ "string-nth" "strings.private" }
|
||||||
{ "set-string-nth" "strings.private" }
|
{ "set-string-nth" "strings.private" }
|
||||||
|
|
|
||||||
|
|
@ -18,8 +18,8 @@ IN: compiler.constants
|
||||||
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
|
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
|
||||||
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
|
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
|
||||||
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
|
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
|
||||||
: word-xt-offset ( -- n ) 8 bootstrap-cells object tag-number - ;
|
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
|
||||||
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
|
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
|
||||||
: word-code-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
|
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
|
||||||
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
|
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
|
||||||
: compiled-header-size ( -- n ) 4 bootstrap-cells ;
|
: compiled-header-size ( -- n ) 4 bootstrap-cells ;
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,9 @@
|
||||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: bootstrap.image.private kernel namespaces system
|
USING: bootstrap.image.private kernel kernel.private namespaces
|
||||||
cpu.x86.assembler layouts compiler.units math generator.fixup
|
system cpu.x86.assembler layouts compiler.units math math.private
|
||||||
compiler.constants vocabs ;
|
generator.fixup compiler.constants vocabs slots.private words
|
||||||
|
words.private ;
|
||||||
IN: bootstrap.x86
|
IN: bootstrap.x86
|
||||||
|
|
||||||
big-endian off
|
big-endian off
|
||||||
|
|
@ -74,27 +75,34 @@ big-endian off
|
||||||
arg0 quot-xt-offset [+] JMP ! execute branch
|
arg0 quot-xt-offset [+] JMP ! execute branch
|
||||||
] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
|
] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
|
||||||
|
|
||||||
|
[
|
||||||
|
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
|
||||||
|
] f f f jit-epilog jit-define
|
||||||
|
|
||||||
|
[ 0 RET ] f f f jit-return jit-define
|
||||||
|
|
||||||
|
! Sub-primitives
|
||||||
|
|
||||||
|
! Quotations and words
|
||||||
|
[
|
||||||
|
arg0 ds-reg [] MOV ! load from stack
|
||||||
|
ds-reg bootstrap-cell SUB ! pop stack
|
||||||
|
arg0 quot-xt-offset [+] JMP ! call quotation
|
||||||
|
] f f f \ (call) define-sub-primitive
|
||||||
|
|
||||||
|
[
|
||||||
|
arg0 ds-reg [] MOV ! load from stack
|
||||||
|
ds-reg bootstrap-cell SUB ! pop stack
|
||||||
|
arg0 word-xt-offset [+] JMP ! execute word
|
||||||
|
] f f f \ (execute) define-sub-primitive
|
||||||
|
|
||||||
|
! Objects
|
||||||
[
|
[
|
||||||
arg1 ds-reg [] MOV ! load from stack
|
arg1 ds-reg [] MOV ! load from stack
|
||||||
arg1 tag-mask get AND ! compute tag
|
arg1 tag-mask get AND ! compute tag
|
||||||
arg1 tag-bits get SHL ! tag the tag
|
arg1 tag-bits get SHL ! tag the tag
|
||||||
ds-reg [] arg1 MOV ! push to stack
|
ds-reg [] arg1 MOV ! push to stack
|
||||||
] f f f jit-tag jit-define
|
] f f f \ tag define-sub-primitive
|
||||||
|
|
||||||
: jit-compare ( -- )
|
|
||||||
arg1 0 MOV ! load t
|
|
||||||
arg1 dup [] MOV
|
|
||||||
temp-reg \ f tag-number MOV ! load f
|
|
||||||
arg0 ds-reg [] MOV ! load first value
|
|
||||||
ds-reg bootstrap-cell SUB ! adjust stack pointer
|
|
||||||
ds-reg [] arg0 CMP ! compare with second value
|
|
||||||
;
|
|
||||||
|
|
||||||
[
|
|
||||||
jit-compare
|
|
||||||
arg1 temp-reg CMOVNE ! not equal?
|
|
||||||
ds-reg [] arg1 MOV ! store
|
|
||||||
] rc-absolute-cell rt-literal 1 rex-length + jit-eq? jit-define
|
|
||||||
|
|
||||||
[
|
[
|
||||||
arg0 ds-reg [] MOV ! load slot number
|
arg0 ds-reg [] MOV ! load slot number
|
||||||
|
|
@ -105,63 +113,187 @@ big-endian off
|
||||||
arg1 tag-bits get SHL
|
arg1 tag-bits get SHL
|
||||||
arg0 arg1 arg0 [+] MOV ! load slot value
|
arg0 arg1 arg0 [+] MOV ! load slot value
|
||||||
ds-reg [] arg0 MOV ! push to stack
|
ds-reg [] arg0 MOV ! push to stack
|
||||||
] f f f jit-slot jit-define
|
] f f f \ slot define-sub-primitive
|
||||||
|
|
||||||
|
! Shufflers
|
||||||
[
|
[
|
||||||
ds-reg bootstrap-cell SUB
|
ds-reg bootstrap-cell SUB
|
||||||
] f f f jit-drop jit-define
|
] f f f \ drop define-sub-primitive
|
||||||
|
|
||||||
|
[
|
||||||
|
ds-reg 2 bootstrap-cells SUB
|
||||||
|
] f f f \ 2drop define-sub-primitive
|
||||||
|
|
||||||
|
[
|
||||||
|
ds-reg 3 bootstrap-cells SUB
|
||||||
|
] f f f \ 3drop define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
arg0 ds-reg [] MOV
|
arg0 ds-reg [] MOV
|
||||||
ds-reg bootstrap-cell ADD
|
ds-reg bootstrap-cell ADD
|
||||||
ds-reg [] arg0 MOV
|
ds-reg [] arg0 MOV
|
||||||
] f f f jit-dup jit-define
|
] f f f \ dup define-sub-primitive
|
||||||
|
|
||||||
|
[
|
||||||
|
arg0 ds-reg [] MOV
|
||||||
|
arg1 ds-reg bootstrap-cell neg [+] MOV
|
||||||
|
ds-reg 2 bootstrap-cells ADD
|
||||||
|
ds-reg [] arg0 MOV
|
||||||
|
ds-reg bootstrap-cell neg [+] arg1 MOV
|
||||||
|
] f f f \ 2dup define-sub-primitive
|
||||||
|
|
||||||
|
[
|
||||||
|
arg0 ds-reg [] MOV
|
||||||
|
arg1 ds-reg -1 bootstrap-cells [+] MOV
|
||||||
|
temp-reg ds-reg -2 bootstrap-cells [+] MOV
|
||||||
|
ds-reg 3 bootstrap-cells ADD
|
||||||
|
ds-reg [] arg0 MOV
|
||||||
|
ds-reg -1 bootstrap-cells [+] arg1 MOV
|
||||||
|
ds-reg -2 bootstrap-cells [+] temp-reg MOV
|
||||||
|
] f f f \ 3dup define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
rs-reg bootstrap-cell ADD
|
|
||||||
arg0 ds-reg [] MOV
|
arg0 ds-reg [] MOV
|
||||||
ds-reg bootstrap-cell SUB
|
ds-reg bootstrap-cell SUB
|
||||||
rs-reg [] arg0 MOV
|
ds-reg [] arg0 MOV
|
||||||
] f f f jit->r jit-define
|
] f f f \ nip define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
ds-reg bootstrap-cell ADD
|
arg0 ds-reg [] MOV
|
||||||
arg0 rs-reg [] MOV
|
ds-reg 2 bootstrap-cells SUB
|
||||||
rs-reg bootstrap-cell SUB
|
|
||||||
ds-reg [] arg0 MOV
|
ds-reg [] arg0 MOV
|
||||||
] f f f jit-r> jit-define
|
] f f f \ 2nip define-sub-primitive
|
||||||
|
|
||||||
|
[
|
||||||
|
arg0 ds-reg -1 bootstrap-cells [+] MOV
|
||||||
|
ds-reg bootstrap-cell ADD
|
||||||
|
ds-reg [] arg0 MOV
|
||||||
|
] f f f \ over define-sub-primitive
|
||||||
|
|
||||||
|
[
|
||||||
|
arg0 ds-reg -2 bootstrap-cells [+] MOV
|
||||||
|
ds-reg bootstrap-cell ADD
|
||||||
|
ds-reg [] arg0 MOV
|
||||||
|
] f f f \ pick define-sub-primitive
|
||||||
|
|
||||||
|
[
|
||||||
|
arg0 ds-reg [] MOV
|
||||||
|
arg1 ds-reg -1 bootstrap-cells [+] MOV
|
||||||
|
ds-reg [] arg1 MOV
|
||||||
|
ds-reg bootstrap-cell ADD
|
||||||
|
ds-reg [] arg0 MOV
|
||||||
|
] f f f \ dupd define-sub-primitive
|
||||||
|
|
||||||
|
[
|
||||||
|
arg0 ds-reg [] MOV
|
||||||
|
arg1 ds-reg -1 bootstrap-cells [+] MOV
|
||||||
|
ds-reg bootstrap-cell ADD
|
||||||
|
ds-reg [] arg0 MOV
|
||||||
|
ds-reg -1 bootstrap-cells [+] arg1 MOV
|
||||||
|
ds-reg -2 bootstrap-cells [+] arg0 MOV
|
||||||
|
] f f f \ tuck define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
arg0 ds-reg [] MOV
|
arg0 ds-reg [] MOV
|
||||||
arg1 ds-reg bootstrap-cell neg [+] MOV
|
arg1 ds-reg bootstrap-cell neg [+] MOV
|
||||||
ds-reg bootstrap-cell neg [+] arg0 MOV
|
ds-reg bootstrap-cell neg [+] arg0 MOV
|
||||||
ds-reg [] arg1 MOV
|
ds-reg [] arg1 MOV
|
||||||
] f f f jit-swap jit-define
|
] f f f \ swap define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
arg0 ds-reg bootstrap-cell neg [+] MOV
|
arg0 ds-reg -1 bootstrap-cells [+] MOV
|
||||||
ds-reg bootstrap-cell ADD
|
arg1 ds-reg -2 bootstrap-cells [+] MOV
|
||||||
ds-reg [] arg0 MOV
|
ds-reg -2 bootstrap-cells [+] arg0 MOV
|
||||||
] f f f jit-over jit-define
|
ds-reg -1 bootstrap-cells [+] arg1 MOV
|
||||||
|
] f f f \ swapd define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
arg0 ds-reg [] MOV
|
arg0 ds-reg [] MOV
|
||||||
ds-reg bootstrap-cell SUB
|
arg1 ds-reg -1 bootstrap-cells [+] MOV
|
||||||
arg1 ds-reg [] MOV
|
temp-reg ds-reg -2 bootstrap-cells [+] MOV
|
||||||
arg1 arg0 SUB
|
ds-reg -2 bootstrap-cells [+] arg1 MOV
|
||||||
|
ds-reg -1 bootstrap-cells [+] arg0 MOV
|
||||||
|
ds-reg [] temp-reg MOV
|
||||||
|
] f f f \ rot define-sub-primitive
|
||||||
|
|
||||||
|
[
|
||||||
|
arg0 ds-reg [] MOV
|
||||||
|
arg1 ds-reg -1 bootstrap-cells [+] MOV
|
||||||
|
temp-reg ds-reg -2 bootstrap-cells [+] MOV
|
||||||
|
ds-reg -2 bootstrap-cells [+] arg0 MOV
|
||||||
|
ds-reg -1 bootstrap-cells [+] temp-reg MOV
|
||||||
ds-reg [] arg1 MOV
|
ds-reg [] arg1 MOV
|
||||||
] f f f jit-fixnum-fast jit-define
|
] f f f \ -rot define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
jit-compare
|
rs-reg bootstrap-cell ADD
|
||||||
arg1 temp-reg CMOVL ! not equal?
|
arg0 ds-reg [] MOV
|
||||||
|
ds-reg bootstrap-cell SUB
|
||||||
|
rs-reg [] arg0 MOV
|
||||||
|
] f f f \ >r define-sub-primitive
|
||||||
|
|
||||||
|
[
|
||||||
|
ds-reg bootstrap-cell ADD
|
||||||
|
arg0 rs-reg [] MOV
|
||||||
|
rs-reg bootstrap-cell SUB
|
||||||
|
ds-reg [] arg0 MOV
|
||||||
|
] f f f \ r> define-sub-primitive
|
||||||
|
|
||||||
|
! Comparisons
|
||||||
|
: jit-compare ( insn -- )
|
||||||
|
arg1 0 MOV ! load t
|
||||||
|
arg1 dup [] MOV
|
||||||
|
temp-reg \ f tag-number MOV ! load f
|
||||||
|
arg0 ds-reg [] MOV ! load first value
|
||||||
|
ds-reg bootstrap-cell SUB ! adjust stack pointer
|
||||||
|
ds-reg [] arg0 CMP ! compare with second value
|
||||||
|
[ arg1 temp-reg ] dip execute ! move t if true
|
||||||
ds-reg [] arg1 MOV ! store
|
ds-reg [] arg1 MOV ! store
|
||||||
] rc-absolute-cell rt-literal 1 rex-length + jit-fixnum>= jit-define
|
;
|
||||||
|
|
||||||
|
: define-jit-compare ( insn word -- )
|
||||||
|
[ [ jit-compare ] curry rc-absolute-cell rt-literal 1 rex-length + ] dip
|
||||||
|
define-sub-primitive ;
|
||||||
|
|
||||||
|
\ CMOVNE \ eq? define-jit-compare
|
||||||
|
\ CMOVL \ fixnum>= define-jit-compare
|
||||||
|
\ CMOVG \ fixnum<= define-jit-compare
|
||||||
|
\ CMOVLE \ fixnum> define-jit-compare
|
||||||
|
\ CMOVGE \ fixnum< define-jit-compare
|
||||||
|
|
||||||
|
! Math
|
||||||
|
: jit-math ( insn -- )
|
||||||
|
arg0 ds-reg [] MOV ! load second input
|
||||||
|
ds-reg bootstrap-cell SUB ! pop stack
|
||||||
|
arg1 ds-reg [] MOV ! load first input
|
||||||
|
[ arg1 arg0 ] dip execute ! compute result
|
||||||
|
ds-reg [] arg1 MOV ! push result
|
||||||
|
;
|
||||||
|
|
||||||
|
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
|
||||||
|
|
||||||
|
[ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive
|
||||||
|
|
||||||
[
|
[
|
||||||
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
|
arg0 ds-reg [] MOV ! load second input
|
||||||
] f f f jit-epilog jit-define
|
ds-reg bootstrap-cell SUB ! pop stack
|
||||||
|
arg1 ds-reg [] MOV ! load first input
|
||||||
|
arg0 tag-bits get SAR ! untag second input
|
||||||
|
arg0 arg1 IMUL2 ! multiply
|
||||||
|
ds-reg [] arg1 MOV ! push result
|
||||||
|
] f f f \ fixnum*fast define-sub-primitive
|
||||||
|
|
||||||
[ 0 RET ] f f f jit-return jit-define
|
[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
|
||||||
|
|
||||||
|
[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive
|
||||||
|
|
||||||
|
[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
|
||||||
|
|
||||||
|
[
|
||||||
|
arg0 ds-reg [] MOV ! load input input
|
||||||
|
arg0 NOT ! complement
|
||||||
|
arg0 tag-mask get XOR ! clear tag bits
|
||||||
|
ds-reg [] arg0 MOV ! save
|
||||||
|
] f f f \ fixnum-bitnot define-sub-primitive
|
||||||
|
|
||||||
[ "bootstrap.x86" forget-vocab ] with-compilation-unit
|
[ "bootstrap.x86" forget-vocab ] with-compilation-unit
|
||||||
|
|
|
||||||
|
|
@ -104,6 +104,8 @@ M: object infer-call
|
||||||
] if
|
] if
|
||||||
] "infer" set-word-prop
|
] "infer" set-word-prop
|
||||||
|
|
||||||
|
\ execute t "no-compile" set-word-prop
|
||||||
|
|
||||||
\ if [
|
\ if [
|
||||||
3 ensure-values
|
3 ensure-values
|
||||||
2 d-tail [ special? ] contains? [
|
2 d-tail [ special? ] contains? [
|
||||||
|
|
@ -123,6 +125,8 @@ M: object infer-call
|
||||||
[ #dispatch ] infer-branches
|
[ #dispatch ] infer-branches
|
||||||
] "infer" set-word-prop
|
] "infer" set-word-prop
|
||||||
|
|
||||||
|
\ dispatch t "no-compile" set-word-prop
|
||||||
|
|
||||||
\ curry [
|
\ curry [
|
||||||
2 ensure-values
|
2 ensure-values
|
||||||
pop-d pop-d swap <curried> push-d
|
pop-d pop-d swap <curried> push-d
|
||||||
|
|
|
||||||
|
|
@ -34,7 +34,9 @@ M: symbol definer drop \ SYMBOL: f ;
|
||||||
M: symbol definition drop f ;
|
M: symbol definition drop f ;
|
||||||
|
|
||||||
PREDICATE: primitive < word ( obj -- ? )
|
PREDICATE: primitive < word ( obj -- ? )
|
||||||
def>> [ do-primitive ] tail? ;
|
[ def>> [ do-primitive ] tail? ]
|
||||||
|
[ sub-primitive>> >boolean ]
|
||||||
|
bi or ;
|
||||||
M: primitive definer drop \ PRIMITIVE: f ;
|
M: primitive definer drop \ PRIMITIVE: f ;
|
||||||
M: primitive definition drop f ;
|
M: primitive definition drop f ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -6,14 +6,17 @@ USING: combinators.short-circuit kernel namespaces
|
||||||
math.order
|
math.order
|
||||||
math.vectors
|
math.vectors
|
||||||
math.trig
|
math.trig
|
||||||
|
math.physics.pos
|
||||||
|
math.physics.vel
|
||||||
combinators arrays sequences random vars
|
combinators arrays sequences random vars
|
||||||
combinators.lib ;
|
combinators.lib
|
||||||
|
accessors ;
|
||||||
|
|
||||||
IN: boids
|
IN: boids
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
TUPLE: boid pos vel ;
|
TUPLE: boid < vel ;
|
||||||
|
|
||||||
C: <boid> boid
|
C: <boid> boid
|
||||||
|
|
||||||
|
|
@ -70,7 +73,7 @@ VAR: separation-radius
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: distance ( boid boid -- n ) [ boid-pos ] [ boid-pos ] bi* v- norm ;
|
: distance ( boid boid -- n ) [ pos>> ] [ pos>> ] bi* v- norm ;
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
|
@ -81,10 +84,10 @@ VAR: separation-radius
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: relative-position ( self other -- v ) swap [ boid-pos ] bi@ v- ;
|
: relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ;
|
||||||
|
|
||||||
: relative-angle ( self other -- angle )
|
: relative-angle ( self other -- angle )
|
||||||
over boid-vel -rot relative-position angle-between ;
|
over vel>> -rot relative-position angle-between ;
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
|
@ -92,9 +95,9 @@ over boid-vel -rot relative-position angle-between ;
|
||||||
|
|
||||||
: vaverage ( seq-of-vectors -- seq ) [ vsum ] [ length ] bi v/n ;
|
: vaverage ( seq-of-vectors -- seq ) [ vsum ] [ length ] bi v/n ;
|
||||||
|
|
||||||
: average-position ( boids -- pos ) [ boid-pos ] map vaverage ;
|
: average-position ( boids -- pos ) [ pos>> ] map vaverage ;
|
||||||
|
|
||||||
: average-velocity ( boids -- vel ) [ boid-vel ] map vaverage ;
|
: average-velocity ( boids -- vel ) [ vel>> ] map vaverage ;
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
|
@ -123,7 +126,7 @@ over boid-vel -rot relative-position angle-between ;
|
||||||
dup cohesion-neighborhood
|
dup cohesion-neighborhood
|
||||||
dup empty?
|
dup empty?
|
||||||
[ 2drop { 0 0 } ]
|
[ 2drop { 0 0 } ]
|
||||||
[ average-position swap boid-pos v- normalize* cohesion-weight> v*n ]
|
[ average-position swap pos>> v- normalize* cohesion-weight> v*n ]
|
||||||
if ;
|
if ;
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
@ -143,7 +146,7 @@ over boid-vel -rot relative-position angle-between ;
|
||||||
dup separation-neighborhood
|
dup separation-neighborhood
|
||||||
dup empty?
|
dup empty?
|
||||||
[ 2drop { 0 0 } ]
|
[ 2drop { 0 0 } ]
|
||||||
[ average-position swap boid-pos swap v- normalize* separation-weight> v*n ]
|
[ average-position swap pos>> swap v- normalize* separation-weight> v*n ]
|
||||||
if ;
|
if ;
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
@ -206,10 +209,10 @@ cond ;
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: new-pos ( boid -- pos ) [ boid-pos ] [ boid-vel time-slice> v*n ] bi v+ ;
|
: new-pos ( boid -- pos ) [ pos>> ] [ vel>> time-slice> v*n ] bi v+ ;
|
||||||
|
|
||||||
: new-vel ( boid -- vel )
|
: new-vel ( boid -- vel )
|
||||||
[ boid-vel ] [ acceleration time-slice> v*n ] bi v+ normalize* ;
|
[ vel>> ] [ acceleration time-slice> v*n ] bi v+ normalize* ;
|
||||||
|
|
||||||
: wrap-pos ( pos -- pos ) { [ wrap-x ] [ wrap-y ] } parallel-call ;
|
: wrap-pos ( pos -- pos ) { [ wrap-x ] [ wrap-y ] } parallel-call ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -19,7 +19,8 @@ USING: combinators.short-circuit kernel namespaces
|
||||||
ui.gadgets.packs
|
ui.gadgets.packs
|
||||||
ui.gadgets.grids
|
ui.gadgets.grids
|
||||||
ui.gestures
|
ui.gestures
|
||||||
assocs.lib vars rewrite-closures boids ;
|
assocs.lib vars rewrite-closures boids accessors
|
||||||
|
math.geometry.rect ;
|
||||||
|
|
||||||
IN: boids.ui
|
IN: boids.ui
|
||||||
|
|
||||||
|
|
@ -27,9 +28,9 @@ IN: boids.ui
|
||||||
! draw-boid
|
! draw-boid
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: point-a ( boid -- a ) boid-pos ;
|
: point-a ( boid -- a ) pos>> ;
|
||||||
|
|
||||||
: point-b ( boid -- b ) [ boid-pos ] [ boid-vel normalize* 20 v*n ] bi v+ ;
|
: point-b ( boid -- b ) [ pos>> ] [ vel>> normalize* 20 v*n ] bi v+ ;
|
||||||
|
|
||||||
: boid-points ( boid -- point-a point-b ) [ point-a ] [ point-b ] bi ;
|
: boid-points ( boid -- point-a point-b ) [ point-a ] [ point-b ] bi ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,54 @@
|
||||||
|
USING: help.markup help.syntax ;
|
||||||
|
|
||||||
|
IN: math.geometry.rect
|
||||||
|
|
||||||
|
HELP: rect
|
||||||
|
{ $class-description "A rectangle with the following slots:"
|
||||||
|
{ $list
|
||||||
|
{ { $link rect-loc } " - the top-left corner of the rectangle as an x/y pair" }
|
||||||
|
{ { $link rect-dim } " - the dimensions of the rectangle as a width/height pair" }
|
||||||
|
}
|
||||||
|
"Rectangles are constructed by calling " { $link <rect> } " and " { $link <extent-rect> } "."
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: <rect> ( loc dim -- rect )
|
||||||
|
{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } { "rect" "a new " { $link rect } } }
|
||||||
|
{ $description "Creates a new rectangle with the specified top-left location and dimensions." } ;
|
||||||
|
|
||||||
|
{ <zero-rect> <rect> <extent-rect> } related-words
|
||||||
|
|
||||||
|
HELP: set-rect-dim ( dim rect -- )
|
||||||
|
{ $values { "dim" "a pair of integers" } { "rect" rect } }
|
||||||
|
{ $description "Modifies the dimensions of a rectangle." }
|
||||||
|
{ $side-effects "rect" } ;
|
||||||
|
|
||||||
|
HELP: rect-bounds
|
||||||
|
{ $values { "rect" rect } { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
|
||||||
|
{ $description "Outputs the location and dimensions of a rectangle." } ;
|
||||||
|
|
||||||
|
{ rect-bounds rect-extent } related-words
|
||||||
|
|
||||||
|
HELP: <extent-rect> ( loc ext -- rect )
|
||||||
|
{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } { "rect" "a new " { $link rect } } }
|
||||||
|
{ $description "Creates a new rectangle with the specified top-left and bottom-right corner locations." } ;
|
||||||
|
|
||||||
|
HELP: rect-extent
|
||||||
|
{ $values { "rect" rect } { "loc" "a pair of integers" } { "ext" "a pair of integers" } }
|
||||||
|
{ $description "Outputs the location of the top-left and bottom-right corners of a rectangle." } ;
|
||||||
|
|
||||||
|
HELP: offset-rect
|
||||||
|
{ $values { "rect" rect } { "loc" "a pair of integers" } { "newrect" "a new " { $link rect } } }
|
||||||
|
{ $description "Creates a new rectangle with the same dimensions, and top-left corner translated by " { $snippet "loc" } "." } ;
|
||||||
|
|
||||||
|
HELP: rect-intersect
|
||||||
|
{ $values { "rect1" rect } { "rect2" rect } { "newrect" "a new " { $link rect } } }
|
||||||
|
{ $description "Computes the intersection of two rectangles." } ;
|
||||||
|
|
||||||
|
HELP: intersects?
|
||||||
|
{ $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "rect" rect } { "?" "a boolean" } }
|
||||||
|
{ $description "Tests if two rectangles (or a point and a rectangle, respectively) have a non-empty intersection." } ;
|
||||||
|
|
||||||
|
HELP: <zero-rect>
|
||||||
|
{ $values { "rect" "a new " { $link rect } } }
|
||||||
|
{ $description "Creates a rectangle located at the origin with zero dimensions." } ;
|
||||||
|
|
||||||
|
|
@ -0,0 +1,42 @@
|
||||||
|
|
||||||
|
USING: kernel arrays math.vectors ;
|
||||||
|
|
||||||
|
IN: math.geometry.rect
|
||||||
|
|
||||||
|
TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
|
||||||
|
|
||||||
|
: <zero-rect> ( -- rect ) rect new ;
|
||||||
|
|
||||||
|
C: <rect> rect
|
||||||
|
|
||||||
|
M: array rect-loc ;
|
||||||
|
|
||||||
|
M: array rect-dim drop { 0 0 } ;
|
||||||
|
|
||||||
|
: rect-bounds ( rect -- loc dim ) dup rect-loc swap rect-dim ;
|
||||||
|
|
||||||
|
: rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
|
||||||
|
|
||||||
|
: 2rect-extent ( rect rect -- loc1 loc2 ext1 ext2 )
|
||||||
|
[ rect-extent ] bi@ swapd ;
|
||||||
|
|
||||||
|
: <extent-rect> ( loc ext -- rect ) over [v-] <rect> ;
|
||||||
|
|
||||||
|
: offset-rect ( rect loc -- newrect )
|
||||||
|
over rect-loc v+ swap rect-dim <rect> ;
|
||||||
|
|
||||||
|
: (rect-intersect) ( rect rect -- array array )
|
||||||
|
2rect-extent vmin >r vmax r> ;
|
||||||
|
|
||||||
|
: rect-intersect ( rect1 rect2 -- newrect )
|
||||||
|
(rect-intersect) <extent-rect> ;
|
||||||
|
|
||||||
|
: intersects? ( rect/point rect -- ? )
|
||||||
|
(rect-intersect) [v-] { 0 0 } = ;
|
||||||
|
|
||||||
|
: (rect-union) ( rect rect -- array array )
|
||||||
|
2rect-extent vmax >r vmin r> ;
|
||||||
|
|
||||||
|
: rect-union ( rect1 rect2 -- newrect )
|
||||||
|
(rect-union) <extent-rect> ;
|
||||||
|
|
||||||
|
|
@ -0,0 +1,5 @@
|
||||||
|
|
||||||
|
IN: math.physics.pos
|
||||||
|
|
||||||
|
TUPLE: pos pos ;
|
||||||
|
|
||||||
|
|
@ -0,0 +1,7 @@
|
||||||
|
|
||||||
|
USING: math.physics.pos ;
|
||||||
|
|
||||||
|
IN: math.physics.vel
|
||||||
|
|
||||||
|
TUPLE: vel < pos vel ;
|
||||||
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2007, 2008 Chris Double.
|
! Copyright (C) 2007, 2008 Chris Double.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel sequences strings fry namespaces math assocs shuffle debugger io
|
USING: kernel sequences strings fry namespaces math assocs shuffle debugger io
|
||||||
vectors arrays math.parser math.order vectors combinators combinators.lib
|
vectors arrays math.parser math.order vectors combinators
|
||||||
classes sets unicode.categories compiler.units parser
|
classes sets unicode.categories compiler.units parser
|
||||||
words quotations effects memoize accessors locals effects splitting
|
words quotations effects memoize accessors locals effects splitting
|
||||||
combinators.short-circuit combinators.short-circuit.smart ;
|
combinators.short-circuit combinators.short-circuit.smart ;
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
|
|
||||||
USING: kernel combinators sequences arrays math math.vectors
|
USING: kernel combinators sequences arrays math math.vectors
|
||||||
generalizations vars ;
|
generalizations vars accessors math.physics.vel ;
|
||||||
|
|
||||||
IN: springies
|
IN: springies
|
||||||
|
|
||||||
|
|
@ -28,23 +28,27 @@ VAR: gravity
|
||||||
! node
|
! node
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
TUPLE: node mass elas pos vel force ;
|
! TUPLE: node mass elas pos vel force ;
|
||||||
|
|
||||||
|
TUPLE: node < vel mass elas force ;
|
||||||
|
|
||||||
C: <node> node
|
C: <node> node
|
||||||
|
|
||||||
: >>pos ( node pos -- node ) over set-node-pos ;
|
! : >>pos ( node pos -- node ) over set-node-pos ;
|
||||||
|
|
||||||
: >>vel ( node vel -- node ) over set-node-vel ;
|
! : >>vel ( node vel -- node ) over set-node-vel ;
|
||||||
|
|
||||||
: pos-x ( node -- x ) node-pos first ;
|
: set-node-vel ( vel node -- ) swap >>vel drop ;
|
||||||
: pos-y ( node -- y ) node-pos second ;
|
|
||||||
: vel-x ( node -- y ) node-vel first ;
|
|
||||||
: vel-y ( node -- y ) node-vel second ;
|
|
||||||
|
|
||||||
: >>pos-x ( node x -- node ) over node-pos set-first ;
|
: pos-x ( node -- x ) pos>> first ;
|
||||||
: >>pos-y ( node y -- node ) over node-pos set-second ;
|
: pos-y ( node -- y ) pos>> second ;
|
||||||
: >>vel-x ( node x -- node ) over node-vel set-first ;
|
: vel-x ( node -- y ) vel>> first ;
|
||||||
: >>vel-y ( node y -- node ) over node-vel set-second ;
|
: vel-y ( node -- y ) vel>> second ;
|
||||||
|
|
||||||
|
: >>pos-x ( node x -- node ) over pos>> set-first ;
|
||||||
|
: >>pos-y ( node y -- node ) over pos>> set-second ;
|
||||||
|
: >>vel-x ( node x -- node ) over vel>> set-first ;
|
||||||
|
: >>vel-y ( node y -- node ) over vel>> set-second ;
|
||||||
|
|
||||||
: apply-force ( node vec -- ) over node-force v+ swap set-node-force ;
|
: apply-force ( node vec -- ) over node-force v+ swap set-node-force ;
|
||||||
|
|
||||||
|
|
@ -61,7 +65,7 @@ TUPLE: spring rest-length k damp node-a node-b ;
|
||||||
C: <spring> spring
|
C: <spring> spring
|
||||||
|
|
||||||
: end-points ( spring -- b-pos a-pos )
|
: end-points ( spring -- b-pos a-pos )
|
||||||
[ spring-node-b node-pos ] [ spring-node-a node-pos ] bi ;
|
[ spring-node-b pos>> ] [ spring-node-a pos>> ] bi ;
|
||||||
|
|
||||||
: spring-length ( spring -- length ) end-points v- norm ;
|
: spring-length ( spring -- length ) end-points v- norm ;
|
||||||
|
|
||||||
|
|
@ -112,10 +116,10 @@ C: <spring> spring
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: relative-velocity-a ( spring -- vel )
|
: relative-velocity-a ( spring -- vel )
|
||||||
[ spring-node-a node-vel ] [ spring-node-b node-vel ] bi v- ;
|
[ spring-node-a vel>> ] [ spring-node-b vel>> ] bi v- ;
|
||||||
|
|
||||||
: unit-vec-b->a ( spring -- vec )
|
: unit-vec-b->a ( spring -- vec )
|
||||||
[ spring-node-a node-pos ] [ spring-node-b node-pos ] bi v- ;
|
[ spring-node-a pos>> ] [ spring-node-b pos>> ] bi v- ;
|
||||||
|
|
||||||
: relative-velocity-along-spring-a ( spring -- vel )
|
: relative-velocity-along-spring-a ( spring -- vel )
|
||||||
[ relative-velocity-a ] [ unit-vec-b->a ] bi vector-projection ;
|
[ relative-velocity-a ] [ unit-vec-b->a ] bi vector-projection ;
|
||||||
|
|
@ -126,10 +130,10 @@ C: <spring> spring
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: relative-velocity-b ( spring -- vel )
|
: relative-velocity-b ( spring -- vel )
|
||||||
[ spring-node-b node-vel ] [ spring-node-a node-vel ] bi v- ;
|
[ spring-node-b vel>> ] [ spring-node-a vel>> ] bi v- ;
|
||||||
|
|
||||||
: unit-vec-a->b ( spring -- vec )
|
: unit-vec-a->b ( spring -- vec )
|
||||||
[ spring-node-b node-pos ] [ spring-node-a node-pos ] bi v- ;
|
[ spring-node-b pos>> ] [ spring-node-a pos>> ] bi v- ;
|
||||||
|
|
||||||
: relative-velocity-along-spring-b ( spring -- vel )
|
: relative-velocity-along-spring-b ( spring -- vel )
|
||||||
[ relative-velocity-b ] [ unit-vec-a->b ] bi vector-projection ;
|
[ relative-velocity-b ] [ unit-vec-a->b ] bi vector-projection ;
|
||||||
|
|
@ -210,9 +214,9 @@ C: <spring> spring
|
||||||
: calc-acceleration ( node -- vec ) [ node-force ] [ node-mass ] bi v/n ;
|
: calc-acceleration ( node -- vec ) [ node-force ] [ node-mass ] bi v/n ;
|
||||||
|
|
||||||
: new-vel ( node -- vel )
|
: new-vel ( node -- vel )
|
||||||
[ node-vel ] [ calc-acceleration time-slice> v*n ] bi v+ ;
|
[ vel>> ] [ calc-acceleration time-slice> v*n ] bi v+ ;
|
||||||
|
|
||||||
: new-pos ( node -- pos ) [ node-pos ] [ node-vel time-slice> v*n ] bi v+ ;
|
: new-pos ( node -- pos ) [ pos>> ] [ vel>> time-slice> v*n ] bi v+ ;
|
||||||
|
|
||||||
: iterate-node ( node -- )
|
: iterate-node ( node -- )
|
||||||
dup new-pos >>pos
|
dup new-pos >>pos
|
||||||
|
|
@ -231,16 +235,21 @@ C: <spring> spring
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: mass ( id x y x-vel y-vel mass elas -- )
|
: mass ( id x y x-vel y-vel mass elas -- )
|
||||||
7 nrot drop
|
node new
|
||||||
6 nrot 6 nrot 2array
|
swap >>elas
|
||||||
5 nrot 5 nrot 2array
|
swap >>mass
|
||||||
0 0 2array <node>
|
-rot 2array >>vel
|
||||||
nodes> swap suffix >nodes ;
|
-rot 2array >>pos
|
||||||
|
0 0 2array >>force
|
||||||
|
nodes> swap suffix >nodes
|
||||||
|
drop ;
|
||||||
|
|
||||||
: spng ( id id-a id-b k damp rest-length -- )
|
: spng ( id id-a id-b k damp rest-length -- )
|
||||||
6 nrot drop
|
spring new
|
||||||
-rot
|
swap >>rest-length
|
||||||
5 nrot node-id
|
swap >>damp
|
||||||
5 nrot node-id
|
swap >>k
|
||||||
<spring>
|
swap node-id >>node-b
|
||||||
springs> swap suffix >springs ;
|
swap node-id >>node-a
|
||||||
|
springs> swap suffix >springs
|
||||||
|
drop ;
|
||||||
|
|
@ -1,16 +1,16 @@
|
||||||
|
|
||||||
USING: kernel namespaces threads sequences math math.vectors
|
USING: kernel namespaces threads sequences math math.vectors
|
||||||
opengl.gl opengl colors ui ui.gadgets ui.gadgets.slate
|
opengl.gl opengl colors ui ui.gadgets ui.gadgets.slate
|
||||||
fry rewrite-closures vars springies ;
|
fry rewrite-closures vars springies accessors math.geometry.rect ;
|
||||||
|
|
||||||
IN: springies.ui
|
IN: springies.ui
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: draw-node ( node -- ) node-pos { -5 -5 } v+ dup { 10 10 } v+ gl-rect ;
|
: draw-node ( node -- ) pos>> { -5 -5 } v+ dup { 10 10 } v+ gl-rect ;
|
||||||
|
|
||||||
: draw-spring ( spring -- )
|
: draw-spring ( spring -- )
|
||||||
[ spring-node-a node-pos ] [ spring-node-b node-pos ] bi gl-line ;
|
[ spring-node-a pos>> ] [ spring-node-b pos>> ] bi gl-line ;
|
||||||
|
|
||||||
: draw-nodes ( -- ) nodes> [ draw-node ] each ;
|
: draw-nodes ( -- ) nodes> [ draw-node ] each ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -6,7 +6,7 @@ TUPLE: foo bar ;
|
||||||
C: <foo> foo
|
C: <foo> foo
|
||||||
[ 2 ] [ 2 T{ foo } <tuple-array> dup mat set length ] unit-test
|
[ 2 ] [ 2 T{ foo } <tuple-array> dup mat set length ] unit-test
|
||||||
[ T{ foo } ] [ mat get first ] unit-test
|
[ T{ foo } ] [ mat get first ] unit-test
|
||||||
[ T{ foo f 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test
|
[ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test
|
||||||
[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test
|
[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test
|
||||||
[ T{ foo f 3 } t ]
|
[ T{ foo f 3 } t ]
|
||||||
[ mat get [ foo-bar 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test
|
[ mat get [ foo-bar 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -1,35 +1,26 @@
|
||||||
! Copyright (C) 2007 Daniel Ehrenberg.
|
! Copyright (C) 2007 Daniel Ehrenberg.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: splitting grouping classes.tuple classes math kernel
|
USING: splitting grouping classes.tuple classes math kernel
|
||||||
sequences arrays ;
|
sequences arrays accessors ;
|
||||||
IN: tuple-arrays
|
IN: tuple-arrays
|
||||||
|
|
||||||
TUPLE: tuple-array example ;
|
TUPLE: tuple-array seq class ;
|
||||||
|
|
||||||
: prepare-example ( tuple -- seq n )
|
|
||||||
dup class over delegate [ 1array ] [ f 2array ] if
|
|
||||||
swap tuple>array length over length - ;
|
|
||||||
|
|
||||||
: <tuple-array> ( length example -- tuple-array )
|
: <tuple-array> ( length example -- tuple-array )
|
||||||
prepare-example [ rot * { } new-sequence ] keep
|
[ tuple>array length 1- [ * { } new-sequence ] keep <sliced-groups> ]
|
||||||
<sliced-groups> tuple-array construct-delegate
|
[ class ] bi tuple-array boa ;
|
||||||
[ set-tuple-array-example ] keep ;
|
|
||||||
|
|
||||||
: reconstruct ( seq example -- tuple )
|
|
||||||
prepend >tuple ;
|
|
||||||
|
|
||||||
M: tuple-array nth
|
M: tuple-array nth
|
||||||
[ delegate nth ] keep
|
[ seq>> nth ] [ class>> ] bi prefix >tuple ;
|
||||||
tuple-array-example reconstruct ;
|
|
||||||
|
|
||||||
: deconstruct ( tuple example -- seq )
|
: deconstruct ( tuple -- seq )
|
||||||
>r tuple>array r> length tail-slice ;
|
tuple>array 1 tail ;
|
||||||
|
|
||||||
M: tuple-array set-nth ( elt n seq -- )
|
M: tuple-array set-nth ( elt n seq -- )
|
||||||
tuck >r >r tuple-array-example deconstruct r> r>
|
>r >r deconstruct r> r> seq>> set-nth ;
|
||||||
delegate set-nth ;
|
|
||||||
|
|
||||||
M: tuple-array new-sequence tuple-array-example >tuple <tuple-array> ;
|
M: tuple-array new-sequence
|
||||||
|
class>> new <tuple-array> ;
|
||||||
|
|
||||||
: >tuple-array ( seq -- tuple-array/seq )
|
: >tuple-array ( seq -- tuple-array/seq )
|
||||||
dup empty? [
|
dup empty? [
|
||||||
|
|
@ -39,4 +30,6 @@ M: tuple-array new-sequence tuple-array-example >tuple <tuple-array> ;
|
||||||
M: tuple-array like
|
M: tuple-array like
|
||||||
drop dup tuple-array? [ >tuple-array ] unless ;
|
drop dup tuple-array? [ >tuple-array ] unless ;
|
||||||
|
|
||||||
|
M: tuple-array length seq>> length ;
|
||||||
|
|
||||||
INSTANCE: tuple-array sequence
|
INSTANCE: tuple-array sequence
|
||||||
|
|
|
||||||
|
|
@ -5,7 +5,7 @@ command-line kernel memory namespaces cocoa.messages
|
||||||
cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
|
cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
|
||||||
cocoa.windows cocoa.classes cocoa.application sequences system
|
cocoa.windows cocoa.classes cocoa.application sequences system
|
||||||
ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
|
ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
|
||||||
ui.cocoa.views core-foundation threads ;
|
ui.cocoa.views core-foundation threads math.geometry.rect ;
|
||||||
IN: ui.cocoa
|
IN: ui.cocoa
|
||||||
|
|
||||||
TUPLE: handle view window ;
|
TUPLE: handle view window ;
|
||||||
|
|
|
||||||
|
|
@ -73,7 +73,7 @@ HELP: command-word
|
||||||
HELP: command-map
|
HELP: command-map
|
||||||
{ $values { "group" string } { "class" "a class word" } { "command-map" "a " { $link command-map } " or " { $link f } } }
|
{ $values { "group" string } { "class" "a class word" } { "command-map" "a " { $link command-map } " or " { $link f } } }
|
||||||
{ $description "Outputs a named command map defined on a class." }
|
{ $description "Outputs a named command map defined on a class." }
|
||||||
{ $class-description "A command map stores a group of related commands. Instances of this class delegate to arrays so behave like sequences; additionally the " { $link command-map-blurb } " slot stores a string description of the command group, or " { $link f } "."
|
{ $class-description "A command map stores a group of related commands. The " { $snippet "commands" } " slot stores an association list mapping gestures to commands, and the " { $snippet "blurb" } " slot stores an optional one-line description string of this command map."
|
||||||
$nl
|
$nl
|
||||||
"Command maps are created by calling " { $link <command-map> } " or " { $link define-command-map } "." } ;
|
"Command maps are created by calling " { $link <command-map> } " or " { $link define-command-map } "." } ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors kernel sequences models ui.gadgets ;
|
USING: accessors kernel sequences models ui.gadgets math.geometry.rect ;
|
||||||
IN: ui.gadgets.books
|
IN: ui.gadgets.books
|
||||||
|
|
||||||
TUPLE: book < gadget ;
|
TUPLE: book < gadget ;
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors arrays ui.gadgets kernel math
|
USING: accessors arrays ui.gadgets kernel math
|
||||||
namespaces vectors sequences math.vectors ;
|
namespaces vectors sequences math.vectors math.geometry.rect ;
|
||||||
IN: ui.gadgets.borders
|
IN: ui.gadgets.borders
|
||||||
|
|
||||||
TUPLE: border < gadget
|
TUPLE: border < gadget
|
||||||
|
|
|
||||||
|
|
@ -11,7 +11,7 @@ $nl
|
||||||
|
|
||||||
HELP: <button>
|
HELP: <button>
|
||||||
{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" "a new " { $link button } } }
|
{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" "a new " { $link button } } }
|
||||||
{ $description "Creates a new " { $link button } " which calls the quotation when clicked. The given gadget becomes the button's delegate." } ;
|
{ $description "Creates a new " { $link button } " which calls the quotation when clicked. The given gadget becomes the button's only child." } ;
|
||||||
|
|
||||||
HELP: <roll-button>
|
HELP: <roll-button>
|
||||||
{ $values { "label" "a label specifier" } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" button } }
|
{ $values { "label" "a label specifier" } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" button } }
|
||||||
|
|
|
||||||
|
|
@ -16,7 +16,7 @@ TUPLE: foo-gadget ;
|
||||||
T{ foo-gadget } <toolbar> "t" set
|
T{ foo-gadget } <toolbar> "t" set
|
||||||
|
|
||||||
[ 2 ] [ "t" get gadget-children length ] unit-test
|
[ 2 ] [ "t" get gadget-children length ] unit-test
|
||||||
[ "Foo A" ] [ "t" get gadget-child gadget-child gadget-child label-string ] unit-test
|
[ "Foo A" ] [ "t" get gadget-child gadget-child label-string ] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
2 <model> {
|
2 <model> {
|
||||||
|
|
|
||||||
|
|
@ -6,7 +6,7 @@ classes.tuple opengl math.vectors
|
||||||
ui.commands ui.gadgets ui.gadgets.borders
|
ui.commands ui.gadgets ui.gadgets.borders
|
||||||
ui.gadgets.labels ui.gadgets.theme
|
ui.gadgets.labels ui.gadgets.theme
|
||||||
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
|
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
|
||||||
ui.render ;
|
ui.render math.geometry.rect ;
|
||||||
IN: ui.gadgets.buttons
|
IN: ui.gadgets.buttons
|
||||||
|
|
||||||
TUPLE: button < border pressed? selected? quot ;
|
TUPLE: button < border pressed? selected? quot ;
|
||||||
|
|
|
||||||
|
|
@ -5,7 +5,8 @@ namespaces opengl opengl.gl sequences strings io.styles
|
||||||
math.vectors sorting colors combinators assocs math.order
|
math.vectors sorting colors combinators assocs math.order
|
||||||
ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
|
ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
|
||||||
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
|
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
|
||||||
ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures ;
|
ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures
|
||||||
|
math.geometry.rect ;
|
||||||
IN: ui.gadgets.editors
|
IN: ui.gadgets.editors
|
||||||
|
|
||||||
TUPLE: editor < gadget
|
TUPLE: editor < gadget
|
||||||
|
|
@ -480,7 +481,7 @@ multiline-editor "general" f {
|
||||||
{ T{ key-down f f "ENTER" } insert-newline }
|
{ T{ key-down f f "ENTER" } insert-newline }
|
||||||
} define-command-map
|
} define-command-map
|
||||||
|
|
||||||
TUPLE: source-editor < editor ;
|
TUPLE: source-editor < multiline-editor ;
|
||||||
|
|
||||||
: <source-editor> ( -- editor )
|
: <source-editor> ( -- editor )
|
||||||
source-editor new-editor ;
|
source-editor new-editor ;
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,7 @@ quotations classes.tuple ui.gadgets.grids ;
|
||||||
IN: ui.gadgets.frames
|
IN: ui.gadgets.frames
|
||||||
|
|
||||||
ARTICLE: "ui-frame-layout" "Frame layouts"
|
ARTICLE: "ui-frame-layout" "Frame layouts"
|
||||||
"Frames resemble " { $link "ui-grid-layout" } " except the size of grid is fixed at 3x3, and the center gadget fills up any available space. Because frames delegate to grids, grid layout words can be used to add and remove children."
|
"Frames resemble " { $link "ui-grid-layout" } " except the size of grid is fixed at 3x3, and the center gadget fills up any available space. Because frames inherit from grids, grid layout words can be used to add and remove children."
|
||||||
{ $subsection frame }
|
{ $subsection frame }
|
||||||
"Creating empty frames:"
|
"Creating empty frames:"
|
||||||
{ $subsection <frame> }
|
{ $subsection <frame> }
|
||||||
|
|
@ -38,7 +38,7 @@ HELP: @bottom-right $ui-frame-constant ;
|
||||||
HELP: frame
|
HELP: frame
|
||||||
{ $class-description "A frame is a gadget which lays out its children in a 3x3 grid. If the frame is enlarged past its preferred size, the center gadget fills up available room."
|
{ $class-description "A frame is a gadget which lays out its children in a 3x3 grid. If the frame is enlarged past its preferred size, the center gadget fills up available room."
|
||||||
$nl
|
$nl
|
||||||
"Frames are constructed by calling " { $link <frame> } " and since they delegate to " { $link grid } " instances, children can be managed with " { $link grid-add } " and " { $link grid-remove } "." } ;
|
"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add } " and " { $link grid-remove } "." } ;
|
||||||
|
|
||||||
HELP: <frame>
|
HELP: <frame>
|
||||||
{ $values { "frame" frame } }
|
{ $values { "frame" frame } }
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2005, 2007 Slava Pestov.
|
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays generic kernel math namespaces sequences words
|
USING: arrays generic kernel math namespaces sequences words
|
||||||
splitting grouping math.vectors ui.gadgets.grids ui.gadgets ;
|
splitting grouping math.vectors ui.gadgets.grids ui.gadgets
|
||||||
|
math.geometry.rect ;
|
||||||
IN: ui.gadgets.frames
|
IN: ui.gadgets.frames
|
||||||
|
|
||||||
! A frame arranges gadgets in a 3x3 grid, where the center
|
! A frame arranges gadgets in a 3x3 grid, where the center
|
||||||
|
|
@ -39,7 +40,7 @@ M: frame layout*
|
||||||
grid-layout ;
|
grid-layout ;
|
||||||
|
|
||||||
: make-frame ( quot -- frame )
|
: make-frame ( quot -- frame )
|
||||||
<frame> make-gadget ; inline
|
<frame> swap make-gadget ; inline
|
||||||
|
|
||||||
: frame, ( gadget i j -- )
|
: frame, ( gadget i j -- )
|
||||||
\ make-gadget get -rot grid-add ;
|
gadget get -rot grid-add ;
|
||||||
|
|
|
||||||
|
|
@ -1,53 +1,7 @@
|
||||||
USING: help.markup help.syntax opengl kernel strings
|
USING: help.markup help.syntax opengl kernel strings
|
||||||
classes.tuple classes quotations models ;
|
classes.tuple classes quotations models math.geometry.rect ;
|
||||||
IN: ui.gadgets
|
IN: ui.gadgets
|
||||||
|
|
||||||
HELP: rect
|
|
||||||
{ $class-description "A rectangle with the following slots:"
|
|
||||||
{ $list
|
|
||||||
{ { $link rect-loc } " - the top-left corner of the rectangle as an x/y pair" }
|
|
||||||
{ { $link rect-dim } " - the dimensions of the rectangle as a width/height pair" }
|
|
||||||
}
|
|
||||||
"Rectangles are constructed by calling " { $link <rect> } " and " { $link <extent-rect> } "."
|
|
||||||
} ;
|
|
||||||
|
|
||||||
HELP: <rect> ( loc dim -- rect )
|
|
||||||
{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } { "rect" "a new " { $link rect } } }
|
|
||||||
{ $description "Creates a new rectangle with the specified top-left location and dimensions." } ;
|
|
||||||
|
|
||||||
{ <zero-rect> <rect> <extent-rect> } related-words
|
|
||||||
|
|
||||||
HELP: set-rect-dim ( dim rect -- )
|
|
||||||
{ $values { "dim" "a pair of integers" } { "rect" rect } }
|
|
||||||
{ $description "Modifies the dimensions of a rectangle. To resize a gadget, use " { $link set-gadget-dim } " or " { $link set-layout-dim } " instead." }
|
|
||||||
{ $side-effects "rect" } ;
|
|
||||||
|
|
||||||
HELP: rect-bounds
|
|
||||||
{ $values { "rect" rect } { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
|
|
||||||
{ $description "Outputs the location and dimensions of a rectangle." } ;
|
|
||||||
|
|
||||||
{ rect-bounds rect-extent } related-words
|
|
||||||
|
|
||||||
HELP: <extent-rect> ( loc ext -- rect )
|
|
||||||
{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } { "rect" "a new " { $link rect } } }
|
|
||||||
{ $description "Creates a new rectangle with the specified top-left and bottom-right corner locations." } ;
|
|
||||||
|
|
||||||
HELP: rect-extent
|
|
||||||
{ $values { "rect" rect } { "loc" "a pair of integers" } { "ext" "a pair of integers" } }
|
|
||||||
{ $description "Outputs the location of the top-left and bottom-right corners of a rectangle." } ;
|
|
||||||
|
|
||||||
HELP: offset-rect
|
|
||||||
{ $values { "rect" rect } { "loc" "a pair of integers" } { "newrect" "a new " { $link rect } } }
|
|
||||||
{ $description "Creates a new rectangle with the same dimensions, and top-left corner translated by " { $snippet "loc" } "." } ;
|
|
||||||
|
|
||||||
HELP: rect-intersect
|
|
||||||
{ $values { "rect1" rect } { "rect2" rect } { "newrect" "a new " { $link rect } } }
|
|
||||||
{ $description "Computes the intersection of two rectangles." } ;
|
|
||||||
|
|
||||||
HELP: intersects?
|
|
||||||
{ $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "rect" rect } { "?" "a boolean" } }
|
|
||||||
{ $description "Tests if two rectangles (or a point and a rectangle, respectively) have a non-empty intersection." } ;
|
|
||||||
|
|
||||||
HELP: gadget-child
|
HELP: gadget-child
|
||||||
{ $values { "gadget" gadget } { "child" gadget } }
|
{ $values { "gadget" gadget } { "child" gadget } }
|
||||||
{ $description "Outputs the first child of the gadget. Typically this word is used with gadgets which are known to have an only child." } ;
|
{ $description "Outputs the first child of the gadget. Typically this word is used with gadgets which are known to have an only child." } ;
|
||||||
|
|
@ -57,10 +11,6 @@ HELP: nth-gadget
|
||||||
{ $description "Outputs the " { $snippet "n" } "th child of the gadget." }
|
{ $description "Outputs the " { $snippet "n" } "th child of the gadget." }
|
||||||
{ $errors "Throws an error if " { $snippet "n" } " is negative or greater than or equal to the number of children." } ;
|
{ $errors "Throws an error if " { $snippet "n" } " is negative or greater than or equal to the number of children." } ;
|
||||||
|
|
||||||
HELP: <zero-rect>
|
|
||||||
{ $values { "rect" "a new " { $link rect } } }
|
|
||||||
{ $description "Creates a rectangle located at the origin with zero dimensions." } ;
|
|
||||||
|
|
||||||
HELP: <gadget>
|
HELP: <gadget>
|
||||||
{ $values { "gadget" "a new " { $link gadget } } }
|
{ $values { "gadget" "a new " { $link gadget } } }
|
||||||
{ $description "Creates a new gadget." } ;
|
{ $description "Creates a new gadget." } ;
|
||||||
|
|
@ -235,8 +185,8 @@ HELP: gadget,
|
||||||
{ $description "Adds a new child to the gadget being constructed. This word can only be used from a quotation passed to " { $link make-gadget } "." } ;
|
{ $description "Adds a new child to the gadget being constructed. This word can only be used from a quotation passed to " { $link make-gadget } "." } ;
|
||||||
|
|
||||||
HELP: make-gadget
|
HELP: make-gadget
|
||||||
{ $values { "quot" quotation } { "gadget" gadget } }
|
{ $values { "gadget" gadget } { "quot" quotation } }
|
||||||
{ $description "Calls the quotation in a new scope with the gadget stored in the " { $link make-gadget } " variable." } ;
|
{ $description "Calls the quotation in a new scope with the gadget stored in the " { $link gadget } " variable." } ;
|
||||||
|
|
||||||
HELP: with-gadget
|
HELP: with-gadget
|
||||||
{ $values { "gadget" gadget } { "quot" quotation } }
|
{ $values { "gadget" gadget } { "quot" quotation } }
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,8 @@
|
||||||
IN: ui.gadgets.tests
|
IN: ui.gadgets.tests
|
||||||
USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
|
USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds
|
||||||
namespaces models kernel dlists dequeues math sets
|
tools.test namespaces models kernel dlists dequeues math sets
|
||||||
math.parser ui sequences hashtables assocs io arrays
|
math.parser ui sequences hashtables assocs io arrays prettyprint
|
||||||
prettyprint io.streams.string ;
|
io.streams.string ;
|
||||||
|
|
||||||
[ T{ rect f { 10 10 } { 20 20 } } ]
|
[ T{ rect f { 10 10 } { 20 20 } } ]
|
||||||
[
|
[
|
||||||
|
|
@ -104,10 +104,10 @@ prettyprint io.streams.string ;
|
||||||
|
|
||||||
[ t ] [ { 25 25 } "g1" get pick-up "g4" get eq? ] unit-test
|
[ t ] [ { 25 25 } "g1" get pick-up "g4" get eq? ] unit-test
|
||||||
|
|
||||||
TUPLE: mock-gadget graft-called ungraft-called ;
|
TUPLE: mock-gadget < gadget graft-called ungraft-called ;
|
||||||
|
|
||||||
: <mock-gadget> ( -- gadget )
|
: <mock-gadget> ( -- gadget )
|
||||||
0 0 mock-gadget boa <gadget> over set-delegate ;
|
mock-gadget new-gadget 0 >>graft-called 0 >>ungraft-called ;
|
||||||
|
|
||||||
M: mock-gadget graft*
|
M: mock-gadget graft*
|
||||||
dup mock-gadget-graft-called 1+
|
dup mock-gadget-graft-called 1+
|
||||||
|
|
|
||||||
|
|
@ -1,51 +1,16 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors arrays hashtables kernel models math namespaces
|
USING: accessors arrays hashtables kernel models math namespaces
|
||||||
sequences quotations math.vectors combinators sorting vectors
|
sequences quotations math.vectors combinators sorting vectors
|
||||||
dlists dequeues models threads concurrency.flags math.order ;
|
dlists dequeues models threads concurrency.flags
|
||||||
|
math.order math.geometry.rect ;
|
||||||
|
|
||||||
IN: ui.gadgets
|
IN: ui.gadgets
|
||||||
|
|
||||||
SYMBOL: ui-notify-flag
|
SYMBOL: ui-notify-flag
|
||||||
|
|
||||||
: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
|
: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
|
||||||
|
|
||||||
TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
|
|
||||||
|
|
||||||
: <zero-rect> ( -- rect ) rect new ;
|
|
||||||
|
|
||||||
C: <rect> rect
|
|
||||||
|
|
||||||
M: array rect-loc ;
|
|
||||||
|
|
||||||
M: array rect-dim drop { 0 0 } ;
|
|
||||||
|
|
||||||
: rect-bounds ( rect -- loc dim ) dup rect-loc swap rect-dim ;
|
|
||||||
|
|
||||||
: rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
|
|
||||||
|
|
||||||
: 2rect-extent ( rect rect -- loc1 loc2 ext1 ext2 )
|
|
||||||
[ rect-extent ] bi@ swapd ;
|
|
||||||
|
|
||||||
: <extent-rect> ( loc ext -- rect ) over [v-] <rect> ;
|
|
||||||
|
|
||||||
: offset-rect ( rect loc -- newrect )
|
|
||||||
over rect-loc v+ swap rect-dim <rect> ;
|
|
||||||
|
|
||||||
: (rect-intersect) ( rect rect -- array array )
|
|
||||||
2rect-extent vmin >r vmax r> ;
|
|
||||||
|
|
||||||
: rect-intersect ( rect1 rect2 -- newrect )
|
|
||||||
(rect-intersect) <extent-rect> ;
|
|
||||||
|
|
||||||
: intersects? ( rect/point rect -- ? )
|
|
||||||
(rect-intersect) [v-] { 0 0 } = ;
|
|
||||||
|
|
||||||
: (rect-union) ( rect rect -- array array )
|
|
||||||
2rect-extent vmax >r vmin r> ;
|
|
||||||
|
|
||||||
: rect-union ( rect1 rect2 -- newrect )
|
|
||||||
(rect-union) <extent-rect> ;
|
|
||||||
|
|
||||||
TUPLE: gadget < rect
|
TUPLE: gadget < rect
|
||||||
pref-dim parent children orientation focus
|
pref-dim parent children orientation focus
|
||||||
visible? root? clipped? layout-state graft-state graft-node
|
visible? root? clipped? layout-state graft-state graft-node
|
||||||
|
|
@ -391,19 +356,17 @@ M: f request-focus-on 2drop ;
|
||||||
: focus-path ( world -- seq )
|
: focus-path ( world -- seq )
|
||||||
[ gadget-focus ] follow ;
|
[ gadget-focus ] follow ;
|
||||||
|
|
||||||
: make-gadget ( quot gadget -- gadget )
|
: gadget, ( gadget -- ) gadget get add-gadget ;
|
||||||
[ \ make-gadget rot with-variable ] keep ; inline
|
|
||||||
|
|
||||||
: gadget, ( gadget -- ) \ make-gadget get add-gadget ;
|
|
||||||
|
|
||||||
: g ( -- gadget ) gadget get ;
|
: g ( -- gadget ) gadget get ;
|
||||||
|
|
||||||
: g-> ( x -- x x gadget ) dup g ;
|
: g-> ( x -- x x gadget ) dup g ;
|
||||||
|
|
||||||
: with-gadget ( gadget quot -- )
|
: with-gadget ( gadget quot -- )
|
||||||
[
|
gadget swap with-variable ; inline
|
||||||
swap dup \ make-gadget set gadget set call
|
|
||||||
] with-scope ; inline
|
: make-gadget ( gadget quot -- gadget )
|
||||||
|
[ with-gadget ] [ drop ] 2bi ; inline
|
||||||
|
|
||||||
! Deprecated
|
! Deprecated
|
||||||
: set-gadget-delegate ( gadget tuple -- )
|
: set-gadget-delegate ( gadget tuple -- )
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2006, 2007 Slava Pestov.
|
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel math namespaces opengl opengl.gl sequences
|
USING: kernel math namespaces opengl opengl.gl sequences
|
||||||
math.vectors ui.gadgets ui.gadgets.grids ui.render ;
|
math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
|
||||||
IN: ui.gadgets.grid-lines
|
IN: ui.gadgets.grid-lines
|
||||||
|
|
||||||
TUPLE: grid-lines color ;
|
TUPLE: grid-lines color ;
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays kernel math namespaces sequences words io
|
USING: arrays kernel math namespaces sequences words io
|
||||||
io.streams.string math.vectors ui.gadgets columns accessors ;
|
io.streams.string math.vectors ui.gadgets columns accessors
|
||||||
|
math.geometry.rect ;
|
||||||
IN: ui.gadgets.grids
|
IN: ui.gadgets.grids
|
||||||
|
|
||||||
TUPLE: grid < gadget
|
TUPLE: grid < gadget
|
||||||
|
|
|
||||||
|
|
@ -2,7 +2,7 @@ USING: ui.gadgets help.markup help.syntax ui.gadgets.packs ;
|
||||||
IN: ui.gadgets.incremental
|
IN: ui.gadgets.incremental
|
||||||
|
|
||||||
HELP: incremental
|
HELP: incremental
|
||||||
{ $class-description "An incremental layout gadget delegates to a " { $link pack } " and implements an optimization which the relayout operation after adding a child to be done in constant time."
|
{ $class-description "Incremental layout gadgets inherit from " { $link pack } " and implement an optimization where the relayout operation after adding a child to be done in constant time."
|
||||||
$nl
|
$nl
|
||||||
"Incremental layout gadgets are created by calling " { $link <incremental> } "."
|
"Incremental layout gadgets are created by calling " { $link <incremental> } "."
|
||||||
$nl
|
$nl
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: io kernel math namespaces math.vectors ui.gadgets
|
USING: io kernel math namespaces math.vectors ui.gadgets
|
||||||
ui.gadgets.packs accessors ;
|
ui.gadgets.packs accessors math.geometry.rect ;
|
||||||
IN: ui.gadgets.incremental
|
IN: ui.gadgets.incremental
|
||||||
|
|
||||||
! Incremental layout allows adding lines to panes to be O(1).
|
! Incremental layout allows adding lines to panes to be O(1).
|
||||||
|
|
|
||||||
|
|
@ -13,11 +13,9 @@ TUPLE: labelled-gadget < track content ;
|
||||||
: <labelled-gadget> ( gadget title -- newgadget )
|
: <labelled-gadget> ( gadget title -- newgadget )
|
||||||
{ 0 1 } labelled-gadget new-track
|
{ 0 1 } labelled-gadget new-track
|
||||||
[
|
[
|
||||||
[
|
<label> reverse-video-theme f track,
|
||||||
<label> reverse-video-theme f track,
|
g-> set-labelled-gadget-content 1 track,
|
||||||
g-> set-labelled-gadget-content 1 track,
|
] make-gadget ;
|
||||||
] with-gadget
|
|
||||||
] keep ;
|
|
||||||
|
|
||||||
M: labelled-gadget focusable-child* labelled-gadget-content ;
|
M: labelled-gadget focusable-child* labelled-gadget-content ;
|
||||||
|
|
||||||
|
|
@ -54,10 +52,8 @@ TUPLE: closable-gadget < frame content ;
|
||||||
: <closable-gadget> ( gadget title quot -- gadget )
|
: <closable-gadget> ( gadget title quot -- gadget )
|
||||||
closable-gadget new-frame
|
closable-gadget new-frame
|
||||||
[
|
[
|
||||||
[
|
<title-bar> @top frame,
|
||||||
<title-bar> @top frame,
|
g-> set-closable-gadget-content @center frame,
|
||||||
g-> set-closable-gadget-content @center frame,
|
] make-gadget ;
|
||||||
] with-gadget
|
|
||||||
] keep ;
|
|
||||||
|
|
||||||
M: closable-gadget focusable-child* closable-gadget-content ;
|
M: closable-gadget focusable-child* closable-gadget-content ;
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,7 @@ USING: accessors ui.commands ui.gestures ui.render ui.gadgets
|
||||||
ui.gadgets.labels ui.gadgets.scrollers
|
ui.gadgets.labels ui.gadgets.scrollers
|
||||||
kernel sequences models opengl math math.order namespaces
|
kernel sequences models opengl math math.order namespaces
|
||||||
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
|
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
|
||||||
math.vectors classes.tuple ;
|
math.vectors classes.tuple math.geometry.rect ;
|
||||||
IN: ui.gadgets.lists
|
IN: ui.gadgets.lists
|
||||||
|
|
||||||
TUPLE: list < pack index presenter color hook ;
|
TUPLE: list < pack index presenter color hook ;
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,8 @@
|
||||||
USING: arrays ui.commands ui.gadgets ui.gadgets.buttons
|
USING: arrays ui.commands ui.gadgets ui.gadgets.buttons
|
||||||
ui.gadgets.worlds ui.gestures generic hashtables kernel math
|
ui.gadgets.worlds ui.gestures generic hashtables kernel math
|
||||||
models namespaces opengl sequences math.vectors
|
models namespaces opengl sequences math.vectors
|
||||||
ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors ;
|
ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors
|
||||||
|
math.geometry.rect ;
|
||||||
IN: ui.gadgets.menus
|
IN: ui.gadgets.menus
|
||||||
|
|
||||||
: menu-loc ( world menu -- loc )
|
: menu-loc ( world menu -- loc )
|
||||||
|
|
|
||||||
|
|
@ -34,13 +34,13 @@ HELP: pack
|
||||||
{ { $link pack-fill } " a rational number between 0 and 1, where 0 gives each gadget its preferred size and 1 fills the dimension perpendicular to the pack's orientation" }
|
{ { $link pack-fill } " a rational number between 0 and 1, where 0 gives each gadget its preferred size and 1 fills the dimension perpendicular to the pack's orientation" }
|
||||||
{ { $link pack-gap } " a pair of integers, the horizontal and vertical gap between children" }
|
{ { $link pack-gap } " a pair of integers, the horizontal and vertical gap between children" }
|
||||||
}
|
}
|
||||||
"Gadgets can delegate to packs and implement their own " { $link pref-dim* } " and " { $link layout* } " methods, reusing pack layout logic by calling " { $link pack-pref-dim } " and " { $link pack-layout } "." } ;
|
"Custom gadgets can inherit from the " { $link pack } " class and implement their own " { $link pref-dim* } " and " { $link layout* } " methods, reusing pack layout logic by calling " { $link pack-pref-dim } " and " { $link pack-layout } "." } ;
|
||||||
|
|
||||||
HELP: pack-layout
|
HELP: pack-layout
|
||||||
{ $values { "pack" "a new " { $link pack } } { "sizes" "a sequence of pairs of integers" } }
|
{ $values { "pack" "a new " { $link pack } } { "sizes" "a sequence of pairs of integers" } }
|
||||||
{ $description "Lays out the pack's children along the " { $link gadget-orientation } " of the pack, with each gadget receiving its size from the corresponding index of the " { $snippet "sizes" } " sequence." }
|
{ $description "Lays out the pack's children along the " { $link gadget-orientation } " of the pack, with each gadget receiving its size from the corresponding index of the " { $snippet "sizes" } " sequence." }
|
||||||
{ $notes
|
{ $notes
|
||||||
"This word is useful if you are writing your own layout gadget which delegates to a " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure."
|
"This word is useful if you are writing your own layout gadget which inherits from " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure."
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: <pack>
|
HELP: <pack>
|
||||||
|
|
@ -61,7 +61,7 @@ HELP: pack-pref-dim
|
||||||
{ $values { "gadget" gadget } { "sizes" "a sequence of pairs of integers" } { "dim" "a pair of integers" } }
|
{ $values { "gadget" gadget } { "sizes" "a sequence of pairs of integers" } { "dim" "a pair of integers" } }
|
||||||
{ $description "Computes the preferred size of a pack, with each gadget receiving its size from the corresponding index of the " { $snippet "sizes" } " sequence." }
|
{ $description "Computes the preferred size of a pack, with each gadget receiving its size from the corresponding index of the " { $snippet "sizes" } " sequence." }
|
||||||
{ $notes
|
{ $notes
|
||||||
"This word is useful if you are writing your own layout gadget which delegates to a " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure."
|
"This word is useful if you are writing your own layout gadget which inherits from " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure."
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: make-pile
|
HELP: make-pile
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: sequences ui.gadgets kernel math math.functions
|
USING: sequences ui.gadgets kernel math math.functions
|
||||||
math.vectors namespaces math.order accessors ;
|
math.vectors namespaces math.order accessors math.geometry.rect ;
|
||||||
IN: ui.gadgets.packs
|
IN: ui.gadgets.packs
|
||||||
|
|
||||||
TUPLE: pack < gadget
|
TUPLE: pack < gadget
|
||||||
|
|
@ -62,10 +62,10 @@ M: pack children-on ( rect gadget -- seq )
|
||||||
[ fast-children-on ] keep <slice> ;
|
[ fast-children-on ] keep <slice> ;
|
||||||
|
|
||||||
: make-pile ( quot -- pack )
|
: make-pile ( quot -- pack )
|
||||||
<pile> make-gadget ; inline
|
<pile> swap make-gadget ; inline
|
||||||
|
|
||||||
: make-filled-pile ( quot -- pack )
|
: make-filled-pile ( quot -- pack )
|
||||||
<filled-pile> make-gadget ; inline
|
<filled-pile> swap make-gadget ; inline
|
||||||
|
|
||||||
: make-shelf ( quot -- pack )
|
: make-shelf ( quot -- pack )
|
||||||
<shelf> make-gadget ; inline
|
<shelf> swap make-gadget ; inline
|
||||||
|
|
|
||||||
|
|
@ -9,7 +9,7 @@ quotations math opengl combinators math.vectors
|
||||||
sorting splitting io.streams.nested assocs
|
sorting splitting io.streams.nested assocs
|
||||||
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
|
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
|
||||||
ui.gadgets.grid-lines classes.tuple models continuations
|
ui.gadgets.grid-lines classes.tuple models continuations
|
||||||
destructors accessors ;
|
destructors accessors math.geometry.rect ;
|
||||||
IN: ui.gadgets.panes
|
IN: ui.gadgets.panes
|
||||||
|
|
||||||
TUPLE: pane < pack
|
TUPLE: pane < pack
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2005, 2007 Slava Pestov
|
! Copyright (C) 2005, 2007 Slava Pestov
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays ui.gadgets ui.gadgets.labels ui.render kernel math
|
USING: arrays ui.gadgets ui.gadgets.labels ui.render kernel math
|
||||||
namespaces sequences math.order ;
|
namespaces sequences math.order math.geometry.rect ;
|
||||||
IN: ui.gadgets.paragraphs
|
IN: ui.gadgets.paragraphs
|
||||||
|
|
||||||
! A word break gadget
|
! A word break gadget
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
USING: ui.gadgets help.markup help.syntax ui.gadgets.viewports
|
USING: ui.gadgets help.markup help.syntax ui.gadgets.viewports
|
||||||
ui.gadgets.sliders ;
|
ui.gadgets.sliders math.geometry.rect ;
|
||||||
IN: ui.gadgets.scrollers
|
IN: ui.gadgets.scrollers
|
||||||
|
|
||||||
HELP: scroller
|
HELP: scroller
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,7 @@ USING: accessors arrays ui.gadgets ui.gadgets.viewports
|
||||||
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
|
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
|
||||||
ui.gadgets.sliders ui.gestures kernel math namespaces sequences
|
ui.gadgets.sliders ui.gestures kernel math namespaces sequences
|
||||||
models models.range models.compose
|
models models.range models.compose
|
||||||
combinators math.vectors classes.tuple ;
|
combinators math.vectors classes.tuple math.geometry.rect ;
|
||||||
IN: ui.gadgets.scrollers
|
IN: ui.gadgets.scrollers
|
||||||
|
|
||||||
TUPLE: scroller < frame viewport x y follows ;
|
TUPLE: scroller < frame viewport x y follows ;
|
||||||
|
|
@ -30,15 +30,15 @@ scroller H{
|
||||||
} set-gestures
|
} set-gestures
|
||||||
|
|
||||||
: viewport, ( child -- )
|
: viewport, ( child -- )
|
||||||
g gadget-model <viewport>
|
g model>> <viewport>
|
||||||
g-> set-scroller-viewport @center frame, ;
|
g-> set-scroller-viewport @center frame, ;
|
||||||
|
|
||||||
: <scroller-model> ( -- model )
|
: <scroller-model> ( -- model )
|
||||||
0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
|
0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
|
||||||
|
|
||||||
: x-model ( -- model ) g gadget-model model-dependencies first ;
|
: x-model ( -- model ) g model>> dependencies>> first ;
|
||||||
|
|
||||||
: y-model ( -- model ) g gadget-model model-dependencies second ;
|
: y-model ( -- model ) g model>> dependencies>> second ;
|
||||||
|
|
||||||
: new-scroller ( gadget class -- scroller )
|
: new-scroller ( gadget class -- scroller )
|
||||||
new-frame
|
new-frame
|
||||||
|
|
@ -46,12 +46,10 @@ scroller H{
|
||||||
<scroller-model> >>model
|
<scroller-model> >>model
|
||||||
faint-boundary
|
faint-boundary
|
||||||
[
|
[
|
||||||
[
|
x-model <x-slider> g-> set-scroller-x @bottom frame,
|
||||||
x-model <x-slider> g-> set-scroller-x @bottom frame,
|
y-model <y-slider> g-> set-scroller-y @right frame,
|
||||||
y-model <y-slider> g-> set-scroller-y @right frame,
|
viewport,
|
||||||
viewport,
|
] make-gadget ;
|
||||||
] with-gadget
|
|
||||||
] keep ;
|
|
||||||
|
|
||||||
: <scroller> ( gadget -- scroller )
|
: <scroller> ( gadget -- scroller )
|
||||||
scroller new-scroller ;
|
scroller new-scroller ;
|
||||||
|
|
@ -78,7 +76,7 @@ scroller H{
|
||||||
] keep dup scroller-value rot v+ swap scroll ;
|
] keep dup scroller-value rot v+ swap scroll ;
|
||||||
|
|
||||||
: relative-scroll-rect ( rect gadget scroller -- newrect )
|
: relative-scroll-rect ( rect gadget scroller -- newrect )
|
||||||
scroller-viewport gadget-child relative-loc offset-rect ;
|
viewport>> gadget-child relative-loc offset-rect ;
|
||||||
|
|
||||||
: find-scroller* ( gadget -- scroller )
|
: find-scroller* ( gadget -- scroller )
|
||||||
dup find-scroller dup [
|
dup find-scroller dup [
|
||||||
|
|
@ -121,13 +119,15 @@ scroller H{
|
||||||
: scroll>top ( gadget -- )
|
: scroll>top ( gadget -- )
|
||||||
<zero-rect> swap scroll>rect ;
|
<zero-rect> swap scroll>rect ;
|
||||||
|
|
||||||
: update-scroller ( scroller follows -- )
|
GENERIC: update-scroller ( scroller follows -- )
|
||||||
{
|
|
||||||
{ [ dup t eq? ] [ drop (scroll>bottom) ] }
|
M: t update-scroller drop (scroll>bottom) ;
|
||||||
{ [ dup rect? ] [ swap (scroll>rect) ] }
|
|
||||||
{ [ dup ] [ swap (scroll>gadget) ] }
|
M: gadget update-scroller swap (scroll>gadget) ;
|
||||||
[ drop dup scroller-value swap scroll ]
|
|
||||||
} cond ;
|
M: rect update-scroller swap (scroll>rect) ;
|
||||||
|
|
||||||
|
M: f update-scroller drop dup scroller-value swap scroll ;
|
||||||
|
|
||||||
M: scroller layout*
|
M: scroller layout*
|
||||||
dup call-next-method
|
dup call-next-method
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,7 @@ USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
|
||||||
ui.gadgets.frames ui.gadgets.grids math.order
|
ui.gadgets.frames ui.gadgets.grids math.order
|
||||||
ui.gadgets.theme ui.render kernel math namespaces sequences
|
ui.gadgets.theme ui.render kernel math namespaces sequences
|
||||||
vectors models models.range math.vectors math.functions
|
vectors models models.range math.vectors math.functions
|
||||||
quotations colors ;
|
quotations colors math.geometry.rect ;
|
||||||
IN: ui.gadgets.sliders
|
IN: ui.gadgets.sliders
|
||||||
|
|
||||||
TUPLE: elevator < gadget direction ;
|
TUPLE: elevator < gadget direction ;
|
||||||
|
|
@ -149,12 +149,12 @@ M: elevator layout*
|
||||||
: <right-button> ( -- button )
|
: <right-button> ( -- button )
|
||||||
{ 0 1 } arrow-right 1 <slide-button> ;
|
{ 0 1 } arrow-right 1 <slide-button> ;
|
||||||
|
|
||||||
: build-x-slider ( slider -- )
|
: build-x-slider ( slider -- slider )
|
||||||
[
|
[
|
||||||
<left-button> @left frame,
|
<left-button> @left frame,
|
||||||
{ 0 1 } elevator,
|
{ 0 1 } elevator,
|
||||||
<right-button> @right frame,
|
<right-button> @right frame,
|
||||||
] with-gadget ;
|
] make-gadget ; inline
|
||||||
|
|
||||||
: <up-button> ( -- button )
|
: <up-button> ( -- button )
|
||||||
{ 1 0 } arrow-up -1 <slide-button> ;
|
{ 1 0 } arrow-up -1 <slide-button> ;
|
||||||
|
|
@ -162,12 +162,12 @@ M: elevator layout*
|
||||||
: <down-button> ( -- button )
|
: <down-button> ( -- button )
|
||||||
{ 1 0 } arrow-down 1 <slide-button> ;
|
{ 1 0 } arrow-down 1 <slide-button> ;
|
||||||
|
|
||||||
: build-y-slider ( slider -- )
|
: build-y-slider ( slider -- slider )
|
||||||
[
|
[
|
||||||
<up-button> @top frame,
|
<up-button> @top frame,
|
||||||
{ 1 0 } elevator,
|
{ 1 0 } elevator,
|
||||||
<down-button> @bottom frame,
|
<down-button> @bottom frame,
|
||||||
] with-gadget ;
|
] make-gadget ; inline
|
||||||
|
|
||||||
: <slider> ( range orientation -- slider )
|
: <slider> ( range orientation -- slider )
|
||||||
slider new-frame
|
slider new-frame
|
||||||
|
|
@ -176,10 +176,10 @@ M: elevator layout*
|
||||||
32 >>line ;
|
32 >>line ;
|
||||||
|
|
||||||
: <x-slider> ( range -- slider )
|
: <x-slider> ( range -- slider )
|
||||||
{ 1 0 } <slider> dup build-x-slider ;
|
{ 1 0 } <slider> build-x-slider ;
|
||||||
|
|
||||||
: <y-slider> ( range -- slider )
|
: <y-slider> ( range -- slider )
|
||||||
{ 0 1 } <slider> dup build-y-slider ;
|
{ 0 1 } <slider> build-y-slider ;
|
||||||
|
|
||||||
M: slider pref-dim*
|
M: slider pref-dim*
|
||||||
dup call-next-method
|
dup call-next-method
|
||||||
|
|
|
||||||
|
|
@ -72,12 +72,10 @@ M: value-ref finish-editing
|
||||||
{ 0 1 } slot-editor new-track
|
{ 0 1 } slot-editor new-track
|
||||||
swap >>ref
|
swap >>ref
|
||||||
[
|
[
|
||||||
[
|
toolbar,
|
||||||
toolbar,
|
<source-editor> g-> set-slot-editor-text
|
||||||
<source-editor> g-> set-slot-editor-text
|
<scroller> 1 track,
|
||||||
<scroller> 1 track,
|
] make-gadget
|
||||||
] with-gadget
|
|
||||||
] keep
|
|
||||||
dup revert ;
|
dup revert ;
|
||||||
|
|
||||||
M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
|
M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors io kernel math namespaces
|
USING: accessors io kernel math namespaces
|
||||||
sequences words math.vectors ui.gadgets ui.gadgets.packs ;
|
sequences words math.vectors ui.gadgets ui.gadgets.packs math.geometry.rect ;
|
||||||
IN: ui.gadgets.tracks
|
IN: ui.gadgets.tracks
|
||||||
|
|
||||||
TUPLE: track < pack sizes ;
|
TUPLE: track < pack sizes ;
|
||||||
|
|
@ -50,10 +50,10 @@ M: track pref-dim*
|
||||||
over track-sizes push add-gadget ;
|
over track-sizes push add-gadget ;
|
||||||
|
|
||||||
: track, ( gadget constraint -- )
|
: track, ( gadget constraint -- )
|
||||||
\ make-gadget get swap track-add ;
|
gadget get swap track-add ;
|
||||||
|
|
||||||
: make-track ( quot orientation -- track )
|
: make-track ( quot orientation -- track )
|
||||||
<track> make-gadget ; inline
|
<track> swap make-gadget ; inline
|
||||||
|
|
||||||
: track-remove ( gadget track -- )
|
: track-remove ( gadget track -- )
|
||||||
over [
|
over [
|
||||||
|
|
|
||||||
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
IN: ui.gadgets.viewports
|
IN: ui.gadgets.viewports
|
||||||
USING: accessors arrays ui.gadgets ui.gadgets.borders
|
USING: accessors arrays ui.gadgets ui.gadgets.borders
|
||||||
kernel math namespaces sequences models math.vectors ;
|
kernel math namespaces sequences models math.vectors math.geometry.rect ;
|
||||||
|
|
||||||
: viewport-gap { 3 3 } ; inline
|
: viewport-gap { 3 3 } ; inline
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -27,7 +27,7 @@ HELP: focus-path
|
||||||
{ $notes "This word is used to avoid sending " { $link gain-focus } " gestures to a gadget which requests focus on an unfocused top-level window, so that, for instance, a text editing caret does not appear in this case." } ;
|
{ $notes "This word is used to avoid sending " { $link gain-focus } " gestures to a gadget which requests focus on an unfocused top-level window, so that, for instance, a text editing caret does not appear in this case." } ;
|
||||||
|
|
||||||
HELP: world
|
HELP: world
|
||||||
{ $class-description "A gadget which appears at the top of the gadget hieararchy, and in turn may be displayed in a native window. Worlds delegate to " { $link gadget } " instances and have the following slots:"
|
{ $class-description "A gadget which appears at the top of the gadget hieararchy, and in turn may be displayed in a native window. Worlds have the following slots:"
|
||||||
{ $list
|
{ $list
|
||||||
{ { $snippet "active?" } " - if set to " { $link f } ", the world will not be drawn. This slot is set to " { $link f } " if an error is thrown while drawing the world; this prevents multiple debugger windows from being shown." }
|
{ { $snippet "active?" } " - if set to " { $link f } ", the world will not be drawn. This slot is set to " { $link f } " if an error is thrown while drawing the world; this prevents multiple debugger windows from being shown." }
|
||||||
{ { $snippet "glass" } " - a glass pane in front of the primary gadget, used to implement behaviors such as popup menus which are hidden when the mouse is clicked outside the menu." }
|
{ { $snippet "glass" } " - a glass pane in front of the primary gadget, used to implement behaviors such as popup menus which are hidden when the mouse is clicked outside the menu." }
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,7 @@
|
||||||
USING: accessors arrays assocs continuations kernel math models
|
USING: accessors arrays assocs continuations kernel math models
|
||||||
namespaces opengl sequences io combinators math.vectors
|
namespaces opengl sequences io combinators math.vectors
|
||||||
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
|
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
|
||||||
debugger ;
|
debugger math.geometry.rect ;
|
||||||
IN: ui.gadgets.worlds
|
IN: ui.gadgets.worlds
|
||||||
|
|
||||||
TUPLE: world < track
|
TUPLE: world < track
|
||||||
|
|
|
||||||
|
|
@ -1,25 +1,25 @@
|
||||||
USING: ui.gadgets ui.gestures help.markup help.syntax
|
USING: ui.gadgets ui.gestures help.markup help.syntax
|
||||||
kernel classes strings opengl.gl models ;
|
kernel classes strings opengl.gl models math.geometry.rect ;
|
||||||
IN: ui.render
|
IN: ui.render
|
||||||
|
|
||||||
HELP: gadget
|
HELP: gadget
|
||||||
{ $class-description "An object which displays itself on the screen and acts on user input gestures. Gadgets have the following slots:"
|
{ $class-description "An object which displays itself on the screen and acts on user input gestures. Gadgets have the following slots:"
|
||||||
{ $list
|
{ $list
|
||||||
{ { $link gadget-pref-dim } " - a cached value for " { $link pref-dim } "; do not read or write this slot directly." }
|
{ { $link "pref-dim" } " - a cached value for " { $link pref-dim } "; do not read or write this slot directly." }
|
||||||
{ { $link gadget-parent } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." }
|
{ { $link "parent" } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." }
|
||||||
{ { $link gadget-children } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." }
|
{ { $link "children" } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." }
|
||||||
{ { $link gadget-orientation } " - an orientation specifier. This slot is used by layout gadgets." }
|
{ { $link "orientation" } " - an orientation specifier. This slot is used by layout gadgets." }
|
||||||
{ { $link gadget-layout-state } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
|
{ { $link "layout-state" } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
|
||||||
{ { $link gadget-visible? } " - a boolean indicating if the gadget should display and receive user input." }
|
{ { $link "visible?" } " - a boolean indicating if the gadget should display and receive user input." }
|
||||||
{ { $link gadget-root? } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
|
{ { $link "root?" } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
|
||||||
{ { $link gadget-clipped? } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
|
{ { $link "clipped?" } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
|
||||||
{ { $link gadget-interior } " - an object whose class implements the " { $link draw-interior } " generic word." }
|
{ { $link "interior" } " - an object whose class implements the " { $link draw-interior } " generic word." }
|
||||||
{ { $link gadget-boundary } " - an object whose class implements the " { $link draw-boundary } " generic word." }
|
{ { $link "boundary" } " - an object whose class implements the " { $link draw-boundary } " generic word." }
|
||||||
{ { $link gadget-model } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
|
{ { $link "model" } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
|
||||||
}
|
}
|
||||||
"Gadgets subclass the " { $link rect } " class, and thus all instances have " { $snippet "loc" } " and " { $snippet "dim" } " instances holding their location and dimensions." }
|
"Gadgets subclass the " { $link rect } " class, and thus all instances have " { $snippet "loc" } " and " { $snippet "dim" } " instances holding their location and dimensions." }
|
||||||
{ $notes
|
{ $notes
|
||||||
"Other classes may delegate to " { $link gadget } " in order to re-implement generic words such as " { $link draw-gadget* } " and " { $link user-input* } ", or to define gestures with " { $link set-gestures } "." } ;
|
"Other classes may inherit from " { $link gadget } " in order to re-implement generic words such as " { $link draw-gadget* } " and " { $link user-input* } ", or to define gestures with " { $link set-gestures } "." } ;
|
||||||
|
|
||||||
HELP: clip
|
HELP: clip
|
||||||
{ $var-description "The current clipping rectangle." } ;
|
{ $var-description "The current clipping rectangle." } ;
|
||||||
|
|
|
||||||
|
|
@ -2,7 +2,8 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien arrays hashtables io kernel math namespaces opengl
|
USING: alien arrays hashtables io kernel math namespaces opengl
|
||||||
opengl.gl opengl.glu sequences strings io.styles vectors
|
opengl.gl opengl.glu sequences strings io.styles vectors
|
||||||
combinators math.vectors ui.gadgets colors math.order ;
|
combinators math.vectors ui.gadgets colors
|
||||||
|
math.order math.geometry.rect ;
|
||||||
IN: ui.render
|
IN: ui.render
|
||||||
|
|
||||||
SYMBOL: clip
|
SYMBOL: clip
|
||||||
|
|
|
||||||
|
|
@ -23,12 +23,10 @@ TUPLE: browser-gadget < track pane history ;
|
||||||
{ 0 1 } browser-gadget new-track
|
{ 0 1 } browser-gadget new-track
|
||||||
dup init-history
|
dup init-history
|
||||||
[
|
[
|
||||||
[
|
toolbar,
|
||||||
toolbar,
|
g <help-pane> g-> set-browser-gadget-pane
|
||||||
g <help-pane> g-> set-browser-gadget-pane
|
<scroller> 1 track,
|
||||||
<scroller> 1 track,
|
] make-gadget ;
|
||||||
] with-gadget
|
|
||||||
] keep ;
|
|
||||||
|
|
||||||
M: browser-gadget call-tool* show-help ;
|
M: browser-gadget call-tool* show-help ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -23,12 +23,10 @@ TUPLE: debugger < track restarts ;
|
||||||
: <debugger> ( error restarts restart-hook -- gadget )
|
: <debugger> ( error restarts restart-hook -- gadget )
|
||||||
{ 0 1 } debugger new-track
|
{ 0 1 } debugger new-track
|
||||||
[
|
[
|
||||||
[
|
toolbar,
|
||||||
toolbar,
|
<restart-list> g-> set-debugger-restarts
|
||||||
<restart-list> g-> set-debugger-restarts
|
swap <debugger-display> <scroller> 1 track,
|
||||||
swap <debugger-display> <scroller> 1 track,
|
] make-gadget ;
|
||||||
] with-gadget
|
|
||||||
] keep ;
|
|
||||||
|
|
||||||
M: debugger focusable-child* debugger-restarts ;
|
M: debugger focusable-child* debugger-restarts ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -109,12 +109,10 @@ deploy-gadget "toolbar" f {
|
||||||
swap >>vocab
|
swap >>vocab
|
||||||
{ 0 1 } >>orientation
|
{ 0 1 } >>orientation
|
||||||
[
|
[
|
||||||
[
|
g vocab>> <deploy-settings>
|
||||||
g vocab>> <deploy-settings>
|
g-> set-deploy-gadget-settings gadget,
|
||||||
g-> set-deploy-gadget-settings gadget,
|
buttons,
|
||||||
buttons,
|
] make-gadget
|
||||||
] with-gadget
|
|
||||||
] keep
|
|
||||||
dup deploy-settings-theme
|
dup deploy-settings-theme
|
||||||
dup com-revert ;
|
dup com-revert ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -16,11 +16,9 @@ TUPLE: inspector-gadget < track object pane ;
|
||||||
: <inspector-gadget> ( -- gadget )
|
: <inspector-gadget> ( -- gadget )
|
||||||
{ 0 1 } inspector-gadget new-track
|
{ 0 1 } inspector-gadget new-track
|
||||||
[
|
[
|
||||||
[
|
toolbar,
|
||||||
toolbar,
|
<pane> g-> set-inspector-gadget-pane <scroller> 1 track,
|
||||||
<pane> g-> set-inspector-gadget-pane <scroller> 1 track,
|
] make-gadget ;
|
||||||
] with-gadget
|
|
||||||
] keep ;
|
|
||||||
|
|
||||||
: inspect-object ( obj inspector -- )
|
: inspect-object ( obj inspector -- )
|
||||||
[ set-inspector-gadget-object ] keep refresh ;
|
[ set-inspector-gadget-object ] keep refresh ;
|
||||||
|
|
|
||||||
|
|
@ -124,12 +124,10 @@ TUPLE: stack-display < track ;
|
||||||
g workspace-listener
|
g workspace-listener
|
||||||
{ 0 1 } stack-display new-track
|
{ 0 1 } stack-display new-track
|
||||||
[
|
[
|
||||||
[
|
dup <toolbar> f track,
|
||||||
dup <toolbar> f track,
|
stack>> [ [ stack. ] curry try ]
|
||||||
stack>> [ [ stack. ] curry try ]
|
t "Data stack" <labelled-pane> 1 track,
|
||||||
t "Data stack" <labelled-pane> 1 track,
|
] make-gadget ;
|
||||||
] with-gadget
|
|
||||||
] keep ;
|
|
||||||
|
|
||||||
M: stack-display tool-scroller
|
M: stack-display tool-scroller
|
||||||
find-workspace workspace-listener tool-scroller ;
|
find-workspace workspace-listener tool-scroller ;
|
||||||
|
|
@ -174,7 +172,7 @@ M: stack-display tool-scroller
|
||||||
: <listener-gadget> ( -- gadget )
|
: <listener-gadget> ( -- gadget )
|
||||||
{ 0 1 } listener-gadget new-track
|
{ 0 1 } listener-gadget new-track
|
||||||
dup init-listener
|
dup init-listener
|
||||||
[ [ listener-output, listener-input, ] with-gadget ] keep ;
|
[ listener-output, listener-input, ] make-gadget ;
|
||||||
|
|
||||||
: listener-help ( -- ) "ui-listener" help-window ;
|
: listener-help ( -- ) "ui-listener" help-window ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -10,12 +10,10 @@ TUPLE: profiler-gadget < track pane ;
|
||||||
: <profiler-gadget> ( -- gadget )
|
: <profiler-gadget> ( -- gadget )
|
||||||
{ 0 1 } profiler-gadget new-track
|
{ 0 1 } profiler-gadget new-track
|
||||||
[
|
[
|
||||||
[
|
toolbar,
|
||||||
toolbar,
|
<pane> g-> set-profiler-gadget-pane
|
||||||
<pane> g-> set-profiler-gadget-pane
|
<scroller> 1 track,
|
||||||
<scroller> 1 track,
|
] make-gadget ;
|
||||||
] with-gadget
|
|
||||||
] keep ;
|
|
||||||
|
|
||||||
: with-profiler-pane ( gadget quot -- )
|
: with-profiler-pane ( gadget quot -- )
|
||||||
>r profiler-gadget-pane r> with-pane ;
|
>r profiler-gadget-pane r> with-pane ;
|
||||||
|
|
|
||||||
|
|
@ -62,12 +62,10 @@ search-field H{
|
||||||
: <live-search> ( string seq limited? presenter -- gadget )
|
: <live-search> ( string seq limited? presenter -- gadget )
|
||||||
{ 0 1 } live-search new-track
|
{ 0 1 } live-search new-track
|
||||||
[
|
[
|
||||||
[
|
<search-field> g-> set-live-search-field f track,
|
||||||
<search-field> g-> set-live-search-field f track,
|
<search-list> g-> set-live-search-list
|
||||||
<search-list> g-> set-live-search-list
|
<scroller> 1 track,
|
||||||
<scroller> 1 track,
|
] make-gadget
|
||||||
] with-gadget
|
|
||||||
] keep
|
|
||||||
[ live-search-field set-editor-string ] keep
|
[ live-search-field set-editor-string ] keep
|
||||||
[ live-search-field end-of-document ] keep ;
|
[ live-search-field end-of-document ] keep ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -30,15 +30,13 @@ IN: ui.tools
|
||||||
{ 0 1 } workspace new-track
|
{ 0 1 } workspace new-track
|
||||||
0 <model> >>model
|
0 <model> >>model
|
||||||
[
|
[
|
||||||
[
|
<listener-gadget> g set-workspace-listener
|
||||||
<listener-gadget> g set-workspace-listener
|
<workspace-book> g set-workspace-book
|
||||||
<workspace-book> g set-workspace-book
|
<workspace-tabs> f track,
|
||||||
<workspace-tabs> f track,
|
g workspace-book 1/5 track,
|
||||||
g workspace-book 1/5 track,
|
g workspace-listener 4/5 track,
|
||||||
g workspace-listener 4/5 track,
|
toolbar,
|
||||||
toolbar,
|
] make-gadget ;
|
||||||
] with-gadget
|
|
||||||
] keep ;
|
|
||||||
|
|
||||||
: resize-workspace ( workspace -- )
|
: resize-workspace ( workspace -- )
|
||||||
dup track-sizes over control-value zero? [
|
dup track-sizes over control-value zero? [
|
||||||
|
|
|
||||||
|
|
@ -27,15 +27,17 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
|
||||||
{ 0 1 } traceback-gadget new-track
|
{ 0 1 } traceback-gadget new-track
|
||||||
swap >>model
|
swap >>model
|
||||||
[
|
[
|
||||||
|
g model>>
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
g gadget-model <datastack-display> 1/2 track,
|
[ <datastack-display> 1/2 track, ]
|
||||||
g gadget-model <retainstack-display> 1/2 track,
|
[ <retainstack-display> 1/2 track, ]
|
||||||
|
bi
|
||||||
] { 1 0 } make-track 1/3 track,
|
] { 1 0 } make-track 1/3 track,
|
||||||
g gadget-model <callstack-display> 2/3 track,
|
]
|
||||||
toolbar,
|
[ <callstack-display> 2/3 track, ] bi
|
||||||
] with-gadget
|
toolbar,
|
||||||
] keep ;
|
] make-gadget ;
|
||||||
|
|
||||||
: <namestack-display> ( model -- gadget )
|
: <namestack-display> ( model -- gadget )
|
||||||
[ [ continuation-name namestack. ] when* ]
|
[ [ continuation-name namestack. ] when* ]
|
||||||
|
|
|
||||||
|
|
@ -60,13 +60,12 @@ M: walker-gadget focusable-child*
|
||||||
swap >>thread
|
swap >>thread
|
||||||
swap >>continuation
|
swap >>continuation
|
||||||
swap >>status
|
swap >>status
|
||||||
|
dup continuation>> <traceback-gadget> >>traceback
|
||||||
[
|
[
|
||||||
[
|
toolbar,
|
||||||
toolbar,
|
g status>> self <thread-status> f track,
|
||||||
g status>> self <thread-status> f track,
|
g traceback>> 1 track,
|
||||||
g continuation>> <traceback-gadget> 1 track,
|
] make-gadget ;
|
||||||
] with-gadget
|
|
||||||
] keep ;
|
|
||||||
|
|
||||||
: walker-help ( -- ) "ui-walker" help-window ;
|
: walker-help ( -- ) "ui-walker" help-window ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
USING: help.markup help.syntax strings quotations debugger
|
USING: help.markup help.syntax strings quotations debugger
|
||||||
io.styles namespaces ui.backend ui.gadgets ui.gadgets.worlds
|
io.styles namespaces ui.backend ui.gadgets ui.gadgets.worlds
|
||||||
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids ;
|
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids math.geometry.rect ;
|
||||||
IN: ui
|
IN: ui
|
||||||
|
|
||||||
HELP: windows
|
HELP: windows
|
||||||
|
|
@ -74,14 +74,14 @@ ARTICLE: "ui-glossary" "UI glossary"
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
{ "gadget" { "a graphical element which responds to user input. Gadgets are tuples which (directly or indirectly) delegate to " { $link gadget } " instances." } }
|
{ "gadget" { "a graphical element which responds to user input. Gadgets are tuples which (directly or indirectly) inherit from " { $link gadget } "." } }
|
||||||
{ "label specifier" { "a string, " { $link f } " or a gadget. See " { $link "ui.gadgets.buttons" } } }
|
{ "label specifier" { "a string, " { $link f } " or a gadget. See " { $link "ui.gadgets.buttons" } } }
|
||||||
{ "orientation specifier" { "one of " { $snippet "{ 0 1 }" } " or " { $snippet "{ 1 0 }" } ", with the former denoting vertical orientation and the latter denoting horizontal. Using a vector instead of symbolic constants allows these values to be directly useful in co-ordinate calculations" } }
|
{ "orientation specifier" { "one of " { $snippet "{ 0 1 }" } " or " { $snippet "{ 1 0 }" } ", with the former denoting vertical orientation and the latter denoting horizontal. Using a vector instead of symbolic constants allows these values to be directly useful in co-ordinate calculations" } }
|
||||||
{ "point" "a pair of integers denoting a pixel location on screen" }
|
{ "point" "a pair of integers denoting a pixel location on screen" }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
ARTICLE: "building-ui" "Building user interfaces"
|
ARTICLE: "building-ui" "Building user interfaces"
|
||||||
"A gadget is a graphical element which responds to user input. Gadgets are implemented as tuples which (directly or indirectly) delegate to instances of " { $link gadget } ", which in turn delegates to " { $link rect } "."
|
"A gadget is a graphical element which responds to user input. Gadgets are implemented as tuples which (directly or indirectly) inherit from " { $link gadget } ", which in turn inherits from " { $link rect } "."
|
||||||
{ $subsection gadget }
|
{ $subsection gadget }
|
||||||
"Gadgets are arranged in a hierarchy, and all visible gadgets except for instances of " { $link world } " are contained in a parent gadget, stored in the " { $link gadget-parent } " slot."
|
"Gadgets are arranged in a hierarchy, and all visible gadgets except for instances of " { $link world } " are contained in a parent gadget, stored in the " { $link gadget-parent } " slot."
|
||||||
{ $subsection "ui-geometry" }
|
{ $subsection "ui-geometry" }
|
||||||
|
|
@ -104,7 +104,7 @@ ARTICLE: "gadgets" "Pre-made UI gadgets"
|
||||||
{ $subsection "ui.gadgets.lists" } ;
|
{ $subsection "ui.gadgets.lists" } ;
|
||||||
|
|
||||||
ARTICLE: "ui-geometry" "Gadget geometry"
|
ARTICLE: "ui-geometry" "Gadget geometry"
|
||||||
"Instances of " { $link gadget } " (and thus all gadgets) delegate to rectangles which specify the gadget's bounding box:"
|
"The " { $link gadget } " class inherits from the " { $link rect } " class, and thus all gadgets have a bounding box:"
|
||||||
{ $subsection rect }
|
{ $subsection rect }
|
||||||
"Rectangles can be taken apart:"
|
"Rectangles can be taken apart:"
|
||||||
{ $subsection rect-loc }
|
{ $subsection rect-loc }
|
||||||
|
|
@ -235,7 +235,7 @@ $nl
|
||||||
$nl
|
$nl
|
||||||
"Gadget construction combinators whose names are prefixed with " { $snippet "make-" } " construct new gadgets and push them on the stack. The primitive combinator used to define all combinators of this form:"
|
"Gadget construction combinators whose names are prefixed with " { $snippet "make-" } " construct new gadgets and push them on the stack. The primitive combinator used to define all combinators of this form:"
|
||||||
{ $subsection make-gadget }
|
{ $subsection make-gadget }
|
||||||
"Words such as " { $link gadget, } " and " { $link track, } " access the gadget through the " { $link make-gadget } " variable."
|
"Words such as " { $link gadget, } " and " { $link track, } " access the gadget through the " { $link gadget } " variable."
|
||||||
$nl
|
$nl
|
||||||
"A combinator which stores a gadget in the " { $link gadget } " variable:"
|
"A combinator which stores a gadget in the " { $link gadget } " variable:"
|
||||||
{ $subsection with-gadget }
|
{ $subsection with-gadget }
|
||||||
|
|
@ -261,7 +261,7 @@ ARTICLE: "ui-layout-impl" "Implementing layout gadgets"
|
||||||
{ $subsection max-dim }
|
{ $subsection max-dim }
|
||||||
{ $subsection dim-sum }
|
{ $subsection dim-sum }
|
||||||
{ $warning
|
{ $warning
|
||||||
"When implementing the " { $link layout* } " generic word for a gadget which intends to delegate to another layout, the " { $link children-on } " word might have to be re-implemented as well."
|
"When implementing the " { $link layout* } " generic word for a gadget which inherits from another layout, the " { $link children-on } " word might have to be re-implemented as well."
|
||||||
$nl
|
$nl
|
||||||
"For example, suppose you want a " { $link grid } " layout which also displays a popup gadget on top. The implementation of " { $link children-on } " for the " { $link grid } " class determines which children of the grid are visible at one time, and this will never include your popup, so it will not be rendered, nor will it respond to gestures. The solution is to re-implement " { $link children-on } " on your class."
|
"For example, suppose you want a " { $link grid } " layout which also displays a popup gadget on top. The implementation of " { $link children-on } " for the " { $link grid } " class determines which children of the grid are visible at one time, and this will never include your popup, so it will not be rendered, nor will it respond to gestures. The solution is to re-implement " { $link children-on } " on your class."
|
||||||
} ;
|
} ;
|
||||||
|
|
|
||||||
|
|
@ -8,7 +8,7 @@ sequences strings vectors words windows.kernel32 windows.gdi32
|
||||||
windows.user32 windows.opengl32 windows.messages windows.types
|
windows.user32 windows.opengl32 windows.messages windows.types
|
||||||
windows.nt windows threads libc combinators continuations
|
windows.nt windows threads libc combinators continuations
|
||||||
command-line shuffle opengl ui.render unicode.case ascii
|
command-line shuffle opengl ui.render unicode.case ascii
|
||||||
math.bitfields locals symbols accessors ;
|
math.bitfields locals symbols accessors math.geometry.rect ;
|
||||||
IN: ui.windows
|
IN: ui.windows
|
||||||
|
|
||||||
SINGLETON: windows-ui-backend
|
SINGLETON: windows-ui-backend
|
||||||
|
|
|
||||||
|
|
@ -6,7 +6,7 @@ assocs kernel math namespaces opengl sequences strings x11.xlib
|
||||||
x11.events x11.xim x11.glx x11.clipboard x11.constants
|
x11.events x11.xim x11.glx x11.clipboard x11.constants
|
||||||
x11.windows io.encodings.string io.encodings.ascii
|
x11.windows io.encodings.string io.encodings.ascii
|
||||||
io.encodings.utf8 combinators debugger command-line qualified
|
io.encodings.utf8 combinators debugger command-line qualified
|
||||||
math.vectors classes.tuple opengl.gl threads ;
|
math.vectors classes.tuple opengl.gl threads math.geometry.rect ;
|
||||||
QUALIFIED: system
|
QUALIFIED: system
|
||||||
IN: ui.x11
|
IN: ui.x11
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
|
|
||||||
USING: namespaces io.files bootstrap.image builder.util ;
|
USING: namespaces debugger io.files bootstrap.image builder.util ;
|
||||||
|
|
||||||
IN: update.backup
|
IN: update.backup
|
||||||
|
|
||||||
|
|
@ -20,6 +20,9 @@ IN: update.backup
|
||||||
|
|
||||||
: backup ( -- )
|
: backup ( -- )
|
||||||
datestamp "datestamp" set
|
datestamp "datestamp" set
|
||||||
backup-boot-image
|
[
|
||||||
backup-image
|
backup-boot-image
|
||||||
backup-vm ;
|
backup-image
|
||||||
|
backup-vm
|
||||||
|
]
|
||||||
|
try ;
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Phil Dawes
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Microsecond precision code timer/profiler.
|
||||||
|
|
@ -0,0 +1,41 @@
|
||||||
|
USING: help.syntax help.markup kernel prettyprint sequences ;
|
||||||
|
IN: wordtimer
|
||||||
|
|
||||||
|
HELP: reset-word-timer
|
||||||
|
{ $description "resets the global wordtimes datastructure. Must be called before calling any word-timer annotated code"
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: add-timer
|
||||||
|
{ $values { "word" "a word" } }
|
||||||
|
{ $description "annotates the word with timing code which stores timing information globally. You can then view the info with print-word-timings"
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: add-timers
|
||||||
|
{ $values { "vocab" "a string" } }
|
||||||
|
{ $description "annotates all the words in the vocab with timer code. After profiling you can remove the annotations with reset-vocab"
|
||||||
|
} ;
|
||||||
|
|
||||||
|
|
||||||
|
HELP: reset-vocab
|
||||||
|
{ $values { "vocab" "a string" } }
|
||||||
|
{ $description "removes the annotations from all the words in the vocab"
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: print-word-timings
|
||||||
|
{ $description "Displays the timing information for each word-timer annotated word. Columns are: total time taken in microseconds, number of invocations, wordname"
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: correct-for-timing-overhead
|
||||||
|
{ $description "attempts to correct the timings to take into account the overhead of the timing function. This is pretty error-prone but can be handy when you're timing words that only take a handful of milliseconds but are called a lot" } ;
|
||||||
|
|
||||||
|
HELP: profile-vocab
|
||||||
|
{ $values { "vocabspec" "string name of a vocab" }
|
||||||
|
{ "quot" "a quotation to run" } }
|
||||||
|
{ $description "Annotates the words in the vocab with timing code then runs the quotation. Finally resets the words and prints the timings information."
|
||||||
|
} ;
|
||||||
|
|
||||||
|
|
||||||
|
ARTICLE: "wordtimer" "Word Timer"
|
||||||
|
"The " { $vocab-link "wordtimer" } " vocabulary measures accumulated execution time for words. If you just want to profile the accumulated time taken by all words in a vocab you can use " { $vocab-link "profile-vocab" } ". If you need more fine grained control then do the following: First annotate individual words with the " { $link add-timer } " word or whole vocabularies with " { $link add-timers } ". Then reset the clock with " { $link reset-word-timer } " and execute your code. Finally you can view the timings with " { $link print-word-timings } ". If you have functions that are quick and called often you may want to " { $link correct-for-timing-overhead } ". To remove all the annotations in the vocab you can use " { $link reset-vocab } ". Alternatively if you just want to time the contents of a vocabulary you can use profile-vocab." ;
|
||||||
|
|
||||||
|
ABOUT: "wordtimer"
|
||||||
|
|
@ -0,0 +1,10 @@
|
||||||
|
USING: tools.test wordtimer math kernel tools.annotations prettyprint ;
|
||||||
|
IN: wordtimer.tests
|
||||||
|
|
||||||
|
: testfn ( a b c d -- a+b c+d )
|
||||||
|
+ [ + ] dip ;
|
||||||
|
|
||||||
|
[ 3 7 ]
|
||||||
|
[ reset-word-timer
|
||||||
|
\ testfn [ reset ] [ add-timer ] bi
|
||||||
|
1 2 3 4 testfn ] unit-test
|
||||||
|
|
@ -0,0 +1,81 @@
|
||||||
|
USING: kernel sequences namespaces math assocs words arrays tools.annotations vocabs sorting prettyprint io micros math.statistics accessors ;
|
||||||
|
IN: wordtimer
|
||||||
|
|
||||||
|
SYMBOL: *wordtimes*
|
||||||
|
SYMBOL: *calling*
|
||||||
|
|
||||||
|
: reset-word-timer ( -- )
|
||||||
|
H{ } clone *wordtimes* set-global
|
||||||
|
H{ } clone *calling* set-global ;
|
||||||
|
|
||||||
|
: lookup-word-time ( wordname -- utime n )
|
||||||
|
*wordtimes* get-global [ drop { 0 0 } ] cache first2 ;
|
||||||
|
|
||||||
|
: update-times ( utime current-utime current-numinvokes -- utime' invokes' )
|
||||||
|
rot [ + ] curry [ 1+ ] bi* ;
|
||||||
|
|
||||||
|
: register-time ( utime word -- )
|
||||||
|
name>>
|
||||||
|
[ lookup-word-time update-times 2array ] keep *wordtimes* get-global set-at ;
|
||||||
|
|
||||||
|
: calling ( word -- )
|
||||||
|
dup *calling* get-global set-at ; inline
|
||||||
|
|
||||||
|
: finished ( word -- )
|
||||||
|
*calling* get-global delete-at ; inline
|
||||||
|
|
||||||
|
: called-recursively? ( word -- t/f )
|
||||||
|
*calling* get-global at ; inline
|
||||||
|
|
||||||
|
: timed-call ( quot word -- )
|
||||||
|
[ calling ] [ >r micro-time r> register-time ] [ finished ] tri ; inline
|
||||||
|
|
||||||
|
: time-unless-recursing ( quot word -- )
|
||||||
|
dup called-recursively? not
|
||||||
|
[ timed-call ] [ drop call ] if ; inline
|
||||||
|
|
||||||
|
: (add-timer) ( word quot -- quot' )
|
||||||
|
[ swap time-unless-recursing ] 2curry ;
|
||||||
|
|
||||||
|
: add-timer ( word -- )
|
||||||
|
dup [ (add-timer) ] annotate ;
|
||||||
|
|
||||||
|
: add-timers ( vocabspec -- )
|
||||||
|
words [ add-timer ] each ;
|
||||||
|
|
||||||
|
: reset-vocab ( vocabspec -- )
|
||||||
|
words [ reset ] each ;
|
||||||
|
|
||||||
|
: dummy-word ( -- ) ;
|
||||||
|
|
||||||
|
: time-dummy-word ( -- n )
|
||||||
|
[ 100000 [ [ dummy-word ] micro-time , ] times ] { } make median ;
|
||||||
|
|
||||||
|
: subtract-overhead ( {oldtime,n} overhead -- {newtime,n} )
|
||||||
|
[ first2 ] dip
|
||||||
|
swap [ * - ] keep 2array ;
|
||||||
|
|
||||||
|
: change-global ( variable quot -- )
|
||||||
|
global swap change-at ;
|
||||||
|
|
||||||
|
: (correct-for-timing-overhead) ( timingshash -- timingshash )
|
||||||
|
time-dummy-word [ subtract-overhead ] curry assoc-map ;
|
||||||
|
|
||||||
|
: correct-for-timing-overhead ( -- )
|
||||||
|
*wordtimes* [ (correct-for-timing-overhead) ] change-global ;
|
||||||
|
|
||||||
|
: print-word-timings ( -- )
|
||||||
|
*wordtimes* get-global [ swap suffix ] { } assoc>map natural-sort reverse pprint ;
|
||||||
|
|
||||||
|
|
||||||
|
: profile-vocab ( vocabspec quot -- )
|
||||||
|
"annotating vocab..." print flush
|
||||||
|
over [ reset-vocab ] [ add-timers ] bi
|
||||||
|
reset-word-timer
|
||||||
|
"executing quotation..." print flush
|
||||||
|
[ call ] micro-time >r
|
||||||
|
"resetting annotations..." print flush
|
||||||
|
reset-vocab
|
||||||
|
correct-for-timing-overhead
|
||||||
|
"total time:" write r> pprint
|
||||||
|
print-word-timings ;
|
||||||
|
|
@ -6,7 +6,6 @@ and the callstack top is passed in EDX */
|
||||||
|
|
||||||
#define ARG0 %eax
|
#define ARG0 %eax
|
||||||
#define ARG1 %edx
|
#define ARG1 %edx
|
||||||
#define XT_REG %ecx
|
|
||||||
#define STACK_REG %esp
|
#define STACK_REG %esp
|
||||||
#define DS_REG %esi
|
#define DS_REG %esi
|
||||||
#define RETURN_REG %eax
|
#define RETURN_REG %eax
|
||||||
|
|
@ -22,9 +21,6 @@ and the callstack top is passed in EDX */
|
||||||
pop %ebx
|
pop %ebx
|
||||||
|
|
||||||
#define QUOT_XT_OFFSET 9
|
#define QUOT_XT_OFFSET 9
|
||||||
#define PROFILING_OFFSET 25
|
|
||||||
#define WORD_DEF_OFFSET 13
|
|
||||||
#define WORD_XT_OFFSET 29
|
|
||||||
|
|
||||||
/* We pass a function pointer to memcpy to work around a Mac OS X
|
/* We pass a function pointer to memcpy to work around a Mac OS X
|
||||||
ABI limitation which would otherwise require us to do a bizzaro PC-relative
|
ABI limitation which would otherwise require us to do a bizzaro PC-relative
|
||||||
|
|
|
||||||
|
|
@ -2,7 +2,6 @@
|
||||||
|
|
||||||
#define ARG0 %rdi
|
#define ARG0 %rdi
|
||||||
#define ARG1 %rsi
|
#define ARG1 %rsi
|
||||||
#define XT_REG %rcx
|
|
||||||
#define STACK_REG %rsp
|
#define STACK_REG %rsp
|
||||||
#define DS_REG %r14
|
#define DS_REG %r14
|
||||||
#define RETURN_REG %rax
|
#define RETURN_REG %rax
|
||||||
|
|
@ -22,9 +21,6 @@
|
||||||
pop %rbx
|
pop %rbx
|
||||||
|
|
||||||
#define QUOT_XT_OFFSET 21
|
#define QUOT_XT_OFFSET 21
|
||||||
#define PROFILING_OFFSET 53
|
|
||||||
#define WORD_DEF_OFFSET 29
|
|
||||||
#define WORD_XT_OFFSET 61
|
|
||||||
|
|
||||||
/* We pass a function pointer to memcpy to work around a Mac OS X
|
/* We pass a function pointer to memcpy to work around a Mac OS X
|
||||||
ABI limitation which would otherwise require us to do a bizzaro PC-relative
|
ABI limitation which would otherwise require us to do a bizzaro PC-relative
|
||||||
|
|
|
||||||
17
vm/cpu-x86.S
17
vm/cpu-x86.S
|
|
@ -1,5 +1,3 @@
|
||||||
#define JUMP_QUOT jmp *QUOT_XT_OFFSET(ARG0)
|
|
||||||
|
|
||||||
DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
|
DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
|
||||||
PUSH_NONVOLATILE
|
PUSH_NONVOLATILE
|
||||||
push ARG0 /* Save quot */
|
push ARG0 /* Save quot */
|
||||||
|
|
@ -14,20 +12,9 @@ DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
|
||||||
POP_NONVOLATILE
|
POP_NONVOLATILE
|
||||||
ret
|
ret
|
||||||
|
|
||||||
DEF(F_FASTCALL void,primitive_call,(void)):
|
|
||||||
mov (DS_REG),ARG0 /* Load quotation from data stack */
|
|
||||||
sub $CELL_SIZE,DS_REG /* Pop data stack */
|
|
||||||
JUMP_QUOT
|
|
||||||
|
|
||||||
/* Don't mess up EDX, it's the callstack top parameter to primitives. */
|
|
||||||
DEF(F_FASTCALL void,primitive_execute,(void)):
|
|
||||||
mov (DS_REG),ARG0 /* Load word from data stack */
|
|
||||||
sub $CELL_SIZE,DS_REG /* Pop data stack */
|
|
||||||
jmp *WORD_XT_OFFSET(ARG0) /* Load word-xt slot */
|
|
||||||
|
|
||||||
DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
|
DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
|
||||||
mov ARG1,STACK_REG /* rewind_to */
|
mov ARG1,STACK_REG /* rewind_to */
|
||||||
JUMP_QUOT
|
jmp *QUOT_XT_OFFSET(ARG0)
|
||||||
|
|
||||||
DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
|
DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
|
||||||
mov STACK_REG,ARG1 /* Save stack pointer */
|
mov STACK_REG,ARG1 /* Save stack pointer */
|
||||||
|
|
@ -39,7 +26,7 @@ DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
|
||||||
pop ARG1 /* OK to clobber ARG1 here */
|
pop ARG1 /* OK to clobber ARG1 here */
|
||||||
pop ARG1
|
pop ARG1
|
||||||
pop ARG1
|
pop ARG1
|
||||||
JUMP_QUOT /* Call the quotation */
|
jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
|
||||||
|
|
||||||
#ifdef WINDOWS
|
#ifdef WINDOWS
|
||||||
.section .drectve
|
.section .drectve
|
||||||
|
|
|
||||||
|
|
@ -129,6 +129,8 @@ typedef struct {
|
||||||
CELL compiledp;
|
CELL compiledp;
|
||||||
/* TAGGED call count for profiling */
|
/* TAGGED call count for profiling */
|
||||||
CELL counter;
|
CELL counter;
|
||||||
|
/* TAGGED machine code for sub-primitive */
|
||||||
|
CELL subprimitive;
|
||||||
/* UNTAGGED execution token: jump here to execute word */
|
/* UNTAGGED execution token: jump here to execute word */
|
||||||
XT xt;
|
XT xt;
|
||||||
/* UNTAGGED compiled code block */
|
/* UNTAGGED compiled code block */
|
||||||
|
|
|
||||||
68
vm/math.c
68
vm/math.c
|
|
@ -35,33 +35,18 @@ DEFINE_PRIMITIVE(float_to_fixnum)
|
||||||
F_FIXNUM y = untag_fixnum_fast(dpop()); \
|
F_FIXNUM y = untag_fixnum_fast(dpop()); \
|
||||||
F_FIXNUM x = untag_fixnum_fast(dpop());
|
F_FIXNUM x = untag_fixnum_fast(dpop());
|
||||||
|
|
||||||
/* The fixnum arithmetic operations defined in C are relatively slow.
|
|
||||||
The Factor compiler has optimized assembly intrinsics for some of these
|
|
||||||
operations. */
|
|
||||||
DEFINE_PRIMITIVE(fixnum_add)
|
DEFINE_PRIMITIVE(fixnum_add)
|
||||||
{
|
{
|
||||||
POP_FIXNUMS(x,y)
|
POP_FIXNUMS(x,y)
|
||||||
box_signed_cell(x + y);
|
box_signed_cell(x + y);
|
||||||
}
|
}
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(fixnum_add_fast)
|
|
||||||
{
|
|
||||||
POP_FIXNUMS(x,y)
|
|
||||||
dpush(tag_fixnum(x + y));
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(fixnum_subtract)
|
DEFINE_PRIMITIVE(fixnum_subtract)
|
||||||
{
|
{
|
||||||
POP_FIXNUMS(x,y)
|
POP_FIXNUMS(x,y)
|
||||||
box_signed_cell(x - y);
|
box_signed_cell(x - y);
|
||||||
}
|
}
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(fixnum_subtract_fast)
|
|
||||||
{
|
|
||||||
POP_FIXNUMS(x,y)
|
|
||||||
dpush(tag_fixnum(x - y));
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Multiply two integers, and trap overflow.
|
/* Multiply two integers, and trap overflow.
|
||||||
Thanks to David Blaikie (The_Vulture from freenode #java) for the hint. */
|
Thanks to David Blaikie (The_Vulture from freenode #java) for the hint. */
|
||||||
DEFINE_PRIMITIVE(fixnum_multiply)
|
DEFINE_PRIMITIVE(fixnum_multiply)
|
||||||
|
|
@ -87,12 +72,6 @@ DEFINE_PRIMITIVE(fixnum_multiply)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(fixnum_multiply_fast)
|
|
||||||
{
|
|
||||||
POP_FIXNUMS(x,y)
|
|
||||||
dpush(tag_fixnum(x * y));
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(fixnum_divint)
|
DEFINE_PRIMITIVE(fixnum_divint)
|
||||||
{
|
{
|
||||||
POP_FIXNUMS(x,y)
|
POP_FIXNUMS(x,y)
|
||||||
|
|
@ -112,24 +91,6 @@ DEFINE_PRIMITIVE(fixnum_mod)
|
||||||
dpush(tag_fixnum(x % y));
|
dpush(tag_fixnum(x % y));
|
||||||
}
|
}
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(fixnum_and)
|
|
||||||
{
|
|
||||||
POP_FIXNUMS(x,y)
|
|
||||||
dpush(tag_fixnum(x & y));
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(fixnum_or)
|
|
||||||
{
|
|
||||||
POP_FIXNUMS(x,y)
|
|
||||||
dpush(tag_fixnum(x | y));
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(fixnum_xor)
|
|
||||||
{
|
|
||||||
POP_FIXNUMS(x,y)
|
|
||||||
dpush(tag_fixnum(x ^ y));
|
|
||||||
}
|
|
||||||
|
|
||||||
/*
|
/*
|
||||||
* Note the hairy overflow check.
|
* Note the hairy overflow check.
|
||||||
* If we're shifting right by n bits, we won't overflow as long as none of the
|
* If we're shifting right by n bits, we won't overflow as long as none of the
|
||||||
|
|
@ -172,35 +133,6 @@ DEFINE_PRIMITIVE(fixnum_shift_fast)
|
||||||
dpush(tag_fixnum(y < 0 ? (x >> -y) : (x << y)));
|
dpush(tag_fixnum(y < 0 ? (x >> -y) : (x << y)));
|
||||||
}
|
}
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(fixnum_less)
|
|
||||||
{
|
|
||||||
POP_FIXNUMS(x,y)
|
|
||||||
box_boolean(x < y);
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(fixnum_lesseq)
|
|
||||||
{
|
|
||||||
POP_FIXNUMS(x,y)
|
|
||||||
box_boolean(x <= y);
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(fixnum_greater)
|
|
||||||
{
|
|
||||||
POP_FIXNUMS(x,y)
|
|
||||||
box_boolean(x > y);
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(fixnum_greatereq)
|
|
||||||
{
|
|
||||||
POP_FIXNUMS(x,y)
|
|
||||||
box_boolean(x >= y);
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(fixnum_not)
|
|
||||||
{
|
|
||||||
drepl(tag_fixnum(~untag_fixnum_fast(dpeek())));
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Bignums */
|
/* Bignums */
|
||||||
DEFINE_PRIMITIVE(fixnum_to_bignum)
|
DEFINE_PRIMITIVE(fixnum_to_bignum)
|
||||||
{
|
{
|
||||||
|
|
|
||||||
11
vm/math.h
11
vm/math.h
|
|
@ -11,23 +11,12 @@ DECLARE_PRIMITIVE(float_to_fixnum);
|
||||||
|
|
||||||
DECLARE_PRIMITIVE(fixnum_add);
|
DECLARE_PRIMITIVE(fixnum_add);
|
||||||
DECLARE_PRIMITIVE(fixnum_subtract);
|
DECLARE_PRIMITIVE(fixnum_subtract);
|
||||||
DECLARE_PRIMITIVE(fixnum_add_fast);
|
|
||||||
DECLARE_PRIMITIVE(fixnum_subtract_fast);
|
|
||||||
DECLARE_PRIMITIVE(fixnum_multiply);
|
DECLARE_PRIMITIVE(fixnum_multiply);
|
||||||
DECLARE_PRIMITIVE(fixnum_multiply_fast);
|
|
||||||
DECLARE_PRIMITIVE(fixnum_divint);
|
DECLARE_PRIMITIVE(fixnum_divint);
|
||||||
DECLARE_PRIMITIVE(fixnum_divmod);
|
DECLARE_PRIMITIVE(fixnum_divmod);
|
||||||
DECLARE_PRIMITIVE(fixnum_mod);
|
DECLARE_PRIMITIVE(fixnum_mod);
|
||||||
DECLARE_PRIMITIVE(fixnum_and);
|
|
||||||
DECLARE_PRIMITIVE(fixnum_or);
|
|
||||||
DECLARE_PRIMITIVE(fixnum_xor);
|
|
||||||
DECLARE_PRIMITIVE(fixnum_shift);
|
DECLARE_PRIMITIVE(fixnum_shift);
|
||||||
DECLARE_PRIMITIVE(fixnum_shift_fast);
|
DECLARE_PRIMITIVE(fixnum_shift_fast);
|
||||||
DECLARE_PRIMITIVE(fixnum_less);
|
|
||||||
DECLARE_PRIMITIVE(fixnum_lesseq);
|
|
||||||
DECLARE_PRIMITIVE(fixnum_greater);
|
|
||||||
DECLARE_PRIMITIVE(fixnum_greatereq);
|
|
||||||
DECLARE_PRIMITIVE(fixnum_not);
|
|
||||||
|
|
||||||
CELL bignum_zero;
|
CELL bignum_zero;
|
||||||
CELL bignum_pos_one;
|
CELL bignum_pos_one;
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,6 @@
|
||||||
#include "master.h"
|
#include "master.h"
|
||||||
|
|
||||||
void *primitives[] = {
|
void *primitives[] = {
|
||||||
primitive_execute,
|
|
||||||
primitive_call,
|
|
||||||
primitive_bignum_to_fixnum,
|
primitive_bignum_to_fixnum,
|
||||||
primitive_float_to_fixnum,
|
primitive_float_to_fixnum,
|
||||||
primitive_fixnum_to_bignum,
|
primitive_fixnum_to_bignum,
|
||||||
|
|
@ -18,24 +16,13 @@ void *primitives[] = {
|
||||||
primitive_bits_double,
|
primitive_bits_double,
|
||||||
primitive_from_rect,
|
primitive_from_rect,
|
||||||
primitive_fixnum_add,
|
primitive_fixnum_add,
|
||||||
primitive_fixnum_add_fast,
|
|
||||||
primitive_fixnum_subtract,
|
primitive_fixnum_subtract,
|
||||||
primitive_fixnum_subtract_fast,
|
|
||||||
primitive_fixnum_multiply,
|
primitive_fixnum_multiply,
|
||||||
primitive_fixnum_multiply_fast,
|
|
||||||
primitive_fixnum_divint,
|
primitive_fixnum_divint,
|
||||||
primitive_fixnum_mod,
|
primitive_fixnum_mod,
|
||||||
primitive_fixnum_divmod,
|
primitive_fixnum_divmod,
|
||||||
primitive_fixnum_and,
|
|
||||||
primitive_fixnum_or,
|
|
||||||
primitive_fixnum_xor,
|
|
||||||
primitive_fixnum_not,
|
|
||||||
primitive_fixnum_shift,
|
primitive_fixnum_shift,
|
||||||
primitive_fixnum_shift_fast,
|
primitive_fixnum_shift_fast,
|
||||||
primitive_fixnum_less,
|
|
||||||
primitive_fixnum_lesseq,
|
|
||||||
primitive_fixnum_greater,
|
|
||||||
primitive_fixnum_greatereq,
|
|
||||||
primitive_bignum_eq,
|
primitive_bignum_eq,
|
||||||
primitive_bignum_add,
|
primitive_bignum_add,
|
||||||
primitive_bignum_subtract,
|
primitive_bignum_subtract,
|
||||||
|
|
@ -67,25 +54,6 @@ void *primitives[] = {
|
||||||
primitive_float_greatereq,
|
primitive_float_greatereq,
|
||||||
primitive_word,
|
primitive_word,
|
||||||
primitive_word_xt,
|
primitive_word_xt,
|
||||||
primitive_drop,
|
|
||||||
primitive_2drop,
|
|
||||||
primitive_3drop,
|
|
||||||
primitive_dup,
|
|
||||||
primitive_2dup,
|
|
||||||
primitive_3dup,
|
|
||||||
primitive_rot,
|
|
||||||
primitive__rot,
|
|
||||||
primitive_dupd,
|
|
||||||
primitive_swapd,
|
|
||||||
primitive_nip,
|
|
||||||
primitive_2nip,
|
|
||||||
primitive_tuck,
|
|
||||||
primitive_over,
|
|
||||||
primitive_pick,
|
|
||||||
primitive_swap,
|
|
||||||
primitive_to_r,
|
|
||||||
primitive_from_r,
|
|
||||||
primitive_eq,
|
|
||||||
primitive_getenv,
|
primitive_getenv,
|
||||||
primitive_setenv,
|
primitive_setenv,
|
||||||
primitive_existsp,
|
primitive_existsp,
|
||||||
|
|
@ -105,7 +73,6 @@ void *primitives[] = {
|
||||||
primitive_code_room,
|
primitive_code_room,
|
||||||
primitive_os_env,
|
primitive_os_env,
|
||||||
primitive_millis,
|
primitive_millis,
|
||||||
primitive_tag,
|
|
||||||
primitive_modify_code_heap,
|
primitive_modify_code_heap,
|
||||||
primitive_dlopen,
|
primitive_dlopen,
|
||||||
primitive_dlsym,
|
primitive_dlsym,
|
||||||
|
|
@ -140,7 +107,6 @@ void *primitives[] = {
|
||||||
primitive_set_alien_cell,
|
primitive_set_alien_cell,
|
||||||
primitive_throw,
|
primitive_throw,
|
||||||
primitive_alien_address,
|
primitive_alien_address,
|
||||||
primitive_slot,
|
|
||||||
primitive_set_slot,
|
primitive_set_slot,
|
||||||
primitive_string_nth,
|
primitive_string_nth,
|
||||||
primitive_set_string_nth,
|
primitive_set_string_nth,
|
||||||
|
|
|
||||||
210
vm/quotations.c
210
vm/quotations.c
|
|
@ -1,8 +1,38 @@
|
||||||
#include "master.h"
|
#include "master.h"
|
||||||
|
|
||||||
/* Simple JIT compiler. This is one of the two compilers implementing Factor;
|
/* Simple non-optimizing compiler.
|
||||||
the second one is written in Factor and performs a lot of optimizations.
|
|
||||||
See core/compiler/compiler.factor */
|
This is one of the two compilers implementing Factor; the second one is written
|
||||||
|
in Factor and performs advanced optimizations. See core/compiler/compiler.factor.
|
||||||
|
|
||||||
|
The non-optimizing compiler compiles a quotation at a time by concatenating
|
||||||
|
machine code chunks; prolog, epilog, call word, jump to word, etc. These machine
|
||||||
|
code chunks are generated from Factor code in core/cpu/.../bootstrap.factor.
|
||||||
|
|
||||||
|
It actually does do a little bit of very simple optimization:
|
||||||
|
|
||||||
|
1) Tail call optimization.
|
||||||
|
|
||||||
|
2) If a quotation is determined to not call any other words (except for a few
|
||||||
|
special words which are open-coded, see below), then no prolog/epilog is
|
||||||
|
generated.
|
||||||
|
|
||||||
|
3) When in tail position and immediately preceded by literal arguments, the
|
||||||
|
'if' and 'dispatch' conditionals are generated inline, instead of as a call to
|
||||||
|
the 'if' word.
|
||||||
|
|
||||||
|
4) When preceded by an array, calls to the 'declare' word are optimized out
|
||||||
|
entirely. This word is only used by the optimizing compiler, and with the
|
||||||
|
non-optimizing compiler it would otherwise just decrease performance to have to
|
||||||
|
push the array and immediately drop it after.
|
||||||
|
|
||||||
|
5) Sub-primitives are primitive words which are implemented in assembly and not
|
||||||
|
in the VM. They are open-coded and no subroutine call is generated. This
|
||||||
|
includes stack shufflers, some fixnum arithmetic words, and words such as tag,
|
||||||
|
slot and eq?. A primitive call is relatively expensive (two subroutine calls)
|
||||||
|
so this results in a big speedup for relatively little effort.
|
||||||
|
|
||||||
|
*/
|
||||||
bool jit_primitive_call_p(F_ARRAY *array, CELL i)
|
bool jit_primitive_call_p(F_ARRAY *array, CELL i)
|
||||||
{
|
{
|
||||||
return (i + 2) == array_capacity(array)
|
return (i + 2) == array_capacity(array)
|
||||||
|
|
@ -32,15 +62,15 @@ bool jit_ignore_declare_p(F_ARRAY *array, CELL i)
|
||||||
&& array_nth(array,i + 1) == userenv[JIT_DECLARE_WORD];
|
&& array_nth(array,i + 1) == userenv[JIT_DECLARE_WORD];
|
||||||
}
|
}
|
||||||
|
|
||||||
F_ARRAY *code_to_emit(CELL name)
|
F_ARRAY *code_to_emit(CELL code)
|
||||||
{
|
{
|
||||||
return untag_object(array_nth(untag_object(userenv[name]),0));
|
return untag_object(array_nth(untag_object(code),0));
|
||||||
}
|
}
|
||||||
|
|
||||||
F_REL rel_to_emit(CELL name, CELL code_format, CELL code_length,
|
F_REL rel_to_emit(CELL code, CELL code_format, CELL code_length,
|
||||||
CELL rel_argument, bool *rel_p)
|
CELL rel_argument, bool *rel_p)
|
||||||
{
|
{
|
||||||
F_ARRAY *quadruple = untag_object(userenv[name]);
|
F_ARRAY *quadruple = untag_object(code);
|
||||||
CELL rel_class = array_nth(quadruple,1);
|
CELL rel_class = array_nth(quadruple,1);
|
||||||
CELL rel_type = array_nth(quadruple,2);
|
CELL rel_type = array_nth(quadruple,2);
|
||||||
CELL offset = array_nth(quadruple,3);
|
CELL offset = array_nth(quadruple,3);
|
||||||
|
|
@ -82,20 +112,9 @@ bool jit_stack_frame_p(F_ARRAY *array)
|
||||||
CELL obj = array_nth(array,i);
|
CELL obj = array_nth(array,i);
|
||||||
if(type_of(obj) == WORD_TYPE)
|
if(type_of(obj) == WORD_TYPE)
|
||||||
{
|
{
|
||||||
if(obj != userenv[JIT_TAG_WORD]
|
F_WORD *word = untag_object(obj);
|
||||||
&& obj != userenv[JIT_EQP_WORD]
|
if(word->subprimitive == F && obj != userenv[JIT_DECLARE_WORD])
|
||||||
&& obj != userenv[JIT_SLOT_WORD]
|
|
||||||
&& obj != userenv[JIT_DROP_WORD]
|
|
||||||
&& obj != userenv[JIT_DUP_WORD]
|
|
||||||
&& obj != userenv[JIT_TO_R_WORD]
|
|
||||||
&& obj != userenv[JIT_FROM_R_WORD]
|
|
||||||
&& obj != userenv[JIT_SWAP_WORD]
|
|
||||||
&& obj != userenv[JIT_OVER_WORD]
|
|
||||||
&& obj != userenv[JIT_FIXNUM_MINUS_WORD]
|
|
||||||
&& obj != userenv[JIT_FIXNUM_GE_WORD])
|
|
||||||
{
|
|
||||||
return true;
|
return true;
|
||||||
}
|
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
@ -139,7 +158,7 @@ void jit_compile(CELL quot, bool relocate)
|
||||||
bool stack_frame = jit_stack_frame_p(untag_object(array));
|
bool stack_frame = jit_stack_frame_p(untag_object(array));
|
||||||
|
|
||||||
if(stack_frame)
|
if(stack_frame)
|
||||||
EMIT(JIT_PROLOG,0);
|
EMIT(userenv[JIT_PROLOG],0);
|
||||||
|
|
||||||
CELL i;
|
CELL i;
|
||||||
CELL length = array_capacity(untag_object(array));
|
CELL length = array_capacity(untag_object(array));
|
||||||
|
|
@ -154,84 +173,44 @@ void jit_compile(CELL quot, bool relocate)
|
||||||
switch(type_of(obj))
|
switch(type_of(obj))
|
||||||
{
|
{
|
||||||
case WORD_TYPE:
|
case WORD_TYPE:
|
||||||
|
word = untag_object(obj);
|
||||||
|
|
||||||
/* Intrinsics */
|
/* Intrinsics */
|
||||||
if(obj == userenv[JIT_TAG_WORD])
|
if(word->subprimitive != F)
|
||||||
{
|
{
|
||||||
EMIT(JIT_TAG,0);
|
if(array_nth(untag_object(word->subprimitive),1) != F)
|
||||||
}
|
{
|
||||||
else if(obj == userenv[JIT_EQP_WORD])
|
GROWABLE_ARRAY_ADD(literals,T);
|
||||||
{
|
}
|
||||||
GROWABLE_ARRAY_ADD(literals,T);
|
|
||||||
EMIT(JIT_EQP,literals_count - 1);
|
EMIT(word->subprimitive,literals_count - 1);
|
||||||
}
|
|
||||||
else if(obj == userenv[JIT_SLOT_WORD])
|
|
||||||
{
|
|
||||||
EMIT(JIT_SLOT,0);
|
|
||||||
}
|
|
||||||
else if(obj == userenv[JIT_DROP_WORD])
|
|
||||||
{
|
|
||||||
EMIT(JIT_DROP,0);
|
|
||||||
}
|
|
||||||
else if(obj == userenv[JIT_DUP_WORD])
|
|
||||||
{
|
|
||||||
EMIT(JIT_DUP,0);
|
|
||||||
}
|
|
||||||
else if(obj == userenv[JIT_TO_R_WORD])
|
|
||||||
{
|
|
||||||
EMIT(JIT_TO_R,0);
|
|
||||||
}
|
|
||||||
else if(obj == userenv[JIT_FROM_R_WORD])
|
|
||||||
{
|
|
||||||
EMIT(JIT_FROM_R,0);
|
|
||||||
}
|
|
||||||
else if(obj == userenv[JIT_SWAP_WORD])
|
|
||||||
{
|
|
||||||
EMIT(JIT_SWAP,0);
|
|
||||||
}
|
|
||||||
else if(obj == userenv[JIT_OVER_WORD])
|
|
||||||
{
|
|
||||||
EMIT(JIT_OVER,0);
|
|
||||||
}
|
|
||||||
else if(obj == userenv[JIT_FIXNUM_MINUS_WORD])
|
|
||||||
{
|
|
||||||
EMIT(JIT_FIXNUM_MINUS,0);
|
|
||||||
}
|
|
||||||
else if(obj == userenv[JIT_FIXNUM_GE_WORD])
|
|
||||||
{
|
|
||||||
GROWABLE_ARRAY_ADD(literals,T);
|
|
||||||
EMIT(JIT_FIXNUM_GE,literals_count - 1);
|
|
||||||
}
|
}
|
||||||
else
|
else
|
||||||
{
|
{
|
||||||
/* Emit the epilog before the primitive call gate
|
|
||||||
so that we save the C stack pointer minus the
|
|
||||||
current stack frame. */
|
|
||||||
word = untag_object(obj);
|
|
||||||
|
|
||||||
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
|
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
|
||||||
|
|
||||||
if(i == length - 1)
|
if(i == length - 1)
|
||||||
{
|
{
|
||||||
if(stack_frame)
|
if(stack_frame)
|
||||||
EMIT(JIT_EPILOG,0);
|
EMIT(userenv[JIT_EPILOG],0);
|
||||||
|
|
||||||
EMIT(JIT_WORD_JUMP,literals_count - 1);
|
EMIT(userenv[JIT_WORD_JUMP],literals_count - 1);
|
||||||
|
|
||||||
tail_call = true;
|
tail_call = true;
|
||||||
}
|
}
|
||||||
else
|
else
|
||||||
EMIT(JIT_WORD_CALL,literals_count - 1);
|
EMIT(userenv[JIT_WORD_CALL],literals_count - 1);
|
||||||
}
|
}
|
||||||
break;
|
break;
|
||||||
case WRAPPER_TYPE:
|
case WRAPPER_TYPE:
|
||||||
wrapper = untag_object(obj);
|
wrapper = untag_object(obj);
|
||||||
GROWABLE_ARRAY_ADD(literals,wrapper->object);
|
GROWABLE_ARRAY_ADD(literals,wrapper->object);
|
||||||
EMIT(JIT_PUSH_LITERAL,literals_count - 1);
|
EMIT(userenv[JIT_PUSH_LITERAL],literals_count - 1);
|
||||||
break;
|
break;
|
||||||
case FIXNUM_TYPE:
|
case FIXNUM_TYPE:
|
||||||
if(jit_primitive_call_p(untag_object(array),i))
|
if(jit_primitive_call_p(untag_object(array),i))
|
||||||
{
|
{
|
||||||
EMIT(JIT_PRIMITIVE,to_fixnum(obj));
|
EMIT(userenv[JIT_PRIMITIVE],to_fixnum(obj));
|
||||||
|
|
||||||
i++;
|
i++;
|
||||||
|
|
||||||
|
|
@ -242,11 +221,11 @@ void jit_compile(CELL quot, bool relocate)
|
||||||
if(jit_fast_if_p(untag_object(array),i))
|
if(jit_fast_if_p(untag_object(array),i))
|
||||||
{
|
{
|
||||||
if(stack_frame)
|
if(stack_frame)
|
||||||
EMIT(JIT_EPILOG,0);
|
EMIT(userenv[JIT_EPILOG],0);
|
||||||
|
|
||||||
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
|
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
|
||||||
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1));
|
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1));
|
||||||
EMIT(JIT_IF_JUMP,literals_count - 2);
|
EMIT(userenv[JIT_IF_JUMP],literals_count - 2);
|
||||||
|
|
||||||
i += 2;
|
i += 2;
|
||||||
|
|
||||||
|
|
@ -257,10 +236,10 @@ void jit_compile(CELL quot, bool relocate)
|
||||||
if(jit_fast_dispatch_p(untag_object(array),i))
|
if(jit_fast_dispatch_p(untag_object(array),i))
|
||||||
{
|
{
|
||||||
if(stack_frame)
|
if(stack_frame)
|
||||||
EMIT(JIT_EPILOG,0);
|
EMIT(userenv[JIT_EPILOG],0);
|
||||||
|
|
||||||
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
|
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
|
||||||
EMIT(JIT_DISPATCH,literals_count - 1);
|
EMIT(userenv[JIT_DISPATCH],literals_count - 1);
|
||||||
|
|
||||||
i++;
|
i++;
|
||||||
|
|
||||||
|
|
@ -274,7 +253,7 @@ void jit_compile(CELL quot, bool relocate)
|
||||||
}
|
}
|
||||||
default:
|
default:
|
||||||
GROWABLE_ARRAY_ADD(literals,obj);
|
GROWABLE_ARRAY_ADD(literals,obj);
|
||||||
EMIT(JIT_PUSH_LITERAL,literals_count - 1);
|
EMIT(userenv[JIT_PUSH_LITERAL],literals_count - 1);
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
@ -282,9 +261,9 @@ void jit_compile(CELL quot, bool relocate)
|
||||||
if(!tail_call)
|
if(!tail_call)
|
||||||
{
|
{
|
||||||
if(stack_frame)
|
if(stack_frame)
|
||||||
EMIT(JIT_EPILOG,0);
|
EMIT(userenv[JIT_EPILOG],0);
|
||||||
|
|
||||||
EMIT(JIT_RETURN,0);
|
EMIT(userenv[JIT_RETURN],0);
|
||||||
}
|
}
|
||||||
|
|
||||||
GROWABLE_ARRAY_TRIM(code);
|
GROWABLE_ARRAY_TRIM(code);
|
||||||
|
|
@ -330,7 +309,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
|
||||||
bool stack_frame = jit_stack_frame_p(untag_object(array));
|
bool stack_frame = jit_stack_frame_p(untag_object(array));
|
||||||
|
|
||||||
if(stack_frame)
|
if(stack_frame)
|
||||||
COUNT(JIT_PROLOG,0)
|
COUNT(userenv[JIT_PROLOG],0)
|
||||||
|
|
||||||
CELL i;
|
CELL i;
|
||||||
CELL length = array_capacity(untag_object(array));
|
CELL length = array_capacity(untag_object(array));
|
||||||
|
|
@ -339,55 +318,34 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
|
||||||
for(i = 0; i < length; i++)
|
for(i = 0; i < length; i++)
|
||||||
{
|
{
|
||||||
CELL obj = array_nth(untag_object(array),i);
|
CELL obj = array_nth(untag_object(array),i);
|
||||||
|
F_WORD *word;
|
||||||
|
|
||||||
switch(type_of(obj))
|
switch(type_of(obj))
|
||||||
{
|
{
|
||||||
case WORD_TYPE:
|
case WORD_TYPE:
|
||||||
/* Intrinsics */
|
/* Intrinsics */
|
||||||
if(obj == userenv[JIT_TAG_WORD])
|
word = untag_object(obj);
|
||||||
COUNT(JIT_TAG,i)
|
if(word->subprimitive != F)
|
||||||
else if(obj == userenv[JIT_EQP_WORD])
|
COUNT(word->subprimitive,i)
|
||||||
COUNT(JIT_EQP,i)
|
else if(i == length - 1)
|
||||||
else if(obj == userenv[JIT_SLOT_WORD])
|
|
||||||
COUNT(JIT_SLOT,i)
|
|
||||||
else if(obj == userenv[JIT_DROP_WORD])
|
|
||||||
COUNT(JIT_DROP,i)
|
|
||||||
else if(obj == userenv[JIT_DUP_WORD])
|
|
||||||
COUNT(JIT_DUP,i)
|
|
||||||
else if(obj == userenv[JIT_TO_R_WORD])
|
|
||||||
COUNT(JIT_TO_R,i)
|
|
||||||
else if(obj == userenv[JIT_FROM_R_WORD])
|
|
||||||
COUNT(JIT_FROM_R,i)
|
|
||||||
else if(obj == userenv[JIT_SWAP_WORD])
|
|
||||||
COUNT(JIT_SWAP,i)
|
|
||||||
else if(obj == userenv[JIT_OVER_WORD])
|
|
||||||
COUNT(JIT_OVER,i)
|
|
||||||
else if(obj == userenv[JIT_FIXNUM_MINUS_WORD])
|
|
||||||
COUNT(JIT_FIXNUM_MINUS,i)
|
|
||||||
else if(obj == userenv[JIT_FIXNUM_GE_WORD])
|
|
||||||
COUNT(JIT_FIXNUM_GE,i)
|
|
||||||
else
|
|
||||||
{
|
{
|
||||||
if(i == length - 1)
|
if(stack_frame)
|
||||||
{
|
COUNT(userenv[JIT_EPILOG],i);
|
||||||
if(stack_frame)
|
|
||||||
COUNT(JIT_EPILOG,i);
|
COUNT(userenv[JIT_WORD_JUMP],i)
|
||||||
|
|
||||||
COUNT(JIT_WORD_JUMP,i)
|
tail_call = true;
|
||||||
|
|
||||||
tail_call = true;
|
|
||||||
}
|
|
||||||
else
|
|
||||||
COUNT(JIT_WORD_CALL,i)
|
|
||||||
}
|
}
|
||||||
|
else
|
||||||
|
COUNT(userenv[JIT_WORD_CALL],i)
|
||||||
break;
|
break;
|
||||||
case WRAPPER_TYPE:
|
case WRAPPER_TYPE:
|
||||||
COUNT(JIT_PUSH_LITERAL,i)
|
COUNT(userenv[JIT_PUSH_LITERAL],i)
|
||||||
break;
|
break;
|
||||||
case FIXNUM_TYPE:
|
case FIXNUM_TYPE:
|
||||||
if(jit_primitive_call_p(untag_object(array),i))
|
if(jit_primitive_call_p(untag_object(array),i))
|
||||||
{
|
{
|
||||||
COUNT(JIT_PRIMITIVE,i);
|
COUNT(userenv[JIT_PRIMITIVE],i);
|
||||||
|
|
||||||
i++;
|
i++;
|
||||||
|
|
||||||
|
|
@ -398,11 +356,11 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
|
||||||
if(jit_fast_if_p(untag_object(array),i))
|
if(jit_fast_if_p(untag_object(array),i))
|
||||||
{
|
{
|
||||||
if(stack_frame)
|
if(stack_frame)
|
||||||
COUNT(JIT_EPILOG,i)
|
COUNT(userenv[JIT_EPILOG],i)
|
||||||
|
|
||||||
i += 2;
|
i += 2;
|
||||||
|
|
||||||
COUNT(JIT_IF_JUMP,i)
|
COUNT(userenv[JIT_IF_JUMP],i)
|
||||||
|
|
||||||
tail_call = true;
|
tail_call = true;
|
||||||
break;
|
break;
|
||||||
|
|
@ -411,11 +369,11 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
|
||||||
if(jit_fast_dispatch_p(untag_object(array),i))
|
if(jit_fast_dispatch_p(untag_object(array),i))
|
||||||
{
|
{
|
||||||
if(stack_frame)
|
if(stack_frame)
|
||||||
COUNT(JIT_EPILOG,i)
|
COUNT(userenv[JIT_EPILOG],i)
|
||||||
|
|
||||||
i++;
|
i++;
|
||||||
|
|
||||||
COUNT(JIT_DISPATCH,i)
|
COUNT(userenv[JIT_DISPATCH],i)
|
||||||
|
|
||||||
tail_call = true;
|
tail_call = true;
|
||||||
break;
|
break;
|
||||||
|
|
@ -429,7 +387,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
default:
|
default:
|
||||||
COUNT(JIT_PUSH_LITERAL,i)
|
COUNT(userenv[JIT_PUSH_LITERAL],i)
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
@ -437,9 +395,9 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
|
||||||
if(!tail_call)
|
if(!tail_call)
|
||||||
{
|
{
|
||||||
if(stack_frame)
|
if(stack_frame)
|
||||||
COUNT(JIT_EPILOG,length)
|
COUNT(userenv[JIT_EPILOG],length)
|
||||||
|
|
||||||
COUNT(JIT_RETURN,length)
|
COUNT(userenv[JIT_RETURN],length)
|
||||||
}
|
}
|
||||||
|
|
||||||
return -1;
|
return -1;
|
||||||
|
|
|
||||||
146
vm/run.c
146
vm/run.c
|
|
@ -90,133 +90,6 @@ void init_stacks(CELL ds_size_, CELL rs_size_)
|
||||||
stack_chain = NULL;
|
stack_chain = NULL;
|
||||||
}
|
}
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(drop)
|
|
||||||
{
|
|
||||||
dpop();
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(2drop)
|
|
||||||
{
|
|
||||||
ds -= 2 * CELLS;
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(3drop)
|
|
||||||
{
|
|
||||||
ds -= 3 * CELLS;
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(dup)
|
|
||||||
{
|
|
||||||
dpush(dpeek());
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(2dup)
|
|
||||||
{
|
|
||||||
CELL top = dpeek();
|
|
||||||
CELL next = get(ds - CELLS);
|
|
||||||
ds += CELLS * 2;
|
|
||||||
put(ds - CELLS,next);
|
|
||||||
put(ds,top);
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(3dup)
|
|
||||||
{
|
|
||||||
CELL c1 = dpeek();
|
|
||||||
CELL c2 = get(ds - CELLS);
|
|
||||||
CELL c3 = get(ds - CELLS * 2);
|
|
||||||
ds += CELLS * 3;
|
|
||||||
put (ds,c1);
|
|
||||||
put (ds - CELLS,c2);
|
|
||||||
put (ds - CELLS * 2,c3);
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(rot)
|
|
||||||
{
|
|
||||||
CELL c1 = dpeek();
|
|
||||||
CELL c2 = get(ds - CELLS);
|
|
||||||
CELL c3 = get(ds - CELLS * 2);
|
|
||||||
put(ds,c3);
|
|
||||||
put(ds - CELLS,c1);
|
|
||||||
put(ds - CELLS * 2,c2);
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(_rot)
|
|
||||||
{
|
|
||||||
CELL c1 = dpeek();
|
|
||||||
CELL c2 = get(ds - CELLS);
|
|
||||||
CELL c3 = get(ds - CELLS * 2);
|
|
||||||
put(ds,c2);
|
|
||||||
put(ds - CELLS,c3);
|
|
||||||
put(ds - CELLS * 2,c1);
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(dupd)
|
|
||||||
{
|
|
||||||
CELL top = dpeek();
|
|
||||||
CELL next = get(ds - CELLS);
|
|
||||||
put(ds,next);
|
|
||||||
put(ds - CELLS,next);
|
|
||||||
dpush(top);
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(swapd)
|
|
||||||
{
|
|
||||||
CELL top = get(ds - CELLS);
|
|
||||||
CELL next = get(ds - CELLS * 2);
|
|
||||||
put(ds - CELLS,next);
|
|
||||||
put(ds - CELLS * 2,top);
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(nip)
|
|
||||||
{
|
|
||||||
CELL top = dpop();
|
|
||||||
drepl(top);
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(2nip)
|
|
||||||
{
|
|
||||||
CELL top = dpeek();
|
|
||||||
ds -= CELLS * 2;
|
|
||||||
drepl(top);
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(tuck)
|
|
||||||
{
|
|
||||||
CELL top = dpeek();
|
|
||||||
CELL next = get(ds - CELLS);
|
|
||||||
put(ds,next);
|
|
||||||
put(ds - CELLS,top);
|
|
||||||
dpush(top);
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(over)
|
|
||||||
{
|
|
||||||
dpush(get(ds - CELLS));
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(pick)
|
|
||||||
{
|
|
||||||
dpush(get(ds - CELLS * 2));
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(swap)
|
|
||||||
{
|
|
||||||
CELL top = dpeek();
|
|
||||||
CELL next = get(ds - CELLS);
|
|
||||||
put(ds,next);
|
|
||||||
put(ds - CELLS,top);
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(to_r)
|
|
||||||
{
|
|
||||||
rpush(dpop());
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(from_r)
|
|
||||||
{
|
|
||||||
dpush(rpop());
|
|
||||||
}
|
|
||||||
|
|
||||||
bool stack_to_array(CELL bottom, CELL top)
|
bool stack_to_array(CELL bottom, CELL top)
|
||||||
{
|
{
|
||||||
F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS);
|
F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS);
|
||||||
|
|
@ -280,13 +153,6 @@ DEFINE_PRIMITIVE(exit)
|
||||||
exit(to_fixnum(dpop()));
|
exit(to_fixnum(dpop()));
|
||||||
}
|
}
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(eq)
|
|
||||||
{
|
|
||||||
CELL lhs = dpop();
|
|
||||||
CELL rhs = dpeek();
|
|
||||||
drepl((lhs == rhs) ? T : F);
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(millis)
|
DEFINE_PRIMITIVE(millis)
|
||||||
{
|
{
|
||||||
box_unsigned_8(current_millis());
|
box_unsigned_8(current_millis());
|
||||||
|
|
@ -297,18 +163,6 @@ DEFINE_PRIMITIVE(sleep)
|
||||||
sleep_millis(to_cell(dpop()));
|
sleep_millis(to_cell(dpop()));
|
||||||
}
|
}
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(tag)
|
|
||||||
{
|
|
||||||
drepl(tag_fixnum(TAG(dpeek())));
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(slot)
|
|
||||||
{
|
|
||||||
F_FIXNUM slot = untag_fixnum_fast(dpop());
|
|
||||||
CELL obj = dpop();
|
|
||||||
dpush(get(SLOT(obj,slot)));
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(set_slot)
|
DEFINE_PRIMITIVE(set_slot)
|
||||||
{
|
{
|
||||||
F_FIXNUM slot = untag_fixnum_fast(dpop());
|
F_FIXNUM slot = untag_fixnum_fast(dpop());
|
||||||
|
|
|
||||||
24
vm/run.h
24
vm/run.h
|
|
@ -245,28 +245,9 @@ DLLEXPORT void save_stacks(void);
|
||||||
DLLEXPORT void nest_stacks(void);
|
DLLEXPORT void nest_stacks(void);
|
||||||
DLLEXPORT void unnest_stacks(void);
|
DLLEXPORT void unnest_stacks(void);
|
||||||
void init_stacks(CELL ds_size, CELL rs_size);
|
void init_stacks(CELL ds_size, CELL rs_size);
|
||||||
DECLARE_PRIMITIVE(drop);
|
|
||||||
DECLARE_PRIMITIVE(2drop);
|
|
||||||
DECLARE_PRIMITIVE(3drop);
|
|
||||||
DECLARE_PRIMITIVE(dup);
|
|
||||||
DECLARE_PRIMITIVE(2dup);
|
|
||||||
DECLARE_PRIMITIVE(3dup);
|
|
||||||
DECLARE_PRIMITIVE(rot);
|
|
||||||
DECLARE_PRIMITIVE(_rot);
|
|
||||||
DECLARE_PRIMITIVE(dupd);
|
|
||||||
DECLARE_PRIMITIVE(swapd);
|
|
||||||
DECLARE_PRIMITIVE(nip);
|
|
||||||
DECLARE_PRIMITIVE(2nip);
|
|
||||||
DECLARE_PRIMITIVE(tuck);
|
|
||||||
DECLARE_PRIMITIVE(over);
|
|
||||||
DECLARE_PRIMITIVE(pick);
|
|
||||||
DECLARE_PRIMITIVE(swap);
|
|
||||||
DECLARE_PRIMITIVE(to_r);
|
|
||||||
DECLARE_PRIMITIVE(from_r);
|
|
||||||
DECLARE_PRIMITIVE(datastack);
|
DECLARE_PRIMITIVE(datastack);
|
||||||
DECLARE_PRIMITIVE(retainstack);
|
DECLARE_PRIMITIVE(retainstack);
|
||||||
DECLARE_PRIMITIVE(execute);
|
|
||||||
DECLARE_PRIMITIVE(call);
|
|
||||||
DECLARE_PRIMITIVE(getenv);
|
DECLARE_PRIMITIVE(getenv);
|
||||||
DECLARE_PRIMITIVE(setenv);
|
DECLARE_PRIMITIVE(setenv);
|
||||||
DECLARE_PRIMITIVE(exit);
|
DECLARE_PRIMITIVE(exit);
|
||||||
|
|
@ -275,11 +256,8 @@ DECLARE_PRIMITIVE(os_envs);
|
||||||
DECLARE_PRIMITIVE(set_os_env);
|
DECLARE_PRIMITIVE(set_os_env);
|
||||||
DECLARE_PRIMITIVE(unset_os_env);
|
DECLARE_PRIMITIVE(unset_os_env);
|
||||||
DECLARE_PRIMITIVE(set_os_envs);
|
DECLARE_PRIMITIVE(set_os_envs);
|
||||||
DECLARE_PRIMITIVE(eq);
|
|
||||||
DECLARE_PRIMITIVE(millis);
|
DECLARE_PRIMITIVE(millis);
|
||||||
DECLARE_PRIMITIVE(sleep);
|
DECLARE_PRIMITIVE(sleep);
|
||||||
DECLARE_PRIMITIVE(tag);
|
|
||||||
DECLARE_PRIMITIVE(slot);
|
|
||||||
DECLARE_PRIMITIVE(set_slot);
|
DECLARE_PRIMITIVE(set_slot);
|
||||||
|
|
||||||
bool stage2;
|
bool stage2;
|
||||||
|
|
|
||||||
|
|
@ -49,6 +49,7 @@ F_WORD *allot_word(CELL vocab, CELL name)
|
||||||
word->props = F;
|
word->props = F;
|
||||||
word->counter = tag_fixnum(0);
|
word->counter = tag_fixnum(0);
|
||||||
word->compiledp = F;
|
word->compiledp = F;
|
||||||
|
word->subprimitive = F;
|
||||||
word->profiling = NULL;
|
word->profiling = NULL;
|
||||||
word->code = NULL;
|
word->code = NULL;
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue