\ *****************************************************************************
\ habschi
\ stefan
\ gregor
\ automaton.fs
\ *****************************************************************************	

\ -----------------------------------------------------------------------------
\ additional string support...

: alloc-str ( len -- addr )
	chars allocate drop
	;

: reloc-str { str len addr -- str len addr }
	str addr len cmove
	str len addr
	;

: store-str { tgt str len addr -- ntgt}
	len tgt !
	addr tgt cell+ !
	tgt 2 cells + 
	;  

: store ( tgt str len -- tgt+2 )
	dup alloc-str
	reloc-str
	store-str
	;

\ -----------------------------------------------------------------------------
\ jump map creation...

: pws ( jump-map -- jump-map+2 )	
	parse-word
	store
	;

: create-jump-map ( u -- jump-map )
	dup 4 * 1 + cells allocate drop 
	2dup ! dup cell+ rot 0
	?do
		pws pws
	loop
	drop
	;

\ -----------------------------------------------------------------------------
\ state transfer...

: jump? ( tgt-addr tgt-u jump-map -- f )
	dup 2swap 2over
	cell+ @ swap @
	compare
	if
		2drop 0
	else
		3 cells + @ swap 2 cells + @
		evaluate 1
	endif
	;

: stopper ( -- c-addr u )
	s" __stopper__"
	;

: stop-token? ( tgt-addr tgt-u -- f )
	stopper compare
	;

: end-run ( f -- )
	if
		." SUCCESS... "
	else
		." FAIL... " 
	endif
	clearstack
	;

create ok? 0 ,

: jump! { tgt-addr tgt-u jump-map f -- }
	tgt-addr tgt-u stop-token?
	if
		0 ok? !
		jump-map @ 0   
		?do			
			tgt-addr tgt-u jump-map cell+ i 4 * cells + jump?
			if 
				i 1 +  ok? !
				leave
			endif
		loop
		ok? @ 
		if
			ok? @ .
		else
			0 end-run
		endif 	
	else	
		f end-run
	endif
	;

\ -----------------------------------------------------------------------------
\ parsing utilities...

: g_state: ( -- )
	create create-jump-map , 
	does> @ 1 jump! 
	;


: t_state: ( -- )
	create create-jump-map , 
	does> @ 0 jump! 
	;

: input: ( -- c-addr u )
	parse-word
	dup alloc-str
	reloc-str rot rot nip
	;

: start: ( -- )
	interpret 
	; 

\ -----------------------------------------------------------------------------
\ putting all together...

stopper 

include input