version 1.45, 2002/12/26 14:09:20
|
version 1.57, 2006/05/07 18:14:11
|
Line 1
|
Line 1
|
\ SEE.FS highend SEE for ANSforth 16may93jaw |
\ SEE.FS highend SEE for ANSforth 16may93jaw |
|
|
\ Copyright (C) 1995,2000 Free Software Foundation, Inc. |
\ Copyright (C) 1995,2000,2003,2004 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
Line 28
|
Line 28
|
require look.fs |
require look.fs |
require termsize.fs |
require termsize.fs |
require wordinfo.fs |
require wordinfo.fs |
[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 275 VARIABLE C-Pass
|
Line 262 VARIABLE C-Pass
|
: back? ( addr target -- addr flag ) |
: back? ( addr target -- addr flag ) |
over u< ; |
over u< ; |
|
|
: .word ( addr xt -- addr ) |
: .word ( addr x -- addr ) |
look 0= IF |
\ print x as a word if possible |
drop dup 1 cells - @ dup body> look |
dup look 0= IF |
IF |
drop dup threaded>name dup 0= if |
nip dup ." <" name>string rot wordinfo .string ." >" |
drop over 1 cells - @ dup body> look |
ELSE |
IF |
drop ." <" 0 .r ." >" |
nip nip dup ." <" name>string rot wordinfo .string ." > " |
THEN |
ELSE |
ELSE |
2drop ." <" 0 .r ." > " |
dup cell+ @ immediate-mask and |
THEN |
IF |
EXIT |
bl cemit ." POSTPONE " |
then |
THEN |
THEN |
dup name>string rot wordinfo .string |
nip dup cell+ @ immediate-mask and |
THEN ; |
IF |
|
bl cemit ." POSTPONE " |
|
THEN |
|
dup name>string rot wordinfo .string |
|
; |
|
|
: c-call ( addr1 -- addr2 ) |
: c-call ( addr1 -- addr2 ) |
Display? IF |
Display? IF |
Line 327 VARIABLE C-Pass
|
Line 318 VARIABLE C-Pass
|
cell+ ; |
cell+ ; |
|
|
: .name-without ( addr -- addr ) |
: .name-without ( addr -- addr ) |
\ prints a name without a() e.g. a(+LOOP) or (s") |
\ !! the stack effect cannot be correct |
dup 1 cells - @ look IF |
\ prints a name without a() e.g. a(+LOOP) or (s") |
|
dup 1 cells - @ threaded>name dup IF |
name>string over c@ 'a = IF |
name>string over c@ 'a = IF |
1 /string |
1 /string |
THEN |
THEN |
Line 354 VARIABLE C-Pass
|
Line 346 VARIABLE C-Pass
|
\ if f is false, addr2=addr1 |
\ if f is false, addr2=addr1 |
\ recognizes the following patterns: |
\ recognizes the following patterns: |
\ c": ahead X: len string then lit X |
\ c": ahead X: len string then lit X |
\ s\": ahead X: string then lit X lit len |
\ flit: ahead X: float then lit X f@ |
\ .\": ahead X: string then lit X lit len type |
\ s\": ahead X: string then lit X lit len |
|
\ .\": ahead X: string then lit X lit len type |
\ !! not recognized anywhere: |
\ !! not recognized anywhere: |
\ abort": if ahead X: len string then lit X c(abort") then |
\ abort": if ahead X: len string then lit X c(abort") then |
dup @ back? if false exit endif |
dup @ back? if false exit endif |
Line 363 VARIABLE C-Pass
|
Line 356 VARIABLE C-Pass
|
r@ @ decompile-prim ['] lit xt>threaded <> if rdrop false exit endif |
r@ @ decompile-prim ['] lit xt>threaded <> if rdrop false exit endif |
r@ cell+ @ over cell+ <> if rdrop false exit endif |
r@ cell+ @ over cell+ <> if rdrop false exit endif |
\ we have at least C" |
\ we have at least C" |
r@ 2 cells + @ decompile-prim ['] lit xt>threaded = if |
r@ 2 cells + @ decompile-prim dup ['] lit xt>threaded = if |
r@ 3 cells + @ over cell+ + aligned r@ = if |
drop r@ 3 cells + @ over cell+ + aligned r@ = if |
\ we have at least s" |
\ we have at least s" |
r@ 4 cells + @ decompile-prim ['] lit-perform xt>threaded = |
r@ 4 cells + @ decompile-prim ['] lit-perform xt>threaded = |
r@ 5 cells + @ ['] type >body = and if |
r@ 5 cells + @ ['] type >body = and if |
Line 381 VARIABLE C-Pass
|
Line 374 VARIABLE C-Pass
|
nip cells r> + true exit |
nip cells r> + true exit |
endif |
endif |
endif |
endif |
|
['] f@ xt>threaded = if |
|
display? if |
|
r@ cell+ @ f@ 10 8 16 f>str-rdp 0 .string bl cemit |
|
endif |
|
drop r> 3 cells + true exit |
|
endif |
\ !! check if count matches space? |
\ !! check if count matches space? |
display? if |
display? if |
s\" c\" " 0 .string r@ cell+ @ count 0 .string '" cemit bl cemit |
s\" c\" " 0 .string r@ cell+ @ count 0 .string '" cemit bl cemit |
Line 455 VARIABLE C-Pass
|
Line 454 VARIABLE C-Pass
|
THEN |
THEN |
THEN |
THEN |
Debug? |
Debug? |
IF dup @ + |
IF @ \ !!! cross-interacts with debugger !!! |
ELSE cell+ |
ELSE cell+ |
THEN ; |
THEN ; |
|
|
: DebugBranch |
: DebugBranch |
Debug? |
Debug? |
IF dup @ over + swap THEN ; \ return 2 different addresses |
IF dup @ swap THEN ; \ return 2 different addresses |
|
|
: c-?branch |
: c-?branch |
Scan? |
Scan? |
Line 495 VARIABLE C-Pass
|
Line 494 VARIABLE C-Pass
|
Display? IF nl S" FOR" .struc level+ THEN ; |
Display? IF nl S" FOR" .struc level+ THEN ; |
|
|
: c-loop |
: c-loop |
Display? IF level- nl .name-without bl cemit nl THEN |
Display? IF level- nl .name-without nl bl cemit THEN |
DebugBranch cell+ |
DebugBranch cell+ |
Scan? |
Scan? |
IF dup BranchAddr? |
IF dup BranchAddr? |
Line 514 VARIABLE C-Pass
|
Line 513 VARIABLE C-Pass
|
THEN |
THEN |
DebugBranch cell+ ; |
DebugBranch cell+ ; |
|
|
: c-exit dup 1 cells - |
: c-exit ( addr1 -- addr2 ) |
CheckEnd |
dup 1 cells - |
IF Display? IF nlflag off S" ;" Com# .string THEN |
CheckEnd |
C-Stop on |
IF |
ELSE Display? IF S" EXIT " .struc THEN |
Display? IF nlflag off S" ;" Com# .string THEN |
THEN |
C-Stop on |
Debug? IF drop THEN ; |
ELSE |
|
Display? IF S" EXIT " .struc THEN |
|
THEN |
|
Debug? IF drop THEN ; \ !!! cross-interacts with debugger !!! |
|
|
: c-abort" |
: c-abort" |
count 2dup + aligned -rot |
count 2dup + aligned -rot |
Line 561 CREATE C-Table
|
Line 563 CREATE C-Table
|
[IFDEF] "lit ' "lit 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) ' a(+do) A, ' c-?do A, [THEN] |
[IFDEF] (+do) ' (+do) A, ' c-?do A, [THEN] |
[IFDEF] (u+do) ' a(u+do) A, ' c-?do A, [THEN] |
[IFDEF] (u+do) ' (u+do) A, ' c-?do A, [THEN] |
[IFDEF] (-do) ' a(-do) A, ' c-?do A, [THEN] |
[IFDEF] (-do) ' (-do) A, ' c-?do A, [THEN] |
[IFDEF] (u-do) ' a(u-do) A, ' c-?do A, [THEN] |
[IFDEF] (u-do) ' (u-do) A, ' c-?do A, [THEN] |
' a(?do) A, ' c-?do A, |
' (?do) A, ' c-?do A, |
' (for) A, ' c-for A, |
' (for) A, ' c-for A, |
' a?branch A, ' c-?branch A, |
' ?branch A, ' c-?branch A, |
' abranch A, ' c-branch A, |
' branch A, ' c-branch A, |
' a(loop) A, ' c-loop A, |
' (loop) A, ' c-loop A, |
' a(+loop) A, ' c-loop A, |
' (+loop) A, ' c-loop A, |
[IFDEF] (s+loop) ' a(s+loop) A, ' c-loop A, [THEN] |
[IFDEF] (s+loop) ' (s+loop) A, ' c-loop A, [THEN] |
[IFDEF] (-loop) ' a(-loop) A, ' c-loop A, [THEN] |
[IFDEF] (-loop) ' (-loop) A, ' c-loop A, [THEN] |
' a(next) A, ' c-loop A, |
' (next) A, ' c-loop A, |
' ;s A, ' c-exit A, |
' ;s A, ' c-exit A, |
[IFDEF] (abort") ' (abort") A, ' c-abort" A, [THEN] |
[IFDEF] (abort") ' (abort") A, ' c-abort" A, [THEN] |
\ only defined if compiler is loaded |
\ only defined if compiler is loaded |
Line 671 Defer discode ( addr u -- ) \ gforth
|
Line 673 Defer discode ( addr u -- ) \ gforth
|
cell +loop |
cell +loop |
here ; |
here ; |
|
|
|
[ifundef] umin \ !! bootstrapping help |
: umin ( u1 u2 -- u ) |
: umin ( u1 u2 -- u ) |
2dup u> |
2dup u> |
if |
if |
swap |
swap |
then |
then |
drop ; |
drop ; |
|
[then] |
|
|
: next-prim ( addr1 -- addr2 ) \ gforth |
: next-prim ( addr1 -- addr2 ) \ gforth |
\G find the next primitive after addr1 (unreliable) |
\G find the next primitive after addr1 (unreliable) |
1+ >r -1 primstart |
1+ >r -1 primstart |
Line 722 Defer discode ( addr u -- ) \ gforth
|
Line 726 Defer discode ( addr u -- ) \ gforth
|
>name ?dup-if |
>name ?dup-if |
." IS " .name cr |
." IS " .name cr |
else |
else |
." lastxt >body !" |
." latestxt >body !" |
then ; |
then ; |
: see-threaded ( addr -- ) |
: see-threaded ( addr -- ) |
C-Pass @ DebugMode = IF |
C-Pass @ DebugMode = IF |
Line 774 Defer discode ( addr u -- ) \ gforth
|
Line 778 Defer discode ( addr u -- ) \ gforth
|
ENDCASE ; |
ENDCASE ; |
|
|
: (xt-see-xt) ( xt -- ) |
: (xt-see-xt) ( xt -- ) |
xt-see cr ." lastxt" ; |
xt-see cr ." latestxt" ; |
' (xt-see-xt) is xt-see-xt |
' (xt-see-xt) is xt-see-xt |
|
|
: (.immediate) ( xt -- ) |
: (.immediate) ( xt -- ) |
Line 795 Defer discode ( addr u -- ) \ gforth
|
Line 799 Defer discode ( addr u -- ) \ gforth
|
else \ interpret/compile word |
else \ interpret/compile word |
r@ xt-see-xt cr |
r@ xt-see-xt cr |
swap xt-see-xt cr |
swap xt-see-xt cr |
." interpret/compile " over .name (.immediate) |
." interpret/compile: " over .name drop |
then |
then |
then |
then |
rdrop drop ; |
rdrop drop ; |