Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
42d8e80ed9
|
|
@ -0,0 +1,118 @@
|
|||
IN: cpu.ppc.assembler.tests
|
||||
USING: cpu.ppc.assembler tools.test arrays kernel namespaces
|
||||
vocabs sequences ;
|
||||
|
||||
: test-assembler ( expected quot -- )
|
||||
[ 1array ] [ [ { } make ] curry ] bi* unit-test ;
|
||||
|
||||
{ HEX: 38220003 } [ 1 2 3 ADDI ] test-assembler
|
||||
{ HEX: 3c220003 } [ 1 2 3 ADDIS ] test-assembler
|
||||
{ HEX: 30220003 } [ 1 2 3 ADDIC ] test-assembler
|
||||
{ HEX: 34220003 } [ 1 2 3 ADDIC. ] test-assembler
|
||||
{ HEX: 38400001 } [ 1 2 LI ] test-assembler
|
||||
{ HEX: 3c400001 } [ 1 2 LIS ] test-assembler
|
||||
{ HEX: 3822fffd } [ 1 2 3 SUBI ] test-assembler
|
||||
{ HEX: 1c220003 } [ 1 2 3 MULI ] test-assembler
|
||||
{ HEX: 7c221a14 } [ 1 2 3 ADD ] test-assembler
|
||||
{ HEX: 7c221a15 } [ 1 2 3 ADD. ] test-assembler
|
||||
{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
|
||||
{ HEX: 7c221e15 } [ 1 2 3 ADDO. ] test-assembler
|
||||
{ HEX: 7c221814 } [ 1 2 3 ADDC ] test-assembler
|
||||
{ HEX: 7c221815 } [ 1 2 3 ADDC. ] test-assembler
|
||||
{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
|
||||
{ HEX: 7c221c15 } [ 1 2 3 ADDCO. ] test-assembler
|
||||
{ HEX: 7c221914 } [ 1 2 3 ADDE ] test-assembler
|
||||
{ HEX: 7c411838 } [ 1 2 3 AND ] test-assembler
|
||||
{ HEX: 7c411839 } [ 1 2 3 AND. ] test-assembler
|
||||
{ HEX: 7c221bd6 } [ 1 2 3 DIVW ] test-assembler
|
||||
{ HEX: 7c221b96 } [ 1 2 3 DIVWU ] test-assembler
|
||||
{ HEX: 7c411a38 } [ 1 2 3 EQV ] test-assembler
|
||||
{ HEX: 7c411bb8 } [ 1 2 3 NAND ] test-assembler
|
||||
{ HEX: 7c4118f8 } [ 1 2 3 NOR ] test-assembler
|
||||
{ HEX: 7c4110f8 } [ 1 2 NOT ] test-assembler
|
||||
{ HEX: 60410003 } [ 1 2 3 ORI ] test-assembler
|
||||
{ HEX: 64410003 } [ 1 2 3 ORIS ] test-assembler
|
||||
{ HEX: 7c411b78 } [ 1 2 3 OR ] test-assembler
|
||||
{ HEX: 7c411378 } [ 1 2 MR ] test-assembler
|
||||
{ HEX: 7c221896 } [ 1 2 3 MULHW ] test-assembler
|
||||
{ HEX: 1c220003 } [ 1 2 3 MULLI ] test-assembler
|
||||
{ HEX: 7c221816 } [ 1 2 3 MULHWU ] test-assembler
|
||||
{ HEX: 7c2219d6 } [ 1 2 3 MULLW ] test-assembler
|
||||
{ HEX: 7c411830 } [ 1 2 3 SLW ] test-assembler
|
||||
{ HEX: 7c411e30 } [ 1 2 3 SRAW ] test-assembler
|
||||
{ HEX: 7c411c30 } [ 1 2 3 SRW ] test-assembler
|
||||
{ HEX: 7c411e70 } [ 1 2 3 SRAWI ] test-assembler
|
||||
{ HEX: 7c221850 } [ 1 2 3 SUBF ] test-assembler
|
||||
{ HEX: 7c221810 } [ 1 2 3 SUBFC ] test-assembler
|
||||
{ HEX: 7c221910 } [ 1 2 3 SUBFE ] test-assembler
|
||||
{ HEX: 7c410774 } [ 1 2 EXTSB ] test-assembler
|
||||
{ HEX: 68410003 } [ 1 2 3 XORI ] test-assembler
|
||||
{ HEX: 7c411a78 } [ 1 2 3 XOR ] test-assembler
|
||||
{ HEX: 7c2200d0 } [ 1 2 NEG ] test-assembler
|
||||
{ HEX: 2c220003 } [ 1 2 3 CMPI ] test-assembler
|
||||
{ HEX: 28220003 } [ 1 2 3 CMPLI ] test-assembler
|
||||
{ HEX: 7c411800 } [ 1 2 3 CMP ] test-assembler
|
||||
{ HEX: 5422190a } [ 1 2 3 4 5 RLWINM ] test-assembler
|
||||
{ HEX: 54221838 } [ 1 2 3 SLWI ] test-assembler
|
||||
{ HEX: 5422e8fe } [ 1 2 3 SRWI ] test-assembler
|
||||
{ HEX: 88220003 } [ 1 2 3 LBZ ] test-assembler
|
||||
{ HEX: 8c220003 } [ 1 2 3 LBZU ] test-assembler
|
||||
{ HEX: a8220003 } [ 1 2 3 LHA ] test-assembler
|
||||
{ HEX: ac220003 } [ 1 2 3 LHAU ] test-assembler
|
||||
{ HEX: a0220003 } [ 1 2 3 LHZ ] test-assembler
|
||||
{ HEX: a4220003 } [ 1 2 3 LHZU ] test-assembler
|
||||
{ HEX: 80220003 } [ 1 2 3 LWZ ] test-assembler
|
||||
{ HEX: 84220003 } [ 1 2 3 LWZU ] test-assembler
|
||||
{ HEX: 7c4118ae } [ 1 2 3 LBZX ] test-assembler
|
||||
{ HEX: 7c4118ee } [ 1 2 3 LBZUX ] test-assembler
|
||||
{ HEX: 7c411aae } [ 1 2 3 LHAX ] test-assembler
|
||||
{ HEX: 7c411aee } [ 1 2 3 LHAUX ] test-assembler
|
||||
{ HEX: 7c411a2e } [ 1 2 3 LHZX ] test-assembler
|
||||
{ HEX: 7c411a6e } [ 1 2 3 LHZUX ] test-assembler
|
||||
{ HEX: 7c41182e } [ 1 2 3 LWZX ] test-assembler
|
||||
{ HEX: 7c41186e } [ 1 2 3 LWZUX ] test-assembler
|
||||
{ HEX: 48000001 } [ 1 B ] test-assembler
|
||||
{ HEX: 48000001 } [ 1 BL ] test-assembler
|
||||
{ HEX: 41800004 } [ 1 BLT ] test-assembler
|
||||
{ HEX: 41810004 } [ 1 BGT ] test-assembler
|
||||
{ HEX: 40810004 } [ 1 BLE ] test-assembler
|
||||
{ HEX: 40800004 } [ 1 BGE ] test-assembler
|
||||
{ HEX: 41800004 } [ 1 BLT ] test-assembler
|
||||
{ HEX: 40820004 } [ 1 BNE ] test-assembler
|
||||
{ HEX: 41820004 } [ 1 BEQ ] test-assembler
|
||||
{ HEX: 41830004 } [ 1 BO ] test-assembler
|
||||
{ HEX: 40830004 } [ 1 BNO ] test-assembler
|
||||
{ HEX: 4c200020 } [ 1 BCLR ] test-assembler
|
||||
{ HEX: 4e800020 } [ BLR ] test-assembler
|
||||
{ HEX: 4e800021 } [ BLRL ] test-assembler
|
||||
{ HEX: 4c200420 } [ 1 BCCTR ] test-assembler
|
||||
{ HEX: 4e800420 } [ BCTR ] test-assembler
|
||||
{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
|
||||
{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
|
||||
{ HEX: 7c6902a6 } [ 3 MFCTR ] test-assembler
|
||||
{ HEX: 7c6103a6 } [ 3 MTXER ] test-assembler
|
||||
{ HEX: 7c6803a6 } [ 3 MTLR ] test-assembler
|
||||
{ HEX: 7c6903a6 } [ 3 MTCTR ] test-assembler
|
||||
{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
|
||||
{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
|
||||
{ HEX: c0220003 } [ 1 2 3 LFS ] test-assembler
|
||||
{ HEX: c4220003 } [ 1 2 3 LFSU ] test-assembler
|
||||
{ HEX: c8220003 } [ 1 2 3 LFD ] test-assembler
|
||||
{ HEX: cc220003 } [ 1 2 3 LFDU ] test-assembler
|
||||
{ HEX: d0220003 } [ 1 2 3 STFS ] test-assembler
|
||||
{ HEX: d4220003 } [ 1 2 3 STFSU ] test-assembler
|
||||
{ HEX: d8220003 } [ 1 2 3 STFD ] test-assembler
|
||||
{ HEX: dc220003 } [ 1 2 3 STFDU ] test-assembler
|
||||
{ HEX: fc201048 } [ 1 2 FMR ] test-assembler
|
||||
{ HEX: fc20101e } [ 1 2 FCTIWZ ] test-assembler
|
||||
{ HEX: fc22182a } [ 1 2 3 FADD ] test-assembler
|
||||
{ HEX: fc22182b } [ 1 2 3 FADD. ] test-assembler
|
||||
{ HEX: fc221828 } [ 1 2 3 FSUB ] test-assembler
|
||||
{ HEX: fc2200f2 } [ 1 2 3 FMUL ] test-assembler
|
||||
{ HEX: fc221824 } [ 1 2 3 FDIV ] test-assembler
|
||||
{ HEX: fc20102c } [ 1 2 FSQRT ] test-assembler
|
||||
{ HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler
|
||||
{ HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler
|
||||
{ HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler
|
||||
|
||||
"cpu.ppc.assembler" words [ must-infer ] each
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2006 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: generator.fixup generic kernel memory namespaces
|
||||
words math math.bitfields math.order io.binary ;
|
||||
USING: generator.fixup kernel namespaces words io.binary math
|
||||
math.order cpu.ppc.assembler.backend ;
|
||||
IN: cpu.ppc.assembler
|
||||
|
||||
! See the Motorola or IBM documentation for details. The opcode
|
||||
|
|
@ -15,215 +15,195 @@ IN: cpu.ppc.assembler
|
|||
!
|
||||
! 14 15 10 STW
|
||||
|
||||
: insn ( operand opcode -- ) { 26 0 } bitfield , ;
|
||||
: a-form ( d a b c xo rc -- n ) { 0 1 6 11 16 21 } bitfield ;
|
||||
: b-form ( bo bi bd aa lk -- n ) { 0 1 2 16 21 } bitfield ;
|
||||
: s>u16 ( s -- u ) HEX: ffff bitand ;
|
||||
: d-form ( d a simm -- n ) s>u16 { 0 16 21 } bitfield ;
|
||||
: sd-form ( d a simm -- n ) s>u16 { 0 21 16 } bitfield ;
|
||||
: i-form ( li aa lk -- n ) { 0 1 0 } bitfield ;
|
||||
: x-form ( a s b rc xo -- n ) { 1 0 11 21 16 } bitfield ;
|
||||
: xfx-form ( d spr xo -- n ) { 1 11 21 } bitfield ;
|
||||
: xo-form ( d a b oe rc xo -- n ) { 1 0 10 11 16 21 } bitfield ;
|
||||
! D-form
|
||||
D: ADDI 14
|
||||
D: ADDIC 12
|
||||
D: ADDIC. 13
|
||||
D: ADDIS 15
|
||||
D: CMPI 11
|
||||
D: CMPLI 10
|
||||
D: LBZ 34
|
||||
D: LBZU 35
|
||||
D: LFD 50
|
||||
D: LFDU 51
|
||||
D: LFS 48
|
||||
D: LFSU 49
|
||||
D: LHA 42
|
||||
D: LHAU 43
|
||||
D: LHZ 40
|
||||
D: LHZU 41
|
||||
D: LWZ 32
|
||||
D: LWZU 33
|
||||
D: MULI 7
|
||||
D: MULLI 7
|
||||
D: STB 38
|
||||
D: STBU 39
|
||||
D: STFD 54
|
||||
D: STFDU 55
|
||||
D: STFS 52
|
||||
D: STFSU 53
|
||||
D: STH 44
|
||||
D: STHU 45
|
||||
D: STW 36
|
||||
D: STWU 37
|
||||
|
||||
: ADDI d-form 14 insn ; : LI 0 rot ADDI ; : SUBI neg ADDI ;
|
||||
: ADDIS d-form 15 insn ; : LIS 0 rot ADDIS ;
|
||||
! SD-form
|
||||
SD: ANDI 28
|
||||
SD: ANDIS 29
|
||||
SD: ORI 24
|
||||
SD: ORIS 25
|
||||
SD: XORI 26
|
||||
SD: XORIS 27
|
||||
|
||||
: ADDIC d-form 12 insn ; : SUBIC neg ADDIC ;
|
||||
! X-form
|
||||
X: AND 0 28 31
|
||||
X: AND. 1 28 31
|
||||
X: CMP 0 0 31
|
||||
X: CMPL 0 32 31
|
||||
X: EQV 0 284 31
|
||||
X: EQV. 1 284 31
|
||||
X: FCMPO 0 32 63
|
||||
X: FCMPU 0 0 63
|
||||
X: LBZUX 0 119 31
|
||||
X: LBZX 0 87 31
|
||||
X: LHAUX 0 375 31
|
||||
X: LHAX 0 343 31
|
||||
X: LHZUX 0 311 31
|
||||
X: LHZX 0 279 31
|
||||
X: LWZUX 0 55 31
|
||||
X: LWZX 0 23 31
|
||||
X: NAND 0 476 31
|
||||
X: NAND. 1 476 31
|
||||
X: NOR 0 124 31
|
||||
X: NOR. 1 124 31
|
||||
X: OR 0 444 31
|
||||
X: OR. 1 444 31
|
||||
X: ORC 0 412 31
|
||||
X: ORC. 1 412 31
|
||||
X: SLW 0 24 31
|
||||
X: SLW. 1 24 31
|
||||
X: SRAW 0 792 31
|
||||
X: SRAW. 1 792 31
|
||||
X: SRAWI 0 824 31
|
||||
X: SRW 0 536 31
|
||||
X: SRW. 1 536 31
|
||||
X: STBUX 0 247 31
|
||||
X: STBX 0 215 31
|
||||
X: STHUX 0 439 31
|
||||
X: STHX 0 407 31
|
||||
X: STWUX 0 183 31
|
||||
X: STWX 0 151 31
|
||||
X: XOR 0 316 31
|
||||
X: XOR. 1 316 31
|
||||
X1: EXTSB 0 954 31
|
||||
X1: EXTSB. 1 954 31
|
||||
: FMR ( a s -- ) 0 -rot 72 0 63 x-insn ;
|
||||
: FMR. ( a s -- ) 0 -rot 72 1 63 x-insn ;
|
||||
: FCTIWZ ( a s -- ) 0 -rot 0 15 63 x-insn ;
|
||||
: FCTIWZ. ( a s -- ) 0 -rot 1 15 63 x-insn ;
|
||||
|
||||
: ADDIC. d-form 13 insn ; : SUBIC. neg ADDIC. ;
|
||||
! XO-form
|
||||
XO: ADD 0 0 266 31
|
||||
XO: ADD. 0 1 266 31
|
||||
XO: ADDC 0 0 10 31
|
||||
XO: ADDC. 0 1 10 31
|
||||
XO: ADDCO 1 0 10 31
|
||||
XO: ADDCO. 1 1 10 31
|
||||
XO: ADDE 0 0 138 31
|
||||
XO: ADDE. 0 1 138 31
|
||||
XO: ADDEO 1 0 138 31
|
||||
XO: ADDEO. 1 1 138 31
|
||||
XO: ADDO 1 0 266 31
|
||||
XO: ADDO. 1 1 266 31
|
||||
XO: DIVW 0 0 491 31
|
||||
XO: DIVW. 0 1 491 31
|
||||
XO: DIVWO 1 0 491 31
|
||||
XO: DIVWO. 1 1 491 31
|
||||
XO: DIVWU 0 0 459 31
|
||||
XO: DIVWU. 0 1 459 31
|
||||
XO: DIVWUO 1 0 459 31
|
||||
XO: DIVWUO. 1 1 459 31
|
||||
XO: MULHW 0 0 75 31
|
||||
XO: MULHW. 0 1 75 31
|
||||
XO: MULHWU 0 0 11 31
|
||||
XO: MULHWU. 0 1 11 31
|
||||
XO: MULLW 0 0 235 31
|
||||
XO: MULLW. 0 1 235 31
|
||||
XO: MULLWO 1 0 235 31
|
||||
XO: MULLWO. 1 1 235 31
|
||||
XO: SUBF 0 0 40 31
|
||||
XO: SUBF. 0 1 40 31
|
||||
XO: SUBFC 0 0 8 31
|
||||
XO: SUBFC. 0 1 8 31
|
||||
XO: SUBFCO 1 0 8 31
|
||||
XO: SUBFCO. 1 1 8 31
|
||||
XO: SUBFE 0 0 136 31
|
||||
XO: SUBFE. 0 1 136 31
|
||||
XO: SUBFEO 1 0 136 31
|
||||
XO: SUBFEO. 1 1 136 31
|
||||
XO: SUBFO 1 0 40 31
|
||||
XO: SUBFO. 1 1 40 31
|
||||
XO1: NEG 0 0 104 31
|
||||
XO1: NEG. 0 1 104 31
|
||||
XO1: NEGO 1 0 104 31
|
||||
XO1: NEGO. 1 1 104 31
|
||||
|
||||
: MULI d-form 7 insn ;
|
||||
! A-form
|
||||
: RLWINM ( d a b c xo -- ) 0 21 a-insn ;
|
||||
: RLWINM. ( d a b c xo -- ) 1 21 a-insn ;
|
||||
: FADD ( d a b -- ) 0 21 0 63 a-insn ;
|
||||
: FADD. ( d a b -- ) 0 21 1 63 a-insn ;
|
||||
: FSUB ( d a b -- ) 0 20 0 63 a-insn ;
|
||||
: FSUB. ( d a b -- ) 0 20 1 63 a-insn ;
|
||||
: FMUL ( d a c -- ) 0 swap 25 0 63 a-insn ;
|
||||
: FMUL. ( d a c -- ) 0 swap 25 1 63 a-insn ;
|
||||
: FDIV ( d a b -- ) 0 18 0 63 a-insn ;
|
||||
: FDIV. ( d a b -- ) 0 18 1 63 a-insn ;
|
||||
: FSQRT ( d b -- ) 0 swap 0 22 0 63 a-insn ;
|
||||
: FSQRT. ( d b -- ) 0 swap 0 22 1 63 a-insn ;
|
||||
|
||||
: (ADD) 266 xo-form 31 insn ;
|
||||
: ADD 0 0 (ADD) ; : ADD. 0 1 (ADD) ;
|
||||
: ADDO 1 0 (ADD) ; : ADDO. 1 1 (ADD) ;
|
||||
! Branches
|
||||
: B ( dest -- ) 0 0 (B) ;
|
||||
: BL ( dest -- ) 0 1 (B) ;
|
||||
BC: LT 12 0
|
||||
BC: GE 4 0
|
||||
BC: GT 12 1
|
||||
BC: LE 4 1
|
||||
BC: EQ 12 2
|
||||
BC: NE 4 2
|
||||
BC: O 12 3
|
||||
BC: NO 4 3
|
||||
B: CLR 0 8 0 0 19
|
||||
B: CLRL 0 8 0 1 19
|
||||
B: CCTR 0 264 0 0 19
|
||||
: BLR ( -- ) 20 BCLR ;
|
||||
: BLRL ( -- ) 20 BCLRL ;
|
||||
: BCTR ( -- ) 20 BCCTR ;
|
||||
|
||||
: (ADDC) 10 xo-form 31 insn ;
|
||||
: ADDC 0 0 (ADDC) ; : ADDC. 0 1 (ADDC) ;
|
||||
: ADDCO 1 0 (ADDC) ; : ADDCO. 1 1 (ADDC) ;
|
||||
! Special registers
|
||||
MFSPR: XER 1
|
||||
MFSPR: LR 8
|
||||
MFSPR: CTR 9
|
||||
MTSPR: XER 1
|
||||
MTSPR: LR 8
|
||||
MTSPR: CTR 9
|
||||
|
||||
: (ADDE) 138 xo-form 31 insn ;
|
||||
: ADDE 0 0 (ADDE) ; : ADDE. 0 1 (ADDE) ;
|
||||
: ADDEO 1 0 (ADDE) ; : ADDEO. 1 1 (ADDE) ;
|
||||
|
||||
: ANDI sd-form 28 insn ;
|
||||
: ANDIS sd-form 29 insn ;
|
||||
|
||||
: (AND) 28 x-form 31 insn ;
|
||||
: AND 0 (AND) ; : AND. 0 (AND) ;
|
||||
|
||||
: (DIVW) 491 xo-form 31 insn ;
|
||||
: DIVW 0 0 (DIVW) ; : DIVW. 0 1 (DIVW) ;
|
||||
: DIVWO 1 0 (DIVW) ; : DIVWO. 1 1 (DIVW) ;
|
||||
|
||||
: (DIVWU) 459 xo-form 31 insn ;
|
||||
: DIVWU 0 0 (DIVWU) ; : DIVWU. 0 1 (DIVWU) ;
|
||||
: DIVWUO 1 0 (DIVWU) ; : DIVWUO. 1 1 (DIVWU) ;
|
||||
|
||||
: (EQV) 284 x-form 31 insn ;
|
||||
: EQV 0 (EQV) ; : EQV. 1 (EQV) ;
|
||||
|
||||
: (NAND) 476 x-form 31 insn ;
|
||||
: NAND 0 (NAND) ; : NAND. 1 (NAND) ;
|
||||
|
||||
: (NOR) 124 x-form 31 insn ;
|
||||
: NOR 0 (NOR) ; : NOR. 1 (NOR) ;
|
||||
|
||||
: NOT dup NOR ; : NOT. dup NOR. ;
|
||||
|
||||
: ORI sd-form 24 insn ; : ORIS sd-form 25 insn ;
|
||||
|
||||
: (OR) 444 x-form 31 insn ;
|
||||
: OR 0 (OR) ; : OR. 1 (OR) ;
|
||||
|
||||
: (ORC) 412 x-form 31 insn ;
|
||||
: ORC 0 (ORC) ; : ORC. 1 (ORC) ;
|
||||
|
||||
: MR dup OR ; : MR. dup OR. ;
|
||||
|
||||
: (MULHW) 75 xo-form 31 insn ;
|
||||
: MULHW 0 0 (MULHW) ; : MULHW. 0 1 (MULHW) ;
|
||||
|
||||
: MULLI d-form 7 insn ;
|
||||
|
||||
: (MULHWU) 11 xo-form 31 insn ;
|
||||
: MULHWU 0 0 (MULHWU) ; : MULHWU. 0 1 (MULHWU) ;
|
||||
|
||||
: (MULLW) 235 xo-form 31 insn ;
|
||||
: MULLW 0 0 (MULLW) ; : MULLW. 0 1 (MULLW) ;
|
||||
: MULLWO 1 0 (MULLW) ; : MULLWO. 1 1 (MULLW) ;
|
||||
|
||||
: (SLW) 24 x-form 31 insn ;
|
||||
: SLW 0 (SLW) ; : SLW. 1 (SLW) ;
|
||||
|
||||
: (SRAW) 792 x-form 31 insn ;
|
||||
: SRAW 0 (SRAW) ; : SRAW. 1 (SRAW) ;
|
||||
|
||||
: (SRW) 536 x-form 31 insn ;
|
||||
: SRW 0 (SRW) ; : SRW. 1 (SRW) ;
|
||||
|
||||
: SRAWI 0 824 x-form 31 insn ;
|
||||
|
||||
: (SUBF) 40 xo-form 31 insn ;
|
||||
: SUBF 0 0 (SUBF) ; : SUBF. 0 1 (SUBF) ;
|
||||
: SUBFO 1 0 (SUBF) ; : SUBFO. 1 1 (SUBF) ;
|
||||
|
||||
: (SUBFC) 8 xo-form 31 insn ;
|
||||
: SUBFC 0 0 (SUBFC) ; : SUBFC. 0 1 (SUBFC) ;
|
||||
: SUBFCO 1 0 (SUBFC) ; : SUBFCO. 1 1 (SUBFC) ;
|
||||
|
||||
: (SUBFE) 136 xo-form 31 insn ;
|
||||
: SUBFE 0 0 (SUBFE) ; : SUBFE. 0 1 (SUBFE) ;
|
||||
: SUBFEO 1 0 (SUBFE) ; : SUBFEO. 1 1 (SUBFE) ;
|
||||
|
||||
: (EXTSB) 0 swap 954 x-form 31 insn ;
|
||||
: EXTSB 0 (EXTSB) ;
|
||||
: EXTSB. 1 (EXTSB) ;
|
||||
|
||||
: XORI sd-form 26 insn ; : XORIS sd-form 27 insn ;
|
||||
|
||||
: (XOR) 316 x-form 31 insn ;
|
||||
: XOR 0 (XOR) ; : XOR. 1 (XOR) ;
|
||||
|
||||
: (NEG) 0 -rot 104 xo-form 31 insn ;
|
||||
: NEG 0 0 (NEG) ; : NEG. 0 1 (NEG) ;
|
||||
: NEGO 1 0 (NEG) ; : NEGO. 1 1 (NEG) ;
|
||||
|
||||
: CMPI d-form 11 insn ;
|
||||
: CMPLI d-form 10 insn ;
|
||||
|
||||
: CMP 0 0 x-form 31 insn ;
|
||||
: CMPL 0 32 x-form 31 insn ;
|
||||
|
||||
: (RLWINM) a-form 21 insn ;
|
||||
: RLWINM 0 (RLWINM) ; : RLWINM. 1 (RLWINM) ;
|
||||
|
||||
: (SLWI) 0 31 pick - ;
|
||||
: SLWI (SLWI) RLWINM ; : SLWI. (SLWI) RLWINM. ;
|
||||
: (SRWI) 32 over - swap 31 ;
|
||||
: SRWI (SRWI) RLWINM ; : SRWI. (SRWI) RLWINM. ;
|
||||
|
||||
: LBZ d-form 34 insn ; : LBZU d-form 35 insn ;
|
||||
: LHA d-form 42 insn ; : LHAU d-form 43 insn ;
|
||||
: LHZ d-form 40 insn ; : LHZU d-form 41 insn ;
|
||||
: LWZ d-form 32 insn ; : LWZU d-form 33 insn ;
|
||||
|
||||
: LBZX 0 87 x-form 31 insn ; : LBZUX 0 119 x-form 31 insn ;
|
||||
: LHAX 0 343 x-form 31 insn ; : LHAUX 0 375 x-form 31 insn ;
|
||||
: LHZX 0 279 x-form 31 insn ; : LHZUX 0 311 x-form 31 insn ;
|
||||
: LWZX 0 23 x-form 31 insn ; : LWZUX 0 55 x-form 31 insn ;
|
||||
|
||||
: STB d-form 38 insn ; : STBU d-form 39 insn ;
|
||||
: STH d-form 44 insn ; : STHU d-form 45 insn ;
|
||||
: STW d-form 36 insn ; : STWU d-form 37 insn ;
|
||||
|
||||
: STBX 0 215 x-form 31 insn ; : STBUX 247 x-form 31 insn ;
|
||||
: STHX 0 407 x-form 31 insn ; : STHUX 439 x-form 31 insn ;
|
||||
: STWX 0 151 x-form 31 insn ; : STWUX 183 x-form 31 insn ;
|
||||
|
||||
GENERIC# (B) 2 ( dest aa lk -- )
|
||||
M: integer (B) i-form 18 insn ;
|
||||
M: word (B) 0 -rot (B) rc-relative-ppc-3 rel-word ;
|
||||
M: label (B) 0 -rot (B) rc-relative-ppc-3 label-fixup ;
|
||||
|
||||
: B 0 0 (B) ; : BL 0 1 (B) ;
|
||||
|
||||
GENERIC: BC ( a b c -- )
|
||||
M: integer BC 0 0 b-form 16 insn ;
|
||||
M: word BC >r 0 BC r> rc-relative-ppc-2 rel-word ;
|
||||
M: label BC >r 0 BC r> rc-relative-ppc-2 label-fixup ;
|
||||
|
||||
: BLT 12 0 rot BC ; : BGE 4 0 rot BC ;
|
||||
: BGT 12 1 rot BC ; : BLE 4 1 rot BC ;
|
||||
: BEQ 12 2 rot BC ; : BNE 4 2 rot BC ;
|
||||
: BO 12 3 rot BC ; : BNO 4 3 rot BC ;
|
||||
|
||||
: BCLR 0 8 0 0 b-form 19 insn ;
|
||||
: BLR 20 BCLR ;
|
||||
: BCLRL 0 8 0 1 b-form 19 insn ;
|
||||
: BLRL 20 BCLRL ;
|
||||
: BCCTR 0 264 0 0 b-form 19 insn ;
|
||||
: BCTR 20 BCCTR ;
|
||||
|
||||
: MFSPR 5 shift 339 xfx-form 31 insn ;
|
||||
: MFXER 1 MFSPR ; : MFLR 8 MFSPR ; : MFCTR 9 MFSPR ;
|
||||
|
||||
: MTSPR 5 shift 467 xfx-form 31 insn ;
|
||||
: MTXER 1 MTSPR ; : MTLR 8 MTSPR ; : MTCTR 9 MTSPR ;
|
||||
|
||||
: LOAD32 >r w>h/h r> tuck LIS dup rot ORI ;
|
||||
|
||||
: LOAD ( n r -- )
|
||||
#! PowerPC cannot load a 32 bit literal in one instruction.
|
||||
>r dup -32768 32767 between? [ r> LI ] [ r> LOAD32 ] if ;
|
||||
|
||||
! Floating point
|
||||
: LFS d-form 48 insn ; : LFSU d-form 49 insn ;
|
||||
: LFD d-form 50 insn ; : LFDU d-form 51 insn ;
|
||||
: STFS d-form 52 insn ; : STFSU d-form 53 insn ;
|
||||
: STFD d-form 54 insn ; : STFDU d-form 55 insn ;
|
||||
|
||||
: (FMR) >r 0 -rot 72 r> x-form 63 insn ;
|
||||
: FMR 0 (FMR) ; : FMR. 1 (FMR) ;
|
||||
|
||||
: (FCTIWZ) >r 0 -rot r> 15 x-form 63 insn ;
|
||||
: FCTIWZ 0 (FCTIWZ) ; : FCTIWZ. 1 (FCTIWZ) ;
|
||||
|
||||
: (FADD) >r 0 21 r> a-form 63 insn ;
|
||||
: FADD 0 (FADD) ; : FADD. 1 (FADD) ;
|
||||
|
||||
: (FSUB) >r 0 20 r> a-form 63 insn ;
|
||||
: FSUB 0 (FSUB) ; : FSUB. 1 (FSUB) ;
|
||||
|
||||
: (FMUL) >r 0 swap 25 r> a-form 63 insn ;
|
||||
: FMUL 0 (FMUL) ; : FMUL. 1 (FMUL) ;
|
||||
|
||||
: (FDIV) >r 0 18 r> a-form 63 insn ;
|
||||
: FDIV 0 (FDIV) ; : FDIV. 1 (FDIV) ;
|
||||
|
||||
: (FSQRT) >r 0 swap 0 22 r> a-form 63 insn ;
|
||||
: FSQRT 0 (FSQRT) ; : FSQRT. 1 (FSQRT) ;
|
||||
|
||||
: FCMPU 0 0 x-form 63 insn ;
|
||||
: FCMPO 0 32 x-form 63 insn ;
|
||||
! Pseudo-instructions
|
||||
: LI 0 rot ADDI ; inline
|
||||
: SUBI neg ADDI ; inline
|
||||
: LIS 0 rot ADDIS ; inline
|
||||
: SUBIC neg ADDIC ; inline
|
||||
: SUBIC. neg ADDIC. ; inline
|
||||
: NOT dup NOR ; inline
|
||||
: NOT. dup NOR. ; inline
|
||||
: MR dup OR ; inline
|
||||
: MR. dup OR. ; inline
|
||||
: (SLWI) 0 31 pick - ; inline
|
||||
: SLWI ( d a b -- ) (SLWI) RLWINM ;
|
||||
: SLWI. ( d a b -- ) (SLWI) RLWINM. ;
|
||||
: (SRWI) 32 over - swap 31 ; inline
|
||||
: SRWI ( d a b -- ) (SRWI) RLWINM ;
|
||||
: SRWI. ( d a b -- ) (SRWI) RLWINM. ;
|
||||
: LOAD32 ( n r -- ) >r w>h/h r> tuck LIS dup rot ORI ;
|
||||
: immediate? ( n -- ? ) HEX: -8000 HEX: 7fff between? ;
|
||||
: LOAD ( n r -- ) over immediate? [ LI ] [ LOAD32 ] if ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,93 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: generator.fixup kernel namespaces sequences
|
||||
words math math.bitfields io.binary parser lexer ;
|
||||
IN: cpu.ppc.assembler.backend
|
||||
|
||||
: insn ( operand opcode -- ) { 26 0 } bitfield , ;
|
||||
|
||||
: a-insn ( d a b c xo rc opcode -- )
|
||||
[ { 0 1 6 11 16 21 } bitfield ] dip insn ;
|
||||
|
||||
: b-insn ( bo bi bd aa lk opcode -- )
|
||||
[ { 0 1 2 16 21 } bitfield ] dip insn ;
|
||||
|
||||
: s>u16 ( s -- u ) HEX: ffff bitand ;
|
||||
|
||||
: d-insn ( d a simm opcode -- )
|
||||
[ s>u16 { 0 16 21 } bitfield ] dip insn ;
|
||||
|
||||
: define-d-insn ( word opcode -- )
|
||||
[ d-insn ] curry (( d a simm -- )) define-declared ;
|
||||
|
||||
: D: CREATE scan-word define-d-insn ; parsing
|
||||
|
||||
: sd-insn ( d a simm opcode -- )
|
||||
[ s>u16 { 0 21 16 } bitfield ] dip insn ;
|
||||
|
||||
: define-sd-insn ( word opcode -- )
|
||||
[ sd-insn ] curry (( d a simm -- )) define-declared ;
|
||||
|
||||
: SD: CREATE scan-word define-sd-insn ; parsing
|
||||
|
||||
: i-insn ( li aa lk opcode -- )
|
||||
[ { 0 1 0 } bitfield ] dip insn ;
|
||||
|
||||
: x-insn ( a s b rc xo opcode -- )
|
||||
[ { 1 0 11 21 16 } bitfield ] dip insn ;
|
||||
|
||||
: (X) ( -- word quot )
|
||||
CREATE scan-word scan-word scan-word [ x-insn ] 3curry ;
|
||||
|
||||
: X: (X) (( a s b -- )) define-declared ; parsing
|
||||
|
||||
: (1) ( quot -- quot' ) [ 0 ] prepose ;
|
||||
|
||||
: X1: (X) (1) (( a s -- )) define-declared ; parsing
|
||||
|
||||
: xfx-insn ( d spr xo opcode -- )
|
||||
[ { 1 11 21 } bitfield ] dip insn ;
|
||||
|
||||
: CREATE-MF ( -- word ) scan "MF" prepend create-in ;
|
||||
|
||||
: MFSPR:
|
||||
CREATE-MF scan-word 5 shift [ 339 31 xfx-insn ] curry
|
||||
(( d -- )) define-declared ; parsing
|
||||
|
||||
: CREATE-MT ( -- word ) scan "MT" prepend create-in ;
|
||||
|
||||
: MTSPR:
|
||||
CREATE-MT scan-word 5 shift [ 467 31 xfx-insn ] curry
|
||||
(( d -- )) define-declared ; parsing
|
||||
|
||||
: xo-insn ( d a b oe rc xo opcode -- )
|
||||
[ { 1 0 10 11 16 21 } bitfield ] dip insn ;
|
||||
|
||||
: (XO) ( -- word quot )
|
||||
CREATE scan-word scan-word scan-word scan-word
|
||||
[ xo-insn ] 2curry 2curry ;
|
||||
|
||||
: XO: (XO) (( a s b -- )) define-declared ; parsing
|
||||
|
||||
: XO1: (XO) (1) (( a s -- )) define-declared ; parsing
|
||||
|
||||
GENERIC# (B) 2 ( dest aa lk -- )
|
||||
M: integer (B) 18 i-insn ;
|
||||
M: word (B) 0 -rot (B) rc-relative-ppc-3 rel-word ;
|
||||
M: label (B) 0 -rot (B) rc-relative-ppc-3 label-fixup ;
|
||||
|
||||
GENERIC: BC ( a b c -- )
|
||||
M: integer BC 0 0 16 b-insn ;
|
||||
M: word BC >r 0 BC r> rc-relative-ppc-2 rel-word ;
|
||||
M: label BC >r 0 BC r> rc-relative-ppc-2 label-fixup ;
|
||||
|
||||
: CREATE-B ( -- word ) scan "B" prepend create-in ;
|
||||
|
||||
: BC:
|
||||
CREATE-B scan-word scan-word
|
||||
[ rot BC ] 2curry (( c -- )) define-declared ; parsing
|
||||
|
||||
: B:
|
||||
CREATE-B scan-word scan-word scan-word scan-word scan-word
|
||||
[ b-insn ] curry curry curry curry curry
|
||||
(( bo -- )) define-declared ; parsing
|
||||
|
|
@ -5,8 +5,6 @@ USING: kernel math sequences arrays assocs sequences.private
|
|||
growable accessors math.order ;
|
||||
IN: heaps
|
||||
|
||||
MIXIN: priority-queue
|
||||
|
||||
GENERIC: heap-push* ( value key heap -- entry )
|
||||
GENERIC: heap-peek ( heap -- value key )
|
||||
GENERIC: heap-pop* ( heap -- )
|
||||
|
|
@ -36,13 +34,10 @@ TUPLE: max-heap < heap ;
|
|||
|
||||
: <max-heap> ( -- max-heap ) max-heap <heap> ;
|
||||
|
||||
INSTANCE: min-heap priority-queue
|
||||
INSTANCE: max-heap priority-queue
|
||||
|
||||
M: priority-queue heap-empty? ( heap -- ? )
|
||||
M: heap heap-empty? ( heap -- ? )
|
||||
data>> empty? ;
|
||||
|
||||
M: priority-queue heap-size ( heap -- n )
|
||||
M: heap heap-size ( heap -- n )
|
||||
data>> length ;
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -152,7 +147,7 @@ DEFER: down-heap
|
|||
|
||||
PRIVATE>
|
||||
|
||||
M: priority-queue heap-push* ( value key heap -- entry )
|
||||
M: heap heap-push* ( value key heap -- entry )
|
||||
[ <entry> dup ] keep [ data-push ] keep up-heap ;
|
||||
|
||||
: heap-push ( value key heap -- ) heap-push* drop ;
|
||||
|
|
@ -163,7 +158,7 @@ M: priority-queue heap-push* ( value key heap -- entry )
|
|||
: >entry< ( entry -- key value )
|
||||
[ value>> ] [ key>> ] bi ;
|
||||
|
||||
M: priority-queue heap-peek ( heap -- value key )
|
||||
M: heap heap-peek ( heap -- value key )
|
||||
data-first >entry< ;
|
||||
|
||||
: entry>index ( entry heap -- n )
|
||||
|
|
@ -172,7 +167,7 @@ M: priority-queue heap-peek ( heap -- value key )
|
|||
] unless
|
||||
entry-index ;
|
||||
|
||||
M: priority-queue heap-delete ( entry heap -- )
|
||||
M: heap heap-delete ( entry heap -- )
|
||||
[ entry>index ] keep
|
||||
2dup heap-size 1- = [
|
||||
nip data-pop*
|
||||
|
|
@ -182,10 +177,10 @@ M: priority-queue heap-delete ( entry heap -- )
|
|||
down-heap
|
||||
] if ;
|
||||
|
||||
M: priority-queue heap-pop* ( heap -- )
|
||||
M: heap heap-pop* ( heap -- )
|
||||
dup data-first swap heap-delete ;
|
||||
|
||||
M: priority-queue heap-pop ( heap -- value key )
|
||||
M: heap heap-pop ( heap -- value key )
|
||||
dup data-first [ swap heap-delete ] keep >entry< ;
|
||||
|
||||
: heap-pop-all ( heap -- alist )
|
||||
|
|
|
|||
|
|
@ -94,4 +94,4 @@ MACRO: bake ( seq -- quot ) [bake] ;
|
|||
|
||||
: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing
|
||||
: `V{ \ } [ >vector ] parse-literal \ bake parsed ; parsing
|
||||
: `[ \ } [ >quotation ] parse-literal \ bake parsed ; parsing
|
||||
: `[ \ ] [ >quotation ] parse-literal \ bake parsed ; parsing
|
||||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.functions math.parser models
|
||||
models.filter models.range models.compose sequences ui
|
||||
ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs
|
||||
ui.gadgets.sliders ui.render math.geometry.rect ;
|
||||
models.filter models.range models.compose sequences ui
|
||||
ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs
|
||||
ui.gadgets.sliders ui.render math.geometry.rect accessors ;
|
||||
IN: color-picker
|
||||
|
||||
! Simple example demonstrating the use of models.
|
||||
|
|
|
|||
|
|
@ -3,17 +3,17 @@ IN: ctags.tests
|
|||
|
||||
[ t ] [
|
||||
91
|
||||
{ { if { "resource:extra/unix/unix.factor" 91 } } } ctag-lineno =
|
||||
{ if { "resource:extra/unix/unix.factor" 91 } } ctag-lineno =
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
"resource:extra/unix/unix.factor"
|
||||
{ { if { "resource:extra/unix/unix.factor" 91 } } } ctag-path =
|
||||
{ if { "resource:extra/unix/unix.factor" 91 } } ctag-path =
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
if
|
||||
{ { if { "resource:extra/unix/unix.factor" 91 } } } ctag-word =
|
||||
\ if
|
||||
{ if { "resource:extra/unix/unix.factor" 91 } } ctag-word =
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
|
|
|
|||
|
|
@ -79,3 +79,15 @@ CONSULT: beta hey value>> 1- ;
|
|||
[ -1 ] [ 1 <hey> four ] unit-test
|
||||
[ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test
|
||||
[ f ] [ hey \ one method ] unit-test
|
||||
|
||||
TUPLE: slot-protocol-test-1 a b ;
|
||||
TUPLE: slot-protocol-test-2 < slot-protocol-test-1 { c integer } ;
|
||||
|
||||
TUPLE: slot-protocol-test-3 d ;
|
||||
|
||||
CONSULT: slot-protocol-test-2 slot-protocol-test-3 d>> ;
|
||||
|
||||
[ "a" "b" 5 ] [
|
||||
T{ slot-protocol-test-3 f T{ slot-protocol-test-2 f "a" "b" 5 } }
|
||||
[ a>> ] [ b>> ] [ c>> ] tri
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007 Daniel Ehrenberg
|
||||
! Copyright (C) 2007, 2008 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors parser generic kernel classes classes.tuple
|
||||
words slots assocs sequences arrays vectors definitions
|
||||
|
|
@ -14,9 +14,11 @@ IN: delegate
|
|||
GENERIC: group-words ( group -- words )
|
||||
|
||||
M: tuple-class group-words
|
||||
"slot-names" word-prop [
|
||||
[ reader-word ] [ writer-word ] bi
|
||||
2array [ 0 2array ] map
|
||||
all-slots [
|
||||
name>>
|
||||
[ reader-word 0 2array ]
|
||||
[ writer-word 0 2array ] bi
|
||||
2array
|
||||
] map concat ;
|
||||
|
||||
! Consultation
|
||||
|
|
|
|||
|
|
@ -1,9 +1,13 @@
|
|||
USING: help.syntax help.markup splitting kernel ;
|
||||
USING: help.syntax help.markup splitting kernel sequences ;
|
||||
IN: tuple-arrays
|
||||
|
||||
HELP: tuple-array
|
||||
{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link <tuple-array> } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back.." } ;
|
||||
{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link <tuple-array> } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. To convert a sequence to a tuple array, use the word " { $link >tuple-array } "." } ;
|
||||
|
||||
HELP: <tuple-array>
|
||||
{ $values { "example" tuple } { "length" "a non-negative integer" } { "tuple-array" tuple-array } }
|
||||
{ $description "Creates an instance of the " { $link <tuple-array> } " class with the given length and containing the given tuple class. The tuple class is specified in the form of an example tuple. If the example tuple has a delegate, the tuple array will store a delegate for each element. Otherwise, the delegate will be assumed to be " { $link f } "." } ;
|
||||
{ $values { "class" "a tuple class" } { "length" "a non-negative integer" } { "tuple-array" tuple-array } }
|
||||
{ $description "Creates an instance of the " { $link <tuple-array> } " class with the given length and containing the given tuple class." } ;
|
||||
|
||||
HELP: >tuple-array
|
||||
{ $values { "seq" sequence } { "tuple-array" tuple-array } }
|
||||
{ $description "Converts a sequence into a homogeneous unboxed tuple array of the type indicated by the first element." } ;
|
||||
|
|
|
|||
|
|
@ -1,16 +1,20 @@
|
|||
USING: tuple-arrays sequences tools.test namespaces kernel math ;
|
||||
USING: tuple-arrays sequences tools.test namespaces kernel math accessors ;
|
||||
IN: tuple-arrays.tests
|
||||
|
||||
SYMBOL: mat
|
||||
TUPLE: foo bar ;
|
||||
C: <foo> foo
|
||||
[ 2 ] [ 2 T{ foo } <tuple-array> dup mat set length ] unit-test
|
||||
[ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
|
||||
[ T{ foo } ] [ mat get 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{ foo f 3 } t ]
|
||||
[ mat get [ foo-bar 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test
|
||||
|
||||
[ 2 ] [ 2 T{ foo t } <tuple-array> dup mat set length ] unit-test
|
||||
[ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
|
||||
[ T{ foo } ] [ mat get first ] unit-test
|
||||
[ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test
|
||||
|
||||
TUPLE: baz { bing integer } bong ;
|
||||
[ 0 ] [ 1 baz <tuple-array> first bing>> ] unit-test
|
||||
[ f ] [ 1 baz <tuple-array> first bong>> ] unit-test
|
||||
|
|
|
|||
|
|
@ -4,27 +4,26 @@ USING: splitting grouping classes.tuple classes math kernel
|
|||
sequences arrays accessors ;
|
||||
IN: tuple-arrays
|
||||
|
||||
TUPLE: tuple-array seq class ;
|
||||
TUPLE: tuple-array { seq read-only } { class read-only } ;
|
||||
|
||||
: <tuple-array> ( length example -- tuple-array )
|
||||
[ tuple>array length 1- [ * { } new-sequence ] keep <sliced-groups> ]
|
||||
[ class ] bi tuple-array boa ;
|
||||
: <tuple-array> ( length class -- tuple-array )
|
||||
[
|
||||
new tuple>array 1 tail
|
||||
[ <repetition> concat ] [ length ] bi <sliced-groups>
|
||||
] [ ] bi tuple-array boa ;
|
||||
|
||||
M: tuple-array nth
|
||||
[ seq>> nth ] [ class>> ] bi prefix >tuple ;
|
||||
|
||||
: deconstruct ( tuple -- seq )
|
||||
tuple>array 1 tail ;
|
||||
|
||||
M: tuple-array set-nth ( elt n seq -- )
|
||||
>r >r deconstruct r> r> seq>> set-nth ;
|
||||
>r >r tuple>array 1 tail r> r> seq>> set-nth ;
|
||||
|
||||
M: tuple-array new-sequence
|
||||
class>> new <tuple-array> ;
|
||||
class>> <tuple-array> ;
|
||||
|
||||
: >tuple-array ( seq -- tuple-array/seq )
|
||||
: >tuple-array ( seq -- tuple-array )
|
||||
dup empty? [
|
||||
0 over first <tuple-array> clone-like
|
||||
0 over first class <tuple-array> clone-like
|
||||
] unless ;
|
||||
|
||||
M: tuple-array like
|
||||
|
|
|
|||
|
|
@ -230,5 +230,3 @@ M: radio-control model-changed
|
|||
swap
|
||||
"toolbar" over class command-map commands>> swap
|
||||
[ -rot <command-button> add-gadget ] curry assoc-each ;
|
||||
|
||||
: toolbar, ( -- ) g <toolbar> f track, ;
|
||||
|
|
|
|||
|
|
@ -24,6 +24,8 @@ grid
|
|||
>r >r 2dup swap add-gadget drop r> r>
|
||||
3dup grid-child unparent rot grid>> nth set-nth ;
|
||||
|
||||
: grid-add* ( grid child i j -- grid ) >r >r dupd swap r> r> grid-add ;
|
||||
|
||||
: grid-remove ( grid i j -- )
|
||||
>r >r >r <gadget> r> r> r> grid-add ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,10 +5,8 @@ kernel namespaces tools.test math.parser sequences math.geometry.rect ;
|
|||
[ t ] [
|
||||
{ 0 0 } { 100 100 } <rect> clip set
|
||||
|
||||
[
|
||||
100 [ number>string <label> gadget, ] each
|
||||
] make-pile
|
||||
|
||||
<pile>
|
||||
100 [ number>string <label> add-gadget ] each
|
||||
dup layout
|
||||
|
||||
visible-children [ label? ] all?
|
||||
|
|
|
|||
|
|
@ -29,30 +29,22 @@ scroller H{
|
|||
{ T{ mouse-scroll } [ do-mouse-scroll ] }
|
||||
} set-gestures
|
||||
|
||||
: viewport, ( child -- )
|
||||
g model>> <viewport>
|
||||
g-> set-scroller-viewport @center frame, ;
|
||||
|
||||
: <scroller-model> ( -- model )
|
||||
0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
|
||||
|
||||
: x-model ( -- model ) g model>> dependencies>> first ;
|
||||
|
||||
: y-model ( -- model ) g model>> dependencies>> second ;
|
||||
|
||||
: new-scroller ( gadget class -- scroller )
|
||||
new-frame
|
||||
t >>root?
|
||||
<scroller-model> >>model
|
||||
faint-boundary
|
||||
[
|
||||
x-model <x-slider> g-> set-scroller-x @bottom frame,
|
||||
y-model <y-slider> g-> set-scroller-y @right frame,
|
||||
viewport,
|
||||
] make-gadget ;
|
||||
new-frame
|
||||
t >>root?
|
||||
<scroller-model> >>model
|
||||
faint-boundary
|
||||
|
||||
: <scroller> ( gadget -- scroller )
|
||||
scroller new-scroller ;
|
||||
dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add*
|
||||
dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add*
|
||||
|
||||
swap over model>> <viewport> >>viewport
|
||||
dup viewport>> @center grid-add* ;
|
||||
|
||||
: <scroller> ( gadget -- scroller ) scroller new-scroller ;
|
||||
|
||||
: scroll ( value scroller -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -138,10 +138,11 @@ M: elevator layout*
|
|||
[ swap find-slider slide-by-line ] curry <repeat-button>
|
||||
[ set-gadget-orientation ] keep ;
|
||||
|
||||
: elevator, ( orientation -- )
|
||||
dup <elevator> g-> set-slider-elevator
|
||||
swap <thumb> g-> set-slider-thumb add-gadget
|
||||
@center frame, ;
|
||||
: elevator, ( gadget orientation -- gadget )
|
||||
tuck <elevator> >>elevator
|
||||
swap <thumb> >>thumb
|
||||
dup elevator>> over thumb>> add-gadget
|
||||
@center grid-add* ;
|
||||
|
||||
: <left-button> ( -- button )
|
||||
{ 0 1 } arrow-left -1 <slide-button> ;
|
||||
|
|
@ -149,26 +150,12 @@ M: elevator layout*
|
|||
: <right-button> ( -- button )
|
||||
{ 0 1 } arrow-right 1 <slide-button> ;
|
||||
|
||||
: build-x-slider ( slider -- slider )
|
||||
[
|
||||
<left-button> @left frame,
|
||||
{ 0 1 } elevator,
|
||||
<right-button> @right frame,
|
||||
] make-gadget ; inline
|
||||
|
||||
: <up-button> ( -- button )
|
||||
{ 1 0 } arrow-up -1 <slide-button> ;
|
||||
|
||||
: <down-button> ( -- button )
|
||||
{ 1 0 } arrow-down 1 <slide-button> ;
|
||||
|
||||
: build-y-slider ( slider -- slider )
|
||||
[
|
||||
<up-button> @top frame,
|
||||
{ 1 0 } elevator,
|
||||
<down-button> @bottom frame,
|
||||
] make-gadget ; inline
|
||||
|
||||
: <slider> ( range orientation -- slider )
|
||||
slider new-frame
|
||||
swap >>orientation
|
||||
|
|
@ -176,10 +163,16 @@ M: elevator layout*
|
|||
32 >>line ;
|
||||
|
||||
: <x-slider> ( range -- slider )
|
||||
{ 1 0 } <slider> build-x-slider ;
|
||||
{ 1 0 } <slider>
|
||||
<left-button> @left grid-add*
|
||||
{ 0 1 } elevator,
|
||||
<right-button> @right grid-add* ;
|
||||
|
||||
: <y-slider> ( range -- slider )
|
||||
{ 0 1 } <slider> build-y-slider ;
|
||||
{ 0 1 } <slider>
|
||||
<up-button> @top grid-add*
|
||||
{ 1 0 } elevator,
|
||||
<down-button> @bottom grid-add* ;
|
||||
|
||||
M: slider pref-dim*
|
||||
dup call-next-method
|
||||
|
|
|
|||
|
|
@ -69,15 +69,13 @@ M: value-ref finish-editing
|
|||
} define-command
|
||||
|
||||
: <slot-editor> ( ref -- gadget )
|
||||
{ 0 1 } slot-editor new-track
|
||||
swap >>ref
|
||||
[
|
||||
toolbar,
|
||||
<source-editor> g-> set-slot-editor-text
|
||||
<scroller> 1 track,
|
||||
] make-gadget
|
||||
{ 0 1 } slot-editor new-track
|
||||
swap >>ref
|
||||
dup <toolbar> f track-add*
|
||||
<source-editor> >>text
|
||||
dup text>> <scroller> 1 track-add*
|
||||
dup revert ;
|
||||
|
||||
|
||||
M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
|
||||
|
||||
M: slot-editor focusable-child* text>> ;
|
||||
|
|
|
|||
|
|
@ -48,9 +48,13 @@ DEFER: (del-page)
|
|||
[ names>> index ] 2keep (del-page) ;
|
||||
|
||||
: <tabbed> ( assoc -- tabbed )
|
||||
tabbed new-frame
|
||||
[ g 0 <model> >>model
|
||||
<pile> 1 >>fill [ >>toggler ] keep swap @left grid-add
|
||||
[ keys >vector g swap >>names ]
|
||||
[ values g model>> <book> [ >>content ] keep swap @center grid-add ] bi
|
||||
g redo-toggler g ] with-gadget ;
|
||||
tabbed new-frame
|
||||
0 <model> >>model
|
||||
<pile> 1 >>fill >>toggler
|
||||
dup toggler>> @left grid-add*
|
||||
swap
|
||||
[ keys >vector >>names ]
|
||||
[ values over model>> <book> >>content dup content>> @center grid-add* ]
|
||||
bi
|
||||
dup redo-toggler ;
|
||||
|
||||
|
|
|
|||
|
|
@ -16,12 +16,11 @@ TUPLE: inspector-gadget < track object pane ;
|
|||
] with-pane ;
|
||||
|
||||
: <inspector-gadget> ( -- gadget )
|
||||
{ 0 1 } inspector-gadget new-track
|
||||
[
|
||||
toolbar,
|
||||
<pane> g-> set-inspector-gadget-pane <scroller> 1 track,
|
||||
] make-gadget ;
|
||||
|
||||
{ 0 1 } inspector-gadget new-track
|
||||
dup <toolbar> f track-add*
|
||||
<pane> >>pane
|
||||
dup pane>> <scroller> 1 track-add* ;
|
||||
|
||||
: inspect-object ( obj mirror keys inspector -- )
|
||||
2nip swap >>object refresh ;
|
||||
|
||||
|
|
|
|||
|
|
@ -12,9 +12,9 @@ IN: ui.tools.listener
|
|||
|
||||
TUPLE: listener-gadget < track input output stack ;
|
||||
|
||||
: listener-output, ( -- )
|
||||
<scrolling-pane> g-> set-listener-gadget-output
|
||||
<scroller> "Output" <labelled-gadget> 1 track, ;
|
||||
: listener-output, ( listener -- listener )
|
||||
<scrolling-pane> >>output
|
||||
dup output>> <scroller> "Output" <labelled-gadget> 1 track-add* ;
|
||||
|
||||
: listener-streams ( listener -- input output )
|
||||
[ input>> ] [ output>> <pane-stream> ] bi ;
|
||||
|
|
@ -22,10 +22,12 @@ TUPLE: listener-gadget < track input output stack ;
|
|||
: <listener-input> ( listener -- gadget )
|
||||
output>> <pane-stream> <interactor> ;
|
||||
|
||||
: listener-input, ( -- )
|
||||
g <listener-input> g-> set-listener-gadget-input
|
||||
: listener-input, ( listener -- listener )
|
||||
dup <listener-input> >>input
|
||||
dup input>>
|
||||
{ 0 100 } <limited-scroller>
|
||||
"Input" <labelled-gadget> f track, ;
|
||||
"Input" <labelled-gadget>
|
||||
f track-add* ;
|
||||
|
||||
: welcome. ( -- )
|
||||
"If this is your first time with Factor, please read the " print
|
||||
|
|
@ -120,14 +122,13 @@ M: engine-word word-completion-string
|
|||
|
||||
TUPLE: stack-display < track ;
|
||||
|
||||
: <stack-display> ( -- gadget )
|
||||
g workspace-listener
|
||||
{ 0 1 } stack-display new-track
|
||||
[
|
||||
dup <toolbar> f track,
|
||||
stack>> [ [ stack. ] curry try ]
|
||||
t "Data stack" <labelled-pane> 1 track,
|
||||
] make-gadget ;
|
||||
: <stack-display> ( workspace -- gadget )
|
||||
listener>>
|
||||
{ 0 1 } stack-display new-track
|
||||
over <toolbar> f track-add*
|
||||
swap
|
||||
stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
|
||||
1 track-add* ;
|
||||
|
||||
M: stack-display tool-scroller
|
||||
find-workspace workspace-listener tool-scroller ;
|
||||
|
|
@ -170,10 +171,11 @@ M: stack-display tool-scroller
|
|||
f <model> swap set-listener-gadget-stack ;
|
||||
|
||||
: <listener-gadget> ( -- gadget )
|
||||
{ 0 1 } listener-gadget new-track
|
||||
{ 0 1 } listener-gadget new-track
|
||||
dup init-listener
|
||||
[ listener-output, listener-input, ] make-gadget ;
|
||||
|
||||
listener-output,
|
||||
listener-input, ;
|
||||
|
||||
: listener-help ( -- ) "ui-listener" help-window ;
|
||||
|
||||
\ listener-help H{ { +nullary+ t } } define-command
|
||||
|
|
|
|||
|
|
@ -2,19 +2,17 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: ui.tools.workspace kernel quotations tools.profiler
|
||||
ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
|
||||
ui.gadgets.tracks ui.gestures ui.gadgets.buttons ;
|
||||
ui.gadgets.tracks ui.gestures ui.gadgets.buttons accessors ;
|
||||
IN: ui.tools.profiler
|
||||
|
||||
TUPLE: profiler-gadget < track pane ;
|
||||
|
||||
: <profiler-gadget> ( -- gadget )
|
||||
{ 0 1 } profiler-gadget new-track
|
||||
[
|
||||
toolbar,
|
||||
<pane> g-> set-profiler-gadget-pane
|
||||
<scroller> 1 track,
|
||||
] make-gadget ;
|
||||
|
||||
{ 0 1 } profiler-gadget new-track
|
||||
dup <toolbar> f track-add*
|
||||
<pane> >>pane
|
||||
dup pane>> <scroller> 1 track-add* ;
|
||||
|
||||
: with-profiler-pane ( gadget quot -- )
|
||||
>r profiler-gadget-pane r> with-pane ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,12 +5,10 @@ ui.gadgets.labelled ui.gadgets.presentations
|
|||
ui.gadgets.scrollers vocabs tools.test.ui ui ;
|
||||
IN: ui.tools.tests
|
||||
|
||||
[ f ]
|
||||
[
|
||||
[ f ] [
|
||||
0 <model> <gadget> [ set-gadget-model ] keep gadget set
|
||||
<workspace-tabs> gadget-children empty?
|
||||
] unit-test
|
||||
] with-scope
|
||||
<gadget> 0 <model> >>model <workspace-tabs> children>> empty?
|
||||
] unit-test
|
||||
|
||||
[ ] [ <workspace> "w" set ] unit-test
|
||||
[ ] [ "w" get com-scroll-up ] unit-test
|
||||
|
|
|
|||
|
|
@ -12,31 +12,36 @@ tools.test tools.vocabs ui.gadgets.buttons ui.gadgets.status-bar
|
|||
mirrors ;
|
||||
IN: ui.tools
|
||||
|
||||
: <workspace-tabs> ( -- tabs )
|
||||
g gadget-model
|
||||
"tool-switching" workspace command-map commands>>
|
||||
: <workspace-tabs> ( workspace -- tabs )
|
||||
model>>
|
||||
"tool-switching" workspace command-map commands>>
|
||||
[ command-string ] { } assoc>map <enum> >alist
|
||||
<toggle-buttons> ;
|
||||
<toggle-buttons> ;
|
||||
|
||||
: <workspace-book> ( -- gadget )
|
||||
[
|
||||
<stack-display> ,
|
||||
<browser-gadget> ,
|
||||
<inspector-gadget> ,
|
||||
<profiler-gadget> ,
|
||||
] { } make g gadget-model <book> ;
|
||||
: <workspace-book> ( workspace -- gadget )
|
||||
|
||||
dup
|
||||
<stack-display>
|
||||
<browser-gadget>
|
||||
<inspector-gadget>
|
||||
<profiler-gadget>
|
||||
4array
|
||||
|
||||
swap model>>
|
||||
|
||||
<book> ;
|
||||
|
||||
: <workspace> ( -- workspace )
|
||||
{ 0 1 } workspace new-track
|
||||
0 <model> >>model
|
||||
[
|
||||
<listener-gadget> g set-workspace-listener
|
||||
<workspace-book> g set-workspace-book
|
||||
<workspace-tabs> f track,
|
||||
g workspace-book 1/5 track,
|
||||
g workspace-listener 4/5 track,
|
||||
toolbar,
|
||||
] make-gadget ;
|
||||
{ 0 1 } workspace new-track
|
||||
|
||||
0 <model> >>model
|
||||
<listener-gadget> >>listener
|
||||
dup <workspace-book> >>book
|
||||
|
||||
dup <workspace-tabs> f track-add*
|
||||
dup book>> 1/5 track-add*
|
||||
dup listener>> 4/5 track-add*
|
||||
dup <toolbar> f track-add* ;
|
||||
|
||||
: resize-workspace ( workspace -- )
|
||||
dup track-sizes over control-value zero? [
|
||||
|
|
|
|||
Loading…
Reference in New Issue