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

version 1.5, 1994/11/29 16:22:47 version 1.16, 1997/05/21 20:39:39
Line 1 Line 1
 \ SEE.FS       highend SEE for ANSforth                16may93jaw  \ SEE.FS       highend SEE for ANSforth                16may93jaw
   
   \ Copyright (C) 1995 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., 675 Mass Ave, Cambridge, MA 02139, USA.
   
   
 \ May be cross-compiled  \ May be cross-compiled
   
 \ I'm sorry. This is really not "forthy" enough.  \ I'm sorry. This is really not "forthy" enough.
   
 \ Ideas:        Level should be a stack  \ Ideas:        Level should be a stack
   
   require termsize.fs
   
 decimal  decimal
   
 \ Screen format words                                   16may93jaw  \ Screen format words                                   16may93jaw
Line 29  VARIABLE Level Line 50  VARIABLE Level
 : level-        -7 Level +! ;  : level-        -7 Level +! ;
   
 VARIABLE nlflag  VARIABLE nlflag
   VARIABLE uppercase      \ structure words are in uppercase
   
 DEFER nlcount ' noop IS nlcount  DEFER nlcount ' noop IS nlcount
   
Line 37  DEFER nlcount ' noop IS nlcount Line 59  DEFER nlcount ' noop IS nlcount
                 XPos @ Level @ = ?Exit                  XPos @ Level @ = ?Exit
                 C-Formated @ IF                  C-Formated @ IF
                 C-Output @                  C-Output @
                 IF C-Clearline @ IF 80 XPos @ - spaces                  IF C-Clearline @ IF cols XPos @ - spaces
                                  ELSE cr THEN                                   ELSE cr THEN
                 1 YPos +! 0 XPos !                  1 YPos +! 0 XPos !
                 Level @ spaces                  Level @ spaces
Line 45  DEFER nlcount ' noop IS nlcount Line 67  DEFER nlcount ' noop IS nlcount
   
 : warp?         ( len -- len )  : warp?         ( len -- len )
                 nlflag @ IF (nl) nlflag off THEN                  nlflag @ IF (nl) nlflag off THEN
                 XPos @ over + 79 u> IF (nl) THEN ;                  XPos @ over + cols u>= IF (nl) THEN ;
   
   : c-to-upper
     dup [char] a >= over [char] z <= and if  bl -  then ;
   
 : ctype         ( adr len -- )  : 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?  : cemit         1 warp?
                 over bl = Level @ XPos @ = and                  over bl = Level @ XPos @ = and
Line 77  VARIABLE Colors Colors on Line 105  VARIABLE Colors Colors on
 ' (.string) IS .string  ' (.string) IS .string
   
   
 : .struc        Str# .string ;  : .struc        
           uppercase on Str# .string ;
   
 \ CODES                                                 15may93jaw  \ CODES                                                 15may93jaw
   
Line 181  VARIABLE C-Pass Line 210  VARIABLE C-Pass
 : ahead? ( n -- flag ) 0> ;  : ahead? ( n -- flag ) 0> ;
   
 : c-(compile)  : c-(compile)
         Display? IF s" POSTPONE " Com# .string      Display?
                     dup @ look 0= ABORT" SEE: No valid XT"      IF
                     cell+ count $1F and 0 .string bl cemit          s" POSTPONE " Com# .string
                  THEN          dup @ look 0= ABORT" SEE: No valid XT"
         cell+ ;          name>string 0 .string bl cemit
       THEN
       cell+ ;
   
 : c-lit  : c-lit
         Display? IF dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit THEN      Display? IF
         cell+ ;          dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
       THEN
       cell+ ;
   
 : c-s"  : c-s"
         count 2dup + aligned -rot          count 2dup + aligned -rot
Line 309  VARIABLE C-Pass Line 342  VARIABLE C-Pass
                                          IF WhileCode2 swap !                                           IF WhileCode2 swap !
                                          ELSE drop THEN                                           ELSE drop THEN
                                 level- nl                                  level- nl
                                 S" WHILE" .struc                                  S" WHILE " .struc
                                 level+                                  level+
                         ELSE    nl S" IF" .struc level+                          ELSE    nl S" IF " .struc level+
                         THEN                          THEN
                 THEN                  THEN
         THEN          THEN
         DebugBranch          DebugBranch
         cell+ ;          cell+ ;
   
 : c-do  
         Display? IF nl S" DO" .struc level+ THEN ;  
   
 : c-?do  
         Display? IF nl S" ?DO" .struc level+ THEN  
         DebugBranch cell+ ;  
   
 : c-for  : c-for
         Display? IF nl S" FOR" .struc level+ THEN ;          Display? IF nl S" FOR" .struc level+ THEN ;
   
 : c-next  : .name-without
         Display? IF level- nl S" NEXT " .struc nl THEN          dup 1 cells - @ look IF name>string 1 /string 1- .struc ELSE drop THEN ;
         DebugBranch cell+ cell+ ;  
   
 : c-loop  : c-loop
         Display? IF level- nl S" LOOP " .struc nl THEN          Display? IF level- nl .name-without bl cemit nl THEN
         DebugBranch cell+ cell+ ;          DebugBranch cell+ cell+ ;
   
   : c-do
           Display? IF nl .name-without level+ THEN ;
   
 : c-+loop  : c-?do
         Display? IF level- nl S" +LOOP " .struc nl THEN          Display? IF nl S" ?DO" .struc level+ THEN
         DebugBranch cell+ cell+ ;          DebugBranch cell+ ;
   
 : c-leave  : c-leave
         Display? IF S" LEAVE " .struc THEN          Display? IF S" LEAVE " .struc THEN
Line 357  VARIABLE C-Pass Line 384  VARIABLE C-Pass
         THEN          THEN
         Debug? IF drop THEN ;          Debug? IF drop THEN ;
   
 : c-;code               \ end of create part  : c-does>               \ end of create part
         Display? IF S" DOES> " Com# .string THEN          Display? IF S" DOES> " Com# .string THEN
         Cell+ cell+ ;          Cell+ cell+ ;
   
Line 372  VARIABLE C-Pass Line 399  VARIABLE C-Pass
   
   
 CREATE C-Table  CREATE C-Table
         ' lit A,         ' c-lit A,          ' lit A,            ' c-lit 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,
         ' ?branch A,     ' c-?branch A,          comp' leave drop A, ' c-leave A,
         ' branch A,      ' c-branch A,          comp' ?leave drop A, ' c-?leave A,
         ' leave A,       ' c-leave A,          ' (do) A,           ' c-do A,
         ' ?leave A,      ' c-?leave A,          ' (+do) A,          ' c-do A,
         ' (do) A,        ' c-do A,          ' (u+do) A,         ' c-do A,
         ' (?do) A,       ' c-?do A,          ' (-do) A,          ' c-do A,
         ' (for) A,       ' c-for A,          ' (u-do) A,         ' c-do A,
         ' (loop) A,      ' c-loop A,          ' (?do) A,          ' c-?do A,
         ' (+loop) A,     ' c-+loop A,          ' (for) A,          ' c-for A,
         ' (next) A,      ' c-next A,          ' ?branch A,        ' c-?branch A,
         ' ;s A,          ' c-exit A,          ' branch A,         ' c-branch A,
         ' (;code) A,     ' c-;code A,          ' (loop) A,         ' c-loop A,
         ' (abort") A,    ' c-abort" A,          ' (+loop) A,        ' c-loop A,
         ' (compile) A,   ' c-(compile) A,          ' (s+loop) A,       ' c-loop A,
         0 ,          ' (-loop) A,        ' c-loop A,
           ' (next) A,         ' c-loop A,
           ' ;s A,             ' c-exit A,
           ' (does>) A,        ' c-does> A,
           ' (abort") A,       ' c-abort" A,
           ' (compile) A,      ' c-(compile) A,
           0 ,             here 0 ,
   
   avariable c-extender
   c-extender !
   
 \ DOTABLE                                               15may93jaw  \ DOTABLE                                               15may93jaw
   
 : DoTable ( cfa -- flag )  : DoTable ( cfa -- flag )
         C-Table          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
                   2 pick <>
         WHILE   2 cells +          WHILE   2 cells +
         REPEAT          REPEAT
         nip cell+ @ EXECUTE          nip cell+ perform
         true          true
         ELSE          ;
         2drop drop false  
         THEN ;  
   
 : BranchTo? ( a-addr -- a-addr )  : BranchTo? ( a-addr -- a-addr )
         Display?  IF     dup BranchAddr?          Display?  IF     dup BranchAddr?
                         IF BEGIN cell+ @ dup 20 u>                          IF
                                   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 <>
Line 428  CREATE C-Table Line 468  CREATE C-Table
         dup >r DoTable r> swap IF drop EXIT THEN          dup >r DoTable r> swap IF drop EXIT THEN
         Display?          Display?
         IF look 0= IF  drop dup 1 cells - @ .  \ ABORT" SEE: Bua!"          IF look 0= IF  drop dup 1 cells - @ .  \ ABORT" SEE: Bua!"
            ELSE  dup cell+ count 31 and rot wordinfo .string  THEN  bl cemit          ELSE
               dup cell+ count dup immediate-mask and
               IF  bl cemit  ." POSTPONE " THEN
               31 and rot wordinfo .string  THEN  bl cemit
         ELSE drop          ELSE drop
         THEN ;          THEN ;
   
Line 440  CREATE C-Table Line 483  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 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
          here @ look 0= ABORT" SEE: No valid xt in defered word"          drop ." noname " type
          here @ look drop dosee cr      then
         ." ' " .name r> ." IS " .name cr ;      space ;
 : dodoe ." Create " dup .name cr  
         S" DOES> " Com# .string XPos @ Level ! name>  Defer discode ( addr -- )
         >does-code dup C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN  \  hook for the disassembler: disassemble code at addr (as far as the
         ScanMode c-pass ! dup makepass  \  disassembler thinks is sensible)
         DisplayMode c-pass ! makepass ;  :noname ( addr -- )
 : doali here @ .name ." Alias " .name cr      drop ." ..." ;
         here @ dosee ;  IS discode
 : docol S" : " Com# .string  
         dup cell+ count $1F and 2 pick wordinfo .string bl cemit bl cemit  : seecode ( xt -- )
         ( XPos @ ) 2 Level !      dup s" Code" .defname
         name> >body      >body discode
         C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN      ."  end-code" cr ;
         ScanMode c-pass ! dup makepass  : seevar ( xt -- )
         DisplayMode c-pass ! makepass ;      s" Variable" .defname cr ;
   : seeuser ( xt -- )
 create wordtypes      s" User" .defname cr ;
         Pri# ,   ' dopri A,  : seecon ( xt -- )
         Var# ,   ' dovar A,      dup >body ?
         Con# ,   ' docon A,      s" Constant" .defname cr ;
         Val# ,   ' doval A,  : seevalue ( xt -- )
         Def# ,   ' dodef A,      dup >body ?
         Doe# ,   ' dodoe A,      s" Value" .defname cr ;
         Ali# ,   ' doali A,  : seedefer ( xt -- )
         Col# ,   ' docol A,      dup >body @ xt-see-xt cr
         Use# ,   ' douse A,      dup s" Defer" .defname cr
         0 ,      >name dup ??? = if
           drop ." lastxt >body !"
 : (dosee) ( lfa -- )      else
         dup dup cell+ c@ >r          ." IS " .name cr
         wordinfo      then ;
         wordtypes  : see-threaded ( addr -- )
         BEGIN dup @ dup      C-Pass @ DebugMode = IF
         WHILE 2 pick = IF cell+ @ nip EXECUTE          ScanMode c-pass !
                           r> dup 32 and IF ."  immediate" THEN          EXIT
                                  64 and IF ."  restrict" THEN EXIT THEN      THEN
               2 cells +      ScanMode c-pass ! dup makepass
         REPEAT      DisplayMode c-pass ! makepass ;
         2drop rdrop  : seedoes ( xt -- )
         .name ." Don't know how to handle" cr ;      dup s" create" .defname cr
       S" DOES> " Com# .string XPos @ Level !
 ' (dosee) IS dosee      >does-code see-threaded ;
   : seecol ( xt -- )
 : xtc ( xt -- )       \ do see at xt      dup s" :" .defname nl
         Look 0= ABORT" SEE: No valid XT"      2 Level !
         cr c-init      >body see-threaded ;
         dosee ;  : seefield ( xt -- )
       dup >body ." 0 " ? ." 0 0 "
 : see   name sfind 0= IF ." Word unknown" cr exit THEN      s" Field" .defname cr ;
         xtc ;  
   : xt-see ( xt -- )
 : lfc   cr c-init cell+ dosee ;      cr c-init
 : nfc   cr c-init dosee ;      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
           2drop 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 ;
   
   : see ( "name" -- ) \ tools
       name find-name dup 0=
       IF
           drop -&13 bounce
       THEN
       name-see ;
   
   

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


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