Commit 52933bc8 authored by pazsan's avatar pazsan

Added forth variants for primitives

Added a generator for forth primitives
Cleaned up some minor errors
Changed names of local access (was cell size dependent)
Where is "getopt.h"???!? Added tiny workaround. Where is getopt_long?
parent 23c4e8e4
......@@ -5,9 +5,9 @@ GCC = gcc
FORTH = gforth
CC = gcc
SWITCHES = \
-fno-defer-pop -fcaller-saves -m486 \
-D_POSIX_VERSION -DUSE_FTOS \
#-DDIRECT_THREADED #-DFORCE_REG #-DNDEBUG #turn off assertions
-fno-defer-pop -fcaller-saves \
-DUSE_TOS -DUSE_FTOS -DDEFAULTBIN='"'`pwd`'"' \
-DDIRECT_THREADED #-DNDEBUG #turn off assertions
CFLAGS = -O4 -Wall -g $(SWITCHES)
#-Xlinker -n puts text and data into the same 256M region
......@@ -72,13 +72,13 @@ kernl32l.fi: main.fs search-order.fs cross.fs aliases.fs vars.fs add.fs \
errore.fs kernal.fs extend.fs tools.fs toolsext.fs \
mach32l.fs $(FORTH_GEN)
-cp kernl32l.fi kernl32l.fi~
$(FORTH) -e 's" mach32l.fs" r/o open-file throw' main.fs
$(FORTH) -e 's" mach32l.fs"' main.fs
kernl32b.fi: main.fs search-order.fs cross.fs aliases.fs vars.fs add.fs \
errore.fs kernal.fs extend.fs tools.fs toolsext.fs \
mach32b.fs $(FORTH_GEN)
-cp kernl32b.fi kernl32b.fi~
$(FORTH) -e 's" mach32b.fs" r/o open-file throw' main.fs
$(FORTH) -e 's" mach32b.fs"' main.fs
engine.s: engine.c primitives.i prim_labels.i machine.h $(INCLUDES)
$(GCC) $(CFLAGS) -S engine.c
......@@ -97,12 +97,19 @@ prim_labels.i : primitives.b prims2x.fs
aliases.fs: primitives.b prims2x.fs
$(FORTH) prims2x.fs -e "s\" primitives.b\" ' output-alias process-file bye" >$@
primitives.fs: primitives.b prims2x.fs
$(FORTH) prims2x.fs -e "s\" primitives.b\" ' output-forth process-file bye" >$@
#primitives.4th: primitives.b primitives2c.el
# $(EMACS) -batch -load primitives2c.el -funcall make-forth
#GNU make default rules
#% :: RCS/%,v
# co $@
#%.o : %.c $(INCLUDES)
# $(CC) $(CFLAGS) -c $< -o $@
%.s : %.c $(INCLUDES)
$(CC) $(CFLAGS) -S $< -o $@
%.o : %.s
$(CC) $(CFLAGS) -c $< -o $@
\ CROSS.FS The Cross-Compiler 06oct92py
\ $Id: cross.fs,v 1.12 1994-09-09 16:27:17 anton Exp $
\ $Id: cross.fs,v 1.13 1994-09-12 19:00:27 pazsan Exp $
\ Idea and implementation: Bernd Paysan (py)
\ Copyright 1992 by the ANSI figForth Development Group
......@@ -40,7 +40,7 @@ VARIABLE GhostNames
0 GhostNames !
: GhostName ( -- addr )
here GhostNames @ , GhostNames ! here 0 ,
name count
bl word count
\ 2dup type space
dup c, here over chars allot swap move align ;
......@@ -84,7 +84,7 @@ Variable tdp
\ Parameter for target systems 06oct92py
include-file
included
>TARGET
......@@ -234,15 +234,13 @@ Variable last-ghost
\ searches for string in word-list ghosts
\ !! wouldn't it be simpler to just use search-wordlist ? ae
dup count [ ' ghosts >body ] ALiteral search-wordlist
\ >r get-order 0 set-order also ghosts r> find >r >r
>r r@ IF >body nip THEN r> ;
\ set-order r> r@ IF >body THEN r> ;
dup IF >r >body nip r> THEN ;
VARIABLE Already
: ghost ( "name" -- ghost )
Already off
>in @ name gfind IF Already on nip EXIT THEN
>in @ bl word gfind IF Already on nip EXIT THEN
drop >in ! Make-Ghost ;
\ resolve 14oct92py
......@@ -330,7 +328,7 @@ VARIABLE ^imm
: string, ( addr count -- )
dup T c, H bounds DO I c@ T c, H LOOP ;
: name, ( "name" -- ) name count string, T align H ;
: name, ( "name" -- ) bl word count string, T align H ;
: view, ( -- ) ( dummy ) ;
VARIABLE CreateFlag CreateFlag off
......@@ -398,14 +396,14 @@ ghost '
: compile ( -- ) \ name
restrict?
name gfind dup 0= ABORT" CROSS: Can't compile "
bl word gfind dup 0= ABORT" CROSS: Can't compile "
0> ( immediate? )
IF >exec @ compile,
ELSE postpone literal postpone gexecute THEN ;
immediate
>TARGET
: ' ( -- cfa ) name gfind 0= ABORT" CROSS: undefined "
: ' ( -- cfa ) bl word gfind 0= ABORT" CROSS: undefined "
dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ;
Cond: ['] compile lit ghost gexecute ;Cond
......@@ -442,7 +440,7 @@ Cond: [Char] ( "<char>" -- ) restrict? Char lit, ;Cond
: ] state on
BEGIN
BEGIN >in @ name
BEGIN >in @ bl word
dup c@ 0= WHILE 2drop refill 0=
ABORT" CROSS: End of file while target compiling"
REPEAT
......@@ -672,14 +670,14 @@ Cond: TO T ' >body H compile ALiteral compile ! ;Cond
\ compile must be last 22feb93py
Cond: compile ( -- ) restrict? \ name
name gfind dup 0= ABORT" CROSS: Can't compile"
bl word gfind dup 0= ABORT" CROSS: Can't compile"
0> IF gexecute
ELSE dup >magic @ <imm> =
IF gexecute
ELSE compile (compile) gexecute THEN THEN ;Cond
Cond: postpone ( -- ) restrict? \ name
name gfind dup 0= ABORT" CROSS: Can't compile"
bl word gfind dup 0= ABORT" CROSS: Can't compile"
0> IF gexecute
ELSE dup >magic @ <imm> =
IF gexecute
......@@ -693,7 +691,7 @@ also minimal
\ define new [IFDEF] and [IFUNDEF] 20may93jaw
: there? name gfind IF >magic @ <fwd> <> ELSE drop false THEN ;
: there? bl word gfind IF >magic @ <fwd> <> ELSE drop false THEN ;
: [IFDEF] there? postpone [IF] ;
: [IFUNDEF] there? 0= postpone [IF] ;
......@@ -749,6 +747,9 @@ bigendian Constant bigendian
: * * ; : / / ;
: dup dup ; : over over ;
: swap swap ; : rot rot ;
: drop drop ;
: lshift lshift ; : 2/ 2/ ;
cell constant cell
\ include bug5.fs
\ only forth also minimal definitions
......
......@@ -6,7 +6,7 @@
' align Alias sfalign
' aligned Alias sfaligned
[ELSE]
: sfloats 4 * ;
: sfloats 2* 2* ;
: sfloat+ 4 + ;
: sfaligned ( addr -- addr' ) 3 + -4 and ;
: sfalign ( -- ) here dup sfaligned swap ?DO bl c, LOOP ;
......@@ -18,7 +18,7 @@
' falign Alias dfalign
' faligned Alias dfaligned
[ELSE]
: dfloats 8 * ;
: dfloats 2* 2* 2* ;
: dfloat+ 8 + ;
: dfaligned ( addr -- addr' ) 7 + -8 and ;
: dfalign ( -- ) here dup dfaligned swap ?DO bl c, LOOP ;
......
......@@ -61,22 +61,22 @@
\ Currently locals may only be
\ defined at the outer level and TO is not supported.
include float.fs
include search-order.fs
include float.fs
: compile-@local ( n -- )
case
0 of postpone @local0 endof
4 of postpone @local4 endof
8 of postpone @local8 endof
12 of postpone @local12 endof
0 of postpone @local0 endof
1 cells of postpone @local1 endof
2 cells of postpone @local2 endof
3 cells of postpone @local3 endof
( otherwise ) dup postpone @local# ,
endcase ;
: compile-f@local ( n -- )
case
0 of postpone f@local0 endof
8 of postpone f@local8 endof
0 of postpone f@local0 endof
1 floats of postpone f@local1 endof
( otherwise ) dup postpone f@local# ,
endcase ;
......@@ -509,5 +509,5 @@ forth definitions
endif ; immediate
: locals|
BEGIN sname 2dup s" |" compare 0= WHILE
BEGIN name 2dup s" |" compare 0= WHILE
(local) REPEAT drop 0 (local) ; immediate restrict
......@@ -32,12 +32,6 @@ Variable HashPointer
: hash-find ( addr len wordlist -- nfa / false )
$C + @ >r
2dup hash cells r> + @ (hashfind) ;
\ BEGIN dup WHILE
\ 2@ >r >r dup r@ cell+ c@ $1F and =
\ IF 2dup r@ cell+ char+ capscomp 0=
\ IF 2drop r> rdrop EXIT THEN THEN
\ rdrop r>
\ REPEAT nip nip ;
\ hash vocabularies 16jul94py
......
......@@ -154,11 +154,10 @@ Defer source
\ name 13feb93py
: capitalize ( addr -- addr )
dup count chars bounds
: capitalize ( addr len -- addr len )
2dup chars chars bounds
?DO I c@ toupper I c! 1 chars +LOOP ;
: (name) ( -- addr ) bl word ;
: sname ( -- c-addr count )
: (name) ( -- c-addr count )
source 2dup >r >r >in @ /string (parse-white)
2dup + r> - 1+ r> min >in ! ;
\ name count ;
......@@ -176,7 +175,7 @@ Defer source
: (compile) ( -- ) r> dup cell+ >r @ A, ;
: postpone ( "name" -- )
name find dup 0= abort" Can't compile "
name sfind dup 0= abort" Can't compile "
0> IF A, ELSE postpone (compile) A, THEN ;
immediate restrict
......@@ -342,15 +341,15 @@ Defer notfound ( c-addr count -- )
: interpret
BEGIN
?stack sname dup
?stack name dup
WHILE
parser
REPEAT
2drop ;
\ sinterpreter scompiler 30apr92py
\ interpreter compiler 30apr92py
: sinterpreter ( c-addr u -- )
: interpreter ( c-addr u -- )
\ interpretation semantics for the name/number c-addr u
2dup sfind dup
IF
......@@ -368,9 +367,9 @@ Defer notfound ( c-addr count -- )
2r> notfound
THEN ;
' sinterpreter IS parser
' interpreter IS parser
: scompiler ( c-addr u -- )
: compiler ( c-addr u -- )
\ compilation semantics for the name/number c-addr u
2dup sfind dup
IF
......@@ -393,17 +392,17 @@ Defer notfound ( c-addr count -- )
drop notfound
THEN ;
: [ ['] sinterpreter IS parser state off ; immediate
: ] ['] scompiler IS parser state on ;
: [ ['] interpreter IS parser state off ; immediate
: ] ['] compiler IS parser state on ;
\ locals stuff needed for control structures
: compile-lp+! ( n -- )
dup negate locals-size +!
0 over = if
else -4 over = if postpone -4lp+!
else 8 over = if postpone 8lp+!
else 16 over = if postpone 16lp+!
else -1 cells over = if postpone lp-
else 1 floats over = if postpone lp+
else 2 floats over = if postpone lp+2
else postpone lp+!# dup ,
then then then then drop ;
......@@ -561,18 +560,13 @@ variable dead-code \ true if normal code at "here" would be dead
: THEN ( orig -- )
dup orig?
dead-code @
dead-orig =
if
dead-orig =
if
>resolve drop
else
>resolve set-locals-size-list dead-code off
then
>resolve drop
else
dead-orig =
if
>resolve drop
dead-code @
if
>resolve set-locals-size-list dead-code off
else \ both live
over list-size adjust-locals-size
>resolve
......@@ -797,12 +791,13 @@ Avariable leave-sp leave-stack 3 cells + leave-sp !
\ information through global variables), but they are useful for dealing
\ with existing/independent defining words
defer header
defer (header)
defer header ' (header) IS header
: name, ( "name" -- )
name c@
name
dup $1F u> -&19 and throw ( is name too long? )
1+ chars allot align ;
dup c, here swap chars dup allot move align ;
: input-stream-header ( "name" -- )
\ !! this is f83-implementation-dependent
align here last ! -1 A,
......@@ -810,9 +805,9 @@ defer header
: input-stream ( -- ) \ general
\ switches back to getting the name from the input stream ;
['] input-stream-header IS header ;
['] input-stream-header IS (header) ;
' input-stream-header IS header
' input-stream-header IS (header)
\ !! make that a 2variable
create nextname-buffer 32 chars allot
......@@ -830,7 +825,7 @@ create nextname-buffer 32 chars allot
dup $1F u> -&19 and throw ( is name too long? )
nextname-buffer c! ( c-addr )
nextname-buffer count move
['] nextname-header IS header ;
['] nextname-header IS (header) ;
: noname-header ( -- )
0 last !
......@@ -838,7 +833,7 @@ create nextname-buffer 32 chars allot
: noname ( -- ) \ general
\ the next defined word remains anonymous. The xt of that word is given by lastxt
['] noname-header IS header ;
['] noname-header IS (header) ;
: lastxt ( -- xt ) \ general
\ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname
......@@ -1024,7 +1019,7 @@ Variable warnings G -1 warnings T !
: rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ;
: ' ( "name" -- addr ) name find 0= if drop -&13 bounce then ;
: ' ( "name" -- addr ) name sfind 0= if -&13 bounce then ;
: ['] ( "name" -- addr ) ' postpone ALiteral ; immediate
\ Input 13feb93py
......@@ -1164,8 +1159,8 @@ create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
: include-file ( i*x fid -- j*x )
push-file loadfile !
0 loadline ! blk off ['] read-loop catch
loadfile @ close-file swap
pop-file throw throw ;
loadfile @ close-file swap 2dup or
pop-file drop throw throw ;
create pathfilenamebuf 256 chars allot \ !! make this grow on demand
......@@ -1195,10 +1190,10 @@ create pathfilenamebuf 256 chars allot \ !! make this grow on demand
open-path-file ( file-id c-addr2 u2 )
dup allocate throw over loadfilename 2! ( file-id c-addr2 u2 )
drop loadfilename 2@ move
include-file
['] include-file catch
\ don't free filenames; they don't take much space
\ and are used for debugging
r> r> loadfilename 2! ;
r> r> loadfilename 2! throw ;
\ HEX DECIMAL 2may93jaw
......@@ -1212,7 +1207,7 @@ create pathfilenamebuf 256 chars allot \ !! make this grow on demand
\ INCLUDE 9may93jaw
: include ( "file" -- )
bl word count included ;
name included ;
\ RECURSE 17may93jaw
......@@ -1289,10 +1284,10 @@ DEFER DOERROR
ELSE
type ." :" dec.
cr dup 2over type cr drop
nip -trailing ( line-start index2 )
nip -trailing 1- ( line-start index2 )
0 >r BEGIN
1- 2dup + c@ bl > WHILE
r> 1+ >r dup 0< UNTIL THEN 1+
2dup + c@ bl > WHILE
r> 1+ >r 1- dup 0< UNTIL THEN 1+
( line-start index1 )
typewhite
r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
......
/*
$Id: main.c,v 1.11 1994-09-08 17:20:09 anton Exp $
$Id: main.c,v 1.12 1994-09-12 19:00:34 pazsan Exp $
Copyright 1993 by the ANSI figForth Development Group
*/
......@@ -14,7 +14,14 @@
#include <stdlib.h>
#include "forth.h"
#include "io.h"
#include "getopt.h"
#ifdef USE_GETOPT
# include "getopt.h"
#else
extern int getopt (argc, argv, optstring);
extern char *optarg;
extern int optind, opterr;
#endif
#ifndef DEFAULTPATH
# define DEFAULTPATH "/usr/local/lib/gforth:."
......@@ -184,7 +191,7 @@ int main(int argc, char **argv, char **env)
char *path, *path1;
char *imagename="gforth.fi";
FILE *image_file;
int c;
int c, retvalue;
#if defined(i386) && defined(ALIGNMENT_CHECK)
/* turn on alignment checks on the 486.
......@@ -198,6 +205,7 @@ int main(int argc, char **argv, char **env)
opterr=0;
while (1) {
int option_index=0;
#ifdef USE_GETOPT
static struct option opts[] = {
{"image-file", required_argument, NULL, 'i'},
{"dictionary-size", required_argument, NULL, 'm'},
......@@ -211,6 +219,10 @@ int main(int argc, char **argv, char **env)
};
c = getopt_long(argc, argv, "+drfl", opts, &option_index);
#else
c = getopt(argc, argv, "imdrflp");
#endif
if (c==EOF)
break;
if (c=='?') {
......@@ -255,6 +267,8 @@ int main(int argc, char **argv, char **env)
for (i=0; i<environ[0]; i++)
printf("%s\n", ((char **)(environ[1]))[i]);
*/
exit(go_forth(loader(image_file),3, environ));
retvalue=go_forth(loader(image_file),3,environ);
deprep_terminal();
exit(retvalue);
}
}
This diff is collapsed.
......@@ -15,6 +15,7 @@
\ 5) Words that call NEXT themselves have to be done very carefully.
\
\ To do:
\ add the store optimization for doubles
\ regarding problem 1 above: It would be better (for over) to implement
\ the alternative
......@@ -36,7 +37,7 @@ maxchar 1+ constant eof-char
begin ( c-addr file-id )
2dup batch-size swap read-file
if
abort" I/O error"
true abort" I/O error"
endif
( c-addr file-id actual-size ) rot over + -rot
batch-size <>
......@@ -240,22 +241,25 @@ constant type-description
: fetch-single ( item -- )
>r
r@ item-name 2@ type ." = ("
r@ item-name 2@ type
." = ("
r@ item-type @ type-c-name 2@ type ." ) "
r@ item-d-offset @ effect-in-size 2@ data-stack-access ." ;" cr
rdrop ;
: fetch-double ( item -- )
>r
." {Double_Store _d; _d.cells.low = "
r@ item-name 2@ type
." = ({Double_Store _d; _d.cells.low = "
r@ item-d-offset @ dup effect-in-size 2@ data-stack-access
." ; _d.cells.high = " 1+ effect-in-size 2@ data-stack-access ." ; "
r@ item-name 2@ type ." = _d.dcell;}" cr
." ; _d.cells.high = " 1+ effect-in-size 2@ data-stack-access
." ; _d.dcell;});" cr
rdrop ;
: fetch-float ( item -- )
>r
r@ item-name 2@ type ." = "
r@ item-name 2@ type
." = "
\ ." (" r@ item-type @ type-c-name 2@ type ." ) "
r@ item-f-offset @ effect-in-size 2@ fp-stack-access ." ;" cr
rdrop ;
......@@ -264,9 +268,7 @@ constant type-description
\ f is true iff the offset of item is the same as on input
>r
r@ item-name 2@ items @ search-wordlist 0=
if
." bug" cr abort
endif
abort" bug"
execute @
dup r@ =
if \ item first appeared in output
......@@ -312,9 +314,7 @@ constant type-description
\ f is true iff the offset of item is the same as on input
>r
r@ item-name 2@ items @ search-wordlist 0=
if
." bug" cr abort
endif
abort" bug"
execute @
dup r@ =
if \ item first appeared in output
......@@ -404,9 +404,9 @@ set-current
execute nip
UNLOOP EXIT
endif
-1 s+loop
-1 +loop
\ we did not find a type, abort
." unknown type prefix" cr ABORT ;
true abort" unknown type prefix" ;
: declare ( addr "name" -- )
\ remember that there is a stack item at addr called name
......@@ -428,6 +428,9 @@ set-current
i declaration
item-descr +loop ;
: fetch ( addr -- )
dup item-type @ type-fetch-handler execute ;
: declarations ( -- )
wordlist dup items ! set-current
effect-in effect-in-end @ declaration-list
......@@ -479,16 +482,13 @@ set-current
." IF_TOS(TOS = sp[0]);" cr
endif ;
: fetch ( addr -- )
dup item-type @ type-fetch-handler execute ;
: fetches ( -- )
effect-in-end @ effect-in ?do
i fetch
item-descr +loop ;
: stack-pointer-updates ( -- )
\ we do not check if an update is a noop; gcc does this for us
\ we need not check if an update is a noop; gcc does this for us
effect-in-size 2@
effect-out-size 2@
rot swap - ( d-in d-out f-diff )
......@@ -506,6 +506,11 @@ set-current
i store
item-descr +loop ;
: .stack-list ( start end -- )
swap ?do
i item-name 2@ type space
item-descr +loop ;
: output-c ( -- )
." I_" c-name 2@ type ." : /* " forth-name 2@ type ." ( " stack-string 2@ type ." ) */" cr
." /* " doc 2@ type ." */" cr
......@@ -523,7 +528,7 @@ set-current
." NEXT_P1;" cr
stores
fill-tos
." NEXT_P2;" cr
." NEXT1_P2;" cr
." }" cr
cr
;
......@@ -535,11 +540,19 @@ set-current
primitive-number @ . ." alias " forth-name 2@ type cr
-1 primitive-number +! ;
: output-forth ( -- )
forth-code @ 0=
IF output-alias
ELSE ." : " forth-name 2@ type ." ( "
effect-in effect-in-end @ .stack-list ." -- "
effect-out effect-out-end @ .stack-list ." )" cr
forth-code 2@ type cr
-1 primitive-number +!
THEN
;
: process-file ( addr u xt -- )
>r r/o open-file
if
." cannot open file" cr abort
endif
>r r/o open-file abort" cannot open file"
warnings @ if
." ------------ CUT HERE -------------" cr endif
r> primfilter ;
......
......@@ -449,20 +449,20 @@ 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: "
: 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
here @ look 0= ABORT" SEE: No valid xt in defered word"
.name cr here @ look drop dosee ;
: dodoe .name ." is created word" cr
here @ look drop dosee cr
." ' " .name r> ." IS " .name cr ;
: dodoe ." Create " .name cr
S" DOES> " Com# .string XPos @ Level !
here @ 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
......@@ -481,17 +481,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 +504,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 ;
......
......@@ -3,8 +3,9 @@
warnings off
include float.fs
include search-order.fs
\ include float.fs
\ include search-order.fs
include glocals.fs
include environ.fs
\ include toolsext.fs
include wordinfo.fs
......
......@@ -14,7 +14,7 @@ CREATE Closenest 7 chars allot
: SKIPNEST
1 BEGIN
BEGIN name count dup WHILE
BEGIN name dup WHILE
2dup Opennest count compare 0=
IF 2drop 1+
ELSE Closenest count compare 0= IF 1- THEN
......@@ -36,7 +36,7 @@ CREATE Closenest 7 chars allot
: [ELSE]
1 BEGIN
BEGIN name count dup WHILE
BEGIN name dup WHILE
comment?
2dup s" [IF]" compare 0=
IF 2drop 1+
......@@ -58,9 +58,9 @@ CREATE Closenest 7 chars allot
\ [IFUNDEF] [IFDEF] 9may93jaw
: [IFUNDEF]
name find nip 0= postpone [IF] ; immediate
bl word find nip 0= postpone [IF] ; immediate
: [IFDEF]
name find nip 0<> postpone [IF] ; immediate
bl word find nip 0<> postpone [IF] ; immediate
\ [IF]? 9jun93jaw
......
......@@ -27,6 +27,10 @@ INCLUDE look.fs
cell+ (name>)
>code-address ['] bl >code-address = ;
: user? ( nfa -- flag )