[gforth] / gforth / see.fs  

gforth: gforth/see.fs

Diff for /gforth/see.fs between version 1.14 and 1.15

version 1.14, Mon Aug 26 10:07:21 1996 UTC version 1.15, Wed Jan 29 21:32:38 1997 UTC
Line 50 
Line 50 
 : 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 68 
Line 69 
                 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
     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 98 
Line 105 
 ' (.string) IS .string  ' (.string) IS .string
   
   
 : .struc        Str# .string ;  : .struc
           uppercase on Str# .string ;
   
 \ CODES                                                 15may93jaw  \ CODES                                                 15may93jaw
   
Line 216 
Line 224 
     THEN      THEN
     cell+ ;      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
         Display?          Display?
Line 383 
Line 351 
         DebugBranch          DebugBranch
         cell+ ;          cell+ ;
   
 : c-?branch-lp+!#  c-?branch cell+ ;  
 : c-branch-lp+!#   c-branch  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+ ;  
   
 : c-+loop  
         Display? IF level- nl S" +LOOP " .struc nl THEN  
         DebugBranch cell+ cell+ ;  
   
 : c-s+loop  
         Display? IF level- nl S" S+LOOP " .struc nl THEN  
         DebugBranch cell+ cell+ ;          DebugBranch cell+ cell+ ;
   
 : c--loop  : c-do
         Display? IF level- nl S" -LOOP " .struc nl THEN          Display? IF nl .name-without level+ THEN ;
         DebugBranch cell+ cell+ ;  
   
 : c-next-lp+!#  c-next cell+ ;  : c-?do
 : c-loop-lp+!#  c-loop cell+ ;          Display? IF nl S" ?DO" .struc level+ THEN
 : c-+loop-lp+!#  c-+loop cell+ ;          DebugBranch 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
Line 454 
Line 400 
   
 CREATE C-Table  CREATE C-Table
         ' lit A,            ' c-lit A,          ' lit A,            ' c-lit A,
         ' @local# A,        ' c-@local# A,  
         ' flit A,           ' c-flit A,  
         ' f@local# A,       ' c-f@local# A,  
         ' laddr# A,         ' c-laddr# A,  
         ' lp+!# A,          ' c-lp+!# 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,
         comp' leave drop A, ' c-leave A,          comp' leave drop A, ' c-leave A,
         comp' ?leave drop A, ' c-?leave A,          comp' ?leave drop A, ' c-?leave A,
         ' (do) A,           ' c-do A,          ' (do) A,           ' c-do A,
           ' (+do) A,          ' c-do A,
           ' (u+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,          ' (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,
         ' (s+loop) A,       ' c-s+loop A,          ' (s+loop) A,       ' c-loop A,
         ' (-loop) A,        ' c--loop A,          ' (-loop) A,        ' c-loop A,
         ' (next) A,         ' c-next A,          ' (next) A,         ' c-loop 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,          ' ;s A,             ' c-exit A,
         ' (does>) A,        ' c-does> A,          ' (does>) A,        ' c-does> A,
         ' (abort") A,       ' c-abort" A,          ' (abort") A,       ' c-abort" A,
         ' (compile) A,      ' c-(compile) A,          ' (compile) A,      ' c-(compile) A,
         0 ,          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+ perform          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 594 
Line 539 
     S" DOES> " Com# .string XPos @ Level !      S" DOES> " Com# .string XPos @ Level !
     >does-code see-threaded ;      >does-code see-threaded ;
 : seecol ( xt -- )  : seecol ( xt -- )
     dup s" :" .defname cr      dup s" :" .defname nl
     2 Level !      2 Level !
     >body see-threaded ;      >body see-threaded ;
 : seefield ( xt -- )  : seefield ( xt -- )

Generate output suitable for use with a patch program
Legend:
Removed from v.1.14  
changed lines
  Added in v.1.15
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help