Diff for /gforth/see.fs between versions 1.13 and 1.14

version 1.13, 1996/08/21 14:58:44 version 1.14, 1996/08/26 10:07:21
Line 459  CREATE C-Table Line 459  CREATE C-Table
         ' f@local# A,       ' c-f@local# A,          ' f@local# A,       ' c-f@local# A,
         ' laddr# A,         ' c-laddr# A,          ' laddr# A,         ' c-laddr# A,
         ' lp+!# A,          ' c-lp+!# A,          ' lp+!# A,          ' c-lp+!# A,
         ' (s") A,           ' c-s" A,          ' (s") A,           ' c-s" A,
         ' (.") A,           ' c-." A,          ' (.") A,           ' c-." A,
         ' "lit A,           ' c-c" A,          ' "lit A,           ' c-c" A,
         ' leave A,          ' c-leave A,          comp' leave drop A, ' c-leave A,
         ' ?leave A,         ' c-?leave A,          comp' ?leave drop A, ' c-?leave A,
         ' (do) A,           ' c-do A,          ' (do) A,           ' c-do A,
         ' (?do) A,          ' c-?do A,          ' (?do) A,          ' c-?do A,
         ' (for) A,          ' c-for A,          ' (for) A,          ' c-for A,
Line 535  CREATE C-Table Line 535  CREATE C-Table
         Branches on ;          Branches on ;
   
 : makepass ( a-addr -- )  : makepass ( a-addr -- )
         c-stop off      c-stop off
         BEGIN      BEGIN
                 analyse          analyse
                 c-stop @          c-stop @
         UNTIL drop ;      UNTIL drop ;
   
 DEFER dosee  Defer xt-see-xt ( xt -- )
   \ this one is just a forward declaration for indirect recursion
 : dopri .name ." is primitive" cr ;  
 : dovar ." Variable " .name cr ;  : .defname ( xt c-addr u -- )
 : douse ." User " .name cr ;      rot look
 : docon  dup ((name>)) >body @ . ." Constant " .name cr ;      if ( c-addr u nfa )
 : doval  dup ((name>)) >body @ . ." Value " .name cr ;          -rot type space .name
 : dodef ." Defer " dup >r .name cr      else
     r@ ((name>)) >body @ look          drop ." noname " type
     0= ABORT" SEE: No valid xt in deferred word"      then
     dup dosee cr      space ;
     ." ' " .name r> ." IS " .name cr ;  
 : dodoe ." Create " dup .name cr  Defer discode ( addr -- )
         S" DOES> " Com# .string XPos @ Level ! name>int  \  hook for the disassembler: disassemble code at addr (as far as the
         >does-code dup C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN  \  disassembler thinks is sensible)
         ScanMode c-pass ! dup makepass  :noname ( addr -- )
         DisplayMode c-pass ! makepass ;      drop ." ..." ;
 : doali here @ .name ." Alias " .name cr  IS discode
         here @ dosee ;  
 : docol  : seecode ( xt -- )
     S" : " Com# .string      dup s" Code" .defname
     dup name>string 2 pick wordinfo .string bl cemit bl cemit      >body discode
     ( XPos @ ) 2 Level !      ."  end-code" cr ;
     name>int >body  : seevar ( xt -- )
     C-Pass @ DebugMode =      s" Variable" .defname cr ;
     IF  : seeuser ( xt -- )
         ScanMode c-pass ! EXIT      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
           drop ." lastxt >body !"
       else
           ." IS " .name cr
       then ;
   : see-threaded ( addr -- )
       C-Pass @ DebugMode = IF
           ScanMode c-pass !
           EXIT
     THEN      THEN
     ScanMode c-pass ! dup makepass      ScanMode c-pass ! dup makepass
     DisplayMode c-pass ! makepass ;      DisplayMode c-pass ! makepass ;
   : seedoes ( xt -- )
 create wordtypes      dup s" create" .defname cr
         Pri# ,   ' dopri A,      S" DOES> " Com# .string XPos @ Level !
         Var# ,   ' dovar A,      >does-code see-threaded ;
         Con# ,   ' docon A,  : seecol ( xt -- )
         Val# ,   ' doval A,      dup s" :" .defname cr
         Def# ,   ' dodef A,      2 Level !
         Doe# ,   ' dodoe A,      >body see-threaded ;
         Ali# ,   ' doali A,  : seefield ( xt -- )
         Col# ,   ' docol A,      dup >body ." 0 " ? ." 0 0 "
         Use# ,   ' douse A,      s" Field" .defname cr ;
         0 ,  
   : xt-see ( xt -- )
 : (dosee) ( lfa -- )      cr c-init
         dup dup cell+ c@ >r      dup >does-code
         wordinfo      if
         wordtypes          seedoes EXIT
         BEGIN dup @ dup      then
         WHILE 2 pick = IF cell+ @ nip EXECUTE      dup forthstart u<
                           r> dup immediate-mask and IF ."  immediate" THEN      if
                           restrict-mask  and IF ."  restrict" THEN          seecode EXIT
                           EXIT THEN      then
               2 cells +      dup >code-address
         REPEAT      CASE
         2drop rdrop          docon: of seecon endof
         .name ." Don't know how to handle" cr ;          docol: of seecol endof
           dovar: of seevar endof
 ' (dosee) IS dosee          douser: of seeuser endof
           dodefer: of seedefer endof
 : xtc ( xt -- )       \ do see at xt          dofield: of seefield endof
         Look 0= ABORT" SEE: No valid XT"          over >body of seecode endof
         cr c-init          2drop abort" unknown word type"
         dosee ;      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@ ['] 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 ( "name" -- ) \ tools  : see ( "name" -- ) \ tools
     name find-name dup 0=      name find-name dup 0=
     IF      IF
         drop -&13 bounce          drop -&13 bounce
     THEN      THEN
     name>int xtc ;      name-see ;
   
 : lfc   cr c-init cell+ dosee ;  
 : nfc   cr c-init dosee ;  
   
   

Removed from v.1.13  
changed lines
  Added in v.1.14


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>