cpu.arm.assembler: dust it off, update to work with contemporary Factor, and clean it up a bit

basis/cpu/arm/assembler/assembler-tests.factor

@@ -1,8 +1,9 @@
 IN: cpu.arm.assembler.tests
-USING: assembler-arm math test namespaces sequences kernel
+USING: cpu.arm.assembler math tools.test namespaces make
-quotations ;
+sequences kernel quotations ;
+FROM: cpu.arm.assembler => B ;
 
-: test-opcode [ { } make first ] curry unit-test ;
+: test-opcode ( expect quot -- ) [ { } make first ] curry unit-test ;
 
 [ HEX: ea000000 ] [ 0 B ] test-opcode
 [ HEX: eb000000 ] [ 0 BL ] test-opcode

basis/cpu/arm/assembler/assembler.factor

@@ -1,31 +1,46 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generator generator.fixup kernel sequences words
+USING: accessors arrays combinators kernel make math math.bitwise
-namespaces math math.bitfields ;
+namespaces sequences words words.symbol parser ;
 IN: cpu.arm.assembler
 
-: define-registers ( seq -- )
+! Registers
-    dup length [ "register" set-word-prop ] 2each ;
+<<
 
-SYMBOL: R0
+SYMBOL: registers
-SYMBOL: R1
-SYMBOL: R2
-SYMBOL: R3
-SYMBOL: R4
-SYMBOL: R5
-SYMBOL: R6
-SYMBOL: R7
-SYMBOL: R8
-SYMBOL: R9
-SYMBOL: R10
-SYMBOL: R11
-SYMBOL: R12
-SYMBOL: R13
-SYMBOL: R14
-SYMBOL: R15
 
-{ R0 R1 R2 R3 R4 R5 R6 R7 R8 R9 R10 R11 R12 R13 R14 R15 }
+V{ } registers set-global
-define-registers
+
+SYNTAX: REGISTER:
+    CREATE-WORD
+    [ define-symbol ]
+    [ registers get length "register" set-word-prop ]
+    [ registers get push ]
+    tri ;
+
+>>
+
+REGISTER: R0
+REGISTER: R1
+REGISTER: R2
+REGISTER: R3
+REGISTER: R4
+REGISTER: R5
+REGISTER: R6
+REGISTER: R7
+REGISTER: R8
+REGISTER: R9
+REGISTER: R10
+REGISTER: R11
+REGISTER: R12
+REGISTER: R13
+REGISTER: R14
+REGISTER: R15
+
+ALIAS: SL R10 ALIAS: FP R11 ALIAS: IP R12
+ALIAS: SP R13 ALIAS: LR R14 ALIAS: PC R15
+
+<PRIVATE
 
 PREDICATE: register < word register >boolean ;
 
@@ -33,8 +48,7 @@ GENERIC: register ( register -- n )
 M: word register "register" word-prop ;
 M: f register drop 0 ;
 
-: SL R10 ; inline : FP R11 ; inline : IP R12 ; inline
+PRIVATE>
-: SP R13 ; inline : LR R14 ; inline : PC R15 ; inline
 
 ! Condition codes
 SYMBOL: cond-code
@@ -46,43 +60,52 @@ SYMBOL: cond-code
     #! Default value is BIN: 1110 AL (= always)
     cond-code [ f ] change BIN: 1110 or ;
 
-: EQ BIN: 0000 >CC ;
+: EQ ( -- ) BIN: 0000 >CC ;
-: NE BIN: 0001 >CC ;
+: NE ( -- ) BIN: 0001 >CC ;
-: CS BIN: 0010 >CC ;
+: CS ( -- ) BIN: 0010 >CC ;
-: CC BIN: 0011 >CC ;
+: CC ( -- ) BIN: 0011 >CC ;
-: LO BIN: 0100 >CC ;
+: LO ( -- ) BIN: 0100 >CC ;
-: PL BIN: 0101 >CC ;
+: PL ( -- ) BIN: 0101 >CC ;
-: VS BIN: 0110 >CC ;
+: VS ( -- ) BIN: 0110 >CC ;
-: VC BIN: 0111 >CC ;
+: VC ( -- ) BIN: 0111 >CC ;
-: HI BIN: 1000 >CC ;
+: HI ( -- ) BIN: 1000 >CC ;
-: LS BIN: 1001 >CC ;
+: LS ( -- ) BIN: 1001 >CC ;
-: GE BIN: 1010 >CC ;
+: GE ( -- ) BIN: 1010 >CC ;
-: LT BIN: 1011 >CC ;
+: LT ( -- ) BIN: 1011 >CC ;
-: GT BIN: 1100 >CC ;
+: GT ( -- ) BIN: 1100 >CC ;
-: LE BIN: 1101 >CC ;
+: LE ( -- ) BIN: 1101 >CC ;
-: AL BIN: 1110 >CC ;
+: AL ( -- ) BIN: 1110 >CC ;
-: NV BIN: 1111 >CC ;
+: NV ( -- ) BIN: 1111 >CC ;
+
+<PRIVATE
 
 : (insn) ( n -- ) CC> 28 shift bitor , ;
 
 : insn ( bitspec -- ) bitfield (insn) ; inline
 
 ! Branching instructions
-GENERIC# (B) 1 ( signed-imm-24 l -- )
+GENERIC# (B) 1 ( target l -- )
 
 M: integer (B) { 24 { 1 25 } { 0 26 } { 1 27 } 0 } insn ;
-M: word (B) 0 swap (B) rc-relative-arm-3 rel-word ;
-M: label (B) 0 swap (B) rc-relative-arm-3 label-fixup ;
 
-: B 0 (B) ; : BL 1 (B) ;
+PRIVATE>
+
+: B ( target -- ) 0 (B) ;
+: BL ( target -- ) 1 (B) ;
 
 ! Data processing instructions
+<PRIVATE
+
 SYMBOL: updates-cond-code
 
+PRIVATE>
+
 : S ( -- ) updates-cond-code on ;
 
 : S> ( -- ? ) updates-cond-code [ f ] change ;
 
+<PRIVATE
+
 : sinsn ( bitspec -- )
     bitfield S> [ 20 2^ bitor ] when (insn) ; inline
 
@@ -100,21 +123,25 @@ M: register shift-imm/reg ( Rs Rm shift -- n )
         { register 0 }
     } bitfield ;
 
-GENERIC: shifter-op ( shifter-op -- n )
+PRIVATE>
 
 TUPLE: IMM immed rotate ;
 C: <IMM> IMM
 
-M: IMM shifter-op
-    dup IMM-immed swap IMM-rotate
-    { { 1 25 } 8 0 } bitfield ;
-
 TUPLE: shifter Rm by shift ;
 C: <shifter> shifter
 
+<PRIVATE
+
+GENERIC: shifter-op ( shifter-op -- n )
+
+M: IMM shifter-op
+    [ immed>> ] [ rotate>> ] bi { { 1 25 } 8 0 } bitfield ;
+
 M: shifter shifter-op
-    dup shifter-by over shifter-Rm rot shifter-shift
+    [ by>> ] [ Rm>> ] [ shift>> ] tri shift-imm/reg ;
-    shift-imm/reg ;
+
+PRIVATE>
 
 : <LSL> ( Rm shift-imm/Rs -- shifter-op ) BIN: 00 <shifter> ;
 : <LSR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 01 <shifter> ;
@@ -123,9 +150,10 @@ M: shifter shifter-op
 : <RRX> ( Rm -- shifter-op ) 0 <ROR> ;
 
 M: register shifter-op 0 <LSL> shifter-op ;
-
 M: integer shifter-op 0 <IMM> shifter-op ;
 
+<PRIVATE
+
 : addr1 ( Rd Rn shifter-op opcode -- )
     {
         21 ! opcode
@@ -134,29 +162,37 @@ M: integer shifter-op 0 <IMM> shifter-op ;
         { register 12 } ! Rd
     } sinsn ;
 
-: AND BIN: 0000 addr1 ;
+PRIVATE>
-: EOR BIN: 0001 addr1 ;
-: SUB BIN: 0010 addr1 ;
-: RSB BIN: 0011 addr1 ;
-: ADD BIN: 0100 addr1 ;
-: ADC BIN: 0101 addr1 ;
-: SBC BIN: 0110 addr1 ;
-: RSC BIN: 0111 addr1 ;
-: ORR BIN: 1100 addr1 ;
-: BIC BIN: 1110 addr1 ;
 
-: MOV f swap BIN: 1101 addr1 ;
+: AND ( Rd Rn shifter-op -- ) BIN: 0000 addr1 ;
-: MVN f swap BIN: 1111 addr1 ;
+: EOR ( Rd Rn shifter-op -- ) BIN: 0001 addr1 ;
+: SUB ( Rd Rn shifter-op -- ) BIN: 0010 addr1 ;
+: RSB ( Rd Rn shifter-op -- ) BIN: 0011 addr1 ;
+: ADD ( Rd Rn shifter-op -- ) BIN: 0100 addr1 ;
+: ADC ( Rd Rn shifter-op -- ) BIN: 0101 addr1 ;
+: SBC ( Rd Rn shifter-op -- ) BIN: 0110 addr1 ;
+: RSC ( Rd Rn shifter-op -- ) BIN: 0111 addr1 ;
+: ORR ( Rd Rn shifter-op -- ) BIN: 1100 addr1 ;
+: BIC ( Rd Rn shifter-op -- ) BIN: 1110 addr1 ;
+
+: MOV ( Rd shifter-op -- ) [ f ] dip BIN: 1101 addr1 ;
+: MVN ( Rd shifter-op -- ) [ f ] dip BIN: 1111 addr1 ;
 
 ! These always update the condition code flags
-: (CMP) >r f -rot r> S addr1 ;
+<PRIVATE
 
-: TST BIN: 1000 (CMP) ;
+: (CMP) ( Rn shifter-op opcode -- ) [ f ] 3dip S addr1 ;
-: TEQ BIN: 1001 (CMP) ;
+
-: CMP BIN: 1010 (CMP) ;
+PRIVATE>
-: CMN BIN: 1011 (CMP) ;
+
+: TST ( Rn shifter-op -- ) BIN: 1000 (CMP) ;
+: TEQ ( Rn shifter-op -- ) BIN: 1001 (CMP) ;
+: CMP ( Rn shifter-op -- ) BIN: 1010 (CMP) ;
+: CMN ( Rn shifter-op -- ) BIN: 1011 (CMP) ;
 
 ! Multiply instructions
+<PRIVATE
+
 : (MLA) ( Rd Rm Rs Rn a -- )
     {
         21
@@ -168,9 +204,6 @@ M: integer shifter-op 0 <IMM> shifter-op ;
         { 1 4 }
     } sinsn ;
 
-: MUL ( Rd Rm Rs -- ) f 0 (MLA) ;
-: MLA ( Rd Rm Rs Rn -- ) 1 (MLA) ;
-
 : (S/UMLAL)  ( RdLo RdHi Rm Rs s a -- )
     {
         { 1 23 }
@@ -184,8 +217,15 @@ M: integer shifter-op 0 <IMM> shifter-op ;
         { 1 4 }
     } sinsn ;
 
-: SMLAL 1 1 (S/UMLAL) ; : SMULL 1 0 (S/UMLAL) ;
+PRIVATE>
-: UMLAL 0 1 (S/UMLAL) ; : UMULL 0 0 (S/UMLAL) ;
+
+: MUL ( Rd Rm Rs -- ) f 0 (MLA) ;
+: MLA ( Rd Rm Rs Rn -- ) 1 (MLA) ;
+
+: SMLAL ( RdLo RdHi Rm Rs -- ) 1 1 (S/UMLAL) ;
+: SMULL ( RdLo RdHi Rm Rs -- ) 1 0 (S/UMLAL) ;
+: UMLAL ( RdLo RdHi Rm Rs -- ) 0 1 (S/UMLAL) ;
+: UMULL ( RdLo RdHi Rm Rs -- ) 0 0 (S/UMLAL) ;
 
 ! Miscellaneous arithmetic instructions
 : CLZ ( Rd Rm -- )
@@ -203,39 +243,21 @@ M: integer shifter-op 0 <IMM> shifter-op ;
 ! Status register acess instructions
 
 ! Load and store instructions
+<PRIVATE
+
 GENERIC: addressing-mode-2 ( addressing-mode -- n )
 
-TUPLE: addressing p u w ;
+TUPLE: addressing base p u w ;
-: <addressing> ( delegate p u w -- addressing )
+C: <addressing> addressing
-    {
-        set-delegate
-        set-addressing-p
-        set-addressing-u
-        set-addressing-w
-    } addressing construct ;
 
 M: addressing addressing-mode-2
-    {
+    { [ p>> ] [ u>> ] [ w>> ] [ base>> addressing-mode-2 ] } cleave
-        addressing-p addressing-u addressing-w delegate
-    } get-slots addressing-mode-2
     { 0 21 23 24 } bitfield ;
 
 M: integer addressing-mode-2 ;
 
 M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ;
 
-! Offset
-: <+> 1 1 0 <addressing> ;
-: <-> 1 0 0 <addressing> ;
-
-! Pre-indexed
-: <!+> 1 1 1 <addressing> ;
-: <!-> 1 0 1 <addressing> ;
-
-! Post-indexed
-: <+!> 0 1 0 <addressing> ;
-: <-!> 0 0 0 <addressing> ;
-
 : addr2 ( Rd Rn addressing-mode b l -- )
     {
         { 1 26 }
@@ -246,16 +268,32 @@ M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ;
         { register 12 }
     } insn ;
 
-: LDR 0 1 addr2 ;
+PRIVATE>
-: LDRB 1 1 addr2 ;
+
-: STR 0 0 addr2 ;
+! Offset
-: STRB 1 0 addr2 ;
+: <+> ( base -- addressing ) 1 1 0 <addressing> ;
+: <-> ( base -- addressing ) 1 0 0 <addressing> ;
+
+! Pre-indexed
+: <!+> ( base -- addressing ) 1 1 1 <addressing> ;
+: <!-> ( base -- addressing ) 1 0 1 <addressing> ;
+
+! Post-indexed
+: <+!> ( base -- addressing ) 0 1 0 <addressing> ;
+: <-!> ( base -- addressing ) 0 0 0 <addressing> ;
+
+: LDR  ( Rd Rn addressing-mode -- ) 0 1 addr2 ;
+: LDRB ( Rd Rn addressing-mode -- ) 1 1 addr2 ;
+: STR  ( Rd Rn addressing-mode -- ) 0 0 addr2 ;
+: STRB ( Rd Rn addressing-mode -- ) 1 0 addr2 ;
 
 ! We might have to simulate these instructions since older ARM
 ! chips don't have them.
 SYMBOL: have-BX?
 SYMBOL: have-BLX?
 
+<PRIVATE
+
 GENERIC# (BX) 1 ( Rm l -- )
 
 M: register (BX) ( Rm l -- )
@@ -270,24 +308,21 @@ M: register (BX) ( Rm l -- )
         { register 0 }
     } insn ;
 
-M: word (BX) 0 swap (BX) rc-relative-arm-3 rel-word ;
+PRIVATE>
 
-M: label (BX) 0 swap (BX) rc-relative-arm-3 label-fixup ;
+: BX ( Rm -- ) have-BX? get [ 0 (BX) ] [ [ PC ] dip MOV ] if ;
 
-: BX have-BX? get [ 0 (BX) ] [ PC swap MOV ] if ;
+: BLX ( Rm -- ) have-BLX? get [ 1 (BX) ] [ LR PC MOV BX ] if ;
-
-: BLX have-BLX? get [ 1 (BX) ] [ LR PC MOV BX ] if ;
 
 ! More load and store instructions
+<PRIVATE
+
 GENERIC: addressing-mode-3 ( addressing-mode -- n )
 
-: b>n/n ( b -- n n ) dup -4 shift swap HEX: f bitand ;
+: b>n/n ( b -- n n ) [ -4 shift ] [ HEX: f bitand ] bi ;
 
 M: addressing addressing-mode-3
-    [ addressing-p ] keep
+    { [ p>> ] [ u>> ] [ w>> ] [ base>> addressing-mode-3 ] } cleave
-    [ addressing-u ] keep
-    [ addressing-w ] keep
-    delegate addressing-mode-3
     { 0 21 23 24 } bitfield ;
 
 M: integer addressing-mode-3
@@ -318,10 +353,12 @@ M: object addressing-mode-3
         { register 12 }
     } insn ;
 
-: LDRH 1 1 0 addr3 ;
+PRIVATE>
-: LDRSB 0 1 1 addr3 ;
+
-: LDRSH 1 1 1 addr3 ;
+: LDRH  ( Rn Rd addressing-mode -- ) 1 1 0 addr3 ;
-: STRH 1 0 0 addr3 ;
+: LDRSB ( Rn Rd addressing-mode -- ) 0 1 1 addr3 ;
+: LDRSH ( Rn Rd addressing-mode -- ) 1 1 1 addr3 ;
+: STRH  ( Rn Rd addressing-mode -- ) 1 0 0 addr3 ;
 
 ! Load and store multiple instructions