version 1.14, 1996/08/26 10:07:21
|
version 1.15, 1997/01/29 21:32:38
|
Line 50 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 68 DEFER nlcount ' noop IS nlcount
|
Line 69 DEFER nlcount ' noop IS nlcount
|
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 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 216 VARIABLE C-Pass
|
Line 224 VARIABLE C-Pass
|
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 VARIABLE C-Pass
|
Line 351 VARIABLE C-Pass
|
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+ ; |
DebugBranch cell+ cell+ ; |
|
|
: c-s+loop |
: c-do |
Display? IF level- nl S" S+LOOP " .struc nl THEN |
Display? IF nl .name-without level+ 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-?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 VARIABLE C-Pass
|
Line 400 VARIABLE C-Pass
|
|
|
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 IS discode
|
Line 539 IS discode
|
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 -- ) |