Merge branch 'master' of git://factorcode.org/git/factor

core/cpu/ppc/assembler/assembler-tests.factor

@@ -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

core/cpu/ppc/assembler/assembler.factor

@@ -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
+USING: generator.fixup kernel namespaces words io.binary math
-words math math.bitfields math.order io.binary ;
+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 , ;
+! D-form
-: a-form ( d a b c xo rc -- n ) { 0 1 6 11 16 21 } bitfield ;
+D: ADDI 14
-: b-form ( bo bi bd aa lk -- n ) { 0 1 2 16 21 } bitfield ;
+D: ADDIC 12
-: s>u16 ( s -- u ) HEX: ffff bitand ;
+D: ADDIC. 13
-: d-form ( d a simm -- n ) s>u16 { 0 16 21 } bitfield ;
+D: ADDIS 15
-: sd-form ( d a simm -- n ) s>u16 { 0 21 16 } bitfield ;
+D: CMPI 11
-: i-form ( li aa lk -- n ) { 0 1 0 } bitfield ;
+D: CMPLI 10
-: x-form ( a s b rc xo -- n ) { 1 0 11 21 16 } bitfield ;
+D: LBZ 34
-: xfx-form ( d spr xo -- n ) { 1 11 21 } bitfield ;
+D: LBZU 35
-: xo-form ( d a b oe rc xo -- n ) { 1 0 10 11 16 21 } bitfield ;
+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 ;
+! SD-form
-: ADDIS d-form 15 insn ;  : LIS 0 rot ADDIS ;
+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 ;
+! Branches
-: ADD 0 0 (ADD) ;  : ADD. 0 1 (ADD) ;
+: B ( dest -- ) 0 0 (B) ;
-: ADDO 1 0 (ADD) ; : ADDO. 1 1 (ADD) ;
+: 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 ;
+! Special registers
-: ADDC 0 0 (ADDC) ;  : ADDC. 0 1 (ADDC) ;
+MFSPR: XER 1
-: ADDCO 1 0 (ADDC) ; : ADDCO. 1 1 (ADDC) ;
+MFSPR: LR 8
+MFSPR: CTR 9
+MTSPR: XER 1
+MTSPR: LR 8
+MTSPR: CTR 9
 
-: (ADDE) 138 xo-form 31 insn ;
+! Pseudo-instructions
-: ADDE 0 0 (ADDE) ;  : ADDE. 0 1 (ADDE) ;
+: LI 0 rot ADDI ; inline
-: ADDEO 1 0 (ADDE) ; : ADDEO. 1 1 (ADDE) ;
+: SUBI neg ADDI ; inline
-
+: LIS 0 rot ADDIS ; inline
-: ANDI sd-form 28 insn ;
+: SUBIC neg ADDIC ; inline
-: ANDIS sd-form 29 insn ;
+: SUBIC. neg ADDIC. ; inline
-
+: NOT dup NOR ; inline
-: (AND) 28 x-form 31 insn ;
+: NOT. dup NOR. ; inline
-: AND 0 (AND) ;  : AND. 0 (AND) ;
+: MR dup OR ; inline
-
+: MR. dup OR. ; inline
-: (DIVW) 491 xo-form 31 insn ;
+: (SLWI) 0 31 pick - ; inline
-: DIVW 0 0 (DIVW) ;  : DIVW. 0 1 (DIVW) ;
+: SLWI ( d a b -- ) (SLWI) RLWINM ;
-: DIVWO 1 0 (DIVW) ; : DIVWO. 1 1 (DIVW) ;
+: SLWI. ( d a b -- ) (SLWI) RLWINM. ;
-
+: (SRWI) 32 over - swap 31 ; inline
-: (DIVWU) 459 xo-form 31 insn ;
+: SRWI ( d a b -- ) (SRWI) RLWINM ;
-: DIVWU 0 0 (DIVWU) ;  : DIVWU. 0 1 (DIVWU) ;
+: SRWI. ( d a b -- ) (SRWI) RLWINM. ;
-: DIVWUO 1 0 (DIVWU) ; : DIVWUO. 1 1 (DIVWU) ;
+: LOAD32 ( n r -- ) >r w>h/h r> tuck LIS dup rot ORI ;
-
+: immediate? ( n -- ? ) HEX: -8000 HEX: 7fff between? ;
-: (EQV) 284 x-form 31 insn ;
+: LOAD ( n r -- ) over immediate? [ LI ] [ LOAD32 ] if ;
-: 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 ;

core/cpu/ppc/assembler/backend/backend.factor

@@ -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

extra/peg/parsers/parsers-docs.factor

@@ -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\" token \",\" token list-of parse  ." "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,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" }
+    { $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 parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
+    { $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" }
+    { $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 parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
+    { $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" }
+    { $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 parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
+    { $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 parse-result-ast ." "V{ \"a\" \"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 ;" "\"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 parse-result-ast ." "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 ;" "\"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 parse-result-ast ." "V{ \"a\" \"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 parse-result-ast ." "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 strings ;" "\"a\" \"_a-zA-Z\" range-pattern parse 1string ." "\"a\"" } 
-    { $example "USING: peg peg.parsers prettyprint ;\n\"0\" \"^0-9\" range-pattern parse ." "f" } 
+    { $code "USING: peg peg.parsers prettyprint ;\n\"0\" \"^0-9\" range-pattern parse => exception"} 
 }
 }  ;

extra/peg/peg-docs.factor

@@ -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 "
+    "Given the input string, parse it using the given parser. The result is the abstract "
-    "the parse was successful, otherwise it is f." } 
+    "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 ." "67" } 
-  { $example "USING: kernel math peg prettyprint ;" "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast ." "67" } 
 } ;
 
 HELP: ensure

extra/ui/gadgets/buttons/buttons.factor

@@ -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, ;

extra/ui/gadgets/frames/frames-docs.factor

@@ -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
 

extra/ui/gadgets/frames/frames.factor

@@ -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 ;

extra/ui/gadgets/gadgets-docs.factor

@@ -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

extra/ui/gadgets/gadgets.factor

@@ -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 [

extra/ui/gadgets/grids/grids.factor

@@ -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 ;
 

extra/ui/gadgets/labelled/labelled.factor

@@ -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
+  { 0 1 } labelled-gadget new-track
-    [
+    swap <label> reverse-video-theme f track-add*
-        <label> reverse-video-theme f track,
+    swap >>content
-        g-> set-labelled-gadget-content 1 track,
+    dup content>> 1 track-add* ;
-    ] make-gadget ;
 
 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 )
-    [
+  <frame>
-        [ <close-box> @left frame, ] when*
+    swap dup [ <close-box> @left grid-add* ] [ drop ] if
-        <title-label> @center frame,
+    swap <title-label> @center grid-add* ;
-    ] make-frame ;
 
 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 
+  closable-gadget new-frame
-    [
+    -rot <title-bar> @top grid-add*
-        <title-bar> @top frame,
+    swap >>content
-        g-> set-closable-gadget-content @center frame,
+    dup content>> @center grid-add* ;
-    ] make-gadget ;
+    
-
 M: closable-gadget focusable-child* closable-gadget-content ;

extra/ui/gadgets/labels/labels.factor

@@ -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* ;

extra/ui/gadgets/packs/packs-docs.factor

@@ -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"

extra/ui/gadgets/packs/packs.factor

@@ -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

extra/ui/gadgets/scrollers/scrollers.factor

@@ -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
+  new-frame
-        t >>root?
+    t >>root?
-        <scroller-model> >>model
+    <scroller-model> >>model
-         faint-boundary
+    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 ;
 
-: <scroller> ( gadget -- scroller )
+    dup model>> dependencies>> first  <x-slider> >>x dup x>> @bottom grid-add*
-    scroller new-scroller ;
+    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 -- )
     [

extra/ui/gadgets/sliders/sliders.factor

@@ -138,10 +138,11 @@ M: elevator layout*
     [ swap find-slider slide-by-line ] curry <repeat-button>
     [ set-gadget-orientation ] keep ;
 
-: elevator, ( orientation -- )
+: elevator, ( gadget orientation -- gadget )
-    dup <elevator> g-> set-slider-elevator
+  tuck <elevator> >>elevator
-    swap <thumb> g-> set-slider-thumb add-gadget
+  swap <thumb>    >>thumb
-    @center frame, ;
+  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

extra/ui/gadgets/slots/slots.factor

@@ -69,15 +69,13 @@ M: value-ref finish-editing
 } define-command
 
 : <slot-editor> ( ref -- gadget )
-    { 0 1 } slot-editor new-track
+  { 0 1 } slot-editor new-track
-        swap >>ref
+    swap >>ref
-    [
+    dup <toolbar> f track-add*
-        toolbar,
+    <source-editor> >>text
-        <source-editor> g-> set-slot-editor-text
+    dup text>> <scroller> 1 track-add*
-        <scroller> 1 track,
-    ] make-gadget
     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
+  dup clear-track
-    [ 1 track, <edit-button> f track, ] with-gadget ;
+    swap          1 track-add*
+    <edit-button> f track-add*
+  drop ;
 
 : update-slot ( editable-slot -- )
     [ [ ref>> get-ref ] [ printer>> ] bi call ] keep

extra/ui/gadgets/tabs/tabs.factor

@@ -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 -- )
+:: add-toggle ( model n name toggler -- )
-    [ [ gadget-parent '[ , , , (del-page) ] "X" swap
+  <frame>
-       <bevel-button> @right frame, ] 3keep 
+    n name toggler parent>> '[ , , , (del-page) ] "X" swap <bevel-button>
-      [ swapd <toggle-button> @center frame, ] dip ] make-frame
+      @right grid-add*
-    add-gadget drop ;
+    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
+  tabbed new-frame
-    [ g 0 <model> >>model
+    0 <model> >>model
-      <pile> 1 >>fill [ >>toggler ] keep swap @left grid-add
+    <pile> 1 >>fill >>toggler
-      [ keys >vector g swap >>names ]
+    dup toggler>> @left grid-add*
-      [ values g model>> <book> [ >>content ] keep swap @center grid-add ] bi
+    swap
-      g redo-toggler g ] with-gadget ;
+      [ keys >vector >>names ]
+      [ values over model>> <book> >>content dup content>> @center grid-add* ]
+    bi
+    dup redo-toggler ;
+    

extra/ui/gadgets/tracks/tracks-docs.factor

@@ -8,10 +8,7 @@ ARTICLE: "ui-track-layout" "Track layouts"
 "Creating empty tracks:"
 { $subsection <track> }
 "Adding children:"
-{ $subsection track-add }
+{ $subsection track-add } ;
-"Creating new tracks using a combinator:"
-{ $subsection make-track }
-{ $subsection track, } ;
 
 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"

extra/ui/gadgets/tracks/tracks-tests.factor

@@ -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 } ] [
-    [
+  { 0 1 } <track>
-        <gadget> { 100 100 } over set-rect-dim 1 track,
+    <gadget> { 100 100 } >>dim 1 track-add*
-    ] { 0 1 } make-track pref-dim
+  pref-dim
 ] unit-test
 
 [ { 100 110 } ] [
-    [
+  { 0 1 } <track>
-        <gadget> { 10 10 } over set-rect-dim f track,
+    <gadget> { 10 10 }   >>dim f track-add*
-        <gadget> { 100 100 } over set-rect-dim 1 track,
+    <gadget> { 100 100 } >>dim 1 track-add*
-    ] { 0 1 } make-track pref-dim
+  pref-dim
 ] unit-test

extra/ui/gadgets/tracks/tracks.factor

@@ -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

extra/ui/tools/inspector/inspector.factor

@@ -16,12 +16,11 @@ TUPLE: inspector-gadget < track object pane ;
     ] with-pane ;
 
 : <inspector-gadget> ( -- gadget )
-    { 0 1 } inspector-gadget new-track
+  { 0 1 } inspector-gadget new-track
-    [
+    dup <toolbar> f track-add*
-        toolbar,
+    <pane> >>pane
-        <pane> g-> set-inspector-gadget-pane <scroller> 1 track,
+    dup pane>> <scroller> 1 track-add* ;
-    ] make-gadget ;
+    
-
 : inspect-object ( obj mirror keys inspector -- )
     2nip swap >>object refresh ;
 

extra/ui/tools/listener/listener.factor

@@ -12,9 +12,9 @@ IN: ui.tools.listener
 
 TUPLE: listener-gadget < track input output stack ;
 
-: listener-output, ( -- )
+: listener-output, ( listener -- listener )
-    <scrolling-pane> g-> set-listener-gadget-output
+  <scrolling-pane> >>output
-    <scroller> "Output" <labelled-gadget> 1 track, ;
+  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, ( -- )
+: listener-input, ( listener -- listener )
-    g <listener-input> g-> set-listener-gadget-input
+  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

extra/ui/tools/profiler/profiler.factor

@@ -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
+  { 0 1 } profiler-gadget new-track
-    [
+    dup <toolbar> f track-add*
-        toolbar,
+    <pane> >>pane
-        <pane> g-> set-profiler-gadget-pane
+    dup pane>> <scroller> 1 track-add* ;
-        <scroller> 1 track,
+    
-    ] make-gadget ;
-
 : with-profiler-pane ( gadget quot -- )
     >r profiler-gadget-pane r> with-pane ;
 

extra/ui/tools/tools-tests.factor

@@ -5,12 +5,10 @@ ui.gadgets.labelled ui.gadgets.presentations
 ui.gadgets.scrollers vocabs tools.test.ui ui ;
 IN: ui.tools.tests
 
+[ f ]
 [
-    [ f ] [
+  <gadget> 0 <model> >>model <workspace-tabs> children>> empty?
-        0 <model> <gadget> [ set-gadget-model ] keep gadget set
+] unit-test
-        <workspace-tabs> gadget-children empty?
-    ] unit-test
-] with-scope
 
 [ ] [ <workspace> "w" set ] unit-test
 [ ] [ "w" get com-scroll-up ] unit-test

extra/ui/ui-docs.factor

@@ -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:"