Test programs and Examples

Forth Cross-Compiler for the TMS320C5x

This chapter presents the listing of the file fcc_c50.wft.

Last update:	7-February-1999
State (estimation)	55%

---

/* ===========================================================================
 
 fcc_c50.wft Oliver Singla
 
 Description: This file is the code for the forth cross-compiler
 for the TI C50 DSP RMS320C50 evalation card).
 The link between PC/DSK is a serial link 
 (either COM1: or COM2:)
 
 *************************
 *** UNDER DEVELOPMENT ***
 *************************
 
 =========================================================================== */
 
host
forget <fcc_c50>
: <fcc_c50> ;
 
/*
 open_comm Initialize the serial port (speed, etc.) and save handle
 close_comm Close serial port
 reset_c50 Reset the C50 (if I understood weel, seems that DTR low means a C50 reset)
 init_mon Sequence to perform after the reset of the C50 to initialize the monitor
 read Read a byte from the serial line
 write Write a byte to the serial line
 send Send a byte to the monitor, then wait the echo from the monitor
 sendw Send a 16-bits word to the monitor
 receive Receive a byte from the monitor
 receivew Receive a 16-bits word from the monitor
*/
 
 
$2BF0 const saved_acc
$2BF1 const saved_ar6
$2BF2 const saved_ar7
$2BB8 const userfunct_addr
 
int target_nameddef
int target_anodef
 
$0A00 const target_cp0
$1A00 const target_dp0
$2BD0 const target_s0 // Target stack base
 
int target_cp  // Target current code pointer
int target_dp // Target current data pointer
 
 
// ********************************************
// *** COMMUNICATION WITH THE DSK MONITOR ***
// *** TROUGHT A RS-232 LINK ***
// ********************************************
 
\ Either COM1: or COM2: has been given before compiling this file
const SerialPort:
 
-1 iint serial
 
: handle
 serial @ ;
 
: open_comm
 57600 NOPARITY 8 2 SerialPort: HFLOW SerialOpen serial ! ;
 
: close_comm
 handle -1 <> IF handle SerialClose ENDIF 
 serial -1 ! ;
 
: reset_c50
 0 handle SerialDtr 20 delay 
 1 handle SerialDtr 20 delay ;
 
: read ( --- b )
 handle SerialIn ;
 
: write ( b --- )
 handle SerialOut ;
 
: send ( b --- )
 dup write read != " DSK no more ready!" ?"error ;
 
: sendw ( hilo --- )
 split send send ;
 
: receive ( --- b )
 0 write read ;
 
: receivew ( --- w )
 receive receive swap join ;
 
// Monitor operations
0 const DDM // Dump Data  DSP -> PC
1 const DPM // Dump Program DSP -> PC
2 const DLD // Download Data PC -> DSP
3 const DLP // Download Program PC -> DSP
5 const EXE // Execute
 
: init_mon
 $80 write
 read ESC != " DSK not ready!" ?"error ;
 
: address> ( w --- )
 sendw ;
 
: len> ( w --- )
 sendw ;
 
: address+len> ( w1 w2 --- )
 swap address> len> ;
 
 
// ********************************************
// *** COMMUNICATION WITH THE DSK MONITOR ***
// *** TROUGHT A RS-232 LINK  ***
// ********************************************
 
: dm! ( w a --- )
 DLD send 0 address+len>
 sendw ;
 
: dm@ ( a --- w )
 DDM send 0 address+len>
 receivew ;
 
: dm? ( a --- )
 dm@ h. ;
 
: pm! ( w a --- )
 DLP send 0 address+len>
 sendw ;
 
: pm@ ( a --- w )
 DPM send 0 address+len>
 receivew ;
 
: pm? ( a --- )
 pm@ h. ;
 
: run ( a --- )
 userfunct_addr dm!
 EXE send
 $2BB0 sendw
 $12 write read drop
 reset_c50
 init_mon ;
 
 
// ********************************************
// *** FORTH CROSS-COMPILER ***
// ********************************************
 
// Add a new word into the Program Memory target 
: pm, ( w --- )
 target_cp @ pm! target_cp incr ;
: pm,,
 swap pm, pm, ;
 
 
// ********************************************
// *** TMS320C50 CODE GENERATION ***
// ********************************************
 
: nop $8B00 pm, ;
 
: ret $EF00 pm, ;
: retd $FF00 pm, ;
: retd_neq $FF08 pm, ;
: reti $BE38 pm, ;
: idle $BE22 pm, ;
 
: sacl_* $9080 pm, ;
: sacl_*- $9090 pm, ;
: sacl_*+ $90A0 pm, ;
: sacl_*,ar7  $908F pm, ;
 
: lacc_#i8 ( b --- )
 $B9 join pm, ;
 
: lacc_#i16 ( w --- )
 $BF80 pm, pm, ;
 
: subb ( w --- )
 $BF00 pm, pm, ;
 
: lar_ar4,* $0480 pm, ;
: lar_ar5,* $0580 pm, ;
: lar_ar5,*- $0590 pm, ;
: lar_ar5,*+ $05A0 pm, ;
 
: sar_ar4,*+ $84A0 pm, ;
: sar_ar5,*+ $85A0 pm, ;
 
: mar_*- $8B90 pm, ;
: mar_*+ $8BA0 pm, ;
: mar_*,ar6 $8B8E pm, ;
: mar_*,ar7 $8B8F pm, ;
: mar_*-,ar6 $8B9E pm, ;
 
: lacc_* $1080 pm, ;
: lacc_*+ $10A0 pm, ;
: lacc_*+,ar7 $10AF pm, ;
 
: lamm_ar4 $0814 pm, ;
: lamm_ar5 $0815 pm, ;
: lamm_ar6 $0816 pm, ;
: lamm_ar7 $0817 pm, ;
 
: neg $BE02 pm, ;
 
: add_* $2080 pm, ;
: add_#i8 ( b --- )
 $B8 join pm, ;
: add_#i16 ( w --- )
 $BF90 pm, pm, ;
: add_*,0,ar7 $208F pm, ;
 
: sub_* $3080 pm, ;
: sub_#i8 ( b --- )
 $BA join pm, ;
: sub_#i16  ( w --- )
 $BFA0 pm, pm, ;
: sub_*,0,ar7 $308F pm, ;
: subs_* $6680 pm, ;
 
: lt_*+ $73A0 pm, ;
: mpy_*- $5490 pm, ;
: pac $BE03 pm, ;
 
: xc_2,gt $F704 pm, ;
: xc_2,neq $F708 pm, ;
: xc_2,lt $F744 pm, ;
: xc_2,eq $F788 pm, ;
: xc_2,geq $F78C pm, ;
: xc_2,leq $F7CC pm, ;
 
: setc_sxm $BE47 pm, ;
 
: bd ( w --- )
 $7D80 pm, pm, ; 
 
 
// ********************************************
// *** REMOVE PREVIOUS COMPILED LITERAL? ***
// *** Optimizer ***
// ********************************************
 
: ?short_lit ( --- b f )
 target_cp @ 2- dup dm@ $90A0 ==
 swap 1+ dm@ split $B9 == rot AND ;
 
: ?long_lit ( --- f )
 target_cp @ 3 - dup dm@ $90A0 ==
 swap 1+ dm@ $BF80 == AND ;
 
: ?lit ( --- f )
 target_nameddef @ NOT IF target_anodef ENDIF @
 target_cp @ over - 2 >= IF ?short_lit under IF 1 ELSE 0 ENDIF ELSE false ENDIF
 target_cp @ rot - 3 >= IF ?long_lit IF 2 ELSE 0 ENDIF ELSE false ENDIF
 or ;
 
: lit-> ( --- n )
 ?short_lit not IF drop target_cp @ 1- dm@ 3 ELSE 2 ENDIF target_cp -! ;
 
 
// ********************************************
// *** FORTH DEFINITIONS ***
// *** Run-Time ***
// ********************************************
 
int ^2dup
: (2dup)
 sacl_*-
 lar_ar5,*+
 retd
 mar_*+
 sar_ar5,*+ ;
 
int ^above
: (above)
 sacl_*-
 mar_*-
 lacc_*+
 retd
 mar_*+
 mar_*+ ;
 
int ^below
: (below)
 mar_*-
 lar_ar5,*-
 retd
 sar_ar5,*+
 sacl_* ;
 
int ^rot
: (rot)
 mar_*-
 lar_ar5,*-
 lar_ar4,*
 sar_ar5,*+
 retd
 sacl_*+
 lamm_ar4 ;
 
int ^-rot
: (-rot)
 mar_*-
 lar_ar5,*-
 lar_ar4,*
 sacl_*+
 retd
 sar_ar4,*+
 lamm_ar5 ;
 
int ^tuck
: (tuck)
 mar_*-
 lar_ar5,*
 sacl_*+
 retd
 sar_ar5,*+
 sacl_* ;
;
 
int ^depth
: (depth)
 sacl_*+
 lamm_ar7
 retd
 target_s0 1+ subb ;
 
int ^swap
: (swap)
 mar_*-
 lar_ar4,*
 retd
 sacl_*+
 lamm_ar4 ;
 
int ^lit==
: (lit==) // ( n1 n2 --- f ) x = n1-n2
 nop
 xc_2,neq // FALSE if (x >= 0) ie (n1-n2 >= 0) ie (n1 >= n2)
 0 lacc_#i8
 ret
 retd
 $FFFF lacc_#i16 ;
 
int ^==
: (==) // ( n1 n2 --- f )
 mar_*-
 sub_* // x=n2-n1
 nop
 xc_2,neq // FALSE if (x != 0) ie (n2-n1 != 0) ie (n1 != n2)
 0 lacc_#i8
 ret
 retd
 $FFFF lacc_#i16 ;
 
int ^lit!=
: (lit!=) // ( n1 n2 --- f ) x = n1-n2
 nop
 xc_2,eq // FALSE if (x >= 0) ie (n1-n2 >= 0) ie (n1 >= n2)
 0 lacc_#i8
 ret
 retd
 $FFFF lacc_#i16 ;
 
int ^!=
: (!=) // ( n1 n2 --- f )
 mar_*-
 sub_* // x=n2-n1
 nop
 xc_2,eq // FALSE if (x != 0) ie (n2-n1 != 0) ie (n1 != n2)
 0 lacc_#i8
 ret
 retd
 $FFFF lacc_#i16 ;
 
int ^lit<
: (lit<) // ( n1 n2 --- f ) x = n1-n2
 nop
 xc_2,geq // FALSE if (x >= 0) ie (n1-n2 >= 0) ie (n1 >= n2)
 0 lacc_#i8
 ret
 retd
 $FFFF lacc_#i16 ;
 
int ^<
: (<) // ( n1 n2 --- f )
 mar_*-
 sub_* // x=n2-n1
 nop
 xc_2,leq // FALSE if (x <= 0) ie (n2-n1 <= 0) ie (n1 >= n2)
 0 lacc_#i8
 ret
 retd
 $FFFF lacc_#i16 ;
 
int ^lit<=
: (lit<=) // ( n1 n2 --- f ) x = n1-n2
 nop
 xc_2,gt // FALSE if (x > 0) ie (n1-n2 > 0) ie (n1 > n2)
 0 lacc_#i8
 ret
 retd
 $FFFF lacc_#i16 ;
 
int ^<=
: (<=) // ( n1 n2 --- f )
 mar_*-
 sub_* // x=n2-n1
 nop
 xc_2,lt  // FALSE if (x < 0) ie (n2-n1 < 0) ie (n1 > n2)
 0 lacc_#i8
 ret
 retd
 $FFFF lacc_#i16 ;
 
int ^lit>
: (lit>) // ( n1 n2 --- f ) x = n1-n2
 nop
 xc_2,leq // FALSE if (x <= 0) ie (n1-n2 <= 0) ie (n1 <= n2)
 0 lacc_#i8
 ret
 retd
 $FFFF lacc_#i16 ;
 
int ^>
: (>) // ( n1 n2 --- f )
 mar_*-
 sub_* // x=n2-n1
 nop
 xc_2,geq // FALSE if (x >= 0) ie (n2-n1 >= 0) ie (n1 <= n2)
 0 lacc_#i8
 ret
 retd
 $FFFF lacc_#i16 ;
 
int ^lit>=
: (lit>=) // ( n1 n2 --- f ) x = n1-n2
 nop
 xc_2,lt // FALSE if (x < 0) ie (n1-n2 < 0) ie (n1 < n2)
 0 lacc_#i8
 ret
 retd
 $FFFF lacc_#i16 ;
 
int ^>=
: (>=) // ( n1 n2 --- f )
 mar_*-
 sub_* // x=n2-n1
  nop
 xc_2,gt // FALSE if (x > 0) ie (n2-n1 > 0) ie (n1 < n2)
 0 lacc_#i8
 ret
 retd
 $FFFF lacc_#i16 ;
 
int ^+!
: (+!) // ( n --- )
 mar_*-,ar6
 add_*
 retd
 sacl_*,ar7
 lacc_* ;
 
int ^-!
: (-!) // ( n --- )
 mar_*-,ar6
 sub_*
 retd
 sacl_*,ar7
 lacc_* ;
 
int ^*
: (*)
 sacl_*-
 lt_*+
 retd
 mpy_*-
 pac ;
 
: run_time
 target_cp @ ^2dup ! (2dup) 
 target_cp @ ^above ! (above) 
 target_cp @ ^below ! (below)
 target_cp @ ^rot ! (rot)
 target_cp @ ^-rot ! (-rot)
 target_cp @ ^tuck ! (tuck)
 target_cp @ ^depth ! (depth)
 target_cp @ ^swap ! (swap)
 target_cp @ ^lit!= ! (lit!=) target_cp @ ^!= ! (!=) 
 target_cp @ ^lit== ! (lit==) target_cp @ ^== ! (==) 
 target_cp @ ^lit< ! (lit<) target_cp @ ^< ! (<) 
 target_cp @ ^lit<= ! (lit<=) target_cp @ ^<= ! (<=) 
 target_cp @ ^lit> ! (lit>) target_cp @ ^> ! (>) 
 target_cp @ ^lit>= ! (lit>=) target_cp @ ^>= ! (>=) 
 target_cp @ ^+! ! (+!)
 target_cp @ ^-! ! (-!)
 target_cp @ ^* ! (*)
;
 
: (?runtime) ( sz --- ) ( areg )
 @ cr '$ emit h. 2 spaces type ;
 
: ?runtime
 " 2DUP" ^2dup (?runtime) 
 " ABOVE" ^above (?runtime) 
 " BELOW" ^below (?runtime)
 " ROT" ^rot (?runtime)
 " -ROT" ^-rot (?runtime)
 " TUCK" ^tuck (?runtime)
 " DEPTH" ^depth (?runtime)
 " SWAP" ^swap (?runtime)
 " lit!=" ^lit!= (?runtime) " !=" ^!= (?runtime)
 " lit==" ^lit== (?runtime) " ==" ^== (?runtime)
 " lit<" ^lit< (?runtime) " <" ^< (?runtime)
 " lit<=" ^lit<= (?runtime) " <=" ^<= (?runtime)
 " lit>" ^lit> (?runtime) " >" ^> (?runtime)
 " lit>=" ^lit>= (?runtime) " >=" ^>= (?runtime)
 " +!" ^+! (?runtime)
 " -!" ^-! (?runtime)
 " *" ^* (?runtime)
;
 
: call: ( areg )
 $7A80 @ pm,, ; 
 
: calld: ( areg )
 $7E80 @ pm,, ; 
 
: (?call_runtime)
 over @ == IF
 under true
 R> 
 ENDIF drop ;
 
: ?call_runtime ( a --- z f )
 ^2dup " 2DUP" (?call_runtime)
 ^above " ABOVE" (?call_runtime)
 ^below " BELOW" (?call_runtime) 
 ^rot " ROT" (?call_runtime) 
 ^-rot " -ROT" (?call_runtime) 
 ^tuck " TUCK" (?call_runtime) 
 ^depth " DEPTH" (?call_runtime) 
 ^swap " SWAP" (?call_runtime)
 ^lit== " lit==" (?call_runtime) ^== " ==" (?call_runtime)
 ^lit!= " lit!=" (?call_runtime) ^!= " !=" (?call_runtime)
 ^lit< " lit<" (?call_runtime) ^< " <" (?call_runtime)
 ^lit<= " lit<=" (?call_runtime) ^<= " <=" (?call_runtime)
 ^lit> " lit>" (?call_runtime) ^> " >" (?call_runtime)
 ^lit>= " lit>=" (?call_runtime) ^>= " >=" (?call_runtime)
 ^+! " +!" (?call_runtime) 
 ^-! " -!" (?call_runtime) 
 ^* " *" (?call_runtime) 
 drop 0 false ;
 
 
// ********************************************
// *** FORTH DEFINITIONS  ***
// *** STACK OPERATIONS ***
// ********************************************
 
: `sp!
 $BF0F target_s0 pm,, ; // lar ar7,#2BD0h
: sp! host? IF compile sp! ELSE `sp! ENDIF ; immediate
 
: depth host? IF compile depth ELSE ^depth call: ENDIF ; immediate
 
: `dup
 sacl_*+ ;
: dup host? IF compile dup ELSE `dup ENDIF ; immediate
 
: 2dup host? IF compile 2dup ELSE ^2dup call: ENDIF ; immediate
 
: `over
 sacl_*-
 lacc_*+
 mar_*+ ;
: over host? IF compile over ELSE `over ENDIF ; immediate
 
: above host? IF compile above ELSE ^above call: ENDIF ; immediate
' above alias pluck
 
: `drop
 mar_*-
 lacc_* ;
: drop host? IF compile drop ELSE `drop ENDIF ; immediate
 
: `under
 mar_*- ;
: under host? IF compile under ELSE `under ENDIF ; immediate
' under alias nip
 
: below host? IF compile below ELSE ^below call: ENDIF ; immediate
 
: swap host? IF compile swap ELSE ^swap call: ENDIF ; immediate
 
: tuck host? IF compile tuck ELSE ^tuck call: ENDIF ; immediate
 
: rot host? IF compile rot ELSE ^rot call: ENDIF ; immediate
: -rot host? IF compile -rot ELSE ^-rot call: ENDIF ; immediate
 
 
// ********************************************
// *** FORTH DEFINITIONS ***
// ***  ARITHMETIC and LOGIC ***
// ********************************************
 
: `negate
 neg ;
: negate host? IF compile negate ELSE `negate ENDIF ; immediate
 
: `+
 ?lit CASE
 1 OF // Optimization: short literal
  lit-> add_#i8
 ENDOF
 2 OF // Optimization: long literal
 lit-> add_#i16
 ENDOF
 mar_*- // No optimization
 add_*
 ENDCASE drop ;
: + host? IF compile + ELSE `+ ENDIF ; immediate
 
: `-
 mar_*-
 sub_*
 neg ;
: - host? IF compile - ELSE `- ENDIF ; immediate
 
: * host? IF compile * ELSE ^* call: ENDIF ; immediate
 
: ==
 host? IF 
 compile ==
 ELSE 
 ?lit CASE
 1 OF // Optimization: short literal
  lit-> sub_#i8
 ^lit== call:
 ENDOF
 2 OF // Optimization: long literal
 lit-> 
 ^lit== calld:
 sub_#i16
 ENDOF
 ^== call: // No optimization
 ENDCASE drop
 ENDIF ; immediate
' == alias =
 
: !=
 host? IF 
 compile !=
 ELSE 
 ?lit CASE
 1 OF // Optimization: short literal
 lit-> sub_#i8
 ^lit!= call:
 ENDOF
 2 OF  // Optimization: long literal
 lit->
 ^lit!= calld:
 sub_#i16
 ENDOF
 ^!= call: // No optimization
 ENDCASE drop
 ENDIF ; immediate
' != alias <>
 
: < 
 host? IF 
 compile < 
 ELSE 
 ?lit CASE
 1 OF // Optimization: short literal
 lit-> sub_#i8
 ^lit< call:
 ENDOF
 2 OF // Optimization: long literal
 lit->
 ^lit< calld:
 sub_#i16
 ENDOF
 ^< call: // No optimization
 ENDCASE drop
 ENDIF ; immediate
 
: <=
 host? IF 
 compile <=
 ELSE 
 ?lit CASE
 1 OF // Optimization: short literal
 lit-> sub_#i8
  ^lit<= call:
 ENDOF
 2 OF // Optimization: long literal
 lit->
 ^lit<= calld:
 sub_#i16
 ENDOF
 ^<= call: // No optimization
 ENDCASE drop
 ENDIF ; immediate
 
: >
 host? IF 
 compile >
 ELSE 
 ?lit CASE
 1 OF // Optimization: short literal
 lit-> sub_#i8
 ^lit> call:
 ENDOF
 2 OF // Optimization: long literal
 lit->
 ^lit> calld:
 sub_#i16
 ENDOF
 ^> call: // No optimization
 ENDCASE drop
 ENDIF ; immediate
 
: >=
 host? IF 
 compile >=
 ELSE 
 ?lit CASE
 1 OF // Optimization: short literal
 lit-> sub_#i8
 ^lit>= call:
 ENDOF
 2 OF // Optimization: long literal
 lit->
 ^lit>= calld:
 sub_#i16
 ENDOF
 ^>= call: // No optimization
 ENDCASE drop
 ENDIF ; immediate
 
 
// ********************************************
// *** FORTH DEFINITIONS ***
// *** MEMORY ***
// ********************************************
 
: `!
 mar_*-,ar6
 sacl_*,ar7
 lacc_* ;
: ! host? IF compile ! ELSE `! ENDIF ; immediate
 
: `@
 sacl_*+
 mar_*,ar6
 lacc_*+,ar7 ;
: @ host? IF compile @ ELSE `@ ENDIF ; immediate
 
: `A>
 sacl_*+
 lamm_ar6 ;
: A> host? IF compile A> ELSE `A> ENDIF ; immediate 
 
: +! host? IF compile +! ELSE ^+! call: ENDIF ; immediate
: -! host? IF compile -! ELSE ^-! call: ENDIF ; immediate
 
 
// ********************************************
// *** CREATING WORDS ***
// ********************************************
 
: !instr ( a --- )
 @ 0 DO
 cellsize+ dup >A @ pm,
 ENDDO drop ;
 
 
\ ---------------------------------------------------------------------------
\ `int Compile-time: ( --- )
\  Run-time: ( --- ) AREG = addr
\ Usage: Creation of a variable into the target.
\ PFA of a Variable Definition:
\ 0-3 type=5
\ 4-7 data address
\ 8-11 instruction compiled for the macro definition
\ ---------------------------------------------------------------------------
: `int
 build>
 0 , // Type
 target_dp @ , // Data Address
 // Instruction is: LAR AR6,#addr
 2 ,  // 2 words
 $BF0E ,
 target_dp @ ,
 target_dp incr // 1 allot
 [compile] immediate
 does>
 target? IF
 2 cellsize * +A // skip Type, Link, Data Address
 A> !instr 
 ENDIF ;
: int host? IF [compile] int ELSE [compile] `int ENDIF ; immediate
' int alias integer
' int alias variable
' int alias var
 
// List all defined variables (simple list)
: vlist
 cr -1 BEGIN
 nextword
 -rot over - 12 == IF
 dup peek ' rt_does> == swap cellsize+ cellsize+ peek 'does> `int == && IF
 swap type space
 ELSE
 under
 ENDIF
 ELSE
 drop under
 ENDIF
 DUP -1 == 
 UNTIL drop ; immediate
 
 
0 iint last_colondef
: :
 host? IF
  [compile] :
 ELSE
 build>
 1 , // Type
 target_cp @ , // Code Address (start)
 dp @ last_colondef !
 0 , // Code address (end), will be resolved by ;
 // Instruction is: CALL xx
 2 , // 2 words
 $7A80 , // CALL
 target_cp @ dup ,
 [compile] immediate
 target_nameddef ! // We create a named definition
 does>
 3 cellsize* +A // skip Type, Data Address
 A> !instr
 ENDIF ; immediate
 
: ;
 host? IF
 [compile] ;
 ELSE
 ret // End the definition with a RET
 last_colondef @ IF
 target_cp @ last_colondef @ >A !
 last_colondef 0!
 ENDIF
 ENDIF ; immediate
 
 
// ********************************************
// *** SOME TOOLS ***
// ********************************************
 
1 const t_int
2 const t_:
 
: table
 build> does> ;
table target_objects
 'does> `int , t_int ,
 'does> : , t_: ,
 0 , 0 ,
 
: ?target_objects ( n --- f )
 target_objects BEGIN
 @+ dup 0 == ?break
 over over == ?break
 @+ 2drop
 AGAIN 2drop @ ;
 
\ List all definitions created into the target
: `words
 cr -1 BEGIN
 nextword
 -rot over - 12 == IF
 dup peek ' rt_does> == swap cellsize+ cellsize+ peek ?target_objects && IF
 swap type space
 ELSE
 under
 ENDIF
 ELSE
 drop under
  ENDIF
 DUP -1 == 
 UNTIL drop ;
: words host? IF compile words ELSE `words ENDIF ; immediate
 
 
: which_def ( a --- sz f )
 -1 BEGIN
 nextword
 -rot over - 12 == IF
 dup dup peek ' rt_does> == swap cellsize+ cellsize+ peek ?target_objects t_: == && IF
 rot >R
 cellsize+ peek cellsize+ peek above == R> swap IF
 under under true [compile] (;)
 ELSE
 drop
 ENDIF
 ELSE
 drop under
 ENDIF
 ELSE
 drop under
 ENDIF
 DUP -1 == 
 UNTIL drop false ;
 
 
// **************************
// *** CONTROL STRUCTURES ***
// *** IF..[ELSE]..ENDIF ***
// **************************
 
: `exit
 ret ;
: exit host? IF compile exit ELSE `exit ENDIF ; immediate 
 
: `?exit
 $FF08 pm,
 mar_*-
 lacc_* ;
: ?exit host? IF ELSE `?exit @ ENDIF ; immediate 
 
: here host? IF compile here ELSE target_cp @ ENDIF ; immediate 
 
: `(0branch) ( a --- )
 $F388 pm, pm,
 mar_*-
 lacc_* ;
 
: `(1branch) ( a --- )
 $F308 pm, pm,
 mar_*-
 lacc_* ;
 
: `(branch) ( a --- )
 $7980 pm, pm, ;
 
: `!code ( w a --- )
 swap over + swap pm! ;
 
: `create_control_stack
 build> 
 dup 2 * 2 + allot !+ 0 !
 does> ;
 
64 `create_control_stack `control_stack
 
: `dummy 1000 ;
 
: `>control ( addr mark --- )
 `control_stack @+ drop 1+! @+ 1- cellsize * 2 * A> + >A 
 swap !+ ! ;
 
: `control> ( --- addr mark )
 `control_stack @+ drop 1-! @+ cellsize * 2 * A> + >A
 @+ @ ;
 
: `control ( --- addr mark )
 `control_stack @+ drop @+ 1- cellsize * 2 * A> + >A
 @+ @ ;
 
: `IF
 `dummy `(0branch)
 target_cp @ 3 - 'IFFI `>control ; immediate
 
: `if? ( mark --- )
 'IFFI == 0 == " IF not called before" ?"error ;
 
: `ELSE
 `control> `if?
 `dummy `(branch)
 target_cp @ 1 - 'IFFI `>control
 target_cp @ over - swap `!code ; immediate
 
: `ENDIF 
 `control> `if? 
 target_cp @ over - swap `!code ; immediate
 
: IF host? IF [compile] IF ELSE [compile] `IF ENDIF ; immediate
: ELSE host? IF [compile] ELSE ELSE [compile] `ELSE ENDIF ; immediate
: ENDIF host? IF [compile] ENDIF ELSE [compile] `ENDIF ENDIF ; immediate
' ENDIF alias THEN
 
: `begin? ( mark --- )
 'BEGI != " BEGIN not called before" ?"error ;
 
: `break?
 dup 'BREA == IF
 drop target_cp @ swap pm!
 `control>
 myself
 ENDIF ;
 
: `begin_or_break? ( addr mark --- )
 under dup 'BEGI != swap dup 'BREA != 
 swap 'WHIL != and and
 " BREAK not allowed here" ?"error ;
 
: `?break
 `control `begin_or_break?
 target_cp @ 1+ 'BREA `>control
 `dummy `(1branch) ; immediate
 
: `?continue
 `control `begin_or_break?
 `control drop `(1branch) ; immediate
 
: `BEGIN
 target_cp @ 'BEGI `>control ; immediate
 
: `AGAIN
 2 target_cp +!
 `control> 
 `break? `begin?
 2 target_cp -!
 `(branch) ; immediate
 
: `UNTIL
 4 target_cp +!
 `control> `break? `begin?
 4 target_cp -!
 `(0branch) ; immediate
 
: BEGIN host? IF [compile] BEGIN ELSE [compile] `BEGIN ENDIF ; immediate
: AGAIN host? IF [compile] AGAIN ELSE [compile] `AGAIN ENDIF ; immediate
: UNTIL host? IF [compile] UNTIL ELSE [compile] `UNTIL ENDIF ; immediate
: ?BREAK host? IF [compile] ?BREAK ELSE [compile] `?BREAK ENDIF ; immediate
: ?CONTINUE host? IF [compile] ?CONTINUE ELSE [compile] `?CONTINUE ENDIF ; immediate
 
 
/*
: ;
 target? IF
 A> >R
 `control_stack @+ drop @ 0 > " Control Structure not endded" ?"error
 R> >A 
 ENDIF 
 [compile] ; ; immediate
*/
 
 
// ********************************************
// *** PSEUDO-DECOMPILER ***
// ********************************************
 
: (.) ( n --- z )
 A> >R base @ >R decimal <#S> R> base ! R> >A ;
 
: (h.) ( n --- z )
 A> >R base @ >R hex <#S> R> base ! R> >A ;
 
: (field1) ( --- )
 BEGIN space wherex 17 == UNTIL ;
 
: (field2) ( --- )
 BEGIN space wherex 40 == UNTIL ;
 
: (forth_decomp) ( z --- )
 (field2) type space ;
 
: (call_decomp) ( a --- )
 (field2) 
 dup ?call_runtime IF 
 under type
 ELSE
 drop which_def IF type ELSE drop ENDIF
 ENDIF ;
 
: (instr) ( z --- )
 (field1) " : " type type ;
 
: (instr+h2) ( a z --- )
 (field1) " : " type type h02. ;
 
: (instr+h4) ( a z --- )
 (field1) " : " type type h04. ;
 
int addr
: next ( --- a )
 addr @ 1+ target_cp @ U>= IF
 -1
 ELSE
 addr @ 1+ pm@
 ENDIF ;
 
: next2 ( --- a )
 addr @ 2 + target_cp @ U>= IF
 -1
 ELSE
 addr @ 2 + pm@
 ENDIF ;
 
: next3 ( --- a )
 addr @ 3 + target_cp @ U>= IF
 -1
 ELSE
 addr @ 3 + pm@
 ENDIF ;
 
: handle_mar_*-
 next $1080 == IF " DROP" (forth_decomp) exit ENDIF
 next $10A0 == IF " UNDER" (forth_decomp) exit ENDIF
 next $2080 == IF " +" (forth_decomp) exit ENDIF
 next $0590 == IF next2 $85A0 == IF next3 $9080 == IF " BELOW" (forth_decomp) exit ENDIF ENDIF ENDIF ;
 
int [decomp]
: (decomp) ( a --- )
 1 [decomp] !
 dup addr !
 dup 1+ >R pm@ dup h04. space
 CASE
 $0480 OF " LAR AR4,*-" (instr) ENDOF
 $0580 OF " LAR AR5,*-" (instr) ENDOF
 $0590 OF " LAR AR5,*-" (instr) ENDOF
 $05A0 OF " LAR AR5,*+" (instr) ENDOF
 $0814 OF " LAMM AR4"  (instr) ENDOF
 $0815 OF " LAMM AR5" (instr) ENDOF
 $0816 OF " LAMM AR6" (instr) ENDOF
 $0817 OF " LAMM AR7" (instr) ENDOF
 $1080 OF " LACC *" (instr) ENDOF
 $10A0 OF " LACC *+" (instr) ENDOF
  $10AF OF " LACC *+,AR7" (instr) ENDOF
 $2080 OF " ADD *" (instr) ENDOF
 $208F OF " ADD *,0,AR7" (instr) ENDOF
 $3080 OF " SUB *" (instr) ENDOF
 $308F OF " SUB *,0,AR7" (instr) ENDOF
 $5490 OF " MPY *-" (instr) ENDOF
 $73A0 OF " LT *+" (instr) ENDOF
 $7980 OF R pm@ dup h04. " B " (instr+h4) R pm@ (.) (forth_decomp) [decomp] incr ENDOF
 $7A80 OF R pm@ dup h04. " CALL " (instr+h4) R pm@ (call_decomp) [decomp] incr ENDOF
 $7E80 OF R pm@ dup h04. " CALLD " (instr+h4) R pm@ (call_decomp) [decomp] incr ENDOF
 $84A0 OF " SAR AR4,*+" (instr) ENDOF
 $85A0 OF " SAR AR5,*+" (instr) ENDOF
 $8B8E OF " MAR *,AR6" (instr) ENDOF
 $8B8F OF " MAR *,AR7" (instr) ENDOF
 $8B90 OF " MAR *-" (instr) handle_mar_*- ENDOF
 $8B9E OF " MAR *-,AR6" (instr) ENDOF
 $8BA0 OF " MAR *+" (instr) ENDOF
 $908F OF " SACL *,AR7" (instr) ENDOF
 $9080 OF " SACL *" (instr) ENDOF
 $9090 OF " SACL *-" (instr) ENDOF
 $90A0 OF " SACL *+" (instr) " LIT" (forth_decomp) ENDOF
 $BE02 OF " NEG" (instr) ENDOF
 $BE03 OF " PAC"  (instr) ENDOF
 $BE22 OF " IDLE" (instr) ENDOF
 $BE38 OF " RETI" (instr) ENDOF
 $BE47 OF " SETC SXM" (instr) ENDOF
 $BF80 OF R pm@ dup h04. " LACC #" (instr+h4) R pm@ (.) (forth_decomp) [decomp] incr ENDOF
 $BF90 OF R pm@ dup h04. " ADD #" (instr+h4) R pm@ (.) (forth_decomp) " +" type [decomp] incr ENDOF
 $BFA0 OF R pm@ dup h04. " SUB #" (instr+h4) R pm@ (.) (forth_decomp) " -" type [decomp] incr ENDOF
 $BF0E OF R pm@ dup h04. " LAR AR6,#" (instr+h4) [decomp] incr ENDOF
 $F704 OF " XC 2,GT" (instr) ENDOF
 $F708 OF " XC 2,NEQ" (instr) ENDOF
 $F744 OF " XC 2,LT" (instr) ENDOF
 $F788 OF " XC 2,EQ" (instr) ENDOF
 $F78C OF " XC 2,GEQ"  (instr) ENDOF
 $F7CC OF " XC 2,LEQ" (instr) ENDOF
 $EF00 OF " RET" (instr) ENDOF
 $F308 OF R pm@ dup h04. " BCNDD " (instr+h4) R pm@ (.) (forth_decomp) [decomp] incr ENDOF
 $F388 OF R pm@ dup h04. " BCNDD " (instr+h4) R pm@ (.) (forth_decomp) [decomp] incr ENDOF
 $FF00 OF " RETD" (instr) ENDOF
 $FF08 OF " RETD NEQ" (instr) ENDOF
 dup split CASE
 $B8 OF over dup " ADD #" (instr+h2) dup (.) (forth_decomp) " +" type ENDOF
 $B9 OF over dup " LACC #" (instr+h2) dup (.) (forth_decomp) ENDOF
 $BA OF over dup " SUB #" (instr+h2) dup (.) (forth_decomp) " -" type ENDOF
 ENDCASE drop drop drop
 ENDCASE drop R> drop ;
 
: decomp
 target_cp @ target_anodef @ != IF
 target_cp @ target_anodef @ DO
 cr I h04. space " : " type
 I (decomp)
 [decomp] @ +ENDDO
 ENDIF ;
 
 
// ********************************************
// *** HOOK THE INTERPRET ***
// ********************************************
 
: target_literal ( n --- )
 sacl_*+
 dup 255 U<= IF lacc_#i8 ELSE lacc_#i16 ENDIF ;
 
: .s
 host? IF
 [compile] .s
 ELSE
 cr " Target Stack: " type
 saved_ar7 dm@ target_s0 - dup 1 > IF
 target_s0 + target_s0 1+ DO
 I dm@ 
 dup $8000 < IF . ELSE '- emit $10000 swap - . ENDIF
 space
 ENDDO
 saved_acc dm@
 dup $8000 < IF . ELSE '- emit $10000 swap - . ENDIF
 ELSE
  0 > IF
 saved_acc dm@ .
 ELSE
 " empty" type
 ENDIF
 ENDIF
 ENDIF ; immediate
 
: target_infos
 cr " Code: $" type target_cp0 h04. " -$" type target_cp @ h04.
 space " (used: " type target_cp @ target_cp0 - 5 .L
 space " free: " type target_dp0 target_cp @ - 5 .L " )" type
 cr " Data: $" type target_dp0 h04. " -$" type target_dp @ h04.
 space " (used: " type target_dp @ target_dp0 - 5 .L
 space " free: " type target_s0 target_dp @ - 5 .L " )" type
 cr " anodef: " type target_anodef @ h.
 target_nameddef @ IF
 cr " nameddef: " type target_nameddef @ h.
 ENDIF
 [compile] .s
 decomp ;
 
: infos
 host? IF [compile] infos ELSE target_infos ENDIF ; immediate
' infos alias ??
 
: target_ok
 target_nameddef @ 0 == IF 
 '{ emit
 saved_ar7 dm@ target_s0 - <#S> type
 " } " type
 ENDIF ;
 
: :
 [compile] :
 target? IF
 target_cp @ target_nameddef ! 
 ENDIF ; immediate
 
: `flush
 target? IF 
 ret // Compile RET at the end of the code
 target_nameddef @ IF
 target_cp @ target_anodef !
 target_nameddef 0 !
 ELSE
 target_anodef @ run
 target_anodef @ target_cp !
 ENDIF
 ENDIF ;
 
: ;
 [compile] ;
 target? IF `flush ENDIF ; immediate
 
 
// ********************************************
// *** SOME MORE TOOLS ***
// ********************************************
 
\ Show the type of the next target object
\ Example: integer xx what xx
: see
 [compile] 'nfa
 dup not " Definition not found" ?"error 
 >R R >A @+ IF 
 cr " Is an alias of " type cellsize -A @+ 10 cellsize* + type
 ENDIF 
 @+ IF
 R> drop " 'C' definition" "error
 ENDIF
 cellsize +A @+ @+ over - 3 cellsize* != IF
 R> drop " Not a target definition" "error
 ENDIF
 dup peek ' rt_does> != IF
 R> drop " Not a target definition" "error
 ENDIF
 cr dup cellsize+ cellsize+ peek ?target_objects CASE
 t_int OF
 " integer Addr=" type
 swap cellsize+ >A @ cellsize+ >A @ dup h04.(.) 2 spaces
 dm@ " Value=" type h04.(.)
 ENDOF
 t_: OF
 " colon definition Start=$" type
 swap cellsize+ >A @ cellsize+ >A @+ @ over h. space
 " End=$" type dup h. space 
 " len=" type dup above - . 
 swap DO 
 cr I h04. space " : " type
 I (decomp)
 [decomp] @ +ENDDO
 ENDOF
 " Not a target definition!" "error
 ENDCASE drop
 R> drop
; immediate
 
 
: `.
 `flush
 saved_ar7 dm@ target_s0 - 0 > IF
 saved_acc dm@ 
 dup $8000 < IF . ELSE '- emit $10000 swap - . ENDIF
 `drop `flush
 ELSE
 " Stack empty!" type
 ENDIF space ; immediate
: . host? IF [compile] . ELSE [compile] `. ENDIF ; immediate
 
 
// ********************************************
// *** INITIALIZATION OF THE FORTH INTO THE ***
// *** C50 DSP (TARGET) ***
// ********************************************
 
: do_call
 target_cp @
 target_cp $2BB0 ! // Target current code pointer
 $BF0D saved_acc pm,, // lar ar5,#2BF0h
 $8B8D pm, // mar *,ar5
 $10A0 pm, // lacc *+
 $06A0 pm, // lar ar6,*+
 $07AF pm,  // lar ar7,*+,ar7
 setc_sxm
 $7A80 $FFFF pm,, // call {routine}
 $BF0D saved_acc pm,, // lar ar5,#2BF0h
 $8B8D pm, // mar *,ar5
 $90A0 pm, // sacl *+
 $86A0 pm, // sar ar6,*+
 $87A0 pm, // sar ar7,*+
 idle // idle
 target_cp ! ;
 
: initforth_c50
 [compile] target
 target_cp @
 target_cp $2A00 ! // Target current code pointer
 $BC00 pm, // ldp #0
 mar_*,ar7
 setc_sxm
 $BF0F target_s0 pm,, // lar ar7,#2BD0h
 $BF0E target_dp0 pm,, // lar ar6,#1A00h
 ret // ret
 do_call
 run_time
 target_cp !
 target_s0 saved_ar7 dm! 
 0 saved_ar6 dm!
 $2A00 run
 target_cp0 target_anodef !
;
 
// Initialization of the forth cross-compiler
: init_fcc
 open_comm 
 reset_c50
 init_mon 
 target_cp0 target_cp ! // Target current code pointer
 target_dp0 target_dp ! // Target current data pointer
 0 target_nameddef !
 initforth_c50 // Compile some code into the target (definitions not macros)
;
 
: target
 target
 ' target_literal (literal) ! 
 ' target_ok (ok) !
; immediate
' target alias tok
 
: host
 host
 0 (literal) ! 
 0 (ok) !
; immediate
' host alias ok
 
: bye
 target? IF close_comm ENDIF
 [compile] bye ; immediate
 
// I'm too lazy to type that each time I compile this file...
init_fcc ;
target
 
// Include here your project
" /wfroth/ti_c50/test.c50" !curr_file
load