Diff for /gforth/see.fs between versions 1.37 and 1.44

version 1.37, 2001/04/08 13:48:12 version 1.44, 2002/12/25 21:16:54
Line 248  VARIABLE C-Pass Line 248  VARIABLE C-Pass
 : back? ( n -- flag ) 0< ;  : back? ( n -- flag ) 0< ;
 : ahead? ( n -- flag ) 0> ;  : ahead? ( n -- flag ) 0> ;
   
 : c-lit  
     Display? IF  
         dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit  
     THEN  
     cell+ ;  
   
 : .word ( addr xt -- addr )  : .word ( addr xt -- addr )
     look 0= IF      look 0= IF
         drop dup 1 cells - @ dup body> look          drop dup 1 cells - @ dup body> look
Line 270  VARIABLE C-Pass Line 264  VARIABLE C-Pass
         dup name>string rot wordinfo .string          dup name>string rot wordinfo .string
     THEN ;      THEN ;
   
 : c-call  : c-call ( addr1 -- addr2 )
     Display? IF  dup @ body> .word bl cemit  THEN  cell+ ;      Display? IF
           dup @ body> .word bl cemit
       THEN
       cell+ ;
   
   : c-callxt ( addr1 -- addr2 )
       Display? IF
           dup @ .word bl cemit
       THEN
       cell+ ;
   
   \ here docon: , docol: , dovar: , douser: , dodefer: , dofield: ,
   \ here over - 2constant doers
   
   : c-lit ( addr1 -- addr2 )
       Display? IF
           dup @ dup body> dup cfaligned over = swap in-dictionary? and if
               ( addr1 addr1@ )
               dup body> @ dovar: = if
                   drop c-call EXIT
               endif
           endif
           \ !! test for cfa here, and print "['] ..."
           dup abs 0 <# #S rot sign #> 0 .string bl cemit
       endif
       cell+ ;
   
   : c-lit+ ( addr1 -- addr2 )
       Display? if
           dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
           s" + " 0 .string
       endif
       cell+ ;
   
 : .name-without ( addr -- addr )  : .name-without ( addr -- addr )
 \ prints a name without () e.g. (+LOOP) or (s")  \ prints a name without () e.g. (+LOOP) or (s")
Line 444  VARIABLE C-Pass Line 470  VARIABLE C-Pass
   
 CREATE C-Table  CREATE C-Table
                 ' lit A,            ' c-lit A,                  ' lit A,            ' c-lit A,
                   ' does-exec A,      ' c-callxt A,
                   ' lit@ A,           ' c-call A,
 [IFDEF] call    ' call A,           ' c-call A, [THEN]  [IFDEF] call    ' call A,           ' c-call A, [THEN]
                 ' (s") A,           ' c-c" A,  \               ' useraddr A,       ....
                  ' (.") A,          ' c-c" A,                  ' lit-perform A,    ' c-call A,
                 ' "lit A,           ' c-c" A,                  ' lit+ A,           ' c-lit+ A,
   [IFDEF] (s")    ' (s") A,           ' c-c" A, [THEN]
   [IFDEF] (.")    ' (.") A,           ' c-c" A, [THEN]
   [IFDEF] "lit    ' "lit A,           ' c-c" A, [THEN]
 [IFDEF] (c")    ' (c") A,           ' c-c" A, [THEN]  [IFDEF] (c")    ' (c") A,           ' c-c" A, [THEN]
                 ' (do) A,           ' c-do A,                  ' (do) A,           ' c-do A,
 [IFDEF] (+do)   ' (+do) A,          ' c-do A, [THEN]  [IFDEF] (+do)   ' (+do) A,          ' c-do A, [THEN]
Line 464  CREATE C-Table Line 495  CREATE C-Table
 [IFDEF] (-loop) ' (-loop) A,        ' c-loop A, [THEN]  [IFDEF] (-loop) ' (-loop) A,        ' c-loop A, [THEN]
                 ' (next) A,         ' c-loop A,                  ' (next) A,         ' c-loop A,
                 ' ;s A,             ' c-exit A,                  ' ;s A,             ' c-exit A,
                 ' (abort") A,       ' c-abort" A,  [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]  [IFDEF] (does>) ' (does>) A,        ' c-does> A, [THEN]
Line 475  c-extender ! Line 506  c-extender !
   
 \ DOTABLE                                               15may93jaw  \ DOTABLE                                               15may93jaw
   
 : DoTable ( cfa -- flag )  : DoTable ( ca/cfa -- flag )
         C-Table      decompile-prim C-Table BEGIN ( cfa table-entry )
         BEGIN   dup @ dup 0=           dup @ dup 0=  IF
                 IF drop cell+ @ dup               drop cell+ @ dup IF ( next table!)
                   IF ( next table!) dup @ ELSE                   dup @
                         ( end!) 2drop false EXIT THEN               ELSE ( end!)
                 THEN                  2drop false EXIT
                 \ jump over to extender, if any 26jan97jaw              THEN 
                 2 pick <>          THEN
         WHILE   2 cells +          \ jump over to extender, if any 26jan97jaw
         REPEAT          xt>threaded 2 pick <>
         nip cell+ perform      WHILE
         true              2 cells +
         ;      REPEAT
       nip cell+ perform
       true
   ;
   
 : BranchTo? ( a-addr -- a-addr )  : BranchTo? ( a-addr -- a-addr )
         Display?  IF    dup BranchAddr?          Display?  IF    dup BranchAddr?
Line 551  Defer discode ( addr u -- ) \ gforth Line 585  Defer discode ( addr u -- ) \ gforth
 : next-head ( addr1 -- addr2 ) \ gforth  : next-head ( addr1 -- addr2 ) \ gforth
     \G find the next header starting after addr1, up to here (unreliable).      \G find the next header starting after addr1, up to here (unreliable).
     here swap u+do      here swap u+do
         i head?          i head? -2 and if
         if  
             i unloop exit              i unloop exit
         then          then
     cell +loop      cell +loop
Line 584  Defer discode ( addr u -- ) \ gforth Line 617  Defer discode ( addr u -- ) \ gforth
   
 : seecode ( xt -- )  : seecode ( xt -- )
     dup s" Code" .defname      dup s" Code" .defname
     threading-method      >code-address
     if  
         >code-address  
     then  
     dup in-dictionary? \ user-defined code word?      dup in-dictionary? \ user-defined code word?
     if      if
         dup next-head          dup next-head
Line 679  Defer discode ( addr u -- ) \ gforth Line 709  Defer discode ( addr u -- ) \ gforth
     if \ normal or immediate word      if \ normal or immediate word
         swap xt-see (.immediate)          swap xt-see (.immediate)
     else      else
         r@ ['] compile-only-error =          r@ ['] ticking-compile-only-error =
         if \ compile-only word          if \ compile-only word
             swap xt-see (.immediate) ."  compile-only"              swap xt-see (.immediate) ."  compile-only"
         else \ interpret/compile word          else \ interpret/compile word

Removed from v.1.37  
changed lines
  Added in v.1.44


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