version 1.27, 2000/06/14 20:31:47
|
version 1.33, 2000/11/13 22:10:30
|
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 480 c-extender !
|
Line 492 c-extender !
|
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 look 0= IF drop dup 1 cells - @ ." <" 0 .r ." >" |
ELSE |
ELSE |
dup cell+ count dup immediate-mask and |
dup cell+ count dup immediate-mask and |
IF bl cemit ." POSTPONE " THEN |
IF bl cemit ." POSTPONE " THEN |
Line 514 Defer xt-see-xt ( xt -- )
|
Line 526 Defer xt-see-xt ( xt -- )
|
then |
then |
space ; |
space ; |
|
|
Defer discode ( addr u -- ) |
Defer discode ( addr u -- ) \ gforth |
\ hook for the disassembler: disassemble code at addr of length u |
\G hook for the disassembler: disassemble code at addr of length u |
' dump IS discode |
' dump IS discode |
|
|
: next-head ( addr1 -- addr2 ) \ gforth |
: next-head ( addr1 -- addr2 ) \ gforth |
Line 535 Defer discode ( addr u -- )
|
Line 547 Defer discode ( addr u -- )
|
then |
then |
drop ; |
drop ; |
|
|
: next-prim ( addr1 -- addr2 ) |
: next-prim ( addr1 -- addr2 ) \ gforth |
\G find the next primitive after addr1 |
\G find the next primitive after addr1 (unreliable) |
1+ >r -1 primstart |
1+ >r -1 primstart |
begin ( umin head R: boundary ) |
begin ( umin head R: boundary ) |
@ dup |
@ dup |
while |
while |
tuck name>int >code-address ( head1 umin c-addr ) |
tuck name>int >code-address ( head1 umin ca R: boundary ) |
r@ - umin |
r@ - umin |
swap |
swap |
repeat |
repeat |
drop r> + ; |
drop dup r@ negate u>= |
|
\ "umin+boundary within [0,boundary)" = "umin within [-boundary,0)" |
|
if ( umin R: boundary ) \ no primitive found behind -> use a default length |
|
drop 31 |
|
then |
|
r> + ; |
|
|
: seecode ( xt -- ) |
: seecode ( xt -- ) |
dup s" Code" .defname |
dup s" Code" .defname |
Line 598 Defer discode ( addr u -- )
|
Line 615 Defer discode ( addr u -- )
|
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 |