gforth/see.fs - diff

Return to see.fs CVS log

Up to [gforth] / gforth

Diff for /gforth/see.fs between versions 1.28 and 1.44

version 1.28, 2000/06/15 09:01:11	version 1.44, 2002/12/25 21:16:54
Line 1	Line 1
\ SEE.FS highend SEE for ANSforth 16may93jaw	\ SEE.FS highend SEE for ANSforth 16may93jaw

\ Copyright (C) 1995 Free Software Foundation, Inc.	\ Copyright (C) 1995,2000 Free Software Foundation, Inc.

\ This file is part of Gforth.	\ This file is part of Gforth.

Line 16	Line 16

\ You should have received a copy of the GNU General Public License	\ You should have received a copy of the GNU General Public License
\ along with this program; if not, write to the Free Software	\ along with this program; if not, write to the Free Software
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.	\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.


\ May be cross-compiled	\ May be cross-compiled
Line 28	Line 28
require look.fs	require look.fs
require termsize.fs	require termsize.fs
require wordinfo.fs	require wordinfo.fs
[IFUNDEF] .name : .name name>string type space ; [THEN]	[IFUNDEF] .name
	: id. ( nt -- ) \ gforth
	\G Print the name of the word represented by @var{nt}.
	\ this name comes from fig-Forth
	name>string type space ;

	' id. alias .id ( nt -- )
	\G F83 name for @code{id.}.

	' id. alias .name ( nt -- )
	\G Gforth <=0.5.0 name for @code{id.}.

	[THEN]

decimal	decimal

Line 87 DEFER nlcount ' noop IS nlcount	Line 99 DEFER nlcount ' noop IS nlcount
IF 2drop ELSE XPos +! C-Output @ IF emit ELSE drop THEN	IF 2drop ELSE XPos +! C-Output @ IF emit ELSE drop THEN
THEN ;	THEN ;

DEFER .string	DEFER .string ( c-addr u n -- )

[IFDEF] Green	[IFDEF] Green
VARIABLE Colors Colors on	VARIABLE Colors Colors on
Line 236 VARIABLE C-Pass	Line 248 VARIABLE C-Pass
: back? ( n -- flag ) 0< ;	: back? ( n -- flag ) 0< ;
: ahead? ( n -- flag ) 0> ;	: ahead? ( n -- flag ) 0> ;

: c-lit	: .word ( addr xt -- addr )
	look 0= IF
	drop dup 1 cells - @ dup body> look
	IF
	nip dup ." <" name>string rot wordinfo .string ." >"
	ELSE
	drop ." <" 0 .r ." >"
	THEN
	ELSE
	dup cell+ @ immediate-mask and
	IF
	bl cemit ." POSTPONE "
	THEN
	dup name>string rot wordinfo .string
	THEN ;

	: c-call ( addr1 -- addr2 )
Display? IF	Display? IF
dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit	dup @ body> .word bl cemit
THEN	THEN
cell+ ;	cell+ ;

	: c-callxt ( addr1 -- addr2 )
	Display? IF
	dup @ .word bl cemit
	THEN
	cell+ ;

	\ here docon: , docol: , dovar: , douser: , dodefer: , dofield: ,
	\ here over - 2constant doers

	: c-lit ( addr1 -- addr2 )
	Display? IF
	dup @ dup body> dup cfaligned over = swap in-dictionary? and if
	( addr1 addr1@ )
	dup body> @ dovar: = if
	drop c-call EXIT
	endif
	endif
	\ !! test for cfa here, and print "['] ..."
	dup abs 0 <# #S rot sign #> 0 .string bl cemit
	endif
	cell+ ;

	: c-lit+ ( addr1 -- addr2 )
	Display? if
	dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
	s" + " 0 .string
	endif
	cell+ ;

: .name-without ( addr -- addr )	: .name-without ( addr -- addr )
\ prints a name without () e.g. (+LOOP) or (s")	\ prints a name without () e.g. (+LOOP) or (s")
dup 1 cells - @ look	dup 1 cells - @ look
Line 413 VARIABLE C-Pass	Line 470 VARIABLE C-Pass

CREATE C-Table	CREATE C-Table
' lit A, ' c-lit A,	' lit A, ' c-lit A,
' (s") A, ' c-c" A,	' does-exec A, ' c-callxt A,
' (.") A, ' c-c" A,	' lit@ A, ' c-call A,
' "lit A, ' c-c" A,	[IFDEF] call ' call A, ' c-call A, [THEN]
	\ ' useraddr A, ....
	' lit-perform A, ' c-call A,
	' lit+ A, ' c-lit+ A,
	[IFDEF] (s") ' (s") A, ' c-c" A, [THEN]
	[IFDEF] (.") ' (.") A, ' c-c" A, [THEN]
	[IFDEF] "lit ' "lit A, ' c-c" A, [THEN]
[IFDEF] (c") ' (c") A, ' c-c" A, [THEN]	[IFDEF] (c") ' (c") A, ' c-c" A, [THEN]
' (do) A, ' c-do A,	' (do) A, ' c-do A,
[IFDEF] (+do) ' (+do) A, ' c-do A, [THEN]	[IFDEF] (+do) ' (+do) A, ' c-do A, [THEN]
Line 432 CREATE C-Table	Line 495 CREATE C-Table
[IFDEF] (-loop) ' (-loop) A, ' c-loop A, [THEN]	[IFDEF] (-loop) ' (-loop) A, ' c-loop A, [THEN]
' (next) A, ' c-loop A,	' (next) A, ' c-loop A,
' ;s A, ' c-exit A,	' ;s A, ' c-exit A,
' (abort") A, ' c-abort" A,	[IFDEF] (abort") ' (abort") A, ' c-abort" A, [THEN]
\ only defined if compiler is loaded	\ only defined if compiler is loaded
[IFDEF] (compile) ' (compile) A, ' c-(compile) A, [THEN]	[IFDEF] (compile) ' (compile) A, ' c-(compile) A, [THEN]
[IFDEF] (does>) ' (does>) A, ' c-does> A, [THEN]	[IFDEF] (does>) ' (does>) A, ' c-does> A, [THEN]
Line 443 c-extender !	Line 506 c-extender !

\ DOTABLE 15may93jaw	\ DOTABLE 15may93jaw

: DoTable ( cfa -- flag )	: DoTable ( ca/cfa -- flag )
C-Table	decompile-prim C-Table BEGIN ( cfa table-entry )
BEGIN dup @ dup 0=	dup @ dup 0= IF
IF drop cell+ @ dup	drop cell+ @ dup IF ( next table!)
IF ( next table!) dup @ ELSE	dup @
( end!) 2drop false EXIT THEN	ELSE ( end!)
THEN	2drop false EXIT
\ jump over to extender, if any 26jan97jaw	THEN
2 pick <>	THEN
WHILE 2 cells +	\ jump over to extender, if any 26jan97jaw
REPEAT	xt>threaded 2 pick <>
nip cell+ perform	WHILE
true	2 cells +
;	REPEAT
	nip cell+ perform
	true
	;

: BranchTo? ( a-addr -- a-addr )	: BranchTo? ( a-addr -- a-addr )
Display? IF dup BranchAddr?	Display? IF dup BranchAddr?
Line 476 c-extender !	Line 542 c-extender !
THEN ;	THEN ;

: analyse ( a-addr1 -- a-addr2 )	: analyse ( a-addr1 -- a-addr2 )
Branches @ IF BranchTo? THEN	Branches @ IF BranchTo? THEN
dup cell+ swap @	dup cell+ swap @
dup >r DoTable r> swap IF drop EXIT THEN	dup >r DoTable r> swap IF drop EXIT THEN
Display?	Display?
IF look 0= IF drop dup 1 cells - @ . \ ABORT" SEE: Bua!"	IF
ELSE	.word bl cemit
dup cell+ count dup immediate-mask and	ELSE
IF bl cemit ." POSTPONE " THEN	drop
31 and rot wordinfo .string THEN bl cemit	THEN ;
ELSE drop
THEN ;

: c-init	: c-init
0 YPos ! 0 XPos !	0 YPos ! 0 XPos !
Line 521 Defer discode ( addr u -- ) \ gforth	Line 585 Defer discode ( addr u -- ) \ gforth
: next-head ( addr1 -- addr2 ) \ gforth	: next-head ( addr1 -- addr2 ) \ gforth
\G find the next header starting after addr1, up to here (unreliable).	\G find the next header starting after addr1, up to here (unreliable).
here swap u+do	here swap u+do
i head?	i head? -2 and if
if
i unloop exit	i unloop exit
then	then
cell +loop	cell +loop
Line 554 Defer discode ( addr u -- ) \ gforth	Line 617 Defer discode ( addr u -- ) \ gforth

: seecode ( xt -- )	: seecode ( xt -- )
dup s" Code" .defname	dup s" Code" .defname
threading-method	>code-address
if
>code-address
then
dup in-dictionary? \ user-defined code word?	dup in-dictionary? \ user-defined code word?
if	if
dup next-head	dup next-head
Line 603 Defer discode ( addr u -- ) \ gforth	Line 663 Defer discode ( addr u -- ) \ gforth
dup >body ." 0 " ? ." 0 0 "	dup >body ." 0 " ? ." 0 0 "
s" Field" .defname cr ;	s" Field" .defname cr ;

: xt-see ( xt -- )	: xt-see ( xt -- ) \ gforth
	\G Decompile the definition represented by @i{xt}.
cr c-init	cr c-init
dup >does-code	dup >does-code
if	if
Line 648 Defer discode ( addr u -- ) \ gforth	Line 709 Defer discode ( addr u -- ) \ gforth
if \ normal or immediate word	if \ normal or immediate word
swap xt-see (.immediate)	swap xt-see (.immediate)
else	else
r@ ['] compile-only-error =	r@ ['] ticking-compile-only-error =
if \ compile-only word	if \ compile-only word
swap xt-see (.immediate) ." compile-only"	swap xt-see (.immediate) ." compile-only"
else \ interpret/compile word	else \ interpret/compile word

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

Removed from v.1.28
changed lines
	Added in v.1.44