arm-asm.f

这个是关于G.726算法的源程序

	WHILE
		LABEL-SIZE +
		DUP LABELS-END U<
	WHILE
	REPEAT
		1 ABORT" ARM Assembler: Too many labels"
	THEN
;

: CREATE-LABEL   ( c-addr1 u1 -- a-addr )
	MAX-LABEL-NAME-SIZE MIN
	ALLOC-LABEL >R
	R@ LABEL>NAME
	2DUP C!
	CHAR+ SWAP CHARS MOVE
	R>
;

: EQUAL   ( c-addr1 u1 c-addr2 u2 -- flag )   \ flag true if strings same
	ROT OVER <>
	IF DROP 2DROP FALSE EXIT THEN
	0 ?DO
		OVER I + C@
		OVER I + C@
		<> IF UNLOOP 2DROP FALSE EXIT THEN
	LOOP
	2DROP TRUE
;

: FIND-LABEL   ( c-addr u -- a-addr true | c-addr u false )
	MAX-LABEL-NAME-SIZE MIN
	2>R
	LABELS
	BEGIN
		DUP LABEL>NAME COUNT
		2R@ EQUAL 0=
	WHILE
		LABEL-SIZE +
		DUP LABELS-END U<
	WHILE
	REPEAT
		DROP 2R> FALSE
		EXIT
	THEN
	2R> 2DROP TRUE
;

\ ----------------------------------------------------------------------------
\ Unresolved Label references
\
\ Structure of object is
\   CELL REF-LINK   \ link to next unresolved references
\   CELL ORIGIN     \ value for OP-ORIGIN where reference occurred
\   CELL OP-ADDR    \ address of instruction where reference occurred
\   CELL '#         \ xt of word handling immediate arguments for reference

: REF>REF-LINK   ( a-addr1 -- a-addr2 )
	;

: REF>ORIGIN   ( a-addr1 -- a-addr2 )
	CELL+ ;

: REF>OP-ADDR   ( a-addr1 -- a-addr2 )
	CELL+ CELL+ ;

: REF>'#   ( a-addr1 -- a-addr2 )
	CELL+ CELL+ CELL+ ;

4 CELLS CONSTANT REF-SIZE

20 CONSTANT #LABEL-REFS   \ Max number of unresolved label references
CREATE LABEL-REFS   \ Size of label reference object
#LABEL-REFS REF-SIZE * ALLOT
HERE CONSTANT LABEL-REFS-END
 
: ALLOC-LABEL-REF   ( -- a-addr )   \ Allocate a reference to a label
	LABEL-REFS
	BEGIN
		DUP REF>ORIGIN @
	WHILE
		REF-SIZE +
		DUP LABEL-REFS-END =
		IF 1 ABORT" ARM Assembler: Too many label references" THEN
	REPEAT
;

: CREATE-LABEL-REF   ( a-addr -- )   \ Create reference to label a-addr
	ALLOC-LABEL-REF >R

	DUP LABEL>REF-LINK @      \ get old head of ref list
	R@ REF>REF-LINK !         \ link to old head from new ref
	R@ SWAP LABEL>REF-LINK !  \ make new ref the head

	CODE-ORIGIN @ R@ REF>ORIGIN  !
	CODE-HERE R@ REF>OP-ADDR !
	'# @ R> REF>'# !
;

: RESOLVE-REF   ( x a-addr -- x a-addr )   \ Ref a-addr resolves to value x
	CODE-ORIGIN @ >R

	>R
	OP-RESET

	FFFFFF10 REGISTER-LOCATION !
	R@ REF>ORIGIN @ CODE-ORIGIN !
	R@ REF>OP-ADDR @ @ OP-VALUE !

	DUP R@ REF>'# @ EXECUTE

	OP-VALUE @
	R@ REF>OP-ADDR @ !

	OP-RESET
	R> 0 OVER REF>ORIGIN !   \ clear ref origin to indicate it is free

	R> CODE-ORIGIN !
;

: LABEL-RESOLVE   ( a-addr -- )   \ Resolve all references to a label
	DUP LABEL>VALUE @
	SWAP LABEL>REF-LINK
	BEGIN
		DUP @    \ get ref-link
		0 ROT !  \ clear ref-link
		DUP
	WHILE
		RESOLVE-REF
		REF>REF-LINK
	REPEAT
	2DROP
;

: CHECK-LABELS-RESOLVED   ( -- )
	0 LABELS
	BEGIN
		DUP LABEL>REF-LINK @
		IF
			." Unresolved label: " DUP LABEL>NAME COUNT TYPE CR
			>R 1+ R>
		THEN
		LABEL-SIZE +
		DUP LABELS-END U< 0=
	UNTIL
	DROP
	ABORT" ARM Assembler: Unresolved labels"
;


\ ----------------------------------------------------------------------------
\ Top level words for labels

: LABELS-RESET   ( -- )   \ Clear all labels and references
	LABELS LABELS-END OVER - ERASE
	LABEL-REFS LABEL-REFS-END OVER - ERASE
;

: GET-LABEL   ( <spaces>"name" -- a-addr flag )   \ Find label or create one
	\ flag is true if label has a value assigned.
	BL WORD COUNT FIND-LABEL
	IF
		DUP LABEL>REF-LINK @ 0=
	ELSE
		CREATE-LABEL FALSE
	THEN
;

PUBLIC: L=    ( x <spaces>"name" -- )   \ ARM Assembler, assign value to label
	OP-END
	GET-LABEL
	ABORT" Assembler: Label already defined"
	SWAP OVER LABEL>VALUE !
	LABEL-RESOLVE
;

PUBLIC: L:    ( <spaces>"name" -- )   \ ARM Assembler, define a label
	OP-END  CODE-ORIGIN @ L= ;

PUBLIC: L#    ( <spaces>"name" -- )   \ ARM Assembler, label reference
	GET-LABEL
	IF
		LABEL>VALUE @   \ use address from label
	ELSE
		CREATE-LABEL-REF
		CODE-ORIGIN @   \ use current address as a dummy value
	THEN
	'# @ EXECUTE
;

\ ----------------------------------------------------------------------------
\ Pseudo instructions

PUBLIC: .    ( -- addr )   \ ARM Assembler, current code address
	CODE-ORIGIN @ ;

: DCD#   ( x -- )
	FFFFFFFF OP-BUILD ;

INSTRUCTIOND# dcd    ( -- addr )   \ ARM Assembler, inline constant
	0 , 0 , FFFFFFFF , ' DCD# , 0 ,

\ ----------------------------------------------------------------------------
\ Top level words for assembler

PUBLIC: [[   ( -- )   \ ARM Assembler, add FORTH wordlist to search order
	ALSO FORTH ;

PUBLIC: ]]   ( -- )   \ ARM Assembler, revert action of [[
	PREVIOUS ;

PUBLIC: CODE-BEGIN   ( a-addr -- )   \ Start code assembly
	CODE-ORIGIN !
	LABELS-RESET
	OP-RESET
;

PUBLIC: CODE-END   ( -- )   \ End code asembly
	OP-END
	CHECK-LABELS-RESOLVED
;

\ ----------------------------------------------------------------------------
\ Condition codes...

: CONDITION   ( u "<spaces>name" -- )   \ Definer for condition codes
	PUBLIC-CREATE ,
	DOES>   ( -- )
	@ F0000000 OP-BUILD
;

00000000 CONDITION eq   \ ARM Assembler, condition code
10000000 CONDITION ne   \ ARM Assembler, condition code
20000000 CONDITION cs   \ ARM Assembler, condition code
30000000 CONDITION cc   \ ARM Assembler, condition code
40000000 CONDITION mi   \ ARM Assembler, condition code
50000000 CONDITION pl   \ ARM Assembler, condition code
60000000 CONDITION vs   \ ARM Assembler, condition code
70000000 CONDITION vc   \ ARM Assembler, condition code
80000000 CONDITION hi   \ ARM Assembler, condition code
90000000 CONDITION ls   \ ARM Assembler, condition code
A0000000 CONDITION ge   \ ARM Assembler, condition code
B0000000 CONDITION lt   \ ARM Assembler, condition code
C0000000 CONDITION gt   \ ARM Assembler, condition code
D0000000 CONDITION le   \ ARM Assembler, condition code
E0000000 CONDITION al   \ ARM Assembler, condition code
F0000000 CONDITION nv   \ ARM Assembler, condition code

\ ----------------------------------------------------------------------------
\ Register operands

: ?BAD-REGISTER   ( x -- )
	ABORT" ARM Assembler: Unexpected or bad register operand"
;

: REGISTER   ( u "<spaces>name" -- )   \ Definer for CPU register words
	PUBLIC-CREATE ,
	DOES>   ( -- )
	@ {-FLAG @
	IF
		\ register in ldm/stm list...
		DUP 0F U> ?BAD-REGISTER
		1 SWAP LSHIFT DUP OP-BUILD
		EXIT
	THEN

	\ get bit position for register in the op-code were building...
	REGISTER-LOCATION DUP @ DUP 8 RSHIFT FF000000 OR ROT !

	DUP -1 = ?BAD-REGISTER

	\ check register type
	2DUP XOR 20 AND ?BAD-REGISTER

	OVER >R

	\ create values for OP-BUILD
	SWAP 0F AND SWAP 1F AND 
	0F OVER LSHIFT >R LSHIFT R>

	\ add op-code bits for shift value if required
	SHIFT-FLAG @
	IF
		SWAP 010 OR
		SWAP 090 OR
	THEN

	\ execute special action for RM register
	DUP 0F AND
	IF
		R@ 'RM @ EXECUTE
	THEN

	R> DROP
	OP-BUILD   \ include bits in op-code we're building
;

00 REGISTER r0   \ ARM Assembler, CPU register
01 REGISTER r1   \ ARM Assembler, CPU register
02 REGISTER r2   \ ARM Assembler, CPU register
03 REGISTER r3   \ ARM Assembler, CPU register
04 REGISTER r4   \ ARM Assembler, CPU register
05 REGISTER r5   \ ARM Assembler, CPU register
06 REGISTER r6   \ ARM Assembler, CPU register
07 REGISTER r7   \ ARM Assembler, CPU register
08 REGISTER r8   \ ARM Assembler, CPU register
09 REGISTER r9   \ ARM Assembler, CPU register
0A REGISTER r10   \ ARM Assembler, CPU register
0B REGISTER r11   \ ARM Assembler, CPU register
0C REGISTER r12   \ ARM Assembler, CPU register
0D REGISTER r13   \ ARM Assembler, CPU register
0E REGISTER r14   \ ARM Assembler, CPU register
0F REGISTER r15   \ ARM Assembler, CPU register
80 REGISTER -r0   \ ARM Assembler, CPU register
81 REGISTER -r1   \ ARM Assembler, CPU register
82 REGISTER -r2   \ ARM Assembler, CPU register
83 REGISTER -r3   \ ARM Assembler, CPU register
84 REGISTER -r4   \ ARM Assembler, CPU register
85 REGISTER -r5   \ ARM Assembler, CPU register
86 REGISTER -r6   \ ARM Assembler, CPU register
87 REGISTER -r7   \ ARM Assembler, CPU register
88 REGISTER -r8   \ ARM Assembler, CPU register
89 REGISTER -r9   \ ARM Assembler, CPU register
8A REGISTER -r10   \ ARM Assembler, CPU register
8B REGISTER -r11   \ ARM Assembler, CPU register
8C REGISTER -r12   \ ARM Assembler, CPU register
8D REGISTER -r13   \ ARM Assembler, CPU register
8E REGISTER -r14   \ ARM Assembler, CPU register
8F REGISTER -r15   \ ARM Assembler, CPU register
20 REGISTER c0   \ ARM Assembler, coprocessor register
21 REGISTER c1   \ ARM Assembler, coprocessor register
22 REGISTER c2   \ ARM Assembler, coprocessor register
23 REGISTER c3   \ ARM Assembler, coprocessor register
24 REGISTER c4   \ ARM Assembler, coprocessor register
25 REGISTER c5   \ ARM Assembler, coprocessor register
26 REGISTER c6   \ ARM Assembler, coprocessor register
27 REGISTER c7   \ ARM Assembler, coprocessor register
28 REGISTER c8   \ ARM Assembler, coprocessor register
29 REGISTER c9   \ ARM Assembler, coprocessor register
2A REGISTER c10   \ ARM Assembler, coprocessor register
2B REGISTER c11   \ ARM Assembler, coprocessor register
2C REGISTER c12   \ ARM Assembler, coprocessor register
2D REGISTER c13   \ ARM Assembler, coprocessor register
2E REGISTER c14   \ ARM Assembler, coprocessor register
2F REGISTER c15   \ ARM Assembler, coprocessor register
PUBLIC: sp r13 ;   \ ARM Assembler, alias for r13
PUBLIC: -sp -r13 ;   \ ARM Assembler, alias for r13
PUBLIC: lr r14 ;   \ ARM Assembler, alias for r14
PUBLIC: -lr -r14 ;   \ ARM Assembler, alias for r14
PUBLIC: pc r15 ;   \ ARM Assembler, alias for r15
PUBLIC: -pc -r15 ;   \ ARM Assembler, alias for r15

\ ----------------------------------------------------------------------------
\ Shift operands

: SHIFT#   ( x -- )   \ Handle immediate operand for shifts
	DUP 1- SHIFT-FLAG @ U> IF INVALID# THEN
	1F AND 7 LSHIFT F90 OP-BUILD
	RESET-#
;
	
: SHIFT   ( n x -- )   \ Definer for shift operand words
	PUBLIC-CREATE , ,
	DOES>   ( -- )
	DUP @ 060 OP-BUILD 
	CELL+ @ SHIFT-FLAG !
	['] SHIFT# '# !
	OP-DEFAULT @ FFFFF0FF AND OP-DEFAULT !   \ force more operands to be given
;

1E 000 SHIFT lsl   ( -- )   \ ARM Assembler, shift operator
1F 020 SHIFT lsr   ( -- )   \ ARM Assembler, shift operator
1F 040 SHIFT asr   ( -- )   \ ARM Assembler, shift operator
1E 060 SHIFT ror   ( -- )   \ ARM Assembler, shift operator

PUBLIC: rrx   ( -- )   \ ARM Assembler, shift operator
	060 FF0 OP-BUILD ;

\ ----------------------------------------------------------------------------
\ Data processing instructions...

: ARM-DATA-LITERAL-ROTATE-COUNT   ( u -- u n )   \ Used by ARM-DATA-LITERAL
	0
	OVER 100 U<
	IF EXIT THEN
	BEGIN
		2 +
		2DUP RROTATE 0FF U>
	WHILE
		DUP 1E U<
	WHILE
	REPEAT
		DROP -1
	THEN
;

: ARM-DATA-LITERAL   ( u -- x )   \ Convert u into 12bit data literal
	ARM-DATA-LITERAL-ROTATE-COUNT
	DUP 0= IF DROP EXIT THEN
	DUP 20 U<
	IF
		DUP >R
		RROTATE
		20 R> - 7 LSHIFT OR
		EXIT
	THEN
	INVALID#
;

: DATA#   ( x -- )   \ Handle literal operand for data instructions
	ARM-DATA-LITERAL
	02000000 OR 02000FFF
	OP-BUILD
;