0 [IF]
Ideas/Todo
[THEN]
UNLOCK
>ENVIRON
\ true SetValue PrimTrace
LOCK
UNLOCK
also assembler definitions
X has? PrimTrace [IF]
: dout PC+6 X , accu X ,
*accu X , txd X ,
PC+4 X , jmp X ,
X , 0 X , ;
[ELSE]
: dout drop ;
[THEN]
LOCK
\ pie primitives
$20 allot
Label start ahere 2 + , jmp ,
Label "IntoForth" 4711 ,
Label RP' 0 ,
Label SP' 0 ,
Label UP' 0 ,
Label IP' 0 ,
Label #0 0 ,
Label #1 1 ,
Label #2 2 ,
Label #4 4 ,
Label #FF $FF ,
Label #$8000 $8000 ,
Label #-1 -1 ,
Label "Next" 1802 ,
Label "Next1" 1802 ,
Label ""Next"" "Next" ,
End-Label
\ The virtual machine registers an data (stacks) go
\ to a seperate memory region (hopefully ram)
\ UNLOCK
\ current-region vm-memory activate ( saved-region )
\ LOCK
Label RP 0 ,
Label SP 0 ,
Label UP 0 ,
Label IP 0 ,
Label W 0 ,
Label t0 0 ,
Label t1 0 ,
Label t2 0 ,
Label t3 0 ,
Label srcx 0 ,
Label dstx 0 ,
"Next" , jmp ,
Label data-stack 50 cells allot
Label data-stack-top 2 cells allot
Label return-stack 50 cells allot
Label return-stack-top 2 cells allot
End-Label
\ UNLOCK
\ ( saved-region ) activate
\ LOCK
\ Up to here it's self modified
Label IntoForth
\ Transfer VM registers initial values
RP' , RP ,
SP' , SP ,
IP' , IP ,
UP' , UP , \ useless since UP is initialized by gforth boot
""Next"" , dstx 1 + ,
#0 , dstx 2 + ,
Label Next #0 , add , \ clear carry
IP , shr ,
sym Next
*accu , W ,
#1 , add ,
accu , add ,
accu , IP ,
Label Next1 W , shr ,
*accu , shr ,
accu , jmp ,
Label "xmov" srcx ,
End-Label
IntoForth "IntoForth" 2* !
Next "Next" 2* !
Next1 "Next1" 2* !
has? PrimTrace [IF]
Label "0" '< ,
Label "1" '1 ,
Label "2" '2 ,
Label "3" '3 ,
Label "4" '4 ,
Label "5" '5 ,
Label "6" '6 ,
Label "A" 'A ,
Label "B" 'B ,
Label "C" 'C ,
Label "D" 'D ,
Label "E" 'E ,
Label "F" '> ,
Label "?" '? ,
Label "+" '+ ,
Label "/" '/ ,
Label "H" 'H ,
Label "I" 'I ,
Label "J" 'J ,
Label "K" 'K ,
Label "L" 'L ,
Label "M" 'M ,
Label "N" 'N ,
Label "O" 'O ,
Label "P" 'P ,
Label "Q" 'Q ,
Label "R" 'R ,
Label "S" 'S ,
Label "T" 'T ,
Label "#" '# ,
End-Label
[THEN]
Code: :docol
': dout
RP , accu ,
#1 , sub ,
accu , RP ,
IP , *accu ,
W , accu ,
#4 , add ,
accu , IP ,
"Next" , jmp ,
end-code
Code: :docon
'1 dout
#0 , add ,
W , shr ,
#2 , add ,
*accu , t0 ,
SP , accu ,
#1 , sub ,
accu , SP ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code: :dovar
'2 dout
W , accu ,
#4 , add ,
accu , t0 ,
SP , accu ,
#1 , sub ,
accu , SP ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code: :douser
'3 dout
#0 , add ,
W , shr ,
#2 , add ,
*accu , accu ,
UP , add ,
accu , t0 ,
SP , accu ,
#1 , sub ,
accu , SP ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code: :dodefer
'4 dout
#0 , add ,
W , shr ,
#2 , add ,
*accu , W ,
"Next1" , jmp ,
end-code
Code: :dofield
'5 dout
#0 , add ,
W , shr ,
#2 , add ,
*accu , accu ,
accu , t0 ,
SP , accu ,
*accu , accu ,
t0 , add ,
accu , t0 ,
SP , accu ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code: :dodoes
'6 dout
RP , accu ,
#1 , sub ,
accu , RP ,
IP , *accu ,
W , accu ,
#4 , add ,
accu , t0 ,
SP , accu ,
#1 , sub ,
accu , SP ,
t0 , *accu ,
t0 , accu ,
#2 , sub ,
#0 , add ,
accu , shr ,
*accu , IP ,
"Next" , jmp ,
end-code
Code: :doesjump
end-code
Code execute
'E dout
SP , accu ,
*accu , W ,
#1 , add ,
accu , SP ,
"Next1" , jmp ,
end-code
Code ;s
'; dout
RP , accu ,
#1 , add ,
accu , RP ,
#1 , sub ,
*accu , IP ,
"Next" , jmp ,
end-code
Code !
'! dout
SP , accu ,
*accu , t0 ,
#1 , add ,
*accu , t1 ,
#1 , add ,
accu , SP ,
t0 , shr ,
t1 , *accu ,
"Next" , jmp ,
end-code
Code @
'@ dout
#0 , add ,
SP , accu ,
*accu , shr ,
*accu , t0 ,
SP , accu ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code ?branch
'? dout
#0 , add ,
IP , shr ,
accu , t0 ,
#1 , add ,
accu , add ,
accu , IP ,
SP , accu ,
*accu , t1 ,
#1 , add ,
accu , SP ,
t1 , accu ,
pc+4 , jz ,
"Next" , jmp ,
'~ dout
t0 , accu ,
*accu , IP ,
"Next" , jmp ,
end-code
Code branch
'b dout
#0 , add ,
IP , shr ,
*accu , IP ,
"Next" , jmp ,
end-code
Code (loop)
'l dout
#0 , add ,
IP , shr ,
accu , t0 ,
#1 , add ,
accu , add ,
accu , IP ,
RP , accu ,
*accu , t2 ,
#1 , add ,
*accu , t3 ,
t2 , accu ,
#1 , add ,
accu , t1 ,
RP , accu ,
t1 , *accu ,
t1 , accu ,
t3 , sub ,
"Next" , jz ,
t0 , accu ,
*accu , IP ,
"Next" , jmp ,
end-code
Code xor
'x dout
SP , accu ,
*accu , t0 ,
#1 , add ,
accu , SP ,
*accu , accu ,
t0 , xor ,
accu , t0 ,
SP , accu ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code or
'o dout
SP , accu ,
*accu , t0 ,
#1 , add ,
accu , SP ,
*accu , accu ,
t0 , or ,
accu , t0 ,
SP , accu ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code and
'a dout
SP , accu ,
*accu , t0 ,
#1 , add ,
accu , SP ,
*accu , accu ,
t0 , and ,
accu , t0 ,
SP , accu ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code +
'+ dout
SP , accu ,
*accu , t0 ,
#1 , add ,
accu , SP ,
*accu , accu ,
t0 , add ,
accu , t0 ,
SP , accu ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code -
'- dout
SP , accu ,
*accu , t0 ,
#1 , add ,
accu , SP ,
*accu , accu ,
t0 , sub ,
accu , t0 ,
SP , accu ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code 2/
'/ dout
#0 , add ,
SP , accu ,
*accu , accu ,
PC+6 , js ,
accu , shr ,
PC+6 , jmp ,
accu , shr ,
#$8000 , or ,
accu , t0 ,
SP , accu ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code 0=
'° dout
SP , accu ,
*accu , accu ,
ZF , accu ,
#1 , xor ,
#1 , sub ,
accu , t0 ,
SP , accu ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code 0<>
'% dout
SP , accu ,
*accu , accu ,
ZF , accu ,
#1 , sub ,
accu , t0 ,
SP , accu ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code =
'= dout
SP , accu ,
*accu , t0 ,
#1 , add ,
accu , SP ,
*accu , accu ,
t0 , sub ,
ZF , accu ,
#1 , xor ,
#1 , sub ,
accu , t0 ,
SP , accu ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code u<
'< dout
SP , accu ,
*accu , t0 ,
#1 , add ,
accu , SP ,
*accu , accu ,
t0 , sub ,
CF , accu ,
#1 , xor ,
#1 , sub ,
accu , t0 ,
SP , accu ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code 1+
'p dout
SP , accu ,
*accu , accu ,
#1 , add ,
accu , t0 ,
SP , accu ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code cell+
'P dout
SP , accu ,
*accu , accu ,
#2 , add ,
accu , t0 ,
SP , accu ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code 8<<
'{ dout
#0 , add ,
SP , accu ,
*accu , accu ,
accu , add ,
accu , add ,
accu , add ,
accu , add ,
accu , add ,
accu , add ,
accu , add ,
accu , add ,
accu , t0 ,
SP , accu ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code 8>>
'{ dout
#0 , add ,
SP , accu ,
Label c-even@ *accu , shr ,
accu , shr ,
accu , shr ,
accu , shr ,
accu , shr ,
accu , shr ,
accu , shr ,
accu , shr ,
#FF , and ,
accu , t0 ,
SP , accu ,
t0 , *accu ,
"Next" , jmp ,
Label "c-even@" c-even@ ,
end-code
Code c@
'c dout
#0 , add ,
SP , accu ,
*accu , shr ,
PC+4 , jc ,
"c-even@" , jmp ,
*accu , accu ,
#FF , and ,
accu , t0 ,
SP , accu ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code 2*
'* dout
SP , accu ,
*accu , accu ,
accu , add ,
accu , t0 ,
SP , accu ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code >r
'R dout
SP , accu ,
*accu , t0 ,
#1 , add ,
accu , SP ,
RP , accu ,
#1 , sub ,
accu , RP ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code r>
'r dout
RP , accu ,
*accu , t0 ,
#1 , add ,
accu , RP ,
SP , accu ,
#1 , sub ,
accu , SP ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code sp@
's dout
SP , accu ,
accu , add ,
accu , t0 ,
SP , accu ,
#1 , sub ,
accu , SP ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code sp!
'S dout
#0 , add ,
SP , accu ,
*accu , shr ,
accu , SP ,
"Next" , jmp ,
end-code
Code rp@
RP , accu ,
accu , add ,
accu , t0 ,
SP , accu ,
#1 , sub ,
accu , SP ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code rp! sym rp!
SP , accu ,
*accu , t0 ,
#1 , add ,
accu , SP ,
#0 , add ,
t0 , shr ,
accu , RP ,
"Next" , jmp ,
end-code
Code drop
'd dout
SP , accu ,
#1 , add ,
accu , SP ,
"Next" , jmp ,
end-code
Code lit
'# dout
IP , shr ,
*accu , t0 ,
#1 , add ,
accu , add ,
accu , IP ,
SP , accu ,
#1 , sub ,
accu , SP ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code dup
'u dout
SP , accu ,
*accu , t0 ,
#1 , sub ,
accu , SP ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code r@
'I dout
RP , accu ,
*accu , t0 ,
SP , accu ,
#1 , sub ,
accu , SP ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code over
'v dout
SP , accu ,
#1 , add ,
*accu , t0 ,
#2 , sub ,
accu , SP ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code swap
'w dout
SP , accu ,
*accu , t0 ,
#1 , add ,
*accu , t1 ,
t0 , *accu ,
#1 , sub ,
t1 , *accu ,
"Next" , jmp ,
end-code
Code d+
SP , accu ,
*accu , t0 ,
#1 , add ,
*accu , t1 ,
#1 , add ,
*accu , t2 ,
accu , SP ,
#1 , add ,
*accu , accu ,
t1 , add ,
accu , t1 ,
CF , accu ,
t2 , add ,
t0 , add ,
accu , t0 ,
SP , accu ,
t0 , *accu ,
#1 , add ,
t1 , *accu ,
"Next" , jmp ,
end-code
Label cf1 0 ,
End-Label
Code d2*+ sym d2*+
SP , accu ,
Label >d2*+ *accu , t0 ,
#1 , add ,
*accu , t1 ,
#1 , add ,
*accu , t2 ,
accu , t3 ,
t0 , accu ,
t2 , add ,
t2 , add ,
accu , t2 ,
CF , accu ,
t1 , add ,
t1 , add ,
accu , t0 ,
t1 , accu ,
#$8000 , and ,
accu , t1 ,
t3 , accu ,
t2 , *accu ,
#1 , sub ,
t0 , *accu ,
#1 , sub ,
t1 , *accu ,
"Next" , jmp ,
end-code
Label "d2*+" >d2*+ ,
End-Label
Code /modstep ( ud c R: u -- ud-?u 0/1 )
sym /modstep
SP , accu ,
*accu , t0 ,
#1 , add ,
*accu , t1 ,
#1 , add ,
*accu , t2 ,
t2 , accu ,
t0 , sub ,
accu , t0 ,
CF , accu ,
t1 , or ,
PC+6 , JZ ,
#0 , accu ,
PC+6 , jmp ,
t0 , t2 ,
#1 , accu ,
accu , t0 ,
SP , accu ,
#1 , add ,
t0 , *accu ,
#1 , add ,
t2 , *accu ,
#1 , sub ,
"d2*+" , jmp ,
end-code
Code (key)
SP , accu ,
#1 , sub ,
accu , SP ,
rxd , *accu ,
"Next" , jmp ,
end-code
Code (key?)
rx? , accu ,
ZF , accu ,
#1 , sub ,
accu , t0 ,
SP , accu ,
#1 , sub ,
accu , SP ,
t0 , *accu ,
"Next" , jmp ,
end-code
Code (emit)
SP , accu ,
*accu , txd ,
#1 , add ,
accu , SP ,
"Next" , jmp ,
end-code
UP 2* Constant UP
: up@ up @ ;
: up! up ! ;
\ include ./key.fs
include ./optcmove.fs
: (bye) 0 execute ;
: float+ 8 + ;
: finish-code ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>