/fth/see.fth

\ @(#) 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]