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

version 1.1, 1994/02/11 16:30:47 version 1.11, 1996/05/04 18:39:25
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 37  DEFER nlcount ' noop IS nlcount Line 58  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 66  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 ;
   
 : ctype         ( adr len -- )  : ctype         ( adr len -- )
                 warp? dup XPos +! C-Output @ IF type ELSE 2drop THEN ;                  warp? dup XPos +! C-Output @ IF type ELSE 2drop THEN ;
Line 181  VARIABLE C-Pass Line 202  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-@local#
       Display? IF
           S" @local" 0 .string
           dup @ dup 1 cells / abs 0 <# #S rot sign #> 0 .string bl cemit
       THEN
       cell+ ;
   
   : c-flit
       Display? IF
           dup f@ scratch represent 0=
           IF    2drop  scratch 3 min 0 .string
           ELSE
               IF  '- cemit  THEN  1-
               scratch over c@ cemit '. cemit 1 /string 0 .string
               'E cemit
               dup abs 0 <# #S rot sign #> 0 .string bl cemit
           THEN THEN
       float+ ;
   
   : c-f@local#
       Display? IF
           S" f@local" 0 .string
           dup @ dup 1 floats / abs 0 <# #S rot sign #> 0 .string bl cemit
       THEN
       cell+ ;
   
   : c-laddr#
       Display? IF
           S" laddr# " 0 .string
           dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit
       THEN
       cell+ ;
   
   : c-lp+!#
       Display? IF
           S" lp+!# " 0 .string
           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 374  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-?branch-lp+!#  c-?branch cell+ ;
   : c-branch-lp+!#   c-branch  cell+ ;
   
 : c-do  : c-do
         Display? IF nl S" DO" .struc level+ THEN ;          Display? IF nl S" DO" .struc level+ THEN ;
   
Line 336  VARIABLE C-Pass Line 404  VARIABLE C-Pass
         Display? IF level- nl S" LOOP " .struc nl THEN          Display? IF level- nl S" LOOP " .struc nl THEN
         DebugBranch cell+ cell+ ;          DebugBranch cell+ cell+ ;
   
   
 : c-+loop  : c-+loop
         Display? IF level- nl S" +LOOP " .struc nl THEN          Display? IF level- nl S" +LOOP " .struc nl THEN
         DebugBranch cell+ cell+ ;          DebugBranch cell+ cell+ ;
   
   : c-s+loop
           Display? IF level- nl S" S+LOOP " .struc nl THEN
           DebugBranch cell+ cell+ ;
   
   : c--loop
           Display? IF level- nl S" -LOOP " .struc nl THEN
           DebugBranch cell+ cell+ ;
   
   : c-next-lp+!#  c-next cell+ ;
   : c-loop-lp+!#  c-loop cell+ ;
   : c-+loop-lp+!#  c-+loop cell+ ;
   : c-s+loop-lp+!#  c-s+loop cell+ ;
   : c--loop-lp+!#  c--loop cell+ ;
   
 : c-leave  : c-leave
         Display? IF S" LEAVE " .struc THEN          Display? IF S" LEAVE " .struc THEN
         Debug? IF dup @ + THEN cell+ ;          Debug? IF dup @ + THEN cell+ ;
Line 357  VARIABLE C-Pass Line 438  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 453  VARIABLE C-Pass
   
   
 CREATE C-Table  CREATE C-Table
         ' lit A,         ' c-lit A,          ' lit A,            ' c-lit A,
         ' (s") A,        ' c-s" A,          ' @local# A,        ' c-@local# A,
         ' (.") A,        ' c-." A,          ' flit A,           ' c-flit A,
         ' "lit A,        ' c-c" A,          ' f@local# A,       ' c-f@local# A,
         ' ?branch A,     ' c-?branch A,          ' laddr# A,         ' c-laddr# A,
         ' branch A,      ' c-branch A,          ' lp+!# A,          ' c-lp+!# A,
         ' leave A,       ' c-leave A,          ' (s") A,           ' c-s" A,
         ' ?leave A,      ' c-?leave A,          ' (.") A,           ' c-." A,
         ' (do) A,        ' c-do A,          ' "lit A,           ' c-c" A,
         ' (?do) A,       ' c-?do A,          ' leave A,          ' c-leave A,
         ' (for) A,       ' c-for A,          ' ?leave A,         ' c-?leave A,
         ' (loop) A,      ' c-loop A,          ' (do) A,           ' c-do A,
         ' (+loop) A,     ' c-+loop A,          ' (?do) A,          ' c-?do A,
         ' (next) A,      ' c-next A,          ' (for) A,          ' c-for A,
         ' exit A,        ' c-exit A,          ' ?branch A,        ' c-?branch A,
         ' (;code) A,     ' c-;code A,          ' branch A,         ' c-branch A,
         ' (abort") A,    ' c-abort" A,          ' (loop) A,         ' c-loop A,
         ' (compile) A,   ' c-(compile) A,          ' (+loop) A,        ' c-+loop A,
           ' (s+loop) A,       ' c-s+loop A,
           ' (-loop) A,        ' c--loop A,
           ' (next) A,         ' c-next A,
           ' ?branch-lp+!# A,  ' c-?branch-lp+!# A,
           ' branch-lp+!# A,   ' c-branch-lp+!# A,
           ' (loop)-lp+!# A,   ' c-loop-lp+!# A,
           ' (+loop)-lp+!# A,  ' c-+loop-lp+!# A,
           ' (s+loop)-lp+!# A, ' c-s+loop-lp+!# A,
           ' (-loop)-lp+!# A,  ' c--loop-lp+!# A,
           ' (next)-lp+!# A,   ' c-next-lp+!# A,
           ' ;s A,             ' c-exit A,
           ' (does>) A,        ' c-does> A,
           ' (abort") A,       ' c-abort" A,
           ' (compile) A,      ' c-(compile) A,
         0 ,          0 ,
   
 \ DOTABLE                                               15may93jaw  \ DOTABLE                                               15may93jaw
Line 400  CREATE C-Table Line 495  CREATE C-Table
         WHILE   2 pick <>          WHILE   2 pick <>
         WHILE   2 cells +          WHILE   2 cells +
         REPEAT          REPEAT
         nip cell+ @ EXECUTE          nip cell+ perform
         true          true
         ELSE          ELSE
         2drop drop false          2drop drop false
Line 427  CREATE C-Table Line 522  CREATE C-Table
         dup cell+ swap @          dup cell+ swap @
         dup >r DoTable r> swap IF drop EXIT THEN          dup >r DoTable r> swap IF drop EXIT THEN
         Display?          Display?
         IF look 0= ABORT" SEE: Bua!"          IF look 0= IF  drop dup 1 cells - @ .  \ ABORT" SEE: Bua!"
            cell+ dup count 31 and rot wordinfo .string bl cemit             ELSE  dup cell+ count 31 and rot wordinfo .string  THEN  bl cemit
         ELSE drop          ELSE drop
         THEN ;          THEN ;
   
Line 449  CREATE C-Table Line 544  CREATE C-Table
 DEFER dosee  DEFER dosee
   
 : dopri .name ." is primitive" cr ;  : dopri .name ." is primitive" cr ;
 : dovar .name ." is variable" cr ;  : dovar ." Variable " .name cr ;
 : docon  dup .name ." is constant, value: "  : douse ." User " .name cr ;
          cell+ (name>) >body @ . cr ;  : docon  dup cell+ (name>) >body @ . ." Constant " .name cr ;
 : doval .name ." is value" cr ;  : doval  dup cell+ (name>) >body @ . ." Value " .name cr ;
 : dodef .name ." is defered word, is: "  : dodef ." Defer " dup >r .name cr
          here @ look 0= ABORT" SEE: No valid xt in defered word"      r@ cell+ (name>) >body @ look
         .name cr here @ look drop dosee ;      0= ABORT" SEE: No valid xt in deferred word"
 : dodoe .name ." is created word" cr      dup dosee cr
         S" DOES> " Com# .string XPos @ Level !      ." ' " .name r> ." IS " .name cr ;
         here @ dup C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN  : dodoe ." Create " dup .name cr
           S" DOES> " Com# .string XPos @ Level ! name>
           >does-code dup C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN
         ScanMode c-pass ! dup makepass          ScanMode c-pass ! dup makepass
         DisplayMode c-pass ! makepass ;          DisplayMode c-pass ! makepass ;
 : doali .name ." is alias of "  : doali here @ .name ." Alias " .name cr
         here @ .name cr  
         here @ dosee ;          here @ dosee ;
 : docol S" : " Com# .string  : docol
         cell+ dup count $1F and 2 pick wordinfo .string bl cemit bl cemit      S" : " Com# .string
         ( XPos @ ) 2 Level !      dup name>string 2 pick wordinfo .string bl cemit bl cemit
         name> >body      ( XPos @ ) 2 Level !
         C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN      name> >body
         ScanMode c-pass ! dup makepass      C-Pass @ DebugMode =
         DisplayMode c-pass ! makepass ;      IF
           ScanMode c-pass ! EXIT
       THEN
       ScanMode c-pass ! dup makepass
       DisplayMode c-pass ! makepass ;
   
 create wordtypes  create wordtypes
         Pri# ,   ' dopri A,          Pri# ,   ' dopri A,
Line 481  create wordtypes Line 581  create wordtypes
         Doe# ,   ' dodoe A,          Doe# ,   ' dodoe A,
         Ali# ,   ' doali A,          Ali# ,   ' doali A,
         Col# ,   ' docol A,          Col# ,   ' docol A,
           Use# ,   ' douse A,
         0 ,          0 ,
   
 : (dosee) ( lfa -- )  : (dosee) ( lfa -- )
         dup cell+ dup c@ 32 and IF over .name ." is an immediate word" cr THEN          dup dup cell+ c@ >r
         wordinfo          wordinfo
         wordtypes          wordtypes
         BEGIN dup @ dup          BEGIN dup @ dup
         WHILE 2 pick = IF cell+ @ nip EXECUTE EXIT THEN          WHILE 2 pick = IF cell+ @ nip EXECUTE
                             r> dup 32 and IF ."  immediate" THEN
                                    64 and IF ."  restrict" THEN EXIT THEN
               2 cells +                2 cells +
         REPEAT          REPEAT
         2drop          2drop rdrop
         .name ." Don't know how to handle" cr ;          .name ." Don't know how to handle" cr ;
   
 ' (dosee) IS dosee  ' (dosee) IS dosee
   
 : see   name find cr 0= IF ." Word unknown" cr drop exit THEN  
         >name c-init  
         dosee ;  
   
 : xtc ( xt -- )       \ do see at xt  : xtc ( xt -- )       \ do see at xt
         Look 0= ABORT" SEE: No valid XT"          Look 0= ABORT" SEE: No valid XT"
         cr c-init          cr c-init
         dosee ;          dosee ;
   
   : see   name sfind 0= IF ." Word unknown" cr exit THEN
           xtc ;
   
 : lfc   cr c-init cell+ dosee ;  : lfc   cr c-init cell+ dosee ;
 : nfc   cr c-init dosee ;  : nfc   cr c-init dosee ;
   

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


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