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