\ @(#) see.fth 98/01/26 1.4
\ SEE ( <name> -- , disassemble pForth word )
\
\ Copyright 1996 Phil Burk

' file? >code rfence a!

anew task-see.fth

: .XT ( xt -- , print execution tokens name )
	>name
	dup c@ flag_immediate and
	IF
		." POSTPONE "
	THEN
	id. space
;

\ dictionary may be defined as byte code or cell code
0 constant BYTE_CODE

BYTE_CODE [IF]
	: CODE@ ( addr -- xt , fetch from code space )   C@ ;
	1 constant CODE_CELL
	.( BYTE_CODE not implemented) abort
[ELSE]
	: CODE@ ( addr -- xt , fetch from code space )   @ ;
	CELL constant CODE_CELL
[THEN]

private{

0 value see_level  \ level of conditional imdentation
0 value see_addr   \ address of next token
0 value see_out

: SEE.INDENT.BY ( -- n )
	see_level 1+ 1 max 4 *
;

: SEE.CR
	>newline
	see_addr ." ( ".hex ." )"
	see.indent.by spaces
	0 -> see_out
;
: SEE.NEWLINE
	see_out 0>
	IF see.cr
	THEN
;
: SEE.CR?
	see_out 6 >
	IF
		see.newline
	THEN
;
: SEE.OUT+
	1 +-> see_out
;

: SEE.ADVANCE
	code_cell +-> see_addr
;
: SEE.GET.INLINE ( -- n )
	see_addr @
;

: SEE.GET.TARGET  ( -- branch-target-addr )
	see_addr @ see_addr +
;

: SEE.SHOW.LIT ( -- )
	see.get.inline .
	see.advance
	see.out+
;

exists? F* [IF]
: SEE.SHOW.FLIT ( -- )
	see_addr f@ f.
	1 floats +-> see_addr
	see.out+
;
[THEN]

: SEE.SHOW.ALIT ( -- )
	see.get.inline >name id. space
	see.advance
	see.out+
;

: SEE.SHOW.STRING ( -- )
	see_addr count 2dup + aligned -> see_addr type
	see.out+
;
: SEE.SHOW.TARGET ( -- )
	see.get.target .hex see.advance
;

: SEE.BRANCH ( -- addr | , handle branch )
	-1 +-> see_level
	see.newline 
	see.get.inline  0>
	IF  \ forward branch
		." ELSE "
		see.get.target \ calculate address of target
		1 +-> see_level
		nip \ remove old address for THEN
	ELSE
		." REPEAT " see.get.target .hex
		drop \ remove old address for THEN
	THEN
	see.advance
	see.cr
;

: SEE.0BRANCH ( -- addr | , handle 0branch )
	see.newline 
	see.get.inline 0>
	IF  \ forward branch
		." IF or WHILE "
		see.get.target \ calculate adress of target
		1 +-> see_level
	ELSE
		." UNTIL=>" see.get.target .hex
	THEN
	see.advance
	see.cr
;

: SEE.XT  { xt -- }
	xt
	CASE
		0 OF see_level 0> IF ." EXIT " see.out+ ELSE ." ;" 0  -> see_addr THEN ENDOF
		['] (LITERAL) OF see.show.lit ENDOF
		['] (ALITERAL) OF see.show.alit ENDOF
[ exists? (FLITERAL) [IF] ]
		['] (FLITERAL) OF see.show.flit ENDOF
[ [THEN] ]
		['] BRANCH    OF see.branch ENDOF
		['] 0BRANCH   OF see.0branch ENDOF
		['] (LOOP)    OF -1 +-> see_level see.newline ." LOOP " see.advance see.cr  ENDOF
		['] (+LOOP)   OF -1 +-> see_level see.newline ." +LOOP" see.advance see.cr  ENDOF
		['] (DO)      OF see.newline ." DO" 1 +-> see_level see.cr ENDOF
		['] (?DO)     OF see.newline ." ?DO " see.advance 1 +-> see_level see.cr ENDOF
		['] (.") OF .' ." ' see.show.string .' " ' ENDOF
		['] (C") OF .' C" ' see.show.string .' " ' ENDOF
		['] (S") OF .' S" ' see.show.string .' " ' ENDOF

		see.cr? xt .xt see.out+
	ENDCASE
;

: (SEE) { cfa | xt  -- }
	0 -> see_level
	cfa -> see_addr
	see.cr
	0 \ fake address for THEN handler
	BEGIN
		see_addr code@ -> xt
		BEGIN
			dup see_addr ( >newline .s ) =
		WHILE
			-1 +-> see_level see.newline 
			." THEN " see.cr
			drop
		REPEAT
		CODE_CELL +-> see_addr
		xt see.xt
		see_addr 0=
	UNTIL
	cr
	0= not abort" SEE conditional analyser nesting failed!"
;

}PRIVATE

: SEE  ( <name> -- , disassemble )
	'
	dup ['] FIRST_COLON >
	IF
		>code (see)
	ELSE
		>name id.
		."  is primitive defined in 'C' kernel." cr
	THEN
;

PRIVATIZE

0 [IF]

: SEE.JOKE
	dup swap drop
;

: SEE.IF
	IF
		." hello" cr
	ELSE
		." bye" cr
	THEN
	see.joke
;
: SEE.DO
	4 0
	DO
		i . cr
	LOOP
;
: SEE."
	." Here are some strings." cr
	c" Forth string." count type cr
	s" Addr/Cnt string" type cr
;

[THEN]
