-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
[ 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
! 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
: 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
: (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.
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 -- )
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
! 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
! ##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
! 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 )
[ >>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 )
{
[
{
T{ ##load-reference f 0 + }
- T{ ##replace-imm f 10 D + }
+ T{ ##replace-imm f + D 0 }
}
] [
{
} 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 }
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 }
} 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 }
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 }
] unit-test
! Scale fusion on ##load/store-memory
+cpu x86?
[
V{
T{ ##peek f 0 D 0 }
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 3 1 }
T{ ##shl-imm f 4 3 2 }
T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar }
- } 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
-
-! 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=
+ } value-numbering-step
] 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
+] when
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
[ 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
[ 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
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
! 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
! 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 -- ? )
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
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
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
system cpu.ppc.assembler compiler.units compiler.constants math\r
math.private math.ranges layouts words vocabs slots.private\r
locals locals.backend generic.single.private fry sequences\r
-threads.private ;\r
+threads.private strings.private ;\r
FROM: cpu.ppc.assembler => B ;\r
IN: bootstrap.ppc\r
\r
3 3 4 LBZX\r
3 3 tag-bits get SLWI\r
! store character to stack\r
- ds-reg ds-reg 4 SUB\r
+ ds-reg ds-reg 4 SUBI\r
3 ds-reg 0 STW\r
] \ string-nth-fast define-sub-primitive\r
\r
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 -- )
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 ;
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 ]
"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 ] }
} 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 ] }
} 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 ;
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
{ 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 ;
: 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 ] }
: 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 ] }
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
: 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 ;
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 ;
! 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
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 ;
] [
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
\r
: 'element' ( -- parser )\r
[\r
- [ ('element') , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,\r
+ [\r
+ ('element') , ":" syntax ,\r
+ "a-zA-Z_" range-pattern\r
+ "a-zA-Z0-9_-" range-pattern repeat1 2seq [ first2 swap prefix >string ] action ,\r
+ ] seq* [ first2 <ebnf-var> ] action ,\r
('element') ,\r
] choice* ;\r
\r
! 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
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
-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
{ { $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"
-! 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
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
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 }
{ 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
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 ;
: 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
:: 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 -- )
dup control-value empty? [ drop ] [
dup line-height \ line-height [
{
- [ draw-selected-rows ]
+ [ draw-selected-row ]
[ draw-lines ]
[ draw-column-lines ]
[ draw-focused-row ]
PRIVATE>
-: (selected-rows) ( table -- assoc )
- [ selected-indices>> ] keep
- '[ _ nth-row drop ] assoc-map ;
-
-: 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 ? )
+ [ selection-index>> value>> ] keep nth-row ;
-: 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 ]
: 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 ;
: 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 ;
[ [ 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>
: 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 ;
{ 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 }
-! 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
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" } ;
[ 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
\ 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
-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
<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 )
{
[ 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 ;
>>
[ 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 ( -- )
{
unmaintained
build-support
images
+factor.dll.exp
+factor.dll.lib
+factor.exp
+factor.lib
+libfactor-ffi-test.exp
+libfactor-ffi-test.lib
void factor_vm::inline_gc(cell gc_roots_)
{
- cell stack_pointer = (cell)ctx->callstack_top + sizeof(cell);
+ cell stack_pointer = (cell)ctx->callstack_top;
if(to_boolean(gc_roots_))
{
projects / factor.git / commitdiff