Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
21c586dd6e
|
|
@ -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
|
||||
|
|
@ -11,7 +11,7 @@ HELP: 1token
|
|||
} { $description
|
||||
"Calls 1string on a character and returns a parser that matches that character."
|
||||
} { $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a\" CHAR: a 1token parse parse-result-ast ." "\"a\"" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a\" CHAR: a 1token parse ." "\"a\"" }
|
||||
} { $see-also 'string' } ;
|
||||
|
||||
HELP: (list-of)
|
||||
|
|
@ -33,8 +33,8 @@ HELP: list-of
|
|||
"Returns a parser that returns a list of items separated by the separator parser. Hides the separators and matches a list of one or more items."
|
||||
} { $notes "Use " { $link list-of-many } " to ensure a list contains two or more items." }
|
||||
{ $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a,a,a,a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a\" \"a\" token \",\" token list-of parse ." "V{ \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a,a,a,a\" \"a\" token \",\" token list-of parse ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
} { $see-also list-of-many } ;
|
||||
|
||||
HELP: list-of-many
|
||||
|
|
@ -46,8 +46,8 @@ HELP: list-of-many
|
|||
"Returns a parser that returns a list of items separated by the separator parser. Hides the separators and matches a list of two or more items."
|
||||
} { $notes "Use " { $link list-of } " to return a list of only one item."
|
||||
} { $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a\" \"a\" token \",\" token list-of-many parse ." "f" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a,a,a,a\" \"a\" token \",\" token list-of-many parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $code "USING: peg peg.parsers prettyprint ;" "\"a\" \"a\" token \",\" token list-of-many parse => exception" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a,a,a,a\" \"a\" token \",\" token list-of-many parse ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
} { $see-also list-of } ;
|
||||
|
||||
HELP: epsilon
|
||||
|
|
@ -72,8 +72,8 @@ HELP: exactly-n
|
|||
} { $description
|
||||
"Returns a parser that matches an exact repetition of the input parser."
|
||||
} { $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 4 exactly-n parse ." "f" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 exactly-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $code "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 4 exactly-n parse => exception" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 exactly-n parse ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
} { $see-also at-least-n at-most-n from-m-to-n } ;
|
||||
|
||||
HELP: at-least-n
|
||||
|
|
@ -84,9 +84,9 @@ HELP: at-least-n
|
|||
} { $description
|
||||
"Returns a parser that matches n or more repetitions of the input parser."
|
||||
} { $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 4 at-least-n parse ." "f" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $code "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 4 at-least-n parse => exception"}
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 at-least-n parse ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaaa\" \"a\" token 4 at-least-n parse ." "V{ \"a\" \"a\" \"a\" \"a\" \"a\" }" }
|
||||
} { $see-also exactly-n at-most-n from-m-to-n } ;
|
||||
|
||||
HELP: at-most-n
|
||||
|
|
@ -97,8 +97,8 @@ HELP: at-most-n
|
|||
} { $description
|
||||
"Returns a parser that matches n or fewer repetitions of the input parser."
|
||||
} { $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 at-most-n parse ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaaa\" \"a\" token 4 at-most-n parse ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
} { $see-also exactly-n at-least-n from-m-to-n } ;
|
||||
|
||||
HELP: from-m-to-n
|
||||
|
|
@ -110,9 +110,9 @@ HELP: from-m-to-n
|
|||
} { $description
|
||||
"Returns a parser that matches between and including m to n repetitions of the input parser."
|
||||
} { $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 3 4 from-m-to-n parse ." "V{ \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 3 4 from-m-to-n parse ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"aaaaa\" \"a\" token 3 4 from-m-to-n parse ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
} { $see-also exactly-n at-most-n at-least-n } ;
|
||||
|
||||
HELP: pack
|
||||
|
|
@ -124,7 +124,7 @@ HELP: pack
|
|||
} { $description
|
||||
"Returns a parser that parses the begin, body, and end parsers in order. The begin and end parsers are hidden."
|
||||
} { $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"hi123bye\" \"hi\" token 'integer' \"bye\" token pack parse parse-result-ast ." "123" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"hi123bye\" \"hi\" token 'integer' \"bye\" token pack parse ." "123" }
|
||||
} { $see-also surrounded-by } ;
|
||||
|
||||
HELP: surrounded-by
|
||||
|
|
@ -136,7 +136,7 @@ HELP: surrounded-by
|
|||
} { $description
|
||||
"Calls token on begin and end to make them into string parsers. Returns a parser that parses the begin, body, and end parsers in order. The begin and end parsers are hidden."
|
||||
} { $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"hi123bye\" 'integer' \"hi\" \"bye\" surrounded-by parse parse-result-ast ." "123" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"hi123bye\" 'integer' \"hi\" \"bye\" surrounded-by parse ." "123" }
|
||||
} { $see-also pack } ;
|
||||
|
||||
HELP: 'digit'
|
||||
|
|
@ -173,7 +173,7 @@ HELP: range-pattern
|
|||
"of characters separated with a dash (-) represents the "
|
||||
"range of characters from the first to the second, inclusive."
|
||||
{ $examples
|
||||
{ $example "USING: peg peg.parsers prettyprint strings ;" "\"a\" \"_a-zA-Z\" range-pattern parse parse-result-ast 1string ." "\"a\"" }
|
||||
{ $example "USING: peg peg.parsers prettyprint ;\n\"0\" \"^0-9\" range-pattern parse ." "f" }
|
||||
{ $example "USING: peg peg.parsers prettyprint strings ;" "\"a\" \"_a-zA-Z\" range-pattern parse 1string ." "\"a\"" }
|
||||
{ $code "USING: peg peg.parsers prettyprint ;\n\"0\" \"^0-9\" range-pattern parse => exception"}
|
||||
}
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -7,11 +7,11 @@ HELP: parse
|
|||
{ $values
|
||||
{ "input" "a string" }
|
||||
{ "parser" "a parser" }
|
||||
{ "result" "a parse-result or f" }
|
||||
{ "ast" "an object" }
|
||||
}
|
||||
{ $description
|
||||
"Given the input string, parse it using the given parser. The result is a <parse-result> object if "
|
||||
"the parse was successful, otherwise it is f." }
|
||||
"Given the input string, parse it using the given parser. The result is the abstract "
|
||||
"syntax tree returned by the parser." }
|
||||
{ $see-also compile } ;
|
||||
|
||||
HELP: compile
|
||||
|
|
@ -20,7 +20,7 @@ HELP: compile
|
|||
{ "word" "a word" }
|
||||
}
|
||||
{ $description
|
||||
"Compile the parser to a word. The word will have stack effect ( -- result )."
|
||||
"Compile the parser to a word. The word will have stack effect ( -- ast )."
|
||||
}
|
||||
{ $see-also parse } ;
|
||||
|
||||
|
|
@ -104,8 +104,7 @@ HELP: semantic
|
|||
"Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with "
|
||||
"the AST produced by 'p1' on the stack returns true." }
|
||||
{ $examples
|
||||
{ $example "USING: kernel math peg prettyprint ;" "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse ." "f" }
|
||||
{ $example "USING: kernel math peg prettyprint ;" "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast ." "67" }
|
||||
{ $example "USING: kernel math peg prettyprint ;" "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse ." "67" }
|
||||
} ;
|
||||
|
||||
HELP: ensure
|
||||
|
|
|
|||
|
|
@ -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, ;
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@ ARTICLE: "ui-frame-layout" "Frame layouts"
|
|||
"Creating empty frames:"
|
||||
{ $subsection <frame> }
|
||||
"Creating new frames using a combinator:"
|
||||
{ $subsection make-frame }
|
||||
{ $subsection frame, }
|
||||
"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add } " or " { $link frame, } ":"
|
||||
{ $subsection @center }
|
||||
|
|
@ -44,15 +43,9 @@ HELP: <frame>
|
|||
{ $values { "frame" frame } }
|
||||
{ $description "Creates a new " { $link frame } " for laying out gadgets in a 3x3 grid." } ;
|
||||
|
||||
{ <frame> make-frame } related-words
|
||||
|
||||
HELP: make-frame
|
||||
{ $values { "quot" quotation } { "frame" frame } }
|
||||
{ $description "Creates a new frame. The quotation can add children by calling the " { $link frame, } " word." } ;
|
||||
|
||||
HELP: frame,
|
||||
{ $values { "gadget" gadget } { "i" "non-negative integer" } { "j" "non-negative integer" } }
|
||||
{ $description "Adds a child gadget at the specified location. This word can only be called inside the quotation passed to " { $link make-frame } "." } ;
|
||||
{ $description "Adds a child gadget at the specified location. This word can only be called inside the quotation passed to make-frame." } ;
|
||||
|
||||
{ grid frame } related-words
|
||||
|
||||
|
|
|
|||
|
|
@ -39,8 +39,5 @@ M: frame layout*
|
|||
[ rot rect-dim fill-center ] 3keep
|
||||
grid-layout ;
|
||||
|
||||
: make-frame ( quot -- frame )
|
||||
<frame> swap make-gadget ; inline
|
||||
|
||||
: frame, ( gadget i j -- )
|
||||
gadget get -rot grid-add ;
|
||||
|
|
|
|||
|
|
@ -180,22 +180,6 @@ HELP: focusable-child
|
|||
{ $values { "gadget" gadget } { "child" gadget } }
|
||||
{ $description "Outputs the child of the gadget which would prefer to receive keyboard focus." } ;
|
||||
|
||||
HELP: make-gadget
|
||||
{ $values { "gadget" gadget } { "quot" quotation } }
|
||||
{ $description "Calls the quotation in a new scope with the gadget stored in the " { $link gadget } " variable." } ;
|
||||
|
||||
HELP: with-gadget
|
||||
{ $values { "gadget" gadget } { "quot" quotation } }
|
||||
{ $description "Calls the quotation in a new scope with the " { $link gadget } " and " { $link make-gadget } " variables set to " { $snippet "gadget" } ". The quotation can call " { $link g } " and " { $link g-> } " to access the gadget." } ;
|
||||
|
||||
HELP: g
|
||||
{ $values { "gadget" gadget } }
|
||||
{ $description "Outputs the gadget being built. Can only be used inside a quotation passed to " { $link with-gadget } "." } ;
|
||||
|
||||
HELP: g->
|
||||
{ $values { "x" object } { "gadget" gadget } }
|
||||
{ $description "Duplicates the top of the stack and outputs the gadget being built. Can only be used inside a quotation passed to " { $link with-gadget } "." } ;
|
||||
|
||||
{ control-value set-control-value gadget-model } related-words
|
||||
|
||||
HELP: control-value
|
||||
|
|
|
|||
|
|
@ -357,16 +357,6 @@ M: f request-focus-on 2drop ;
|
|||
: focus-path ( world -- seq )
|
||||
[ focus>> ] follow ;
|
||||
|
||||
: g ( -- gadget ) gadget get ;
|
||||
|
||||
: g-> ( x -- x x gadget ) dup g ;
|
||||
|
||||
: with-gadget ( gadget quot -- )
|
||||
gadget swap with-variable ; inline
|
||||
|
||||
: make-gadget ( gadget quot -- gadget )
|
||||
[ with-gadget ] [ drop ] 2bi ; inline
|
||||
|
||||
! Deprecated
|
||||
: set-gadget-delegate ( gadget tuple -- )
|
||||
over [
|
||||
|
|
|
|||
|
|
@ -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,17 +5,16 @@ ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers
|
|||
ui.gadgets.tracks ui.gadgets.theme ui.gadgets.frames
|
||||
ui.gadgets.grids io kernel math models namespaces prettyprint
|
||||
sequences sequences words classes.tuple ui.gadgets ui.render
|
||||
colors ;
|
||||
colors accessors ;
|
||||
IN: ui.gadgets.labelled
|
||||
|
||||
TUPLE: labelled-gadget < track content ;
|
||||
|
||||
: <labelled-gadget> ( gadget title -- newgadget )
|
||||
{ 0 1 } labelled-gadget new-track
|
||||
[
|
||||
<label> reverse-video-theme f track,
|
||||
g-> set-labelled-gadget-content 1 track,
|
||||
] make-gadget ;
|
||||
{ 0 1 } labelled-gadget new-track
|
||||
swap <label> reverse-video-theme f track-add*
|
||||
swap >>content
|
||||
dup content>> 1 track-add* ;
|
||||
|
||||
M: labelled-gadget focusable-child* labelled-gadget-content ;
|
||||
|
||||
|
|
@ -39,10 +38,9 @@ M: labelled-gadget focusable-child* labelled-gadget-content ;
|
|||
: <title-label> ( text -- label ) <label> dup title-theme ;
|
||||
|
||||
: <title-bar> ( title quot -- gadget )
|
||||
[
|
||||
[ <close-box> @left frame, ] when*
|
||||
<title-label> @center frame,
|
||||
] make-frame ;
|
||||
<frame>
|
||||
swap dup [ <close-box> @left grid-add* ] [ drop ] if
|
||||
swap <title-label> @center grid-add* ;
|
||||
|
||||
TUPLE: closable-gadget < frame content ;
|
||||
|
||||
|
|
@ -50,10 +48,9 @@ TUPLE: closable-gadget < frame content ;
|
|||
[ [ closable-gadget? ] is? ] find-parent ;
|
||||
|
||||
: <closable-gadget> ( gadget title quot -- gadget )
|
||||
closable-gadget new-frame
|
||||
[
|
||||
<title-bar> @top frame,
|
||||
g-> set-closable-gadget-content @center frame,
|
||||
] make-gadget ;
|
||||
|
||||
closable-gadget new-frame
|
||||
-rot <title-bar> @top grid-add*
|
||||
swap >>content
|
||||
dup content>> @center grid-add* ;
|
||||
|
||||
M: closable-gadget focusable-child* closable-gadget-content ;
|
||||
|
|
|
|||
|
|
@ -64,7 +64,11 @@ M: object >label ;
|
|||
M: f >label drop <gadget> ;
|
||||
|
||||
: label-on-left ( gadget label -- button )
|
||||
[ >label f track, 1 track, ] { 1 0 } make-track ;
|
||||
|
||||
{ 1 0 } <track>
|
||||
swap >label f track-add*
|
||||
swap 1 track-add* ;
|
||||
|
||||
: label-on-right ( label gadget -- button )
|
||||
[ f track, >label 1 track, ] { 1 0 } make-track ;
|
||||
{ 1 0 } <track>
|
||||
swap f track-add*
|
||||
swap >label 1 track-add* ;
|
||||
|
|
|
|||
|
|
@ -9,10 +9,6 @@ ARTICLE: "ui-pack-layout" "Pack layouts"
|
|||
{ $subsection <pack> }
|
||||
{ $subsection <pile> }
|
||||
{ $subsection <shelf> }
|
||||
"Creating packs using a combinator:"
|
||||
{ $subsection make-pile }
|
||||
{ $subsection make-filled-pile }
|
||||
{ $subsection make-shelf }
|
||||
|
||||
"For more control, custom layouts can reuse portions of pack layout logic:"
|
||||
{ $subsection pack-pref-dim }
|
||||
|
|
@ -24,9 +20,6 @@ HELP: pack
|
|||
{ $link <pack> }
|
||||
{ $link <pile> }
|
||||
{ $link <shelf> }
|
||||
{ $link make-pile }
|
||||
{ $link make-filled-pile }
|
||||
{ $link make-shelf }
|
||||
}
|
||||
"Packs have the following slots:"
|
||||
{ $list
|
||||
|
|
@ -64,16 +57,4 @@ HELP: pack-pref-dim
|
|||
"This word is useful if you are writing your own layout gadget which inherits from " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure."
|
||||
} ;
|
||||
|
||||
HELP: make-pile
|
||||
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } }
|
||||
{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically. The quotation can add children by calling the gadget, word." } ;
|
||||
|
||||
HELP: make-filled-pile
|
||||
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } }
|
||||
{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically, such that all gadgets have the same width. The quotation can add children by calling the gadget, word." } ;
|
||||
|
||||
HELP: make-shelf
|
||||
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } }
|
||||
{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets horizontally. The quotation can add children by calling the gadget, word." } ;
|
||||
|
||||
ABOUT: "ui-pack-layout"
|
||||
|
|
|
|||
|
|
@ -60,12 +60,3 @@ M: pack layout*
|
|||
M: pack children-on ( rect gadget -- seq )
|
||||
dup gadget-orientation swap gadget-children
|
||||
[ fast-children-on ] keep <slice> ;
|
||||
|
||||
: make-pile ( quot -- pack )
|
||||
<pile> swap make-gadget ; inline
|
||||
|
||||
: make-filled-pile ( quot -- pack )
|
||||
<filled-pile> swap make-gadget ; inline
|
||||
|
||||
: make-shelf ( quot -- pack )
|
||||
<shelf> swap make-gadget ; inline
|
||||
|
|
|
|||
|
|
@ -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>> ;
|
||||
|
|
@ -98,8 +96,10 @@ TUPLE: editable-slot < track printer ref ;
|
|||
<roll-button> ;
|
||||
|
||||
: display-slot ( gadget editable-slot -- )
|
||||
dup clear-track
|
||||
[ 1 track, <edit-button> f track, ] with-gadget ;
|
||||
dup clear-track
|
||||
swap 1 track-add*
|
||||
<edit-button> f track-add*
|
||||
drop ;
|
||||
|
||||
: update-slot ( editable-slot -- )
|
||||
[ [ ref>> get-ref ] [ printer>> ] bi call ] keep
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
USING: accessors kernel fry math math.vectors sequences arrays vectors assocs
|
||||
hashtables models models.range models.compose combinators
|
||||
ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs
|
||||
ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books ;
|
||||
ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ;
|
||||
|
||||
IN: ui.gadgets.tabs
|
||||
|
||||
|
|
@ -12,11 +12,12 @@ TUPLE: tabbed < frame names toggler content ;
|
|||
|
||||
DEFER: (del-page)
|
||||
|
||||
: add-toggle ( model n name toggler -- )
|
||||
[ [ gadget-parent '[ , , , (del-page) ] "X" swap
|
||||
<bevel-button> @right frame, ] 3keep
|
||||
[ swapd <toggle-button> @center frame, ] dip ] make-frame
|
||||
add-gadget drop ;
|
||||
:: add-toggle ( model n name toggler -- )
|
||||
<frame>
|
||||
n name toggler parent>> '[ , , , (del-page) ] "X" swap <bevel-button>
|
||||
@right grid-add*
|
||||
n model name <toggle-button> @center grid-add*
|
||||
toggler swap add-gadget drop ;
|
||||
|
||||
: redo-toggler ( tabbed -- )
|
||||
[ names>> ] [ model>> ] [ toggler>> ] tri
|
||||
|
|
@ -48,9 +49,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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,10 +8,7 @@ ARTICLE: "ui-track-layout" "Track layouts"
|
|||
"Creating empty tracks:"
|
||||
{ $subsection <track> }
|
||||
"Adding children:"
|
||||
{ $subsection track-add }
|
||||
"Creating new tracks using a combinator:"
|
||||
{ $subsection make-track }
|
||||
{ $subsection track, } ;
|
||||
{ $subsection track-add } ;
|
||||
|
||||
HELP: track
|
||||
{ $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ;
|
||||
|
|
@ -20,18 +17,8 @@ HELP: <track>
|
|||
{ $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } }
|
||||
{ $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ;
|
||||
|
||||
{ <track> make-track } related-words
|
||||
|
||||
HELP: track-add
|
||||
{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
|
||||
{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ;
|
||||
|
||||
HELP: track,
|
||||
{ $values { "gadget" gadget } { "constraint" "a number between 0 and 1, or " { $link f } } }
|
||||
{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child. This word can only be called inside the quotation passed to " { $link make-track } "." } ;
|
||||
|
||||
HELP: make-track
|
||||
{ $values { "quot" quotation } { "orientation" "an orientation specifier" } { "track" track } }
|
||||
{ $description "Creates a new track. The quotation can add children by calling the " { $link track, } " word." } ;
|
||||
|
||||
ABOUT: "ui-track-layout"
|
||||
|
|
|
|||
|
|
@ -1,15 +1,16 @@
|
|||
USING: kernel ui.gadgets ui.gadgets.tracks tools.test math.geometry.rect ;
|
||||
USING: kernel ui.gadgets ui.gadgets.tracks tools.test
|
||||
math.geometry.rect accessors ;
|
||||
IN: ui.gadgets.tracks.tests
|
||||
|
||||
[ { 100 100 } ] [
|
||||
[
|
||||
<gadget> { 100 100 } over set-rect-dim 1 track,
|
||||
] { 0 1 } make-track pref-dim
|
||||
{ 0 1 } <track>
|
||||
<gadget> { 100 100 } >>dim 1 track-add*
|
||||
pref-dim
|
||||
] unit-test
|
||||
|
||||
[ { 100 110 } ] [
|
||||
[
|
||||
<gadget> { 10 10 } over set-rect-dim f track,
|
||||
<gadget> { 100 100 } over set-rect-dim 1 track,
|
||||
] { 0 1 } make-track pref-dim
|
||||
{ 0 1 } <track>
|
||||
<gadget> { 10 10 } >>dim f track-add*
|
||||
<gadget> { 100 100 } >>dim 1 track-add*
|
||||
pref-dim
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -53,12 +53,6 @@ M: track pref-dim*
|
|||
pick sizes>> push
|
||||
add-gadget ;
|
||||
|
||||
: track, ( gadget constraint -- )
|
||||
gadget get swap track-add ;
|
||||
|
||||
: make-track ( quot orientation -- track )
|
||||
<track> swap make-gadget ; inline
|
||||
|
||||
: track-remove ( gadget track -- )
|
||||
over [
|
||||
[ gadget-children index ] 2keep
|
||||
|
|
|
|||
|
|
@ -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,14 +22,16 @@ 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
|
||||
"cookbook" ($link) "." print nl ;
|
||||
"handbook" ($link) "." print nl ;
|
||||
|
||||
M: listener-gadget focusable-child*
|
||||
input>> ;
|
||||
|
|
@ -169,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
|
||||
|
|
|
|||
|
|
@ -232,16 +232,7 @@ ARTICLE: "ui-layout-combinators" "Creating layouts using combinators"
|
|||
"The " { $link make } " combinator provides a convenient way of constructing sequences by keeping the intermediate sequence off the stack until construction is done. The " { $link , } " and " { $link % } " words operate on this implicit sequence, reducing stack noise."
|
||||
$nl
|
||||
"Similar tools exist for constructing complex gadget hierarchies. Different words are used for different types of gadgets; see " { $link "ui-pack-layout" } ", " { $link "ui-track-layout" } " and " { $link "ui-frame-layout" } " for specifics. This section documents their common factors."
|
||||
$nl
|
||||
"Gadget construction combinators whose names are prefixed with " { $snippet "make-" } " construct new gadgets and push them on the stack. The primitive combinator used to define all combinators of this form:"
|
||||
{ $subsection make-gadget }
|
||||
"Words such as " { $link track, } " access the gadget through the " { $link gadget } " variable."
|
||||
$nl
|
||||
"A combinator which stores a gadget in the " { $link gadget } " variable:"
|
||||
{ $subsection with-gadget }
|
||||
"The following words access the " { $link gadget } " variable; they can be used from " { $link with-gadget } " to store child gadgets in tuple slots:"
|
||||
{ $subsection g }
|
||||
{ $subsection g-> } ;
|
||||
;
|
||||
|
||||
ARTICLE: "ui-null-layout" "Manual layouts"
|
||||
"When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually:"
|
||||
|
|
|
|||
Loading…
Reference in New Issue