Merge branch 'master' of git://factorcode.org/git/factor
Daniel Ehrenberg
commit
24ad579631
|
|
@ -1,4 +1,4 @@
|
|||
USING: sequences sequences.private arrays bit-arrays kernel
|
||||
USING: alien sequences sequences.private arrays bit-arrays kernel
|
||||
tools.test math random ;
|
||||
IN: bit-arrays.tests
|
||||
|
||||
|
|
@ -79,4 +79,8 @@ IN: bit-arrays.tests
|
|||
|
||||
[ 49 ] [ 49 <bit-array> dup set-bits [ ] count ] unit-test
|
||||
|
||||
[ 1 ] [ ?{ f t f t } byte-length ] unit-test
|
||||
|
||||
[ HEX: a ] [ ?{ f t f t } bit-array>integer ] unit-test
|
||||
|
||||
[ HEX: 100 ] [ ?{ f f f f f f f f t } bit-array>integer ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2007, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.data accessors math alien.accessors kernel
|
||||
kernel.private sequences sequences.private byte-arrays
|
||||
parser prettyprint.custom fry ;
|
||||
USING: alien alien.data accessors io.binary math math.bitwise
|
||||
alien.accessors kernel kernel.private sequences
|
||||
sequences.private byte-arrays parser prettyprint.custom fry
|
||||
locals ;
|
||||
IN: bit-arrays
|
||||
|
||||
TUPLE: bit-array
|
||||
|
|
@ -13,11 +14,10 @@ TUPLE: bit-array
|
|||
|
||||
: n>byte ( m -- n ) -3 shift ; inline
|
||||
|
||||
: byte/bit ( n alien -- byte bit )
|
||||
over n>byte alien-unsigned-1 swap 7 bitand ; inline
|
||||
: bit/byte ( n -- bit byte ) [ 7 bitand ] [ n>byte ] bi ; inline
|
||||
|
||||
: set-bit ( ? byte bit -- byte )
|
||||
2^ rot [ bitor ] [ bitnot bitand ] if ; inline
|
||||
: bit-index ( n bit-array -- bit# byte# byte-array )
|
||||
[ >fixnum bit/byte ] [ underlying>> ] bi* ; inline
|
||||
|
||||
: bits>cells ( m -- n ) 31 + -5 shift ; inline
|
||||
|
||||
|
|
@ -25,7 +25,7 @@ TUPLE: bit-array
|
|||
|
||||
: (set-bits) ( bit-array n -- )
|
||||
[ [ length bits>cells ] keep ] dip swap underlying>>
|
||||
'[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each-integer ; inline
|
||||
'[ [ _ _ ] dip 4 * set-alien-unsigned-4 ] each-integer ; inline
|
||||
|
||||
: clean-up ( bit-array -- )
|
||||
! Zero bits after the end.
|
||||
|
|
@ -47,12 +47,13 @@ PRIVATE>
|
|||
M: bit-array length length>> ; inline
|
||||
|
||||
M: bit-array nth-unsafe
|
||||
[ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline
|
||||
bit-index nth-unsafe swap bit? ; inline
|
||||
|
||||
:: toggle-bit ( ? n x -- y )
|
||||
x n ? [ set-bit ] [ clear-bit ] if ; inline
|
||||
|
||||
M: bit-array set-nth-unsafe
|
||||
[ >fixnum ] [ underlying>> ] bi*
|
||||
[ byte/bit set-bit ] 2keep
|
||||
swap n>byte set-alien-unsigned-1 ; inline
|
||||
bit-index [ toggle-bit ] change-nth-unsafe ; inline
|
||||
|
||||
GENERIC: clear-bits ( bit-array -- )
|
||||
|
||||
|
|
@ -83,25 +84,17 @@ M: bit-array resize
|
|||
bit-array boa
|
||||
dup clean-up ; inline
|
||||
|
||||
M: bit-array byte-length length 7 + -3 shift ; inline
|
||||
M: bit-array byte-length length bits>bytes ; inline
|
||||
|
||||
SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
|
||||
|
||||
: integer>bit-array ( n -- bit-array )
|
||||
dup 0 = [
|
||||
<bit-array>
|
||||
] [
|
||||
[ log2 1 + <bit-array> 0 ] keep
|
||||
[ dup 0 = ] [
|
||||
[ pick underlying>> pick set-alien-unsigned-1 ] keep
|
||||
[ 1 + ] [ -8 shift ] bi*
|
||||
] until 2drop
|
||||
] if ;
|
||||
dup 0 =
|
||||
[ <bit-array> ]
|
||||
[ dup log2 1 + [ nip ] [ bits>bytes >le ] 2bi bit-array boa ] if ;
|
||||
|
||||
: bit-array>integer ( bit-array -- n )
|
||||
0 swap underlying>> dup length iota <reversed> [
|
||||
alien-unsigned-1 swap 8 shift bitor
|
||||
] with each ;
|
||||
underlying>> le> ;
|
||||
|
||||
INSTANCE: bit-array sequence
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors namespaces kernel parser assocs sequences ;
|
||||
USING: accessors namespaces kernel math parser assocs sequences ;
|
||||
IN: compiler.cfg.registers
|
||||
|
||||
! Virtual registers, used by CFG and machine IRs, are just integers
|
||||
|
|
@ -34,7 +34,7 @@ ERROR: bad-vreg vreg ;
|
|||
|
||||
! ##inc-d and ##inc-r affect locations as follows. Location D 0 before
|
||||
! an ##inc-d 1 becomes D 1 after ##inc-d 1.
|
||||
TUPLE: loc { n read-only } ;
|
||||
TUPLE: loc { n integer read-only } ;
|
||||
|
||||
TUPLE: ds-loc < loc ;
|
||||
C: <ds-loc> ds-loc
|
||||
|
|
|
|||
|
|
@ -70,7 +70,10 @@ M: ##unbox-alien rewrite rewrite-unbox-any-c-ptr ;
|
|||
! construct a new ##load-memory or ##store-memory with the
|
||||
! ##add's operand as the displacement
|
||||
: fuse-displacement? ( insn -- ? )
|
||||
base>> vreg>insn ##add? ;
|
||||
{
|
||||
[ offset>> 0 = complex-addressing? or ]
|
||||
[ base>> vreg>insn ##add? ]
|
||||
} 1&& ;
|
||||
|
||||
GENERIC: alien-insn-value ( insn -- value )
|
||||
|
||||
|
|
@ -106,12 +109,14 @@ M: ##store-memory-imm new-alien-insn drop \ ##store-memory new-insn ;
|
|||
[ >>displacement ] [ >>scale ] bi* ;
|
||||
|
||||
: rewrite-memory-op ( insn -- insn/f )
|
||||
{
|
||||
{ [ dup fuse-base-offset? ] [ fuse-base-offset ] }
|
||||
{ [ dup fuse-displacement-offset? ] [ fuse-displacement-offset ] }
|
||||
{ [ dup fuse-scale? ] [ fuse-scale ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
complex-addressing? [
|
||||
{
|
||||
{ [ dup fuse-base-offset? ] [ fuse-base-offset ] }
|
||||
{ [ dup fuse-displacement-offset? ] [ fuse-displacement-offset ] }
|
||||
{ [ dup fuse-scale? ] [ fuse-scale ] }
|
||||
[ drop f ]
|
||||
} cond
|
||||
] [ drop f ] if ;
|
||||
|
||||
: rewrite-memory-imm-op ( insn -- insn/f )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -91,7 +91,7 @@ cpu x86.32? [
|
|||
[
|
||||
{
|
||||
T{ ##load-reference f 0 + }
|
||||
T{ ##replace-imm f 10 D + }
|
||||
T{ ##replace-imm f + D 0 }
|
||||
}
|
||||
] [
|
||||
{
|
||||
|
|
@ -2576,7 +2576,8 @@ cpu x86? [
|
|||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
! Base offset fusion on ##load/store-memory
|
||||
! Base offset fusion on ##load/store-memory -- only on x86
|
||||
cpu x86?
|
||||
[
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
|
|
@ -2586,7 +2587,18 @@ cpu x86? [
|
|||
T{ ##add-imm f 4 2 31337 }
|
||||
T{ ##load-memory f 5 2 3 0 31337 int-rep c:uchar }
|
||||
}
|
||||
] [
|
||||
]
|
||||
[
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##peek f 1 D 1 }
|
||||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##add-imm f 4 2 31337 }
|
||||
T{ ##load-memory f 5 4 3 0 0 int-rep c:uchar }
|
||||
}
|
||||
] ?
|
||||
[
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##peek f 1 D 1 }
|
||||
|
|
@ -2597,7 +2609,8 @@ cpu x86? [
|
|||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
! Displacement offset fusion on ##load/store-memory
|
||||
! Displacement offset fusion on ##load/store-memory -- only on x86
|
||||
cpu x86?
|
||||
[
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
|
|
@ -2607,7 +2620,18 @@ cpu x86? [
|
|||
T{ ##add-imm f 4 3 31337 }
|
||||
T{ ##load-memory f 5 2 3 0 31338 int-rep c:uchar }
|
||||
}
|
||||
] [
|
||||
]
|
||||
[
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##peek f 1 D 1 }
|
||||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##add-imm f 4 3 31337 }
|
||||
T{ ##load-memory f 5 2 4 0 1 int-rep c:uchar }
|
||||
}
|
||||
] ?
|
||||
[
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##peek f 1 D 1 }
|
||||
|
|
@ -2632,6 +2656,7 @@ cpu x86? [
|
|||
] unit-test
|
||||
|
||||
! Scale fusion on ##load/store-memory
|
||||
cpu x86?
|
||||
[
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
|
|
@ -2641,7 +2666,18 @@ cpu x86? [
|
|||
T{ ##shl-imm f 4 3 2 }
|
||||
T{ ##load-memory f 5 2 3 2 0 int-rep c:uchar }
|
||||
}
|
||||
] [
|
||||
]
|
||||
[
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##peek f 1 D 1 }
|
||||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##shl-imm f 4 3 2 }
|
||||
T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar }
|
||||
}
|
||||
] ?
|
||||
[
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##peek f 1 D 1 }
|
||||
|
|
@ -2652,26 +2688,28 @@ cpu x86? [
|
|||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
! Don't do scale fusion if there's already a scale
|
||||
[ ] [
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##peek f 1 D 1 }
|
||||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##shl-imm f 4 3 2 }
|
||||
T{ ##load-memory f 5 2 4 1 0 int-rep c:uchar }
|
||||
} dup value-numbering-step assert=
|
||||
] unit-test
|
||||
cpu x86? [
|
||||
! Don't do scale fusion if there's already a scale
|
||||
[ ] [
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##peek f 1 D 1 }
|
||||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##shl-imm f 4 3 2 }
|
||||
T{ ##load-memory f 5 2 4 1 0 int-rep c:uchar }
|
||||
} dup value-numbering-step assert=
|
||||
] unit-test
|
||||
|
||||
! Don't do scale fusion if the scale factor is out of range
|
||||
[ ] [
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##peek f 1 D 1 }
|
||||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##shl-imm f 4 3 4 }
|
||||
T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar }
|
||||
} dup value-numbering-step assert=
|
||||
] unit-test
|
||||
! Don't do scale fusion if the scale factor is out of range
|
||||
[ ] [
|
||||
V{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##peek f 1 D 1 }
|
||||
T{ ##tagged>integer f 2 0 }
|
||||
T{ ##tagged>integer f 3 1 }
|
||||
T{ ##shl-imm f 4 3 4 }
|
||||
T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar }
|
||||
} dup value-numbering-step assert=
|
||||
] unit-test
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -462,3 +462,13 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-
|
|||
1 1
|
||||
[ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call
|
||||
] unit-test
|
||||
|
||||
! GC root offsets were computed wrong on x86
|
||||
: gc-root-messup ( a -- b )
|
||||
dup [
|
||||
1024 (byte-array) 2array
|
||||
10 void* "libc" "malloc" { ulong } alien-invoke
|
||||
void "libc" "free" { void* } alien-invoke
|
||||
] when ;
|
||||
|
||||
[ ] [ 2000 [ "hello" clone dup gc-root-messup first eq? t assert= ] times ] unit-test
|
||||
|
|
|
|||
|
|
@ -99,9 +99,6 @@ IN: compiler.tests.float
|
|||
[ 2 ] [ 3.0 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
|
||||
[ 2 ] [ 1.0 3.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
|
||||
|
||||
! Ensure that float-min and min, and float-max and max, have
|
||||
! consistent behavior with respect to NaNs
|
||||
|
||||
: two-floats ( a b -- a b ) { float float } declare ; inline
|
||||
|
||||
[ -11.3 ] [ -11.3 17.5 [ two-floats min ] compile-call ] unit-test
|
||||
|
|
@ -109,17 +106,7 @@ IN: compiler.tests.float
|
|||
[ 17.5 ] [ -11.3 17.5 [ two-floats max ] compile-call ] unit-test
|
||||
[ 17.5 ] [ 17.5 -11.3 [ two-floats max ] compile-call ] unit-test
|
||||
|
||||
: check-compiled-binary-op ( a b word -- )
|
||||
[ '[ [ [ two-floats _ execute ] compile-call ] call( a b -- c ) ] ]
|
||||
[ '[ _ execute ] ]
|
||||
bi 2bi fp-bitwise= ; inline
|
||||
|
||||
[ t ] [ 0/0. 3.0 \ min check-compiled-binary-op ] unit-test
|
||||
[ t ] [ 3.0 0/0. \ min check-compiled-binary-op ] unit-test
|
||||
[ t ] [ 0/0. 3.0 \ max check-compiled-binary-op ] unit-test
|
||||
[ t ] [ 3.0 0/0. \ max check-compiled-binary-op ] unit-test
|
||||
|
||||
! Test vector ops
|
||||
! Test loops
|
||||
[ 30.0 ] [
|
||||
float-array{ 1 2 3 4 } float-array{ 1 2 3 4 }
|
||||
[ { float-array float-array } declare [ * ] [ + ] 2map-reduce ] compile-call
|
||||
|
|
@ -134,3 +121,13 @@ IN: compiler.tests.float
|
|||
float-array{ 1 2 3 4 }
|
||||
[ { float-array } declare [ dup * ] [ + ] map-reduce ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ 4.5 ] [
|
||||
float-array{ 1.0 3.5 }
|
||||
[ { float-array } declare 0.0 [ + ] reduce ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ float-array{ 2.0 4.5 } ] [
|
||||
float-array{ 1.0 3.5 }
|
||||
[ { float-array } declare [ 1 + ] map ] compile-call
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators io kernel math namespaces
|
||||
prettyprint sequences vectors ;
|
||||
sequences vectors ;
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
IN: compression.lzw
|
||||
|
||||
|
|
|
|||
|
|
@ -508,8 +508,6 @@ M: stack-params param-reg 2drop ;
|
|||
! objects in %compare-imm?
|
||||
HOOK: fused-unboxing? cpu ( -- ? )
|
||||
|
||||
M: object fused-unboxing? f ;
|
||||
|
||||
! Can this value be an immediate operand for %add-imm, %sub-imm,
|
||||
! or %mul-imm?
|
||||
HOOK: immediate-arithmetic? cpu ( n -- ? )
|
||||
|
|
|
|||
|
|
@ -72,6 +72,14 @@ HEX{ 7c 41 1a 2e } [ 1 2 3 LHZX ] test-assembler
|
|||
HEX{ 7c 41 1a 6e } [ 1 2 3 LHZUX ] test-assembler
|
||||
HEX{ 7c 41 18 2e } [ 1 2 3 LWZX ] test-assembler
|
||||
HEX{ 7c 41 18 6e } [ 1 2 3 LWZUX ] test-assembler
|
||||
HEX{ 7c 41 1c 2e } [ 1 2 3 LFSX ] test-assembler
|
||||
HEX{ 7c 41 1c 6e } [ 1 2 3 LFSUX ] test-assembler
|
||||
HEX{ 7c 41 1c ae } [ 1 2 3 LFDX ] test-assembler
|
||||
HEX{ 7c 41 1c ee } [ 1 2 3 LFDUX ] test-assembler
|
||||
HEX{ 7c 41 1d 2e } [ 1 2 3 STFSX ] test-assembler
|
||||
HEX{ 7c 41 1d 6e } [ 1 2 3 STFSUX ] test-assembler
|
||||
HEX{ 7c 41 1d ae } [ 1 2 3 STFDX ] test-assembler
|
||||
HEX{ 7c 41 1d ee } [ 1 2 3 STFDUX ] test-assembler
|
||||
HEX{ 48 00 00 01 } [ 1 B ] test-assembler
|
||||
HEX{ 48 00 00 01 } [ 1 BL ] test-assembler
|
||||
HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler
|
||||
|
|
|
|||
|
|
@ -66,6 +66,10 @@ X: FCMPO 0 32 63
|
|||
X: FCMPU 0 0 63
|
||||
X: LBZUX 0 119 31
|
||||
X: LBZX 0 87 31
|
||||
X: LFDUX 0 631 31
|
||||
X: LFDX 0 599 31
|
||||
X: LFSUX 0 567 31
|
||||
X: LFSX 0 535 31
|
||||
X: LHAUX 0 375 31
|
||||
X: LHAX 0 343 31
|
||||
X: LHZUX 0 311 31
|
||||
|
|
@ -89,6 +93,10 @@ X: SRW 0 536 31
|
|||
X: SRW. 1 536 31
|
||||
X: STBUX 0 247 31
|
||||
X: STBX 0 215 31
|
||||
X: STFDUX 0 759 31
|
||||
X: STFDX 0 727 31
|
||||
X: STFSUX 0 695 31
|
||||
X: STFSX 0 663 31
|
||||
X: STHUX 0 439 31
|
||||
X: STHX 0 407 31
|
||||
X: STWUX 0 183 31
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: bootstrap.image.private kernel kernel.private namespaces
|
|||
system cpu.ppc.assembler compiler.units compiler.constants math
|
||||
math.private math.ranges layouts words vocabs slots.private
|
||||
locals locals.backend generic.single.private fry sequences
|
||||
threads.private ;
|
||||
threads.private strings.private ;
|
||||
FROM: cpu.ppc.assembler => B ;
|
||||
IN: bootstrap.ppc
|
||||
|
||||
|
|
@ -502,7 +502,7 @@ CONSTANT: nv-reg 17
|
|||
3 3 4 LBZX
|
||||
3 3 tag-bits get SLWI
|
||||
! store character to stack
|
||||
ds-reg ds-reg 4 SUB
|
||||
ds-reg ds-reg 4 SUBI
|
||||
3 ds-reg 0 STW
|
||||
] \ string-nth-fast define-sub-primitive
|
||||
|
||||
|
|
|
|||
|
|
@ -46,6 +46,10 @@ M: ppc machine-registers
|
|||
CONSTANT: scratch-reg 30
|
||||
CONSTANT: fp-scratch-reg 30
|
||||
|
||||
M: ppc complex-addressing? f ;
|
||||
|
||||
M: ppc fused-unboxing? f ;
|
||||
|
||||
M: ppc %load-immediate ( reg n -- ) swap LOAD ;
|
||||
|
||||
M: ppc %load-reference ( reg obj -- )
|
||||
|
|
@ -139,9 +143,12 @@ M:: ppc %dispatch ( src temp -- )
|
|||
temp MTCTR
|
||||
BCTR ;
|
||||
|
||||
M: ppc %slot ( dst obj slot -- ) swapd LWZX ;
|
||||
: (%slot) ( dst obj slot scale tag -- obj dst slot )
|
||||
[ 0 assert= ] bi@ swapd ;
|
||||
|
||||
M: ppc %slot ( dst obj slot scale tag -- ) (%slot) LWZX ;
|
||||
M: ppc %slot-imm ( dst obj slot tag -- ) slot-offset LWZ ;
|
||||
M: ppc %set-slot ( src obj slot -- ) swapd STWX ;
|
||||
M: ppc %set-slot ( src obj slot scale tag -- ) (%slot) STWX ;
|
||||
M: ppc %set-slot-imm ( src obj slot tag -- ) slot-offset STW ;
|
||||
|
||||
M: ppc %add ADD ;
|
||||
|
|
@ -357,7 +364,7 @@ M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
|
|||
|
||||
dst displacement base temp
|
||||
{
|
||||
{ [ base-class \ f class<= ] [ 2drop %box-displaced-alien/f ] }
|
||||
{ [ base-class \ f class<= ] [ drop %box-displaced-alien/f ] }
|
||||
{ [ base-class \ alien class<= ] [ %box-displaced-alien/alien ] }
|
||||
{ [ base-class \ byte-array class<= ] [ %box-displaced-alien/byte-array ] }
|
||||
[ %box-displaced-alien/dynamic ]
|
||||
|
|
@ -366,7 +373,7 @@ M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
|
|||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M:: ppc %load-memory-imm ( dst base offset rep c-type -- )
|
||||
M: ppc %load-memory-imm ( dst base offset rep c-type -- )
|
||||
[
|
||||
{
|
||||
{ c:char [ [ dup ] 2dip LBZ dup EXTSB ] }
|
||||
|
|
@ -382,7 +389,26 @@ M:: ppc %load-memory-imm ( dst base offset rep c-type -- )
|
|||
} case
|
||||
] ?if ;
|
||||
|
||||
M:: ppc %store-memory-imm ( src base offset rep c-type -- )
|
||||
: (%memory) ( val base displacement scale offset rep c-type -- base val displacement rep c-type )
|
||||
[ [ 0 assert= ] bi@ swapd ] 2dip ; inline
|
||||
|
||||
M: ppc %load-memory ( dst base displacement scale offset rep c-type -- )
|
||||
(%memory) [
|
||||
{
|
||||
{ c:char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
|
||||
{ c:uchar [ LBZX ] }
|
||||
{ c:short [ LHAX ] }
|
||||
{ c:ushort [ LHZX ] }
|
||||
} case
|
||||
] [
|
||||
{
|
||||
{ int-rep [ LWZX ] }
|
||||
{ float-rep [ LFSX ] }
|
||||
{ double-rep [ LFDX ] }
|
||||
} case
|
||||
] ?if ;
|
||||
|
||||
M: ppc %store-memory-imm ( src base offset rep c-type -- )
|
||||
[
|
||||
{
|
||||
{ c:char [ STB ] }
|
||||
|
|
@ -398,6 +424,22 @@ M:: ppc %store-memory-imm ( src base offset rep c-type -- )
|
|||
} case
|
||||
] ?if ;
|
||||
|
||||
M: ppc %store-memory ( src base displacement scale offset rep c-type -- )
|
||||
(%memory) [
|
||||
{
|
||||
{ c:char [ STBX ] }
|
||||
{ c:uchar [ STBX ] }
|
||||
{ c:short [ STHX ] }
|
||||
{ c:ushort [ STHX ] }
|
||||
} case
|
||||
] [
|
||||
{
|
||||
{ int-rep [ STWX ] }
|
||||
{ float-rep [ STFSX ] }
|
||||
{ double-rep [ STFDX ] }
|
||||
} case
|
||||
] ?if ;
|
||||
|
||||
: load-zone-ptr ( reg -- )
|
||||
vm-reg "nursery" vm-field-offset ADDI ;
|
||||
|
||||
|
|
@ -440,18 +482,18 @@ M:: ppc %allot ( dst size class nursery-ptr -- )
|
|||
temp2 load-decks-offset
|
||||
temp1 scratch-reg temp2 STBX ;
|
||||
|
||||
M:: ppc %write-barrier ( src slot temp1 temp2 -- )
|
||||
M:: ppc %write-barrier ( src slot scale tag temp1 temp2 -- )
|
||||
scale 0 assert= tag 0 assert=
|
||||
temp1 src slot ADD
|
||||
temp1 temp2 (%write-barrier) ;
|
||||
|
||||
M:: ppc %write-barrier-imm ( src slot temp1 temp2 -- )
|
||||
temp1 src slot ADDI
|
||||
M:: ppc %write-barrier-imm ( src slot tag temp1 temp2 -- )
|
||||
temp1 src slot tag slot-offset ADDI
|
||||
temp1 temp2 (%write-barrier) ;
|
||||
|
||||
M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
|
||||
temp2 load-zone-ptr
|
||||
temp1 temp2 0 LWZ
|
||||
temp2 temp2 2 cells LWZ
|
||||
temp1 vm-reg "nursery" vm-field-offset LWZ
|
||||
temp2 vm-reg "nursery" vm-field-offset 2 cells + LWZ
|
||||
temp1 temp1 size ADDI
|
||||
! is here >= end?
|
||||
temp1 0 temp2 CMP
|
||||
|
|
@ -460,8 +502,11 @@ M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
|
|||
{ cc/<= [ label BGT ] }
|
||||
} case ;
|
||||
|
||||
: gc-root-offsets ( seq -- seq' )
|
||||
[ n>> spill@ ] map f like ;
|
||||
|
||||
M: ppc %call-gc ( gc-roots -- )
|
||||
3 swap %load-reference
|
||||
3 swap gc-root-offsets %load-reference
|
||||
4 %load-vm-addr
|
||||
"inline_gc" f %alien-invoke ;
|
||||
|
||||
|
|
@ -586,6 +631,7 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
|
|||
: load-from-frame ( dst n rep -- )
|
||||
{
|
||||
{ int-rep [ [ 1 ] dip LWZ ] }
|
||||
{ tagged-rep [ [ 1 ] dip LWZ ] }
|
||||
{ float-rep [ [ 1 ] dip LFS ] }
|
||||
{ double-rep [ [ 1 ] dip LFD ] }
|
||||
{ stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] }
|
||||
|
|
@ -597,6 +643,7 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
|
|||
: store-to-frame ( src n rep -- )
|
||||
{
|
||||
{ int-rep [ [ 1 ] dip STW ] }
|
||||
{ tagged-rep [ [ 1 ] dip STW ] }
|
||||
{ float-rep [ [ 1 ] dip STFS ] }
|
||||
{ double-rep [ [ 1 ] dip STFD ] }
|
||||
{ stack-params [ [ [ 0 ] dip next-param@ LWZ 0 1 ] dip STW ] }
|
||||
|
|
|
|||
|
|
@ -3,7 +3,12 @@ kernel tools.test namespaces make layouts ;
|
|||
IN: cpu.x86.assembler.tests
|
||||
|
||||
! immediate operands
|
||||
[ { HEX: b9 HEX: 01 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 1 MOV ] { } make ] unit-test
|
||||
cell 4 = [
|
||||
[ { HEX: b9 HEX: 01 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 1 MOV ] { } make ] unit-test
|
||||
] [
|
||||
[ { HEX: b9 HEX: 01 HEX: 00 HEX: 00 HEX: 00 HEX: 00 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 1 MOV ] { } make ] unit-test
|
||||
] if
|
||||
|
||||
[ { HEX: 83 HEX: c1 HEX: 01 } ] [ [ ECX 1 ADD ] { } make ] unit-test
|
||||
[ { HEX: 81 HEX: c1 HEX: 96 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 150 ADD ] { } make ] unit-test
|
||||
[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test
|
||||
|
|
|
|||
|
|
@ -45,7 +45,7 @@ HOOK: extra-stack-space cpu ( stack-frame -- n )
|
|||
: param@ ( n -- op ) reserved-stack-space + stack@ ;
|
||||
|
||||
: gc-root-offsets ( seq -- seq' )
|
||||
[ n>> special-offset ] map f like ;
|
||||
[ n>> spill-offset special-offset cell + ] map f like ;
|
||||
|
||||
: decr-stack-reg ( n -- )
|
||||
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
|
||||
|
|
@ -70,9 +70,9 @@ HOOK: pic-tail-reg cpu ( -- reg )
|
|||
|
||||
M: x86 complex-addressing? t ;
|
||||
|
||||
M: x86 fused-unboxing? ( -- ? ) t ;
|
||||
M: x86 fused-unboxing? t ;
|
||||
|
||||
M: x86 immediate-store? ( obj -- ? ) immediate-comparand? ;
|
||||
M: x86 immediate-store? immediate-comparand? ;
|
||||
|
||||
M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors ascii combinators images images.loader io
|
||||
io.encodings.ascii io.encodings.string kernel locals make math
|
||||
math.parser prettyprint sequences ;
|
||||
math.parser sequences ;
|
||||
IN: images.ppm
|
||||
|
||||
SINGLETON: ppm-image
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: accessors arrays assocs byte-arrays classes combinators
|
|||
compression.lzw endian fry grouping images io
|
||||
io.binary io.encodings.ascii io.encodings.binary
|
||||
io.encodings.string io.encodings.utf8 io.files kernel math
|
||||
math.bitwise math.order math.parser pack prettyprint sequences
|
||||
math.bitwise math.order math.parser pack sequences
|
||||
strings math.vectors specialized-arrays locals
|
||||
images.loader ;
|
||||
FROM: alien.c-types => float ;
|
||||
|
|
|
|||
|
|
@ -528,3 +528,17 @@ Tok = Spaces (Number | Special )
|
|||
] [
|
||||
error>> [ redefined-rule? ] [ name>> "lol" = ] bi and
|
||||
] must-fail-with
|
||||
|
||||
[
|
||||
{ "a" "a" }
|
||||
] [
|
||||
EBNF: foo Bar = "a":a1 "a":a2 => [[ a1 a2 2array ]] ;EBNF
|
||||
"aa" foo
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ "a" "a" }
|
||||
] [
|
||||
EBNF: foo2 Bar = "a":a-1 "a":a-2 => [[ a-1 a-2 2array ]] ;EBNF
|
||||
"aa" foo2
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -230,7 +230,11 @@ DEFER: 'action'
|
|||
|
||||
: 'element' ( -- parser )
|
||||
[
|
||||
[ ('element') , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,
|
||||
[
|
||||
('element') , ":" syntax ,
|
||||
"a-zA-Z_" range-pattern
|
||||
"a-zA-Z0-9_-" range-pattern repeat1 2seq [ first2 swap prefix >string ] action ,
|
||||
] seq* [ first2 <ebnf-var> ] action ,
|
||||
('element') ,
|
||||
] choice* ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,13 +1,15 @@
|
|||
! Copyright (C) 2007, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays alien.libraries accessors io.backend io.encodings.utf8 io.files
|
||||
io.streams.c init fry namespaces math make assocs kernel parser
|
||||
parser.notes lexer strings.parser vocabs sequences sequences.deep
|
||||
sequences.private words memory kernel.private continuations io
|
||||
vocabs.loader system strings sets vectors quotations byte-arrays
|
||||
sorting compiler.units definitions generic generic.standard
|
||||
generic.single tools.deploy.config combinators classes vocabs.loader.private
|
||||
classes.builtin slots.private grouping command-line io.pathnames ;
|
||||
USING: arrays alien.libraries accessors io.backend
|
||||
io.encodings.utf8 io.files io.streams.c init fry namespaces math
|
||||
make assocs kernel parser parser.notes lexer strings.parser
|
||||
vocabs sequences sequences.deep sequences.private words memory
|
||||
kernel.private continuations io vocabs.loader system strings
|
||||
sets vectors quotations byte-arrays sorting compiler.units
|
||||
definitions generic generic.standard generic.single
|
||||
tools.deploy.config combinators combinators.private classes
|
||||
vocabs.loader.private classes.builtin slots.private grouping
|
||||
command-line io.pathnames ;
|
||||
QUALIFIED: bootstrap.stage2
|
||||
QUALIFIED: classes.private
|
||||
QUALIFIED: compiler.crossref
|
||||
|
|
@ -548,10 +550,18 @@ SYMBOL: deploy-vocab
|
|||
strip-words
|
||||
clear-megamorphic-caches ;
|
||||
|
||||
: die-with ( error original-error -- * )
|
||||
#! We don't want DCE to drop the error before the die call!
|
||||
[ die 1 exit ] (( a -- * )) call-effect-unsafe ;
|
||||
|
||||
: die-with2 ( error original-error -- * )
|
||||
#! We don't want DCE to drop the error before the die call!
|
||||
[ die 1 exit ] (( a b -- * )) call-effect-unsafe ;
|
||||
|
||||
: deploy-error-handler ( quot -- )
|
||||
[
|
||||
strip-debugger?
|
||||
[ error-continuation get call>> callstack>array die 1 exit ]
|
||||
[ original-error get die-with2 ]
|
||||
! Don't reference these words literally, if we're stripping the
|
||||
! debugger out we don't want to load the prettyprinter at all
|
||||
[ [:c] execute( -- ) nl [print-error] execute( error -- ) flush ] if
|
||||
|
|
|
|||
|
|
@ -1,17 +1,14 @@
|
|||
USING: compiler.units words vocabs kernel threads.private ;
|
||||
USING: compiler.units continuations kernel namespaces
|
||||
threads.private words vocabs tools.deploy.shaker ;
|
||||
IN: debugger
|
||||
|
||||
: consume ( error -- )
|
||||
#! We don't want DCE to drop the error before the die call!
|
||||
drop ;
|
||||
: error. ( error -- ) original-error get die-with2 ;
|
||||
|
||||
: print-error ( error -- ) die consume ;
|
||||
|
||||
: error. ( error -- ) die consume ;
|
||||
: print-error ( error -- ) error. ;
|
||||
|
||||
"threads" vocab [
|
||||
[
|
||||
"error-in-thread" "threads" lookup
|
||||
[ [ die 2drop ] define ] [ f "combination" set-word-prop ] bi
|
||||
[ [ drop error. ] define ] [ f "combination" set-word-prop ] bi
|
||||
] with-compilation-unit
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -25,13 +25,11 @@ ARTICLE: "ui.gadgets.tables.selection" "Table row selection"
|
|||
{ { $slot "selection" } { " - if set to a model, the values of the currently selected row or rows, as determined by a " { $link row-value } " call to the renderer, is stored in this model. See " { $link "models" } "." } }
|
||||
{ { $slot "selection-index" } { " - if set to a model, the indices of the currently selected rows." } }
|
||||
{ { $slot "selection-required?" } { " - if set to a true value, the table ensures that some row is always selected, if the model is non-empty. If set to " { $link f } ", a state where nothing is selected is permitted to occur. The default is " { $link f } "." } }
|
||||
{ { $slot "multiple-selection?" } { " - if set to a true value, users are allowed to select more than one value." } }
|
||||
}
|
||||
"Some words for row selection:"
|
||||
{ $subsections
|
||||
selected-rows
|
||||
(selected-rows)
|
||||
selected
|
||||
selected-row
|
||||
(selected-row)
|
||||
} ;
|
||||
|
||||
ARTICLE: "ui.gadgets.tables.actions" "Table row actions"
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs hashtables arrays colors colors.constants fry
|
||||
kernel math math.functions math.ranges math.rectangles math.order
|
||||
|
|
@ -18,6 +18,7 @@ GENERIC: column-titles ( renderer -- strings )
|
|||
GENERIC: row-columns ( row renderer -- columns )
|
||||
GENERIC: row-value ( row renderer -- object )
|
||||
GENERIC: row-color ( row renderer -- color )
|
||||
GENERIC: row-value? ( value row renderer -- ? )
|
||||
|
||||
SINGLETON: trivial-renderer
|
||||
|
||||
|
|
@ -29,6 +30,7 @@ M: object column-titles drop f ;
|
|||
M: trivial-renderer row-columns drop ;
|
||||
M: object row-value drop ;
|
||||
M: object row-color 2drop f ;
|
||||
M: object row-value? drop eq? ;
|
||||
|
||||
TUPLE: table < line-gadget
|
||||
{ renderer initial: trivial-renderer }
|
||||
|
|
@ -41,33 +43,11 @@ focus-border-color
|
|||
{ mouse-color initial: COLOR: black }
|
||||
column-line-color
|
||||
selection-required?
|
||||
selection
|
||||
selection-index
|
||||
selected-indices
|
||||
selection
|
||||
mouse-index
|
||||
{ takes-focus? initial: t }
|
||||
focused?
|
||||
multiple-selection? ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: add-selected-index ( table n -- table )
|
||||
over selected-indices>> conjoin ;
|
||||
|
||||
: multiple>single ( values -- value/f ? )
|
||||
dup assoc-empty? [ drop f f ] [ values first t ] if ;
|
||||
|
||||
: selected-index ( table -- n )
|
||||
selected-indices>> multiple>single drop ;
|
||||
|
||||
: set-selected-index ( table n -- table )
|
||||
dup associate >>selected-indices ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: selected ( table -- index/indices )
|
||||
[ selected-indices>> ] [ multiple-selection?>> ] bi
|
||||
[ multiple>single drop ] unless ;
|
||||
focused? ;
|
||||
|
||||
: new-table ( rows renderer class -- table )
|
||||
new-line-gadget
|
||||
|
|
@ -77,8 +57,7 @@ PRIVATE>
|
|||
focus-border-color >>focus-border-color
|
||||
transparent >>column-line-color
|
||||
f <model> >>selection-index
|
||||
f <model> >>selection
|
||||
H{ } clone >>selected-indices ;
|
||||
f <model> >>selection ;
|
||||
|
||||
: <table> ( rows renderer -- table ) table new-table ;
|
||||
|
||||
|
|
@ -156,30 +135,23 @@ M: table layout*
|
|||
: row-bounds ( table row -- loc dim )
|
||||
row-rect rect-bounds ; inline
|
||||
|
||||
: draw-selected-rows ( table -- )
|
||||
{
|
||||
{ [ dup selected-indices>> assoc-empty? ] [ drop ] }
|
||||
[
|
||||
[ selected-indices>> keys ] [ selection-color>> gl-color ] [ ] tri
|
||||
[ swap row-bounds gl-fill-rect ] curry each
|
||||
]
|
||||
} cond ;
|
||||
: draw-selected-row ( table -- )
|
||||
dup selection-index>> value>> [
|
||||
dup selection-color>> gl-color
|
||||
dup selection-index>> value>> row-bounds gl-fill-rect
|
||||
] [ drop ] if ;
|
||||
|
||||
: draw-focused-row ( table -- )
|
||||
{
|
||||
{ [ dup focused?>> not ] [ drop ] }
|
||||
{ [ dup selected-index not ] [ drop ] }
|
||||
[
|
||||
[ ] [ selected-index ] [ focus-border-color>> gl-color ] tri
|
||||
row-bounds gl-rect
|
||||
]
|
||||
} cond ;
|
||||
dup { [ focused?>> ] [ selection-index>> value>> ] } 1&& [
|
||||
dup focus-border-color>> gl-color
|
||||
dup selection-index>> value>> row-bounds gl-rect
|
||||
] [ drop ] if ;
|
||||
|
||||
: draw-moused-row ( table -- )
|
||||
dup mouse-index>> dup [
|
||||
over mouse-color>> gl-color
|
||||
row-bounds gl-rect
|
||||
] [ 2drop ] if ;
|
||||
dup mouse-index>> [
|
||||
dup mouse-color>> gl-color
|
||||
dup mouse-index>> row-bounds gl-rect
|
||||
] [ drop ] if ;
|
||||
|
||||
: column-line-offsets ( table -- xs )
|
||||
[ column-widths>> ] [ gap>> ] bi
|
||||
|
|
@ -217,7 +189,7 @@ M: table layout*
|
|||
:: row-font ( row ind table -- font )
|
||||
table font>> clone
|
||||
row table renderer>> row-color [ >>foreground ] when*
|
||||
ind table selected-indices>> key?
|
||||
ind table selection-index>> value>> =
|
||||
[ table selection-color>> >>background ] when ;
|
||||
|
||||
: draw-columns ( columns widths alignment font gap -- )
|
||||
|
|
@ -239,7 +211,7 @@ M: table draw-gadget*
|
|||
dup control-value empty? [ drop ] [
|
||||
dup line-height \ line-height [
|
||||
{
|
||||
[ draw-selected-rows ]
|
||||
[ draw-selected-row ]
|
||||
[ draw-lines ]
|
||||
[ draw-column-lines ]
|
||||
[ draw-focused-row ]
|
||||
|
|
@ -262,37 +234,15 @@ M: table pref-dim*
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: (selected-rows) ( table -- assoc )
|
||||
[ selected-indices>> ] keep
|
||||
'[ _ nth-row drop ] assoc-map ;
|
||||
: (selected-row) ( table -- value/f ? )
|
||||
[ selection-index>> value>> ] keep nth-row ;
|
||||
|
||||
: selected-rows ( table -- assoc )
|
||||
[ selected-indices>> ] [ ] [ renderer>> ] tri
|
||||
'[ _ nth-row drop _ row-value ] assoc-map ;
|
||||
|
||||
: (selected-row) ( table -- value/f ? ) (selected-rows) multiple>single ;
|
||||
|
||||
: selected-row ( table -- value/f ? ) selected-rows multiple>single ;
|
||||
: selected-row ( table -- value/f ? )
|
||||
[ (selected-row) ] [ renderer>> ] bi
|
||||
swap [ row-value t ] [ 2drop f f ] if ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: set-table-model ( model value multiple? -- )
|
||||
[ values ] [ multiple>single drop ] if swap set-model ;
|
||||
|
||||
: update-selected ( table -- )
|
||||
[
|
||||
[ selection>> ]
|
||||
[ selected-rows ]
|
||||
[ multiple-selection?>> ] tri
|
||||
set-table-model
|
||||
]
|
||||
[
|
||||
[ selection-index>> ]
|
||||
[ selected-indices>> ]
|
||||
[ multiple-selection?>> ] tri
|
||||
set-table-model
|
||||
] bi ;
|
||||
|
||||
: show-row-summary ( table n -- )
|
||||
over nth-row
|
||||
[ swap [ renderer>> row-value ] keep show-summary ]
|
||||
|
|
@ -302,34 +252,45 @@ PRIVATE>
|
|||
: hide-mouse-help ( table -- )
|
||||
f >>mouse-index [ hide-status ] [ relayout-1 ] bi ;
|
||||
|
||||
: find-row-index ( value table -- n/f )
|
||||
[ model>> value>> ] [ renderer>> ] bi
|
||||
'[ _ row-value eq? ] with find drop ;
|
||||
: ((select-row)) ( n table -- )
|
||||
[ selection-index>> set-model ]
|
||||
[ [ selected-row drop ] keep selection>> set-model ]
|
||||
bi ;
|
||||
|
||||
: (update-selected-indices) ( table -- set )
|
||||
[ selection>> value>> dup { [ array? not ] [ ] } 1&& [ 1array ] when ] keep
|
||||
'[ _ find-row-index ] map sift unique f assoc-like ;
|
||||
: update-mouse-index ( table -- )
|
||||
dup [ model>> value>> ] [ mouse-index>> ] bi
|
||||
dup [ swap length [ drop f ] [ 1 - min ] if-zero ] [ 2drop f ] if
|
||||
>>mouse-index drop ;
|
||||
|
||||
: initial-selected-indices ( table -- set )
|
||||
: initial-selection-index ( table -- n/f )
|
||||
{
|
||||
[ model>> value>> empty? not ]
|
||||
[ selection-required?>> ]
|
||||
[ drop { 0 } unique ]
|
||||
[ drop 0 ]
|
||||
} 1&& ;
|
||||
|
||||
: update-selected-indices ( table -- set )
|
||||
{
|
||||
[ (update-selected-indices) ]
|
||||
[ initial-selected-indices ]
|
||||
} 1|| ;
|
||||
: find-row-index ( value table -- n/f )
|
||||
[ model>> value>> ] [ renderer>> ] bi
|
||||
'[ _ row-value? ] with find drop ;
|
||||
|
||||
: update-selection ( table -- )
|
||||
[
|
||||
{
|
||||
[ [ selection>> value>> ] keep find-row-index ]
|
||||
[ initial-selection-index ]
|
||||
} 1||
|
||||
] keep
|
||||
over [ ((select-row)) ] [
|
||||
[ selection-index>> set-model ]
|
||||
[ selection>> set-model ]
|
||||
2bi
|
||||
] if ;
|
||||
|
||||
M: table model-changed
|
||||
nip dup update-selected-indices {
|
||||
[ >>selected-indices f >>mouse-index drop ]
|
||||
[ multiple>single drop show-row-summary ]
|
||||
[ drop update-selected ]
|
||||
[ drop relayout ]
|
||||
} 2cleave ;
|
||||
nip
|
||||
dup update-selection
|
||||
dup update-mouse-index
|
||||
[ dup mouse-index>> show-row-summary ] [ relayout ] bi ;
|
||||
|
||||
: thin-row-rect ( table row -- rect )
|
||||
row-rect [ { 0 1 } v* ] change-dim ;
|
||||
|
|
@ -337,14 +298,11 @@ M: table model-changed
|
|||
: scroll-to-row ( table n -- )
|
||||
dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ;
|
||||
|
||||
: add-selected-row ( table n -- )
|
||||
[ scroll-to-row ]
|
||||
[ add-selected-index relayout-1 ] 2bi ;
|
||||
|
||||
: (select-row) ( table n -- )
|
||||
[ scroll-to-row ]
|
||||
[ set-selected-index relayout-1 ]
|
||||
2bi ;
|
||||
[ swap ((select-row)) ]
|
||||
[ drop relayout-1 ]
|
||||
2tri ;
|
||||
|
||||
: mouse-row ( table -- n )
|
||||
[ hand-rel second ] keep y>line ;
|
||||
|
|
@ -353,23 +311,9 @@ M: table model-changed
|
|||
[ [ mouse-row ] keep 2dup valid-line? ]
|
||||
[ ] [ '[ nip @ ] ] tri* if ; inline
|
||||
|
||||
: (table-button-down) ( quot table -- )
|
||||
dup takes-focus?>> [ dup request-focus ] when swap
|
||||
'[ swap [ >>mouse-index ] _ bi ] [ drop ] if-mouse-row ; inline
|
||||
|
||||
: table-button-down ( table -- )
|
||||
[ (select-row) ] swap (table-button-down) ;
|
||||
|
||||
: continued-button-down ( table -- )
|
||||
dup multiple-selection?>>
|
||||
[ [ add-selected-row ] swap (table-button-down) ] [ table-button-down ] if ;
|
||||
|
||||
: thru-button-down ( table -- )
|
||||
dup multiple-selection?>> [
|
||||
[ 2dup over selected-index (a,b) swap
|
||||
[ swap add-selected-index drop ] curry each add-selected-row ]
|
||||
swap (table-button-down)
|
||||
] [ table-button-down ] if ;
|
||||
dup takes-focus?>> [ dup request-focus ] when
|
||||
[ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -386,22 +330,20 @@ PRIVATE>
|
|||
|
||||
: table-button-up ( table -- )
|
||||
dup [ mouse-row ] keep valid-line? [
|
||||
dup row-action? [ row-action ] [ update-selected ] if
|
||||
dup row-action? [ row-action ] [ drop ] if
|
||||
] [ drop ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: select-row ( table n -- )
|
||||
over validate-line
|
||||
[ (select-row) ]
|
||||
[ drop update-selected ]
|
||||
[ show-row-summary ]
|
||||
2tri ;
|
||||
[ (select-row) ] [ show-row-summary ] 2bi ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: prev/next-row ( table n -- )
|
||||
[ dup selected-index ] dip '[ _ + ] [ 0 ] if* select-row ;
|
||||
[ dup selection-index>> value>> ] dip
|
||||
'[ _ + ] [ 0 ] if* select-row ;
|
||||
|
||||
: previous-row ( table -- )
|
||||
-1 prev/next-row ;
|
||||
|
|
@ -453,8 +395,6 @@ table "sundry" f {
|
|||
{ mouse-enter show-mouse-help }
|
||||
{ mouse-leave hide-mouse-help }
|
||||
{ motion show-mouse-help }
|
||||
{ T{ button-down f { S+ } 1 } thru-button-down }
|
||||
{ T{ button-down f { A+ } 1 } continued-button-down }
|
||||
{ T{ button-up } table-button-up }
|
||||
{ T{ button-up f { S+ } } table-button-up }
|
||||
{ T{ button-down } table-button-down }
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays sequences sorting assocs colors.constants fry
|
||||
combinators combinators.smart combinators.short-circuit editors make
|
||||
|
|
@ -49,6 +49,8 @@ M: source-file-renderer prototype-row
|
|||
M: source-file-renderer row-value
|
||||
drop dup [ first [ <pathname> ] [ f ] if* ] when ;
|
||||
|
||||
M: source-file-renderer row-value? row-value = ;
|
||||
|
||||
M: source-file-renderer column-titles
|
||||
drop { "" "File" "Errors" } ;
|
||||
|
||||
|
|
@ -152,7 +154,7 @@ error-display "toolbar" f {
|
|||
[ swap '[ error-type _ at ] filter ] <smart-arrow> ;
|
||||
|
||||
:: <error-list-gadget> ( model -- gadget )
|
||||
vertical error-list-gadget new-track
|
||||
vertical \ error-list-gadget new-track
|
||||
<error-toggle> [ >>error-toggle ] [ >>visible-errors ] bi*
|
||||
dup visible-errors>> model <error-model> >>model
|
||||
f <model> >>source-file
|
||||
|
|
@ -176,16 +178,16 @@ M: error-list-gadget focusable-child*
|
|||
|
||||
\ error-list-help H{ { +nullary+ t } } define-command
|
||||
|
||||
error-list-gadget "toolbar" f {
|
||||
\ error-list-gadget "toolbar" f {
|
||||
{ T{ key-down f f "F1" } error-list-help }
|
||||
} define-command-map
|
||||
|
||||
: error-list-window ( -- )
|
||||
error-list-model get [ drop all-errors ] <arrow>
|
||||
<error-list-gadget> "Errors" open-status-window ;
|
||||
MEMO: error-list-gadget ( -- gadget )
|
||||
error-list-model get-global [ drop all-errors ] <arrow>
|
||||
<error-list-gadget> ;
|
||||
|
||||
: show-error-list ( -- )
|
||||
[ error-list-gadget? ] find-window
|
||||
[ raise-window ] [ error-list-window ] if* ;
|
||||
[ error-list-gadget eq? ] find-window
|
||||
[ raise-window ] [ error-list-gadget "Errors" open-status-window ] if* ;
|
||||
|
||||
\ show-error-list H{ { +nullary+ t } } define-command
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
USING: windows.directx.dinput windows.kernel32 windows.ole32 windows.com
|
||||
windows.com.syntax alien alien.c-types alien.data alien.syntax
|
||||
kernel system namespaces combinators sequences fry math accessors
|
||||
macros words quotations libc continuations generalizations
|
||||
splitting locals assocs init specialized-arrays memoize
|
||||
USING: windows.directx.dinput windows.kernel32 windows.ole32
|
||||
windows.com windows.com.syntax alien alien.c-types alien.data
|
||||
alien.syntax kernel system namespaces combinators sequences fry
|
||||
math accessors macros words quotations libc continuations
|
||||
generalizations splitting locals assocs init specialized-arrays
|
||||
classes.struct strings arrays literals ;
|
||||
SPECIALIZED-ARRAY: DIOBJECTDATAFORMAT
|
||||
IN: windows.directx.dinput.constants
|
||||
|
|
@ -20,21 +20,21 @@ SYMBOLS:
|
|||
|
||||
<PRIVATE
|
||||
|
||||
<<
|
||||
: initialize ( variable quot -- )
|
||||
call swap set-global ; inline
|
||||
|
||||
MEMO: c-type* ( name -- c-type ) c-type ;
|
||||
MEMO: heap-size* ( c-type -- n ) heap-size ;
|
||||
<<
|
||||
|
||||
GENERIC: array-base-type ( c-type -- c-type' )
|
||||
M: object array-base-type ;
|
||||
M: array array-base-type first ;
|
||||
|
||||
: (field-spec-of) ( field struct -- field-spec )
|
||||
c-type* fields>> [ name>> = ] with find nip ;
|
||||
c-type fields>> [ name>> = ] with find nip ;
|
||||
: (offsetof) ( field struct -- offset )
|
||||
[ (field-spec-of) offset>> ] [ drop 0 ] if* ;
|
||||
: (sizeof) ( field struct -- size )
|
||||
[ (field-spec-of) type>> array-base-type heap-size* ] [ drop 1 ] if* ;
|
||||
[ (field-spec-of) type>> array-base-type heap-size ] [ drop 1 ] if* ;
|
||||
|
||||
: (flag) ( thing -- integer )
|
||||
{
|
||||
|
|
@ -56,14 +56,17 @@ M: array array-base-type first ;
|
|||
[ first dup word? [ '[ _ get ] ] [ drop [ f ] ] if ]
|
||||
} cleave
|
||||
[ DIOBJECTDATAFORMAT <struct-boa> ] dip
|
||||
'[ _ clone @ >>pguid ] ;
|
||||
curry ;
|
||||
|
||||
: set-DIOBJECTDATAFORMAT ( array struct pguid n -- array )
|
||||
[ [ clone ] dip >>pguid ] dip pick set-nth ;
|
||||
|
||||
:: make-DIOBJECTDATAFORMAT-array-quot ( struct array -- quot )
|
||||
array length '[ _ malloc-DIOBJECTDATAFORMAT-array ]
|
||||
array [| args i |
|
||||
struct args <DIOBJECTDATAFORMAT>-quot
|
||||
i '[ _ pick set-nth ] compose compose
|
||||
] each-index ;
|
||||
i '[ @ _ set-DIOBJECTDATAFORMAT ]
|
||||
] map-index [ ] join compose ;
|
||||
|
||||
>>
|
||||
|
||||
|
|
@ -832,8 +835,7 @@ MACRO: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
|
|||
[ define-constants ] "windows.directx.dinput.constants" add-startup-hook
|
||||
|
||||
: uninitialize ( variable quot -- )
|
||||
[ '[ _ when* f ] change-global ]
|
||||
[ drop global delete-at ] 2bi ; inline
|
||||
[ [ get-global ] dip when* ] [ drop global delete-at ] 2bi ; inline
|
||||
|
||||
: free-dinput-constants ( -- )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -8,3 +8,9 @@ Nmakefile
|
|||
unmaintained
|
||||
build-support
|
||||
images
|
||||
factor.dll.exp
|
||||
factor.dll.lib
|
||||
factor.exp
|
||||
factor.lib
|
||||
libfactor-ffi-test.exp
|
||||
libfactor-ffi-test.lib
|
||||
|
|
|
|||
Loading…
Reference in New Issue