version 1.17, 1997/06/01 20:50:39
|
version 1.22, 1999/02/16 06:32:30
|
Line 25
|
Line 25
|
|
|
\ Ideas: Level should be a stack |
\ Ideas: Level should be a stack |
|
|
|
require look.fs |
require termsize.fs |
require termsize.fs |
|
require wordinfo.fs |
|
[IFUNDEF] .name : .name name>string type space ; [THEN] |
|
|
decimal |
decimal |
|
|
Line 56 DEFER nlcount ' noop IS nlcount
|
Line 59 DEFER nlcount ' noop IS nlcount
|
|
|
: nl nlflag on ; |
: nl nlflag on ; |
: (nl) nlcount |
: (nl) nlcount |
XPos @ Level @ = ?Exit |
XPos @ Level @ = IF EXIT THEN \ ?Exit |
C-Formated @ IF |
C-Formated @ IF |
C-Output @ |
C-Output @ |
IF C-Clearline @ IF cols XPos @ - spaces |
IF C-Clearline @ IF cols XPos @ - spaces |
Line 69 DEFER nlcount ' noop IS nlcount
|
Line 72 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 |
: c-to-upper ( c1 -- c2 ) \ gforth |
dup [char] a >= over [char] z <= and if bl - then ; |
\ 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 @ |
Line 247 VARIABLE C-Pass
|
Line 251 VARIABLE C-Pass
|
THEN |
THEN |
cell+ ; |
cell+ ; |
|
|
: c-s" |
: .name-without ( addr -- addr ) |
count 2dup + aligned -rot |
\ prints a name without () e.g. (+LOOP) or (s") |
Display? |
dup 1 cells - @ look |
IF [char] S cemit [char] " cemit bl cemit 0 .string |
IF name>string over c@ '( = IF 1 /string THEN |
[char] " cemit bl cemit |
2dup + 1- c@ ') = IF 1- THEN .struc ELSE drop |
ELSE 2drop |
THEN ; |
THEN ; |
|
|
|
: c-." |
|
count 2dup + aligned -rot |
|
Display? |
|
IF [char] . cemit |
|
[char] " cemit bl cemit 0 .string |
|
[char] " cemit bl cemit |
|
ELSE 2drop |
|
THEN ; |
|
|
|
: c-c" |
: c-c" |
|
Display? IF nl .name-without THEN |
count 2dup + aligned -rot |
count 2dup + aligned -rot |
Display? |
Display? |
IF [char] C cemit [char] " cemit bl cemit 0 .string |
IF bl cemit 0 .string |
[char] " cemit bl cemit |
[char] " cemit bl cemit |
ELSE 2drop |
ELSE 2drop |
THEN ; |
THEN ; |
Line 373 VARIABLE C-Pass
|
Line 368 VARIABLE C-Pass
|
: c-for |
: c-for |
Display? IF nl S" FOR" .struc level+ THEN ; |
Display? IF nl S" FOR" .struc level+ THEN ; |
|
|
: .name-without |
|
\ prints a name without () e.g. (+LOOP) |
|
dup 1 cells - @ look IF name>string 1 /string 1- .struc ELSE drop THEN ; |
|
|
|
: c-loop |
: c-loop |
Display? IF level- nl .name-without bl cemit nl THEN |
Display? IF level- nl .name-without bl cemit nl THEN |
DebugBranch cell+ |
DebugBranch cell+ |
Line 405 VARIABLE C-Pass
|
Line 396 VARIABLE C-Pass
|
|
|
: c-does> \ end of create part |
: c-does> \ end of create part |
Display? IF S" DOES> " Com# .string THEN |
Display? IF S" DOES> " Com# .string THEN |
Cell+ cell+ ; |
maxaligned /does-handler + ; |
|
|
: c-abort" |
: c-abort" |
count 2dup + aligned -rot |
count 2dup + aligned -rot |
Line 418 VARIABLE C-Pass
|
Line 409 VARIABLE C-Pass
|
|
|
|
|
CREATE C-Table |
CREATE C-Table |
' lit A, ' c-lit A, |
' lit A, ' c-lit A, |
' (s") A, ' c-s" A, |
' (s") A, ' c-c" A, |
' (.") A, ' c-." A, |
' (.") A, ' c-c" A, |
' "lit A, ' c-c" A, |
' "lit A, ' c-c" A, |
' (do) A, ' c-do A, |
[IFDEF] (c") ' (c") A, ' c-c" A, [THEN] |
' (+do) A, ' c-do A, |
' (do) A, ' c-do A, |
' (u+do) A, ' c-do A, |
[IFDEF] (+do) ' (+do) A, ' c-do A, [THEN] |
' (-do) A, ' c-do A, |
[IFDEF] (u+do) ' (u+do) A, ' c-do A, [THEN] |
' (u-do) A, ' c-do A, |
[IFDEF] (-do) ' (-do) A, ' c-do A, [THEN] |
' (?do) A, ' c-?do A, |
[IFDEF] (u-do) ' (u-do) A, ' c-do A, [THEN] |
' (for) A, ' c-for A, |
' (?do) A, ' c-?do A, |
' ?branch A, ' c-?branch A, |
' (for) A, ' c-for A, |
' branch A, ' c-branch A, |
' ?branch A, ' c-?branch A, |
' (loop) A, ' c-loop A, |
' branch A, ' c-branch A, |
' (+loop) A, ' c-loop A, |
' (loop) A, ' c-loop A, |
' (s+loop) A, ' c-loop A, |
' (+loop) A, ' c-loop A, |
' (-loop) A, ' c-loop A, |
[IFDEF] (s+loop) ' (s+loop) A, ' c-loop A, [THEN] |
' (next) A, ' c-loop A, |
[IFDEF] (-loop) ' (-loop) A, ' c-loop A, [THEN] |
' ;s A, ' c-exit A, |
' (next) A, ' c-loop A, |
' (does>) A, ' c-does> A, |
' ;s A, ' c-exit A, |
' (abort") A, ' c-abort" A, |
' (does>) A, ' c-does> A, |
' (compile) A, ' c-(compile) A, |
' (abort") A, ' c-abort" A, |
0 , here 0 , |
' (compile) A, ' c-(compile) A, |
|
0 , here 0 , |
|
|
avariable c-extender |
avariable c-extender |
c-extender ! |
c-extender ! |
Line 527 IS discode
|
Line 519 IS discode
|
|
|
: seecode ( xt -- ) |
: seecode ( xt -- ) |
dup s" Code" .defname |
dup s" Code" .defname |
>body discode |
threading-method |
|
if |
|
>code-address |
|
then |
|
discode |
." end-code" cr ; |
." end-code" cr ; |
: seevar ( xt -- ) |
: seevar ( xt -- ) |
s" Variable" .defname cr ; |
s" Variable" .defname cr ; |
Line 572 IS discode
|
Line 568 IS discode
|
if |
if |
seedoes EXIT |
seedoes EXIT |
then |
then |
dup forthstart u< |
dup xtprim? |
if |
if |
seecode EXIT |
seecode EXIT |
then |
then |
Line 581 IS discode
|
Line 577 IS discode
|
docon: of seecon endof |
docon: of seecon endof |
docol: of seecol endof |
docol: of seecol endof |
dovar: of seevar endof |
dovar: of seevar endof |
|
[ [IFDEF] douser: ] |
douser: of seeuser endof |
douser: of seeuser endof |
|
[ [THEN] ] |
|
[ [IFDEF] dodefer: ] |
dodefer: of seedefer endof |
dodefer: of seedefer endof |
|
[ [THEN] ] |
|
[ [IFDEF] dofield: ] |
dofield: of seefield endof |
dofield: of seefield endof |
|
[ [THEN] ] |
over >body of seecode endof |
over >body of seecode endof |
2drop abort" unknown word type" |
2drop abort" unknown word type" |
ENDCASE ; |
ENDCASE ; |
Line 615 IS discode
|
Line 617 IS discode
|
then |
then |
rdrop drop ; |
rdrop drop ; |
|
|
: see ( "name" -- ) \ tools |
: see ( "<spaces>name" -- ) \ tools |
|
\G Locate @var{name} using the current search order. Display the |
|
\G definition of @var{name}. Since this is achieved by decompiling |
|
\G the definition, the formatting is mechanised and some source |
|
\G information (comments, interpreted sequences within definitions |
|
\G etc.) is lost. |
name find-name dup 0= |
name find-name dup 0= |
IF |
IF |
drop -&13 bounce |
drop -&13 bounce |