version 1.24, 1999/11/20 12:12:52
|
version 1.41, 2002/09/14 11:18:57
|
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 136 VARIABLE SearchPointer
|
Line 148 VARIABLE SearchPointer
|
\ The branchtable consists of three entrys: |
\ The branchtable consists of three entrys: |
\ address of branch , branch destination , branch type |
\ address of branch , branch destination , branch type |
|
|
CREATE BranchTable 500 allot |
CREATE BranchTable 128 cells allot |
here 3 cells - |
here 3 cells - |
ACONSTANT MaxTable |
ACONSTANT MaxTable |
|
|
Line 242 VARIABLE C-Pass
|
Line 254 VARIABLE C-Pass
|
THEN |
THEN |
cell+ ; |
cell+ ; |
|
|
|
: .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 |
|
Display? IF ." call " dup @ body> .word bl cemit THEN 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 444 VARIABLE C-Pass
|
|
|
CREATE C-Table |
CREATE C-Table |
' lit A, ' c-lit A, |
' lit A, ' c-lit A, |
|
[IFDEF] call ' call A, ' c-call A, [THEN] |
' (s") A, ' c-c" A, |
' (s") A, ' c-c" A, |
' (.") A, ' c-c" A, |
' (.") A, ' c-c" A, |
' "lit A, ' c-c" A, |
' "lit A, ' c-c" A, |
Line 451 c-extender !
|
Line 483 c-extender !
|
( end!) 2drop false EXIT THEN |
( end!) 2drop false EXIT THEN |
THEN |
THEN |
\ jump over to extender, if any 26jan97jaw |
\ jump over to extender, if any 26jan97jaw |
2 pick <> |
xt>threaded 2 pick <> |
WHILE 2 cells + |
WHILE 2 cells + |
REPEAT |
REPEAT |
nip cell+ perform |
nip cell+ perform |
Line 476 c-extender !
|
Line 508 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 514 Defer xt-see-xt ( xt -- )
|
Line 544 Defer xt-see-xt ( xt -- )
|
then |
then |
space ; |
space ; |
|
|
Defer discode ( addr -- ) |
Defer discode ( addr u -- ) \ gforth |
\ hook for the disassembler: disassemble code at addr (as far as the |
\G hook for the disassembler: disassemble code at addr of length u |
\ disassembler thinks is sensible) |
' dump IS discode |
:noname ( addr -- ) |
|
drop ." ..." ; |
: next-head ( addr1 -- addr2 ) \ gforth |
IS discode |
\G find the next header starting after addr1, up to here (unreliable). |
|
here swap u+do |
|
i head? |
|
if |
|
i unloop exit |
|
then |
|
cell +loop |
|
here ; |
|
|
|
: umin ( u1 u2 -- u ) |
|
2dup u> |
|
if |
|
swap |
|
then |
|
drop ; |
|
|
|
: next-prim ( addr1 -- addr2 ) \ gforth |
|
\G find the next primitive after addr1 (unreliable) |
|
1+ >r -1 primstart |
|
begin ( umin head R: boundary ) |
|
@ dup |
|
while |
|
tuck name>int >code-address ( head1 umin ca R: boundary ) |
|
r@ - umin |
|
swap |
|
repeat |
|
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 |
threading-method |
>code-address |
|
dup in-dictionary? \ user-defined code word? |
if |
if |
>code-address |
dup next-head |
|
else |
|
dup next-prim |
then |
then |
discode |
over - discode |
." end-code" cr ; |
." end-code" cr ; |
: seevar ( xt -- ) |
: seevar ( xt -- ) |
s" Variable" .defname cr ; |
s" Variable" .defname cr ; |
: seeuser ( xt -- ) |
: seeuser ( xt -- ) |
Line 542 IS discode
|
Line 606 IS discode
|
: seedefer ( xt -- ) |
: seedefer ( xt -- ) |
dup >body @ xt-see-xt cr |
dup >body @ xt-see-xt cr |
dup s" Defer" .defname cr |
dup s" Defer" .defname cr |
>name dup ??? = if |
>name ?dup-if |
drop ." lastxt >body !" |
|
else |
|
." IS " .name cr |
." IS " .name cr |
|
else |
|
." lastxt >body !" |
then ; |
then ; |
: see-threaded ( addr -- ) |
: see-threaded ( addr -- ) |
C-Pass @ DebugMode = IF |
C-Pass @ DebugMode = IF |
Line 566 IS discode
|
Line 630 IS discode
|
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 590 IS discode
|
Line 655 IS discode
|
[ [IFDEF] dofield: ] |
[ [IFDEF] dofield: ] |
dofield: of seefield endof |
dofield: of seefield endof |
[ [THEN] ] |
[ [THEN] ] |
over >body of seecode endof |
over of seecode endof \ direct threaded code words |
|
over >body of seecode endof \ indirect threaded code words |
2drop abort" unknown word type" |
2drop abort" unknown word type" |
ENDCASE ; |
ENDCASE ; |
|
|
Line 610 IS discode
|
Line 676 IS discode
|
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 |