gforth: gforth/see.fs

Diff for /gforth/see.fs between version 1.8 and 1.42

-version 1.8, Thu Nov  2 14:20:53 1995 UTC
+version 1.42, Wed Dec  4 10:42:59 2002 UTC
  Line 1
  Line 1
  Line 1
  \ SEE.FS       highend SEE for ANSforth                16may93jaw
+ \ Copyright (C) 1995,2000 Free Software Foundation, Inc.
+ \ This file is part of Gforth.
+ \ Gforth is free software; you can redistribute it and/or
+ \ modify it under the terms of the GNU General Public License
+ \ as published by the Free Software Foundation; either version 2
+ \ of the License, or (at your option) any later version.
+ \ This program is distributed in the hope that it will be useful,
+ \ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ \ GNU General Public License for more details.
+ \ You should have received a copy of the GNU General Public License
+ \ along with this program; if not, write to the Free Software
+ \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  \ May be cross-compiled
  \ I'm sorry. This is really not "forthy" enough.
  \ Ideas:        Level should be a stack
+ require look.fs
+ require termsize.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
  \ Screen format words                                   16may93jaw
- Line 29
+ Line 65
  Line 29
  Line 65
  : level-        -7 Level +! ;
  VARIABLE nlflag
+ VARIABLE uppercase      \ structure words are in uppercase
  DEFER nlcount ' noop IS nlcount
  : nl            nlflag on ;
  : (nl)          nlcount
-                 XPos @ Level @ = ?Exit
+                 XPos @ Level @ = IF EXIT THEN \ ?Exit
                  C-Formated @ IF
                  C-Output @
-                 IF C-Clearline @ IF 80 XPos @ - spaces
+                 IF C-Clearline @ IF cols XPos @ - spaces
                                   ELSE cr THEN
 YPos +! 0 XPos !
                  Level @ spaces
- Line 45
+ Line 82
  Line 45
  Line 82
  : warp?         ( len -- len )
                  nlflag @ IF (nl) nlflag off THEN
-                 XPos @ over + 79 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 -- )
-                 warp? dup XPos +! C-Output @ IF type ELSE 2drop THEN ;
+                 warp? dup XPos +! C-Output @
+                 IF uppercase @ IF bounds ?DO i c@ c-to-upper emit LOOP
+                                   uppercase off ELSE type THEN
+                 ELSE 2drop THEN ;
  : cemit         1 warp?
                  over bl = Level @ XPos @ = and
                  IF 2drop ELSE XPos +! C-Output @ IF emit ELSE drop THEN
                  THEN ;
- DEFER .string
+ DEFER .string ( c-addr u n -- )
  [IFDEF] Green
  VARIABLE Colors Colors on
- Line 77
+ Line 121
  Line 77
  Line 121
  ' (.string) IS .string
- : .struc        Str# .string ;
+ : .struc
+         uppercase on Str# .string ;
- \ CODES                                                 15may93jaw
+ \ CODES (Branchtypes)                                    15may93jaw
 CONSTANT RepeatCode
 CONSTANT AgainCode
- Line 89
+ Line 134
  Line 89
  Line 134
 CONSTANT AheadCode
 CONSTANT WhileCode2
 CONSTANT Disable
+CONSTANT LeaveCode
  \ FORMAT WORDS                                          13jun93jaw
  VARIABLE C-Stop
  VARIABLE Branches
- VARIABLE BranchPointer
+ VARIABLE BranchPointer  \ point to the end of branch table
  VARIABLE SearchPointer
- CREATE BranchTable 500 allot
+ \ The branchtable consists of three entrys:
+ \ address of branch , branch destination , branch type
+ CREATE BranchTable 128 cells allot
  here 3 cells -
  ACONSTANT MaxTable
  : FirstBranch BranchTable cell+ SearchPointer ! ;
- : (BranchAddr?) ( a-addr -- a-addr true | false )
+ : (BranchAddr?) ( a-addr1 -- a-addr2 true | false )
+ \ searches a branch with destination a-addr1
+ \ a-addr1: branch destination
+ \ a-addr2: pointer in branch table
          SearchPointer @
          BEGIN   dup BranchPointer @ u<
          WHILE
- Line 132
+ Line 186
  Line 132
  Line 186
 drop true
          THEN ;
+ : MyBranch      ( a-addr -- a-addr a-addr2 )
+ \ finds branch table entry for branch at a-addr
+                 dup @ over +
+                 BranchAddr?
+                 BEGIN
+                 WHILE 1 cells - @
+                       over <>
+                 WHILE dup @ over +
+                       MoreBranchAddr?
+                 REPEAT
+                 SearchPointer @ 3 cells -
+                 ELSE    true ABORT" SEE: Table failure"
+                 THEN ;
  \
  \                 addrw               addrt
  \       BEGIN ... WHILE ... AGAIN ... THEN
- Line 180
+ Line 248
  Line 180
  Line 248
  : back? ( n -- flag ) 0< ;
  : ahead? ( n -- flag ) 0> ;
- : c-(compile)
-         Display? IF s" POSTPONE " Com# .string
-                     dup @ look 0= ABORT" SEE: No valid XT"
-                     cell+ count $1F and 0 .string bl cemit
-                  THEN
-         cell+ ;
  : c-lit
      Display? IF
          dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
      THEN
      cell+ ;
- : c-@local#
+ : .word ( addr xt -- addr )
-     Display? IF
+     look 0= IF
-         S" @local" 0 .string
+         drop dup 1 cells - @ dup body> look
-         dup @ dup 1 cells / abs 0 <# #S rot sign #> 0 .string bl cemit
+         IF
-     THEN
+             nip dup ." <" name>string rot wordinfo .string ." >"
-     cell+ ;
- : c-flit
-     Display? IF
-         dup f@ scratch represent 0=
-         IF    2drop  scratch 3 min 0 .string
          ELSE
-             IF  '- cemit  THEN  1-
+             drop ." <" 0 .r ." >"
-             scratch over c@ cemit '. cemit 1 /string 0 .string
-             'E cemit
-             dup abs 0 <# #S rot sign #> 0 .string bl cemit
-         THEN THEN
-     float+ ;
- : c-f@local#
-     Display? IF
-         S" f@local" 0 .string
-         dup @ dup 1 floats / abs 0 <# #S rot sign #> 0 .string bl cemit
-     THEN
-     cell+ ;
- : c-laddr#
-     Display? IF
-         S" laddr# " 0 .string
-         dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
      THEN
-     cell+ ;
+     ELSE
+         dup cell+ @ immediate-mask and
- : c-lp+!#
+         IF
-     Display? IF
+             bl cemit  ." POSTPONE "
-         S" lp+!# " 0 .string
-         dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
      THEN
-     cell+ ;
+         dup name>string rot wordinfo .string
- : c-s"
-         count 2dup + aligned -rot
-         Display?
-         IF      [char] S cemit [char] " cemit bl cemit 0 .string
-                 [char] " cemit bl cemit
-         ELSE    2drop
          THEN ;
- : c-."
+ : c-call
-         count 2dup + aligned -rot
+     Display? IF  ." call " dup @ body> .word bl cemit  THEN  cell+ ;
-         Display?
-         IF      [char] . cemit
+ : .name-without ( addr -- addr )
-                 [char] " cemit bl cemit 0 .string
+ \ prints a name without () e.g. (+LOOP) or (s")
-                 [char] " cemit bl cemit
+   dup 1 cells - @ look
-         ELSE    2drop
+   IF   name>string over c@ '( = IF 1 /string THEN
+dup + 1- c@ ') = IF 1- THEN .struc ELSE drop
          THEN ;
  : c-c"
+         Display? IF nl .name-without THEN
          count 2dup + aligned -rot
          Display?
-         IF      [char] C cemit [char] " cemit bl cemit 0 .string
+         IF      bl cemit 0 .string
                  [char] " cemit bl cemit
          ELSE    2drop
          THEN ;
- : Forward? ( a-addr true | false -- )
+ : Forward? ( a-addr true | false -- a-addr true | false )
+ \ a-addr1 is pointer into branch table
+ \ returns true when jump is a forward jump
          IF      dup dup @ swap 1 cells - @ -
                  Ahead? IF true ELSE drop false THEN
                  \ only if forward jump
          ELSE    false THEN ;
- : RepeatCheck
+ : RepeatCheck ( a-addr1 a-addr2 true | false -- false )
          IF  BEGIN  2dup
 cells - @ swap dup @ +
                     u<=
- Line 304
+ Line 337
  Line 304
  Line 337
                          IF      drop S" REPEAT " .struc nl
                          ELSE    S" AGAIN " .struc nl
                          THEN
-                 ELSE    dup cell+ BranchAddr? Forward?
+                 ELSE    MyBranch cell+ @ LeaveCode =
+                         IF      S" LEAVE " .struc
+                         ELSE
+                                 dup cell+ BranchAddr? Forward?
                          IF      dup cell+ @ WhileCode2 =
                                  IF nl S" ELSE" .struc level+
                                  ELSE level- nl S" ELSE" .struc level+ THEN
- Line 313
+ Line 349
  Line 313
  Line 349
                          THEN
                  THEN
          THEN
+         THEN
          Debug?
          IF      dup @ +
          ELSE    cell+
          THEN ;
- : MyBranch      ( a-addr -- a-addr a-addr2 )
-                 dup @ over +
-                 BranchAddr?
-                 BEGIN
-                 WHILE 1 cells - @
-                       over <>
-                 WHILE dup @ over +
-                       MoreBranchAddr?
-                 REPEAT
-                 SearchPointer @ 3 cells -
-                 ELSE    true ABORT" SEE: Table failure"
-                 THEN ;
  : DebugBranch
          Debug?
          IF      dup @ over + swap THEN ; \ return 2 different addresses
- Line 353
+ Line 377
  Line 353
  Line 377
                                  level- nl
                                  S" WHILE " .struc
                                  level+
+                         ELSE    MyBranch cell+ @ LeaveCode =
+                                 IF   s" 0= ?LEAVE " .struc
                          ELSE    nl S" IF " .struc level+
                          THEN
                  THEN
          THEN
+         THEN
          DebugBranch
          cell+ ;
- : c-?branch-lp+!#  c-?branch cell+ ;
+ : c-for
- : c-branch-lp+!#   c-branch  cell+ ;
+         Display? IF nl S" FOR" .struc level+ THEN ;
+ : c-loop
+         Display? IF level- nl .name-without bl cemit nl THEN
+         DebugBranch cell+
+         Scan?
+         IF      dup BranchAddr?
+                 BEGIN   WHILE cell+ LeaveCode swap !
+                         dup MoreBranchAddr?
+                 REPEAT
+         THEN
+         cell+ ;
  : c-do
-         Display? IF nl S" DO" .struc level+ THEN ;
+         Display? IF nl .name-without level+ THEN ;
  : c-?do
          Display? IF nl S" ?DO" .struc level+ THEN
          DebugBranch cell+ ;
- : c-for
-         Display? IF nl S" FOR" .struc level+ THEN ;
- : c-next
-         Display? IF level- nl S" NEXT " .struc nl THEN
-         DebugBranch cell+ cell+ ;
- : c-loop
-         Display? IF level- nl S" LOOP " .struc nl THEN
-         DebugBranch cell+ cell+ ;
- : c-+loop
-         Display? IF level- nl S" +LOOP " .struc nl THEN
-         DebugBranch cell+ cell+ ;
- : c-s+loop
-         Display? IF level- nl S" S+LOOP " .struc nl THEN
-         DebugBranch cell+ cell+ ;
- : c--loop
-         Display? IF level- nl S" -LOOP " .struc nl THEN
-         DebugBranch cell+ cell+ ;
- : c-next-lp+!#  c-next cell+ ;
- : c-loop-lp+!#  c-loop cell+ ;
- : c-+loop-lp+!#  c-+loop cell+ ;
- : c-s+loop-lp+!#  c-s+loop cell+ ;
- : c--loop-lp+!#  c--loop cell+ ;
- : c-leave
-         Display? IF S" LEAVE " .struc THEN
-         Debug? IF dup @ + THEN cell+ ;
- : c-?leave
-         Display? IF S" ?LEAVE " .struc THEN
-         cell+ DebugBranch swap cell+ swap cell+ ;
  : c-exit  dup 1 cells -
          CheckEnd
          IF      Display? IF nlflag off S" ;" Com# .string THEN
- Line 415
+ Line 416
  Line 415
  Line 416
          THEN
          Debug? IF drop THEN ;
- : c-does>               \ end of create part
-         Display? IF S" DOES> " Com# .string THEN
-         Cell+ cell+ ;
  : c-abort"
          count 2dup + aligned -rot
          Display?
- Line 428
+ Line 425
  Line 428
  Line 425
          ELSE    2drop
          THEN ;
+ [IFDEF] (does>)
+ : c-does>               \ end of create part
+         Display? IF S" DOES> " Com# .string THEN
+         maxaligned /does-handler + ;
+ [THEN]
+ [IFDEF] (compile)
+ : c-(compile)
+     Display?
+     IF
+         s" POSTPONE " Com# .string
+         dup @ look 0= ABORT" SEE: No valid XT"
+         name>string 0 .string bl cemit
+     THEN
+     cell+ ;
+ [THEN]
  CREATE C-Table
          ' lit A,            ' c-lit A,
-         ' @local# A,        ' c-@local# A,
+ [IFDEF] call    ' call A,           ' c-call A, [THEN]
-         ' flit A,           ' c-flit A,
+ [IFDEF] (s")    ' (s") A,           ' c-c" A, [THEN]
-         ' f@local# A,       ' c-f@local# A,
+ [IFDEF] (.")    ' (.") A,           ' c-c" A, [THEN]
-         ' laddr# A,         ' c-laddr# A,
+ [IFDEF] "lit    ' "lit A,           ' c-c" A, [THEN]
-         ' lp+!# A,          ' c-lp+!# A,
+ [IFDEF] (c")    ' (c") A,           ' c-c" A, [THEN]
-         ' (s") A,           ' c-s" A,
-         ' (.") A,           ' c-." A,
-         ' "lit A,           ' c-c" A,
-         ' leave A,          ' c-leave A,
-         ' ?leave A,         ' c-?leave A,
          ' (do) A,           ' c-do A,
+ [IFDEF] (+do)   ' (+do) A,          ' c-do A, [THEN]
+ [IFDEF] (u+do)  ' (u+do) A,         ' c-do A, [THEN]
+ [IFDEF] (-do)   ' (-do) A,          ' c-do A, [THEN]
+ [IFDEF] (u-do)  ' (u-do) A,         ' c-do A, [THEN]
          ' (?do) A,          ' c-?do A,
          ' (for) A,          ' c-for A,
          ' ?branch A,        ' c-?branch A,
          ' branch A,         ' c-branch A,
          ' (loop) A,         ' c-loop A,
-         ' (+loop) A,        ' c-+loop A,
+                 ' (+loop) A,        ' c-loop A,
-         ' (s+loop) A,       ' c-s+loop A,
+ [IFDEF] (s+loop) ' (s+loop) A,       ' c-loop A, [THEN]
-         ' (-loop) A,        ' c--loop A,
+ [IFDEF] (-loop) ' (-loop) A,        ' c-loop A, [THEN]
-         ' (next) A,         ' c-next A,
+                 ' (next) A,         ' c-loop A,
-         ' ?branch-lp+!# A,  ' c-?branch-lp+!# A,
-         ' branch-lp+!# A,   ' c-branch-lp+!# A,
-         ' (loop)-lp+!# A,   ' c-loop-lp+!# A,
-         ' (+loop)-lp+!# A,  ' c-+loop-lp+!# A,
-         ' (s+loop)-lp+!# A, ' c-s+loop-lp+!# A,
-         ' (-loop)-lp+!# A,  ' c--loop-lp+!# A,
-         ' (next)-lp+!# A,   ' c-next-lp+!# A,
          ' ;s A,             ' c-exit A,
-         ' (does>) A,        ' c-does> A,
+ [IFDEF] (abort") ' (abort") A,      ' c-abort" A, [THEN]
-         ' (abort") A,       ' c-abort" A,
+ \ only defined if compiler is loaded
-         ' (compile) A,      ' c-(compile) A,
+ [IFDEF] (compile) ' (compile) A,      ' c-(compile) A, [THEN]
-,
+ [IFDEF] (does>) ' (does>) A,        ' c-does> A, [THEN]
+,             here 0 ,
+ avariable c-extender
+ c-extender !
  \ DOTABLE                                               15may93jaw
  : DoTable ( cfa -- flag )
          C-Table
-         BEGIN   dup @ dup
+         BEGIN   dup @ dup 0=
-         WHILE   2 pick <>
+                 IF drop cell+ @ dup
+                   IF ( next table!) dup @ ELSE
+                         ( end!) 2drop false EXIT THEN
+                 THEN
+                 \ jump over to extender, if any 26jan97jaw
+                 xt>threaded 2 pick <>
          WHILE   2 cells +
          REPEAT
-         nip cell+ @ EXECUTE
+         nip cell+ perform
          true
-         ELSE
+         ;
-drop drop false
-         THEN ;
  : BranchTo? ( a-addr -- a-addr )
          Display?  IF     dup BranchAddr?
-                         IF BEGIN cell+ @ dup 20 u>
+                         IF
+                                 BEGIN cell+ @ dup 20 u>
                                  IF drop nl S" BEGIN " .struc level+
                                  ELSE
-                                   dup Disable <>
+                                   dup Disable <> over LeaveCode <> and
                                    IF   WhileCode2 =
                                         IF nl S" THEN " .struc nl ELSE
                                         level- nl S" THEN " .struc nl THEN
- Line 499
+ Line 512
  Line 499
  Line 512
          dup cell+ swap @
          dup >r DoTable r> swap IF drop EXIT THEN
          Display?
-         IF look 0= IF  drop dup 1 cells - @ .  \ ABORT" SEE: Bua!"
+     IF
-            ELSE  dup cell+ count 31 and rot wordinfo .string  THEN  bl cemit
+         .word bl cemit
-         ELSE drop
+     ELSE
+         drop
          THEN ;
  : c-init
- Line 518
+ Line 532
  Line 518
  Line 532
                  c-stop @
          UNTIL drop ;
- DEFER dosee
+ Defer xt-see-xt ( xt -- )
+ \ this one is just a forward declaration for indirect recursion
- : dopri .name ." is primitive" cr ;
+ : .defname ( xt c-addr u -- )
- : dovar ." Variable " .name cr ;
+     rot look
- : douse ." User " .name cr ;
+     if ( c-addr u nfa )
- : docon  dup cell+ (name>) >body @ . ." Constant " .name cr ;
+         -rot type space .name
- : doval  dup cell+ (name>) >body @ . ." Value " .name cr ;
+     else
- : dodef ." Defer " dup >r .name cr
+         drop ." noname " type
-     r@ cell+ (name>) >body @ look
+     then
-= ABORT" SEE: No valid xt in deferred word"
+     space ;
-     dup dosee cr
-     ." ' " .name r> ." IS " .name cr ;
+ Defer discode ( addr u -- ) \ gforth
- : dodoe ." Create " dup .name cr
+ \G hook for the disassembler: disassemble code at addr of length u
-         S" DOES> " Com# .string XPos @ Level ! name>
+ ' dump IS discode
-         >does-code dup C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN
-         ScanMode c-pass ! dup makepass
+ : next-head ( addr1 -- addr2 ) \ gforth
-         DisplayMode c-pass ! makepass ;
+     \G find the next header starting after addr1, up to here (unreliable).
- : doali here @ .name ." Alias " .name cr
+     here swap u+do
-         here @ dosee ;
+         i head?
- : docol S" : " Com# .string
+         if
-         dup cell+ count $1F and 2 pick wordinfo .string bl cemit bl cemit
+             i unloop exit
-         ( XPos @ ) 2 Level !
+         then
-         name> >body
+     cell +loop
-         C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN
+     here ;
+ : umin ( u1 u2 -- u )
+dup u>
+     if
+         swap
+     then
+     drop ;
+ : next-prim ( addr1 -- addr2 ) \ gforth
+     \G find the next primitive after addr1 (unreliable)
++ >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 -- )
+     dup s" Code" .defname
+     >code-address
+     dup in-dictionary? \ user-defined code word?
+     if
+         dup next-head
+     else
+         dup next-prim
+     then
+     over - discode
+     ." end-code" cr ;
+ : seevar ( xt -- )
+     s" Variable" .defname cr ;
+ : seeuser ( xt -- )
+     s" User" .defname cr ;
+ : seecon ( xt -- )
+     dup >body ?
+     s" Constant" .defname cr ;
+ : seevalue ( xt -- )
+     dup >body ?
+     s" Value" .defname cr ;
+ : seedefer ( xt -- )
+     dup >body @ xt-see-xt cr
+     dup s" Defer" .defname cr
+     >name ?dup-if
+         ." IS " .name cr
+     else
+         ." lastxt >body !"
+     then ;
+ : see-threaded ( addr -- )
+     C-Pass @ DebugMode = IF
+         ScanMode c-pass !
+         EXIT
+     THEN
          ScanMode c-pass ! dup makepass
          DisplayMode c-pass ! makepass ;
+ : seedoes ( xt -- )
+     dup s" create" .defname cr
+     S" DOES> " Com# .string XPos @ Level !
+     >does-code see-threaded ;
+ : seecol ( xt -- )
+     dup s" :" .defname nl
+Level !
+     >body see-threaded ;
+ : seefield ( xt -- )
+     dup >body ." 0 " ? ." 0 0 "
+     s" Field" .defname cr ;
- create wordtypes
+ : xt-see ( xt -- ) \ gforth
-         Pri# ,   ' dopri A,
+     \G Decompile the definition represented by @i{xt}.
-         Var# ,   ' dovar A,
-         Con# ,   ' docon A,
-         Val# ,   ' doval A,
-         Def# ,   ' dodef A,
-         Doe# ,   ' dodoe A,
-         Ali# ,   ' doali A,
-         Col# ,   ' docol A,
-         Use# ,   ' douse A,
-,
- : (dosee) ( lfa -- )
-         dup dup cell+ c@ >r
-         wordinfo
-         wordtypes
-         BEGIN dup @ dup
-         WHILE 2 pick = IF cell+ @ nip EXECUTE
-                           r> dup 32 and IF ."  immediate" THEN
-and IF ."  restrict" THEN EXIT THEN
-cells +
-         REPEAT
-drop rdrop
-         .name ." Don't know how to handle" cr ;
- ' (dosee) IS dosee
- : xtc ( xt -- )       \ do see at xt
-         Look 0= ABORT" SEE: No valid XT"
          cr c-init
-         dosee ;
+     dup >does-code
+     if
- : see   name sfind 0= IF ." Word unknown" cr exit THEN
+         seedoes EXIT
-         xtc ;
+     then
+     dup xtprim?
- : lfc   cr c-init cell+ dosee ;
+     if
- : nfc   cr c-init dosee ;
+         seecode EXIT
+     then
+     dup >code-address
+     CASE
+         docon: of seecon endof
+         docol: of seecol endof
+         dovar: of seevar endof
+ [ [IFDEF] douser: ]
+         douser: of seeuser endof
+ [ [THEN] ]
+ [ [IFDEF] dodefer: ]
+         dodefer: of seedefer endof
+ [ [THEN] ]
+ [ [IFDEF] dofield: ]
+         dofield: of seefield endof
+ [ [THEN] ]
+         over       of seecode endof \ direct threaded code words
+         over >body of seecode endof \ indirect threaded code words
+drop abort" unknown word type"
+     ENDCASE ;
+ : (xt-see-xt) ( xt -- )
+     xt-see cr ." lastxt" ;
+ ' (xt-see-xt) is xt-see-xt
+ : (.immediate) ( xt -- )
+     ['] execute = if
+         ."  immediate"
+     then ;
+ : name-see ( nfa -- )
+     dup name>int >r
+     dup name>comp
+     over r@ =
+     if \ normal or immediate word
+         swap xt-see (.immediate)
+     else
+         r@ ['] ticking-compile-only-error =
+         if \ compile-only word
+             swap xt-see (.immediate) ."  compile-only"
+         else \ interpret/compile word
+             r@ xt-see-xt cr
+             swap xt-see-xt cr
+             ." interpret/compile " over .name (.immediate)
+         then
+     then
+     rdrop drop ;
+ : 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=
+     IF
+         drop -&13 throw
+     THEN
+     name-see ;

-Generate output suitable for use with a patch program
+Legend:



Removed from v.1.8
 


changed lines


 
Added in v.1.42
 Legend:



Removed from v.1.8
 


changed lines


 
Added in v.1.42
-Removed from v.1.8
+Added in v.1.42

CVS Admin

gforth: gforth/see.fs

Diff for /gforth/see.fs between version 1.8 and 1.42

ViewCVS and CVS Help