hi

AT91所有开发板的资料 AT91所有开发板的资料

: A1>R ( --) 4 # {-} RSP [] A1, STR  ;
: A2>R ( --) 4 # {-} RSP [] A2, STR  ;
: R>A1 ( --) 4 # {+} RSP ][ A1, {!} LDR  ;
: R>A2 ( --) 4 # {+} RSP ][ A2, {!} LDR  ;
: A1>D ( --) 4 # {-} DSP [] A1, STR  ;
: A2>D ( --) 4 # {-} DSP [] A2, STR  ;
: D>A1 ( --) 4 # {+} DSP ][ A1, {!} LDR  ;
: D>A2 ( --) 4 # {+} DSP ][ A2, {!} LDR  ;


: (next) ( --) 4 # {+} RSP ][ PC, {!} LDR  ;
: (before) ( --) 4 # {-} RSP [] LR, STR  ;
: (call) ( a --) Here -   BL ;

: (lit) ( -- n; next cell has number)
  R>A1                    \ Pop Return Address which points to lit.
  4 # {+} A1 [] A2, LDR   \ Fetch literal and incr return address
  A2>D   A1>R  ;          \ Push literal & Push new return address

." Loaded" CR CR

\ CIAO
\ ------------------------------------------------------

." Loading Target Compiler..."

                         Forth Definitions
: Twords words ;

HEX
: Clean ( --;word in input) \ removes last char from a word name
  ' >lfa >nfa >R            \ push nfa
    0 I c@ 7F AND I + c!   \ put 0 in char pos
    I c@ 1 - R> c! ;        \ Decrement the count

Hex
: flipper ( -- a) \ toggles the start address for target compiling
  Here 8000 >   IF  2000  ELSE  8000  ENDIF
  ." New B4 for " .Platform  ."  starts at: " dup u. cr ;

VARIABLE 'Target   Flipper 'TARGET !
VARIABLE 'First                     \ Address of PFA of the first word of the
                                    \ new forth to close the voc.
VARIABLE '(.")                      \ Address of print string internal to
                                    \ patch in
VARIABLE 'Lit                       \ Address of Lit to patch in
VARIABLE 'Root                      \ Address of the Root Voc in the target.
VARIABLE 'End                       \ Address to store end of Forth for Boot Sequence

: Complete ( --) \ Seal up the new Forth Voc and jump to new Forth 
  'First @ OFF ." DONE!" ciao CR  ." And away we go..." CR 'Target @ >R ;

\ Target compilation  check routines
HEX
: ?Target ( a -- a)
  dup 'Target @ Here within? 
  IF ." WARNING Target word in USE- " 'Word Count Type CR Endif ;

: ?Host
  dup 'Target @ Here within? 0= 
  IF ." WARNING Host word being Compiled- " 'Word Count Type CR Endif ;

\ Target literal Handling and words that use literal
: Literal ( n --) 
  'Lit @ ?dup IF   !call ,
              ELSE ." WARNING Uninitialized 'Lit for " u. cr
              ENDIF ; IMMEDIATE

DECIMAL
: ."         \ Special version which put in the target (.")
  state @ 0= IF 34 word count type EXIT  ENDIF \ not compiling, print it
  '(.") @ !call \ i.e. we do Compile (.") for the target
  Mark
    34 word count 
   >R  I c,   Here I cmove  
   R>  Allot Aligned
  Resolve ; IMMEDIATE

\ USER VARIABLES
: 'User     'Target @ 4 + ;   : +User     'Target @ 8 + ;

: User
  :
  +User @ [compile] Literal
  'User   [compile] Literal
  +User @ + +User !
[ 4asm ]
  D>A1
  A1 [] A2, LDR   \ Fetch contents of 'User
  D>A1            \ Get +User  
  A1 A2 A2, ADD   \ The rest is history.
  A2>D
  !Next
[Compile] [  ;   

                      Forth Definitions

DECIMAL
: interpret  ( --)
  BEGIN
    ( ?stack) 32 token c@ 0<>
  WHILE 
     'word dup >UC find ?dup
      IF state @
            IF  1 =
                IF ?Target execute ELSE  ?Host   !call ENDIF
            ELSE drop  execute
            ENDIF
       ELSE number?
            IF   state @ IF [compile] literal ENDIF
            ELSE 0 error
            ENDIF
       ENDIF
   REPEAT ;

: (Xquit) \ --
  0 state !
  BEGIN  
 \     (r0) @ rp!
     query interpret  state @ 0= IF  prompt  ENDIF
  0 UNTIL ;


\ Mapped 
(Xquit)


\ ------------------------------   
\ TARGET FORTH STARTS HERE

Vocabulary Target   Target Definitions

'TARGET @ dp !     \ New Forth Starts Here
0 ,                \ Boot Vector goes here & we put it in 'Boot later
Here 8 + ,         \ Will contain 'User Space
0 ,                \ Will contain #User - length of use space
Hex 300 Allot      \ Make some space for the User Variables

                    Forth Target Definitions 4ASM
\ My first word.

: LIT [ (lit) ] ;

                     Forth Target Definitions
' LIT 4 - 'First !        \ Store the First Words LFA for patching Later.
' LIT 'LIT !              \ store for use by host version of literal.

\ Save IP here for this Task is Tasking. 
\ This will be the first word of the new forth. We'll patch it later.

4 User (IP) 
 
\ Setup up Return Stack Full Decending
Decimal 132 User RStack
          4 User (R0)
RStack 128 + (R0)  !        \ (R0) points to where the return stack starts 

\ Setup up Data Stack Full Decending
Decimal 132 User DStack
          4 User (S0)
DStack 128 + (S0)   !       \ (S0) points to where the data stack starts 

\ Setup Current &  Context. 
Decimal 4 User Current    4 User Context  
        4 User !Root                      \ Cold Forth Voc copy

\ IO Buffs
Decimal 132 User TIB 
TIB 4 + TIB !           \ TIB points to where the terminal input buffer starts 

4 User Span                          4 User >In     4 User State
4 User Base 10 Base !                4 User dp      4 User fence
4 User 'Boot  'Target @ 'Boot !
4 User Cond BINARY 1110 Cond !  \ record ASM cond flags & default to {AL}

\ B4 Primitives
\ assumes that a1 and a2 are the working
\ registers and that D and R are the data and
\ return stacks respectively.
 
Target Definitions 4ASM
DECIMAL

: drop ( n --) code[   4 # DSP DSP, ADD  ( d>a1) ]code 
: 2drop ( n1 n2 --) code[  8 # DSP DSP, ADD  ( d>a1) ]code 
: R>Drop ( --) code[   4 # RSP RSP, ADD  ( d>a1) ]code
: dup ( n1 -- n1 n1)  code[ 4 # {+} DSP ][ A1, LDR a1>d ]code
: swap ( n1 n2 -- n2 n1)  code[ d>a2 d>a1   a2>d a1>d ]code
: over ( n1 n2 -- n1 n2 n1) code[  8 # {+} DSP ][ A1, LDR a1>d ]code
: nip ( n1 n2 -- n2) 
  Code[ 4 # {+} DSP ][ A1, {!} LDR   4 # {+} DSP ][ A1, STR ]Code
: >R ( n --)  Code[ d>a1  a1>r ]Code
: R> ( -- n)  Code[ r>a1  a1>d ]Code
: I ( -- n)   Code[ 4 # {+} RSP ][ A1, LDR a1>d ]Code
: FINAL ( --) Code[ 0 # A1, MOV  4 # {+} RSP ][ A1, STR ]Code
: @ ( a --n)   code[   d>a1  A1 [] A2, LDR   A2>D ]code
: ! ( n a --)  code[   d>a1  d>a2  A1 [] A2, STR  ]code
: C@ ( a --n)  code[   d>a1  A1 [] A2, {B} LDR   A2>D ]code
: C! ( n a --) code[   d>a1   d>a2   A1 [] A2, {B} STR ]code

: rot ( n1 n2 n3 -- n2 n3 n1)
  code[  4 # {+} DSP ][ R0, {!} LDR
         4 # {+} DSP ][ R1, {!} LDR 
         4 # {+} DSP ][ R2, {!} LDR
         4 # {-} DSP [] R1, STR
         4 # {-} DSP [] R0, STR
         4 # {-} DSP [] R2, STR
]code

: = ( n1 n2 -- f) 
code[  D>A1   D>A2       \ pop items to test
    A1 A2, TEQ           \ are they equal?
    0 # A1, MOV          \ assume not and answer 0
    0 # A1, {EQ} MVN     \ however make this -1 if they were
    A1>D
]code

: <> ( n1 n2 -- f)
code[  D>A1   D>A2   \ pop items to test
   A1 A2, TEQ        \ are they not equal?
   0 # A1, MOV       \ assume not and answer 0
   0 # A1, {NE} MVN  \ however make this -1 if they were
   A1>D
]code

: < ( n1 n2 -- f)
code[  D>A2   
   D>A1     
   A2  A1, CMP     \ subtract setting flags accordingly
   0 # A1, MOV       \ assume false
   0 # A1, {LT} MVN   \ however make this -1 if they were
   A1>D
]code


: > ( n1 n2 -- f)
code[  D>A2   
   D>A1     
   A2  A1, CMP     \ subtract setting flags accordingly
   0 # A1, MOV       \ assume false
   0 # A1, {GT} MVN   \ however make this -1 if they were
   A1>D
]code

: 0= ( n1 -- f)
code[  D>A1             \ pop item to test
   0 # A1, TEQ       \ are they equal?
   0 # A1, MOV       \ assume not and answer 0
   0 # A1, {EQ} MVN   \ however make this -1 if they were
   A1>D
]code

: 0<> ( n1 -- f)
code[  D>A1             \ pop item to test
   0 # A1, TEQ          \ are they not equal?
   0 # A1, MOV          \ assume not and answer 0
   0 # A1, {NE} MVN     \ however make this -1 if they were
   A1>D
]code

: 0 ( -- 0) code[ 0 # A1, MOV  A1>D ]code
: 1 ( -- 1) code[ 1 # A1, MOV  A1>D ]code
: 2 ( -- 2) code[ 2 # A1, MOV  A1>D ]code
: 4 ( -- 4) code[ 4 # A1, MOV  A1>D ]code
: -1 ( -- -1) code[ 0 # A1, MVN A1>D ]code


: 1+ ( n -- n+1) code[ D>A1   1 # A2, MOV    A2 A1 A1, ADD   A1>D ]code

: - ( n1 n2 -- n' ) code[   D>A1   D>A2   A1 A2 A2, SUB   A2>D ]code
: + ( n1 n2 -- n' ) code[   D>A1   D>A2   A1 A2 A2, ADD   A2>D ]code

: +! ( n a --)
code[   d>a1          \ get addr         
        d>a2          \ get amount
        A1 [] r0, LDR \ get content of addr
        A2 r0 r0, ADD \ add amount
        A1 [] r0, STR \ put it back 
]code
   
: AND ( n1 n2 -- n' ) code[   D>A1   D>A2   A1 A2 A2, AND   A2>D ]code 
: OR ( n1 n2 -- n' )   code[   D>A1   D>A2   A1 A2 A2, ORR   A2>D ]code  

\ Use this version for (M) ARM parts that support Multiply
\ : U* ( n1 n2 -- 64b )
\ [
\    D>A1
\   D>A2
\   A1 A2 R4, R5, UMULL
\   4 # {-} DSP [] R5, STR
\   4 # {-} DSP [] R4, STR
\ ] ;
           
    
: >> \ n1 n2 -- n1 shifted right by n2
code[
   D>A1             \ pop shift
   D>A2             \ pop data
   A1 LSR A2 R5, MOV
   4 # {-} DSP [] R5, STR 
]code

: << \ n1 n2 -- n1 shifted left by n2
code[
   D>A1             \ pop shift
   D>A2             \ pop data
   A1 LSL A2 R5, MOV
   4 # {-} DSP [] R5, STR 
]code

: within?    \ n1 n2 n3 -- t|f true if n1 is within range n2 to n3
Code[
  4 # {+} DSP ][ R0, {!} LDR  \ Get upper bound
  4 # {+} DSP ][ R1, {!} LDR  \ Get Lower bound
  4 # {+} DSP ][ R2, {!} LDR  \ Get value
  0 # A1, MOV                 \ Assume False
  R0  R2, CMP                 \ Is it above upper bound?
  {GT} A1>D                   \ Yes return false
  LR PC,  {GT} MOV            \
  R1  R2, CMP                 \ Is it below the lower bound? 
  {LT} A1>D                   \ Yes return false
  LR PC,  {LT} MOV
  0 # A1, MVN                 \ Passed all the tests, Return True
  A1>D                    
]Code

: ?dup ( n1 -- 0 | n1 n1)  
code[ 
     4 # {+} DSP ][ A1, LDR \ get n
     0 # A1, TEQ 
     {NE} a1>d 
]code

                      Forth
\ IO
Evaluator7T? IF( \ DEMON IO
                      Forth Target Definitions 4asm
: (TTY-emit) \ c --
code[    4 # {+} DSP ][ R0, {!} LDR    \ store char in R0
         0 >Demon                      \ ask demon to output it
]code

: (TTY-Key) \ -- c
code[  4 >Demon   4 # {-} DSP [] R0, STR \ SWI and push R0 which holds char
]code

                      Forth

 )ELSE( \ ANGEL IO
                      Forth Target Definitions 4asm

: (tty-emit) ( c --)
code[ D>A1             \ DSP now points to memory containing char
      DSP R1, MOV      \ set up R1 to point address of char
      3 >Angel         \ print it via angel
 ]code                 \ pop it to get rid of it. (automatic)

: (TTY-Key) \ -- c
code[  0 # R1, MOV      \ R1 must be 0
       7 >Angel         \ aks the nice angel for a char
       R0 A1, MOV       \ R0 has the char
       A1>D             \ which we push.
]code

                      Forth 
)ENDIF

\ SECONDARIES
                       Forth Target Definitions

: NOOP ( --) ;

\ : Nip ( n1 n2 -- n2) Swap Drop ;

\ U* High level version for non M ARMs
: U* ( n1 n2 -- 64b )
  dup 0=                              \ is the multiplier 0?
  IF    Nip                           \ If we are multiplying by 0 return 0
  ELSE  0 Swap  FOR Over + REPEAT Nip \ multiply by repeated addition
  ENDIF 0 ;                           \ leave 0 for high 32bits Filthy Hack!

\ CHARACTER IO
: Key Noop ;           : Emit Noop ;
Now Key is (TTY-Key)   Now Emit is (TTY-emit)

DECIMAL                            
: star ( --)  42 emit ;   : space ( --) 32 emit ;  
: plus ( --) 43 emit ;    : dot ( --) 46 emit ;

: (type) ( a n --)   FOR dup C@ emit 1+ REPEAT drop ;

: Type Noop ;   Now Type is (type)

Forth Target Definitions 4ASM

: NEGATE ( n -- -n)
Code[    D>A2   A2 A1, MVN    0 # R0, MVN   R0 A1 A1, SUB    A1>D ]Code

                     Forth Target Definitions

: ON ( a --)  -1 Swap ! ;
: OFF ( a --)  0 Swap ! ;
: MAX ( n1 n2 -- Nmax)  Over Over < IF nip ELSE drop ENDIF ;
: MIN ( n1 n2 -- Nmin)  Over Over < IF drop ELSE nip ENDIF ;
: 0< ( n -- f) 0 < ;

\ We will shove text above Here (Word aligned).

DECIMAL
: Align ( a -- a') dup 3 AND  dup IF 4 Swap - ENDIF + ; 

: 'Word ( --a )   dp @  Align ;

                 Forth Target Definitions 4ASM
HEX
: >nfa ( lfa -- nfa)
Code[ D>A1                \ get lfa
Here
      4 # A1 A1, SUB      \ Subtact Cell size from A1
      A1 [] R2, {B} LDR   \ Get byte pointed to by A1 into R1
      7F # R2 R2, AND     \ don't check the immediate bit
      20 # R2 CMP
Here - {GE} B
      A1>D                \ Push LFA
]Code

: CMove ( a1 a2 u --)
Code[
  4 # {+} DSP ][ R0, {!} LDR    \ store l in R0
  4 # {+} DSP ][ A2, {!} LDR    \ store a2 in A2
  4 # {+} DSP ][ A1, {!} LDR    \ store a2 in A2
Here
  0 # R0, TEQ                   \ end of string?
  LR PC,  {EQ} MOV              \ Yes Exit
  1 # {+} A1 [] R1, {!} {B} LDR \ get a byte and inc
  1 # {+} A2 [] R1, {!} {B} STR \ store it and inc
  1 # R0 R0, SUB                \ decrement count
Here - B                        \ Go round again
]Code