version 1.2, 1994/05/03 19:10:36
|
version 1.9, 1995/11/07 18:06:59
|
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. |
Line 188 VARIABLE C-Pass
|
Line 207 VARIABLE C-Pass
|
cell+ ; |
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 370 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 400 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 434 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 449 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, |
' ;s 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 427 CREATE C-Table
|
Line 518 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 540 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 S" : " Com# .string |
cell+ dup count $1F and 2 pick wordinfo .string bl cemit bl cemit |
dup cell+ count $1F and 2 pick wordinfo .string bl cemit bl cemit |
( XPos @ ) 2 Level ! |
( XPos @ ) 2 Level ! |
name> >body |
name> >body |
C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN |
C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN |
Line 481 create wordtypes
|
Line 573 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 ; |
|
|