Diff for /gforth/see.fs between versions 1.16 and 1.26

version 1.16, 1997/05/21 20:39:39 version 1.26, 2000/05/27 18:55:55
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 108  VARIABLE Colors Colors on Line 112  VARIABLE Colors Colors on
 : .struc          : .struc        
         uppercase on Str# .string ;          uppercase on Str# .string ;
   
 \ CODES                                                 15may93jaw  \ CODES (Branchtypes)                                    15may93jaw
   
 21 CONSTANT RepeatCode  21 CONSTANT RepeatCode
 22 CONSTANT AgainCode  22 CONSTANT AgainCode
Line 118  VARIABLE Colors Colors on Line 122  VARIABLE Colors Colors on
 11 CONSTANT AheadCode  11 CONSTANT AheadCode
 13 CONSTANT WhileCode2  13 CONSTANT WhileCode2
 14 CONSTANT Disable  14 CONSTANT Disable
   15 CONSTANT LeaveCode
   
   
 \ FORMAT WORDS                                          13jun93jaw  \ FORMAT WORDS                                          13jun93jaw
   
 VARIABLE C-Stop  VARIABLE C-Stop
 VARIABLE Branches  VARIABLE Branches
   
 VARIABLE BranchPointer  VARIABLE BranchPointer  \ point to the end of branch table
 VARIABLE SearchPointer  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 -  here 3 cells -
 ACONSTANT MaxTable  ACONSTANT MaxTable
   
 : FirstBranch BranchTable cell+ SearchPointer ! ;  : 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 @          SearchPointer @
         BEGIN   dup BranchPointer @ u<          BEGIN   dup BranchPointer @ u<
         WHILE          WHILE
Line 161  ACONSTANT MaxTable Line 174  ACONSTANT MaxTable
         2drop true          2drop true
         THEN ;          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  \                 addrw               addrt
 \       BEGIN ... WHILE ... AGAIN ... THEN  \       BEGIN ... WHILE ... AGAIN ... THEN
Line 209  VARIABLE C-Pass Line 236  VARIABLE C-Pass
 : back? ( n -- flag ) 0< ;  : back? ( n -- flag ) 0< ;
 : ahead? ( n -- flag ) 0> ;  : ahead? ( n -- flag ) 0> ;
   
 : c-(compile)  
     Display?  
     IF  
         s" POSTPONE " Com# .string  
         dup @ look 0= ABORT" SEE: No valid XT"  
         name>string 0 .string bl cemit  
     THEN  
     cell+ ;  
   
 : c-lit  : c-lit
     Display? IF      Display? IF
         dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit          dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
     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 ;
   
   
 : 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 - @ -          IF      dup dup @ swap 1 cells - @ -
                 Ahead? IF true ELSE drop false THEN                  Ahead? IF true ELSE drop false THEN
                 \ only if forward jump                  \ only if forward jump
         ELSE    false THEN ;          ELSE    false THEN ;
   
 : RepeatCheck  : RepeatCheck ( a-addr1 a-addr2 true | false -- false )
         IF  BEGIN  2dup          IF  BEGIN  2dup
                    1 cells - @ swap dup @ +                     1 cells - @ swap dup @ +
                    u<=                     u<=
Line 295  VARIABLE C-Pass Line 306  VARIABLE C-Pass
                         IF      drop S" REPEAT " .struc nl                          IF      drop S" REPEAT " .struc nl
                         ELSE    S" AGAIN " .struc nl                          ELSE    S" AGAIN " .struc nl
                         THEN                          THEN
                 ELSE    dup cell+ BranchAddr? Forward?                  ELSE    MyBranch cell+ @ LeaveCode =
                         IF      dup cell+ @ WhileCode2 =                          IF      S" LEAVE " .struc
                                 IF nl S" ELSE" .struc level+                          ELSE
                                 ELSE level- nl S" ELSE" .struc level+ THEN                                  dup cell+ BranchAddr? Forward?
                                 cell+ Disable swap !                                  IF      dup cell+ @ WhileCode2 =
                         ELSE    S" AHEAD" .struc level+                                          IF nl S" ELSE" .struc level+
                         THEN                                          ELSE level- nl S" ELSE" .struc level+ THEN
                                           cell+ Disable swap !
                                   ELSE    S" AHEAD" .struc level+
                                   THEN
                           THEN
                 THEN                  THEN
         THEN          THEN
         Debug?          Debug?
Line 309  VARIABLE C-Pass Line 324  VARIABLE C-Pass
         ELSE    cell+          ELSE    cell+
         THEN ;          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  : DebugBranch
         Debug?          Debug?
         IF      dup @ over + swap THEN ; \ return 2 different addresses          IF      dup @ over + swap THEN ; \ return 2 different addresses
Line 344  VARIABLE C-Pass Line 346  VARIABLE C-Pass
                                 level- nl                                  level- nl
                                 S" WHILE " .struc                                  S" WHILE " .struc
                                 level+                                  level+
                         ELSE    nl S" IF " .struc level+                          ELSE    MyBranch cell+ @ LeaveCode =
                                   IF   s" 0= ?LEAVE " .struc
                                   ELSE nl S" IF " .struc level+
                                   THEN
                         THEN                          THEN
                 THEN                  THEN
         THEN          THEN
Line 354  VARIABLE C-Pass Line 359  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  
         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+ cell+ ;          DebugBranch cell+ 
           Scan? 
           IF      dup BranchAddr? 
                   BEGIN   WHILE cell+ LeaveCode swap !
                           dup MoreBranchAddr?
                   REPEAT
           THEN
           cell+ ;
   
 : c-do  : c-do
         Display? IF nl .name-without level+ THEN ;          Display? IF nl .name-without level+ THEN ;
Line 368  VARIABLE C-Pass Line 377  VARIABLE C-Pass
         Display? IF nl S" ?DO" .struc level+ THEN          Display? IF nl S" ?DO" .struc level+ THEN
         DebugBranch cell+ ;          DebugBranch 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 -  : c-exit  dup 1 cells -
         CheckEnd          CheckEnd
         IF      Display? IF nlflag off S" ;" Com# .string THEN          IF      Display? IF nlflag off S" ;" Com# .string THEN
Line 384  VARIABLE C-Pass Line 385  VARIABLE C-Pass
         THEN          THEN
         Debug? IF drop THEN ;          Debug? IF drop THEN ;
   
 : c-does>               \ end of create part  
         Display? IF S" DOES> " Com# .string THEN  
         Cell+ cell+ ;  
   
 : c-abort"  : c-abort"
         count 2dup + aligned -rot          count 2dup + aligned -rot
         Display?          Display?
Line 397  VARIABLE C-Pass Line 394  VARIABLE C-Pass
         ELSE    2drop          ELSE    2drop
         THEN ;          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  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,
         comp' leave drop A, ' c-leave A,  [IFDEF] (c")    ' (c") A,           ' c-c" A, [THEN]
         comp' ?leave drop A, ' c-?leave A,                  ' (do) A,           ' c-do A,
         ' (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]
         ' (u-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,                  ' ?branch A,        ' c-?branch A,
         ' ?branch A,        ' c-?branch 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,
         ' (+loop) A,        ' c-loop A,  [IFDEF] (s+loop) ' (s+loop) A,       ' c-loop A, [THEN]
         ' (s+loop) A,       ' c-loop A,  [IFDEF] (-loop) ' (-loop) A,        ' c-loop A, [THEN]
         ' (-loop) A,        ' c-loop A,                  ' (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,
         ' (does>) A,        ' c-does> A,  \ only defined if compiler is loaded
         ' (abort") A,       ' c-abort" A,  [IFDEF] (compile) ' (compile) A,      ' c-(compile) A, [THEN]
         ' (compile) A,      ' c-(compile) A,  [IFDEF] (does>) ' (does>) A,        ' c-does> A, [THEN]
         0 ,             here 0 ,                  0 ,             here 0 ,
   
 avariable c-extender  avariable c-extender
 c-extender !  c-extender !
Line 446  c-extender ! Line 459  c-extender !
         ;          ;
   
 : BranchTo? ( a-addr -- a-addr )  : BranchTo? ( a-addr -- a-addr )
         Display?  IF     dup BranchAddr?          Display?  IF    dup BranchAddr?
                         IF                          IF
                                 BEGIN cell+ @ dup 20 u>                                  BEGIN cell+ @ dup 20 u>
                                 IF drop nl S" BEGIN " .struc level+                                  IF drop nl S" BEGIN " .struc level+
                                 ELSE                                  ELSE
                                   dup Disable <>                                    dup Disable <> over LeaveCode <> and
                                   IF   WhileCode2 =                                    IF   WhileCode2 =
                                        IF nl S" THEN " .struc nl ELSE                                         IF nl S" THEN " .struc nl ELSE
                                        level- nl S" THEN " .struc nl THEN                                         level- nl S" THEN " .struc nl THEN
Line 510  IS discode Line 523  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 525  IS discode Line 542  IS discode
 : seedefer ( xt -- )  : seedefer ( xt -- )
     dup >body @ xt-see-xt cr      dup >body @ xt-see-xt cr
     dup s" Defer" .defname cr      dup s" Defer" .defname cr
     >name dup ??? = if      >name ?dup-if
         drop ." lastxt >body !"  
     else  
         ." IS " .name cr          ." IS " .name cr
       else
           ." lastxt >body !"
     then ;      then ;
 : see-threaded ( addr -- )  : see-threaded ( addr -- )
     C-Pass @ DebugMode = IF      C-Pass @ DebugMode = IF
Line 555  IS discode Line 572  IS discode
     if      if
         seedoes EXIT          seedoes EXIT
     then      then
     dup forthstart u<      dup xtprim?
     if      if
         seecode EXIT          seecode EXIT
     then      then
Line 564  IS discode Line 581  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 598  IS discode Line 621  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 throw
     THEN      THEN
     name-see ;      name-see ;
   

Removed from v.1.16  
changed lines
  Added in v.1.26


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