version 1.7, 1995/10/07 17:38:19
|
version 1.15, 1997/01/29 21:32:38
|
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 |
: c-flit |
cell+ ; |
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-s" |
: c-s" |
count 2dup + aligned -rot |
count 2dup + aligned -rot |
Line 319 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 382 VARIABLE C-Pass
|
Line 399 VARIABLE C-Pass
|
|
|
|
|
CREATE C-Table |
CREATE C-Table |
' lit A, ' c-lit A, |
' lit A, ' c-lit A, |
' flit A, ' c-flit 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, |
' ?branch A, ' c-?branch A, |
comp' ?leave drop A, ' c-?leave A, |
' branch A, ' c-branch A, |
' (do) A, ' c-do A, |
' leave A, ' c-leave A, |
' (+do) A, ' c-do A, |
' ?leave A, ' c-?leave A, |
' (u+do) A, ' c-do A, |
' (do) A, ' c-do A, |
' (-do) A, ' c-do A, |
' (?do) A, ' c-?do A, |
' (u-do) A, ' c-do A, |
' (for) A, ' c-for A, |
' (?do) A, ' c-?do A, |
' (loop) A, ' c-loop A, |
' (for) A, ' c-for A, |
' (+loop) A, ' c-+loop A, |
' ?branch A, ' c-?branch A, |
' (next) A, ' c-next A, |
' branch A, ' c-branch A, |
' ;s A, ' c-exit A, |
' (loop) A, ' c-loop A, |
' (does>) A, ' c-does> A, |
' (+loop) A, ' c-loop A, |
' (abort") A, ' c-abort" A, |
' (s+loop) A, ' c-loop A, |
' (compile) A, ' c-(compile) A, |
' (-loop) A, ' c-loop A, |
0 , |
' (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 451 CREATE C-Table
|
Line 480 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 ; |
|
|
|
|