Suppress CR in quiet mode, patch by Derek Fawcus.

[pforth] / fth / see.fth

\ @(#) see.fth 98/01/26 1.4\r
\ SEE ( <name> -- , disassemble pForth word )\r
\\r
\ Copyright 1996 Phil Burk\r
\r
' file? >code rfence a!\r
\r
anew task-see.fth\r
\r
: .XT ( xt -- , print execution tokens name )\r
	>name\r
	dup c@ flag_immediate and\r
	IF\r
		." POSTPONE "\r
	THEN\r
	id. space\r
;\r
\r
\ dictionary may be defined as byte code or cell code\r
0 constant BYTE_CODE\r
\r
BYTE_CODE [IF]\r
	: CODE@ ( addr -- xt , fetch from code space )   C@ ;\r
	1 constant CODE_CELL\r
	.( BYTE_CODE not implemented) abort\r
[ELSE]\r
	: CODE@ ( addr -- xt , fetch from code space )   @ ;\r
	CELL constant CODE_CELL\r
[THEN]\r
\r
private{\r
\r
0 value see_level  \ level of conditional imdentation\r
0 value see_addr   \ address of next token\r
0 value see_out\r
\r
: SEE.INDENT.BY ( -- n )\r
	see_level 1+ 1 max 4 *\r
;\r
\r
: SEE.CR\r
	>newline\r
	see_addr ." ( ".hex ." )"\r
	see.indent.by spaces\r
	0 -> see_out\r
;\r
: SEE.NEWLINE\r
	see_out 0>\r
	IF see.cr\r
	THEN\r
;\r
: SEE.CR?\r
	see_out 6 >\r
	IF\r
		see.newline\r
	THEN\r
;\r
: SEE.OUT+\r
	1 +-> see_out\r
;\r
\r
: SEE.ADVANCE\r
	code_cell +-> see_addr\r
;\r
: SEE.GET.INLINE ( -- n )\r
	see_addr @\r
;\r
\r
: SEE.GET.TARGET  ( -- branch-target-addr )\r
	see_addr @ see_addr +\r
;\r
\r
: SEE.SHOW.LIT ( -- )\r
	see.get.inline .\r
	see.advance\r
	see.out+\r
;\r
\r
exists? F* [IF]\r
: SEE.SHOW.FLIT ( -- )\r
	see_addr f@ f.\r
	1 floats +-> see_addr\r
	see.out+\r
;\r
[THEN]\r
\r
: SEE.SHOW.ALIT ( -- )\r
	see.get.inline >name id. space\r
	see.advance\r
	see.out+\r
;\r
\r
: SEE.SHOW.STRING ( -- )\r
	see_addr count 2dup + aligned -> see_addr type\r
	see.out+\r
;\r
: SEE.SHOW.TARGET ( -- )\r
	see.get.target .hex see.advance\r
;\r
\r
: SEE.BRANCH ( -- addr | , handle branch )\r
	-1 +-> see_level\r
	see.newline \r
	see.get.inline  0>\r
	IF  \ forward branch\r
		." ELSE "\r
		see.get.target \ calculate address of target\r
		1 +-> see_level\r
		nip \ remove old address for THEN\r
	ELSE\r
		." REPEAT " see.get.target .hex\r
		drop \ remove old address for THEN\r
	THEN\r
	see.advance\r
	see.cr\r
;\r
\r
: SEE.0BRANCH ( -- addr | , handle 0branch )\r
	see.newline \r
	see.get.inline 0>\r
	IF  \ forward branch\r
		." IF or WHILE "\r
		see.get.target \ calculate adress of target\r
		1 +-> see_level\r
	ELSE\r
		." UNTIL=>" see.get.target .hex\r
	THEN\r
	see.advance\r
	see.cr\r
;\r
\r
: SEE.XT  { xt -- }\r
	xt\r
	CASE\r
		0 OF see_level 0> IF ." EXIT " see.out+ ELSE ." ;" 0  -> see_addr THEN ENDOF\r
		['] (LITERAL) OF see.show.lit ENDOF\r
		['] (ALITERAL) OF see.show.alit ENDOF\r
[ exists? (FLITERAL) [IF] ]\r
		['] (FLITERAL) OF see.show.flit ENDOF\r
[ [THEN] ]\r
		['] BRANCH    OF see.branch ENDOF\r
		['] 0BRANCH   OF see.0branch ENDOF\r
		['] (LOOP)    OF -1 +-> see_level see.newline ." LOOP " see.advance see.cr  ENDOF\r
		['] (+LOOP)   OF -1 +-> see_level see.newline ." +LOOP" see.advance see.cr  ENDOF\r
		['] (DO)      OF see.newline ." DO" 1 +-> see_level see.cr ENDOF\r
		['] (?DO)     OF see.newline ." ?DO " see.advance 1 +-> see_level see.cr ENDOF\r
		['] (.") OF .' ." ' see.show.string .' " ' ENDOF\r
		['] (C") OF .' C" ' see.show.string .' " ' ENDOF\r
		['] (S") OF .' S" ' see.show.string .' " ' ENDOF\r
\r
		see.cr? xt .xt see.out+\r
	ENDCASE\r
;\r
\r
: (SEE) { cfa | xt  -- }\r
	0 -> see_level\r
	cfa -> see_addr\r
	see.cr\r
	0 \ fake address for THEN handler\r
	BEGIN\r
		see_addr code@ -> xt\r
		BEGIN\r
			dup see_addr ( >newline .s ) =\r
		WHILE\r
			-1 +-> see_level see.newline \r
			." THEN " see.cr\r
			drop\r
		REPEAT\r
		CODE_CELL +-> see_addr\r
		xt see.xt\r
		see_addr 0=\r
	UNTIL\r
	cr\r
	0= not abort" SEE conditional analyser nesting failed!"\r
;\r
\r
}PRIVATE\r
\r
: SEE  ( <name> -- , disassemble )\r
	'\r
	dup ['] FIRST_COLON >\r
	IF\r
		>code (see)\r
	ELSE\r
		>name id.\r
		."  is primitive defined in 'C' kernel." cr\r
	THEN\r
;\r
\r
PRIVATIZE\r
\r
0 [IF]\r
\r
: SEE.JOKE\r
	dup swap drop\r
;\r
\r
: SEE.IF\r
	IF\r
		." hello" cr\r
	ELSE\r
		." bye" cr\r
	THEN\r
	see.joke\r
;\r
: SEE.DO\r
	4 0\r
	DO\r
		i . cr\r
	LOOP\r
;\r
: SEE."\r
	." Here are some strings." cr\r
	c" Forth string." count type cr\r
	s" Addr/Cnt string" type cr\r
;\r
\r
[THEN]\r