version 1.49, 2003/01/26 20:56:37
|
version 1.74, 2010/08/28 10:04:34
|
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,2006,2007,2008 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
\ Gforth is free software; you can redistribute it and/or |
\ Gforth is free software; you can redistribute it and/or |
\ modify it under the terms of the GNU General Public License |
\ modify it under the terms of the GNU General Public License |
\ as published by the Free Software Foundation; either version 2 |
\ as published by the Free Software Foundation, either version 3 |
\ of the License, or (at your option) any later version. |
\ of the License, or (at your option) any later version. |
|
|
\ This program is distributed in the hope that it will be useful, |
\ This program is distributed in the hope that it will be useful, |
Line 15
|
Line 15
|
\ GNU General Public License for more details. |
\ GNU General Public License for more details. |
|
|
\ 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, see http://www.gnu.org/licenses/. |
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
|
|
|
|
|
\ May be cross-compiled |
\ May be cross-compiled |
Line 28
|
Line 27
|
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 84 DEFER nlcount ' noop IS nlcount
|
Line 70 DEFER nlcount ' noop IS nlcount
|
nlflag @ IF (nl) nlflag off THEN |
nlflag @ IF (nl) nlflag off THEN |
XPos @ over + cols u>= IF (nl) THEN ; |
XPos @ over + cols u>= IF (nl) THEN ; |
|
|
: c-to-upper ( c1 -- c2 ) \ gforth |
|
\ nac05feb1999 there is a primitive, toupper, with this function |
|
dup [char] a >= over [char] z <= and if bl - then ; |
|
|
|
: ctype ( adr len -- ) |
: ctype ( adr len -- ) |
warp? dup XPos +! C-Output @ |
warp? dup XPos +! C-Output @ |
IF uppercase @ IF bounds ?DO i c@ c-to-upper emit LOOP |
IF uppercase @ IF bounds ?DO i c@ toupper emit LOOP |
uppercase off ELSE type THEN |
uppercase off ELSE type THEN |
ELSE 2drop THEN ; |
ELSE 2drop THEN ; |
|
|
Line 99 DEFER nlcount ' noop IS nlcount
|
Line 81 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 xt-see-xt ( xt -- ) |
|
\ this one is just a forward declaration for indirect recursion |
|
|
|
: .defname ( xt c-addr u -- ) |
|
rot look |
|
if ( c-addr u nfa ) |
|
-rot type space .name |
|
else |
|
drop ." noname " type |
|
then |
|
space ; |
|
|
|
Defer discode ( addr u -- ) \ gforth |
|
\G hook for the disassembler: disassemble u bytes of code at addr |
|
' dump IS discode |
|
|
|
: next-head ( addr1 -- addr2 ) \ gforth |
|
\G find the next header starting after addr1, up to here (unreliable). |
|
here swap u+do |
|
i head? -2 and if |
|
i unloop exit |
|
then |
|
cell +loop |
|
here ; |
|
|
|
[ifundef] umin \ !! bootstrapping help |
|
: umin ( u1 u2 -- u ) |
|
2dup u> |
|
if |
|
swap |
|
then |
|
drop ; |
|
[then] |
|
|
|
: 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> + ; |
|
|
DEFER .string ( c-addr u n -- ) |
DEFER .string ( c-addr u n -- ) |
|
|
[IFDEF] Green |
[IFDEF] Green |
Line 137 VARIABLE Colors Colors on
|
Line 171 VARIABLE Colors Colors on
|
else |
else |
base @ >r try |
base @ >r try |
8 base ! 0 <<# # # # '\ hold #> ctype #>> 0 |
8 base ! 0 <<# # # # '\ hold #> ctype #>> 0 |
recover |
restore |
|
r@ base ! |
endtry |
endtry |
r> base ! throw |
rdrop throw |
endif |
endif |
endif |
endif |
1 /string |
1 /string |
Line 271 VARIABLE C-Pass
|
Line 306 VARIABLE C-Pass
|
: Scan? ( -- flag ) C-Pass @ 0= ; |
: Scan? ( -- flag ) C-Pass @ 0= ; |
: Display? ( -- flag ) C-Pass @ 1 = ; |
: Display? ( -- flag ) C-Pass @ 1 = ; |
: Debug? ( -- flag ) C-Pass @ 2 = ; |
: Debug? ( -- flag ) C-Pass @ 2 = ; |
|
: ?.string ( c-addr u n -- ) Display? if .string else 2drop drop then ; |
|
|
: back? ( addr target -- addr flag ) |
: back? ( addr target -- addr flag ) |
over u< ; |
over u< ; |
Line 279 VARIABLE C-Pass
|
Line 315 VARIABLE C-Pass
|
\ print x as a word if possible |
\ print x as a word if possible |
dup look 0= IF |
dup look 0= IF |
drop dup threaded>name dup 0= if |
drop dup threaded>name dup 0= if |
2drop dup 1 cells - @ dup body> look |
drop over 1 cells - @ dup body> look |
IF |
IF |
nip dup ." <" name>string rot wordinfo .string ." > " |
nip nip dup ." <" name>string rot wordinfo .string ." > " |
ELSE |
ELSE |
drop ." <" 0 .r ." > " |
2drop ." <" 0 .r ." > " |
THEN |
THEN |
EXIT |
EXIT |
then |
then |
Line 310 VARIABLE C-Pass
|
Line 346 VARIABLE C-Pass
|
\ here docon: , docol: , dovar: , douser: , dodefer: , dofield: , |
\ here docon: , docol: , dovar: , douser: , dodefer: , dofield: , |
\ here over - 2constant doers |
\ here over - 2constant doers |
|
|
|
[IFDEF] !does |
|
: c-does> \ end of create part |
|
Display? IF S" DOES> " Com# .string THEN ; |
|
\ maxaligned /does-handler + ; \ !! no longer needed for non-cross stuff |
|
[THEN] |
|
|
: c-lit ( addr1 -- addr2 ) |
: c-lit ( addr1 -- addr2 ) |
Display? IF |
dup @ dup body> dup cfaligned over = swap in-dictionary? and if |
dup @ dup body> dup cfaligned over = swap in-dictionary? and if |
( addr1 addr1@ ) |
( addr1 addr1@ ) |
dup body> @ dovar: = if |
dup body> @ dovar: = if |
drop c-call EXIT |
drop c-call EXIT |
|
endif |
|
endif |
endif |
|
endif |
|
over 4 cells + over = if |
|
over 1 cells + @ decompile-prim ['] call xt>threaded = >r |
|
over 3 cells + @ decompile-prim ['] ;S xt>threaded = |
|
r> and if |
|
over 2 cells + @ ['] !does >body = if drop |
|
S" DOES> " Com# ?.string 4 cells + EXIT endif |
|
endif |
|
[IFDEF] !;abi-code |
|
over 2 cells + @ ['] !;abi-code >body = if drop |
|
S" ;abi-code " Com# ?.string 4 cells + |
|
c-stop on |
|
Display? if |
|
dup dup next-head over - discode |
|
S" end-code" Com# ?.string |
|
then EXIT |
|
endif |
|
[THEN] |
|
endif |
|
Display? if |
\ !! test for cfa here, and print "['] ..." |
\ !! test for cfa here, and print "['] ..." |
dup abs 0 <# #S rot sign #> 0 .string bl cemit |
dup abs 0 <# #S rot sign #> 0 .string bl cemit |
endif |
else drop then |
cell+ ; |
cell+ ; |
|
|
: c-lit+ ( addr1 -- addr2 ) |
: c-lit+ ( addr1 -- addr2 ) |
Line 467 VARIABLE C-Pass
|
Line 527 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 507 VARIABLE C-Pass
|
Line 567 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 526 VARIABLE C-Pass
|
Line 586 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 543 VARIABLE C-Pass
|
Line 606 VARIABLE C-Pass
|
ELSE 2drop |
ELSE 2drop |
THEN ; |
THEN ; |
|
|
[IFDEF] (does>) |
|
: c-does> \ end of create part |
|
Display? IF S" DOES> " Com# .string THEN |
|
maxaligned /does-handler + ; |
|
[THEN] |
|
|
|
[IFDEF] (compile) |
[IFDEF] (compile) |
: c-(compile) |
: c-(compile) |
Display? |
Display? |
Line 590 CREATE C-Table
|
Line 647 CREATE C-Table
|
[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 |
[IFDEF] (compile) ' (compile) A, ' c-(compile) A, [THEN] |
[IFDEF] (compile) ' (compile) A, ' c-(compile) A, [THEN] |
[IFDEF] (does>) ' (does>) A, ' c-does> A, [THEN] |
|
0 , here 0 , |
0 , here 0 , |
|
|
avariable c-extender |
avariable c-extender |
Line 658 c-extender !
|
Line 714 c-extender !
|
c-stop @ |
c-stop @ |
UNTIL drop ; |
UNTIL drop ; |
|
|
Defer xt-see-xt ( xt -- ) |
|
\ this one is just a forward declaration for indirect recursion |
|
|
|
: .defname ( xt c-addr u -- ) |
|
rot look |
|
if ( c-addr u nfa ) |
|
-rot type space .name |
|
else |
|
drop ." noname " type |
|
then |
|
space ; |
|
|
|
Defer discode ( addr u -- ) \ gforth |
|
\G hook for the disassembler: disassemble code at addr of length u |
|
' dump IS discode |
|
|
|
: next-head ( addr1 -- addr2 ) \ gforth |
|
\G find the next header starting after addr1, up to here (unreliable). |
|
here swap u+do |
|
i head? -2 and 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 |
>code-address |
>code-address |
Line 718 Defer discode ( addr u -- ) \ gforth
|
Line 725 Defer discode ( addr u -- ) \ gforth
|
then |
then |
over - discode |
over - discode |
." end-code" cr ; |
." end-code" cr ; |
|
: seeabicode ( xt -- ) |
|
dup s" ABI-Code" .defname |
|
>body dup dup next-head |
|
swap - discode |
|
." end-code" cr ; |
: seevar ( xt -- ) |
: seevar ( xt -- ) |
s" Variable" .defname cr ; |
s" Variable" .defname cr ; |
: seeuser ( xt -- ) |
: seeuser ( xt -- ) |
Line 734 Defer discode ( addr u -- ) \ gforth
|
Line 746 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 769 Defer discode ( addr u -- ) \ gforth
|
Line 781 Defer discode ( addr u -- ) \ gforth
|
dup >code-address |
dup >code-address |
CASE |
CASE |
docon: of seecon endof |
docon: of seecon endof |
|
[IFDEF] dovalue: |
|
dovalue: of seevalue endof |
|
[THEN] |
docol: of seecol endof |
docol: of seecol endof |
dovar: of seevar endof |
dovar: of seevar endof |
[ [IFDEF] douser: ] |
[IFDEF] douser: |
douser: of seeuser endof |
douser: of seeuser endof |
[ [THEN] ] |
[THEN] |
[ [IFDEF] dodefer: ] |
[IFDEF] dodefer: |
dodefer: of seedefer endof |
dodefer: of seedefer endof |
[ [THEN] ] |
[THEN] |
[ [IFDEF] dofield: ] |
[IFDEF] dofield: |
dofield: of seefield endof |
dofield: of seefield endof |
[ [THEN] ] |
[THEN] |
|
[IFDEF] doabicode: |
|
doabicode: of seeabicode endof |
|
[THEN] |
over of seecode endof \ direct threaded code words |
over of seecode endof \ direct threaded code words |
over >body of seecode endof \ indirect threaded code words |
over >body of seecode endof \ indirect threaded code words |
2drop abort" unknown word type" |
2drop abort" unknown word type" |
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 807 Defer discode ( addr u -- ) \ gforth
|
Line 825 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 ; |