--- gforth/see.fs 1994/07/13 19:21:08 1.3 +++ gforth/see.fs 1996/05/04 18:39:25 1.11 @@ -1,11 +1,32 @@ \ 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 \ I'm sorry. This is really not "forthy" enough. \ Ideas: Level should be a stack +require termsize.fs + decimal \ Screen format words 16may93jaw @@ -37,7 +58,7 @@ DEFER nlcount ' noop IS nlcount XPos @ Level @ = ?Exit C-Formated @ IF C-Output @ - IF C-Clearline @ IF 80 XPos @ - spaces + IF C-Clearline @ IF cols XPos @ - spaces ELSE cr THEN 1 YPos +! 0 XPos ! Level @ spaces @@ -45,7 +66,7 @@ DEFER nlcount ' noop IS nlcount : warp? ( len -- len ) nlflag @ IF (nl) nlflag off THEN - XPos @ over + 79 u> IF (nl) THEN ; + XPos @ over + cols u>= IF (nl) THEN ; : ctype ( adr len -- ) warp? dup XPos +! C-Output @ IF type ELSE 2drop THEN ; @@ -181,15 +202,59 @@ VARIABLE C-Pass : ahead? ( n -- flag ) 0> ; : c-(compile) - Display? IF s" POSTPONE " Com# .string - dup @ look 0= ABORT" SEE: No valid XT" - cell+ count $1F and 0 .string bl cemit - THEN - cell+ ; + Display? + IF + s" POSTPONE " Com# .string + dup @ look 0= ABORT" SEE: No valid XT" + name>string 0 .string bl cemit + THEN + cell+ ; : c-lit - Display? IF dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit THEN - cell+ ; + Display? IF + 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" count 2dup + aligned -rot @@ -309,15 +374,18 @@ VARIABLE C-Pass IF WhileCode2 swap ! ELSE drop THEN level- nl - S" WHILE" .struc + S" WHILE " .struc level+ - ELSE nl S" IF" .struc level+ + ELSE nl S" IF " .struc level+ THEN THEN THEN DebugBranch cell+ ; +: c-?branch-lp+!# c-?branch cell+ ; +: c-branch-lp+!# c-branch cell+ ; + : c-do Display? IF nl S" DO" .struc level+ THEN ; @@ -336,11 +404,24 @@ VARIABLE C-Pass Display? IF level- nl S" LOOP " .struc 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+ ; + +: 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 Display? IF S" LEAVE " .struc THEN Debug? IF dup @ + THEN cell+ ; @@ -357,7 +438,7 @@ VARIABLE C-Pass THEN Debug? IF drop THEN ; -: c-;code \ end of create part +: c-does> \ end of create part Display? IF S" DOES> " Com# .string THEN Cell+ cell+ ; @@ -372,24 +453,38 @@ VARIABLE C-Pass CREATE C-Table - ' lit A, ' c-lit A, - ' (s") A, ' c-s" A, - ' (.") A, ' c-." A, - ' "lit A, ' c-c" A, - ' ?branch A, ' c-?branch A, - ' branch A, ' c-branch A, - ' leave A, ' c-leave A, - ' ?leave A, ' c-?leave A, - ' (do) A, ' c-do A, - ' (?do) A, ' c-?do A, - ' (for) A, ' c-for A, - ' (loop) A, ' c-loop A, - ' (+loop) A, ' c-+loop A, - ' (next) A, ' c-next A, - ' ;s A, ' c-exit A, - ' (;code) A, ' c-;code A, - ' (abort") A, ' c-abort" A, - ' (compile) A, ' c-(compile) 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, + ' (.") A, ' c-." A, + ' "lit A, ' c-c" A, + ' leave A, ' c-leave A, + ' ?leave A, ' c-?leave A, + ' (do) A, ' c-do A, + ' (?do) A, ' c-?do A, + ' (for) A, ' c-for A, + ' ?branch A, ' c-?branch A, + ' branch A, ' c-branch A, + ' (loop) A, ' c-loop 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 , \ DOTABLE 15may93jaw @@ -400,7 +495,7 @@ CREATE C-Table WHILE 2 pick <> WHILE 2 cells + REPEAT - nip cell+ @ EXECUTE + nip cell+ perform true ELSE 2drop drop false @@ -449,28 +544,33 @@ CREATE C-Table DEFER dosee : dopri .name ." is primitive" cr ; -: dovar .name ." is variable" cr ; -: docon dup .name ." is constant, value: " - cell+ (name>) >body @ . cr ; -: doval .name ." is value" cr ; -: dodef .name ." is defered word, is: " - here @ look 0= ABORT" SEE: No valid xt in defered word" - .name cr here @ look drop dosee ; -: dodoe .name ." is created word" cr - S" DOES> " Com# .string XPos @ Level ! - here @ dup C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN +: dovar ." Variable " .name cr ; +: douse ." User " .name cr ; +: docon dup cell+ (name>) >body @ . ." Constant " .name cr ; +: doval dup cell+ (name>) >body @ . ." Value " .name cr ; +: dodef ." Defer " dup >r .name cr + r@ cell+ (name>) >body @ look + 0= ABORT" SEE: No valid xt in deferred word" + dup dosee cr + ." ' " .name r> ." IS " .name cr ; +: 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 DisplayMode c-pass ! makepass ; -: doali .name ." is alias of " - here @ .name cr +: doali here @ .name ." Alias " .name cr here @ dosee ; -: docol S" : " Com# .string - dup cell+ count $1F and 2 pick wordinfo .string bl cemit bl cemit - ( XPos @ ) 2 Level ! - name> >body - C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN - ScanMode c-pass ! dup makepass - DisplayMode c-pass ! makepass ; +: docol + S" : " Com# .string + dup name>string 2 pick wordinfo .string bl cemit bl cemit + ( XPos @ ) 2 Level ! + name> >body + C-Pass @ DebugMode = + IF + ScanMode c-pass ! EXIT + THEN + ScanMode c-pass ! dup makepass + DisplayMode c-pass ! makepass ; create wordtypes Pri# , ' dopri A, @@ -481,17 +581,20 @@ create wordtypes Doe# , ' dodoe A, Ali# , ' doali A, Col# , ' docol A, + Use# , ' douse A, 0 , : (dosee) ( lfa -- ) - dup dup cell+ c@ 32 and IF over .name ." is an immediate word" cr THEN + dup dup cell+ c@ >r wordinfo wordtypes 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 + REPEAT - 2drop + 2drop rdrop .name ." Don't know how to handle" cr ; ' (dosee) IS dosee @@ -501,7 +604,7 @@ create wordtypes cr c-init dosee ; -: see name find 0= IF ." Word unknown" cr drop exit THEN +: see name sfind 0= IF ." Word unknown" cr exit THEN xtc ; : lfc cr c-init cell+ dosee ;