gforth/see.fs - diff

Return to see.fs CVS log

Up to [gforth] / gforth

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

-version 1.11, 1996/05/04 18:39:25
+version 1.14, 1996/08/26 10:07:21
  Line 459  CREATE C-Table
          ' f@local# A,       ' c-f@local# A,
          ' laddr# A,         ' c-laddr# A,
          ' lp+!# A,          ' c-lp+!# A,
          ' (s") A,           ' c-s" A,
          ' (.") A,           ' 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,
          ' (for) A,          ' c-for A,
  Line 535  CREATE C-Table
          Branches on ;
  : 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 cell+ (name>) >body @ . ." Constant " .name cr ;
+     if ( c-addr u nfa )
- : doval  dup cell+ (name>) >body @ . ." Value " .name cr ;
+         -rot type space .name
- : dodef ." Defer " dup >r .name cr
+     else
-     r@ cell+ (name>) >body @ look
+         drop ." noname " type
-= 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>
+ \  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> >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
      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 cr
+Level !
+     >body see-threaded ;
+ : seefield ( xt -- )
+     dup >body ." 0 " ? ." 0 0 "
+     s" Field" .defname cr ;
+ : xt-see ( xt -- )
+     cr c-init
+     dup >does-code
+     if
+         seedoes EXIT
+     then
+     dup forthstart u<
+     if
+         seecode EXIT
+     then
+     dup >code-address
+     CASE
+         docon: of seecon endof
+         docol: of seecol endof
+         dovar: of seevar endof
+         douser: of seeuser endof
+         dodefer: of seedefer endof
+         dofield: of seefield endof
+         over >body of seecode endof
+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@ ['] 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 ;
- create wordtypes
+ : see ( "name" -- ) \ tools
-         Pri# ,   ' dopri A,
+     name find-name dup 0=
-         Var# ,   ' dovar A,
+     IF
-         Con# ,   ' docon A,
+         drop -&13 bounce
-         Val# ,   ' doval A,
+     THEN
-         Def# ,   ' dodef A,
+     name-see ;
-         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 ;
- : see   name sfind 0= IF ." Word unknown" cr exit THEN
-         xtc ;
- : lfc   cr c-init cell+ dosee ;
- : nfc   cr c-init dosee ;

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

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