Integrated locals (in particular automatic scoping) into the system.

Makefile

@@ -3,7 +3,7 @@
 RM	= echo 'Trying to remove'
 GCC	= gcc
 CC	= gcc
-SWITCHES = -DUSE_TOS -DUSE_FTOS -DDEFAULTBIN='"'$(PWD)'"' # -DDIRECT_THREADED 
+SWITCHES = -D_POSIX_VERSION #-DUSE_TOS -DUSE_FTOS -DDEFAULTBIN='"'$(PWD)'"' # -DDIRECT_THREADED 
 CFLAGS	= -O4 -Wall -g $(SWITCHES)
 
 #-Xlinker -n puts text and data into the same 256M region

cross.fs

 \ CROSS.FS     The Cross-Compiler                      06oct92py
-\ $Id: cross.fs,v 1.5 1994-06-01 10:05:14 pazsan Exp $
+\ $Id: cross.fs,v 1.6 1994-06-17 12:34:58 anton Exp $
 \ Idea and implementation: Bernd Paysan (py)
 \ Copyright 1992 by the ANSI figForth Development Group
 
@@ -134,7 +134,8 @@ include machine.fs
 : cell+         cell + ;
 : cells         cell<< lshift ;
 : chars         ;
-
+: floats	float * ;
+    
 >CROSS
 : cell/         cell<< rshift ;
 >TARGET
@@ -488,6 +489,8 @@ Cond: [Char]   ( "<char>" -- )  restrict? Char  lit, ;Cond
 
 Cond: EXIT ( -- )  restrict?  compile ;S  ;Cond
 
+Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond
+
 Cond: ; ( -- ) restrict?
                depth ?dup IF   1- <> ABORT" CROSS: Stack changed"
                           ELSE true ABORT" CROSS: Stack empty" THEN

float.fs

 \ High level floating point                            14jan94py
 
-: faligned ( addr -- f-addr )
-  [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
-
-: falign ( -- )
-  here dup faligned swap
-  ?DO  bl c,  LOOP ;
-
 : f, ( f -- )  here 1 floats allot f! ;
 
 \ !! have create produce faligned pfas

gforth.el

@@ -16,7 +16,7 @@
 ;; file named COPYING.  Among other things, the copyright notice
 ;; and this notice must be preserved on all copies.
 
-;;; $Header: /usr/local/lib/cvs-repository/src-master/gforth/gforth.el,v 1.1 1994-05-07 14:55:53 anton Exp $
+;;; $Header: /usr/local/lib/cvs-repository/src-master/gforth/gforth.el,v 1.2 1994-06-17 12:35:01 anton Exp $
 
 ;;-------------------------------------------------------------------
 ;; A Forth indentation, documentation search and interaction library
@@ -121,6 +121,7 @@ OBS! All words in forth-negatives must be surrounded by spaces.")
   (make-local-variable 'parse-sexp-ignore-comments)
   (setq parse-sexp-ignore-comments t))
   
+;;;###autoload
 (defun forth-mode ()
   "
 Major mode for editing Forth code. Tab indents for Forth code. Comments

gforth.texi

@@ -177,7 +177,7 @@ variable @code{GFORTHPATH}; if this does not exist, in
 @node Notation, Arithmetic, Words, Words
 @section Notation
 
-The Forth words are describes in this section in the glossary notation
+The Forth words are described in this section in the glossary notation
 that has become a de-facto standard for Forth texts, i.e.
 
 @quotation
@@ -320,10 +320,10 @@ theoretically keep floating point numbers on the data stack. As an
 additional difficulty, you don't know how many cells a floating point
 numkber takes. It is reportedly possible to write words in a way that
 they work also for a unified stack model, but we do not recommend trying
-it. Also, a Forth system to keep the local variables on the return
-stack. This is reasonable, as local variables usually eliminate the need
-to use the return stack explicitely. So, if you want to produce a
-standard complying program and if you are using local variables in a
+it. Also, a Forth system is allowed to keep the local variables on the
+return stack. This is reasonable, as local variables usually eliminate
+the need to use the return stack explicitely. So, if you want to produce
+a standard complying program and if you are using local variables in a
 word, forget about return stack manipulations in that word (see the
 standard document for the exact rules).
 
@@ -417,7 +417,7 @@ IF
   @var{code}
 ENDIF
 @end example
-
+or
 @example
 @var{flag}
 IF
@@ -527,11 +527,13 @@ index by @var{n} instead of by 1. The loop is terminated when the border
 between @var{limit-1} and @var{limit} is crossed. E.g.:
 
 4 0 ?DO  i .  2 +LOOP   prints 0 2
+
 4 1 ?DO  i .  2 +LOOP   prints 1 3
 
 The behaviour of @code{@var{n} +LOOP} is peculiar when @var{n} is negative:
 
 -1 0 ?DO  i .  -1 +LOOP  prints 0 -1
+
  0 0 ?DO  i .  -1 +LOOP  prints nothing
 
 Therefore we recommend avoiding using @code{@var{n} +LOOP} with negative
@@ -539,7 +541,9 @@ Therefore we recommend avoiding using @code{@var{n} +LOOP} with negative
 case behaves symmetrical to the positive case:
 
 -2 0 ?DO  i .  -1 +LOOP  prints 0 -1
+
 -1 0 ?DO  i .  -1 +LOOP  prints 0
+
  0 0 ?DO  i .  -1 +LOOP  prints nothing
 
 The loop is terminated when the border between @var{limit-sgn(n)} and

io.c

@@ -717,7 +717,7 @@ install_signal_handlers (void)
    but I would like something more automatic - anton */
 #define SIGS_TO_IGNORE	SIGCHLD
 #define SIGS_TO_ABORT	SIGINT, SIGILL, SIGFPE, SIGUSR1, SIGSEGV, SIGUSR2, \
-			SIGALRM, SIGEMT, SIGBUS, SIGSYS
+			SIGALRM,  SIGBUS
 #define SIGS_TO_QUIT	SIGHUP, SIGQUIT, SIGABRT, SIGPIPE, \
 			SIGTERM 
 

locals-test.fs

@@ -28,18 +28,20 @@ depth . cr
 ." testing part 2" cr
 
 : xxxx
+    [ ." starting xxxx" .s cr ]
 { f } f
-xif
+if
   { a b }
   b a
 [ ." before else" .s cr ]
-xelse
+else
 [ ." after else" .s cr ]
   { c d }
   c d
-xthen
+then
 [ ." locals-size after then:" locals-size @ . cr ]
 f drop
+    [ ." ending xxxx" .s cr ]
 ;
 
 2 3 1 xxxx . . cr
@@ -47,25 +49,25 @@ f drop
 cr cr cr
 
 : xxx3
-xbegin
+begin
   { a }
-xuntil
+until
 a
 ;
 ." after xxx3" .s cr cr cr
 
 : xxx2
 [ ." start of xxx2" .s cr ]
-xbegin
+begin
 [ ." after begin" .s cr ]
   { a }
 [ ." after { a }" .s cr ]
-1 xwhile
+1 while
 [ ." after while" .s cr ]
   { b }
   a b
 [ ." after a" .s cr ]
-xrepeat
+repeat
 [ ." after repeat" .s cr
   also locals words previous cr
 ]
@@ -75,52 +77,56 @@ a
 
 : xxx4
 [ ." before if" localsinfo ]
-xif
+if
 [ ." after if" localsinfo ]
 { a }
 [ ." before begin" localsinfo ]
-xbegin
+begin
 [ ." after begin" localsinfo ]
 [ 1 cs-roll ]
 [ ." before then" localsinfo ]
-xthen
+then
 { b }
-xuntil
+until
 [ ." after until" localsinfo ]
 ;
 
 : xxx5
 { a }
-xahead
-xbegin
+ahead
+begin
 [ ." after begin" localsinfo ]
 [ 1 cs-roll ]
-xthen
+then
 [ ." after then" localsinfo ]
-xuntil
+until
 [ ." after until" localsinfo ]
 ;
 
+." xxx6 coming up" cr
 : xxx6
-xif
+    [ ." starting xxx6" localsinfo ]
+if
 { x }
-xelse
+else
 [ ." after else" localsinfo ]
-xahead
-xbegin
+ahead
+begin
 [ ." after begin" localsinfo ]
-[ 2 CS-ROLL ] xthen
+[ 2 CS-ROLL ] then
 [ ." after then" localsinfo ]
-xuntil
+until
+then
+    [ ." ending xxx6" localsinfo ]
 ;
 
 ." xxx7 coming up" cr
 : xxx7
 { b }
-xdo
+do
 { a }
 [ ." before loop" localsinfo ]
-xloop
+loop
 [ ." after loop" localsinfo ]
 ;
 
@@ -128,36 +134,36 @@ xloop
 
 : xxx8
 { b }
-x?do
+?do
 { a }
 [ ." before loop" localsinfo ]
-xloop
+loop
 [ ." after loop" localsinfo ]
 ;
 
 ." xxx9 coming up" cr
 : xxx9
 { b }
-xdo
+do
 { c }
 [ ." before ?leave" leave-sp ? leave-stack . cr ]
-x?leave
+?leave
 [ ." after ?leave" leave-sp ? cr ]
 { a }
 [ ." before loop" localsinfo ]
-xloop
+loop
 [ ." after loop" localsinfo ]
 ;
 
 ." strcmp coming up" cr
 : strcmp { addr1 u1 addr2 u2 -- n }
- addr1 addr2 u1 u2 min 0 x?do
+ addr1 addr2 u1 u2 min 0 ?do
    { s1 s2 }
-   s1 c@ s2 c@ - ?dup xif
-     unloop xexit
-   xthen
+   s1 c@ s2 c@ - ?dup if
+     unloop exit
+   then
    s1 char+ s2 char+
- xloop
+ loop
  2drop
  u1 u2 - ;
 
@@ -178,13 +184,13 @@ s" " s" " strcmp . cr
 ;
 
 : findchar { c addr u -- i }
- addr u 0 x?do
+ addr u 0 ?do
    { p }
-   p c@ c = xif
-     p xleave
-   xthen
+   p c@ c = if
+     p leave
+   then
    p char+
- xloop
+ loop
  addr - ;
 
 
@@ -213,7 +219,7 @@ testfindchar
 
 : xxx10
 [ ." before if" localsinfo ]
-xif
+if
 [ ." after if" localsinfo ]
 scope
 [ ." after scope" localsinfo ]
@@ -221,13 +227,27 @@ scope
 [ ." before endscope" localsinfo ]
 endscope
 [ ." before begin" localsinfo ]
-xbegin
+begin
 [ ." after begin" localsinfo ]
 [ 1 cs-roll ]
 [ ." before then" localsinfo ]
-xthen
+then
 { b }
-xuntil
+until
 [ ." after until" localsinfo ]
 ;
 
+: xxx11
+    if
+    { a }
+    exit
+    [ ." after xexit" localsinfo ]
+    else
+    { b }
+    [ ." before xthen" localsinfo
+    then
+    [ ." after xthen" localsinfo ]
+;
+
+
+bye

machine32b.fs

@@ -4,5 +4,6 @@
     2 Constant cell<<
     5 Constant cell>bit
     8 Constant bits/byte
+    8 Constant float
  true Constant endian
 ( true=big, false=little )

machine32l.fs

@@ -4,5 +4,6 @@
     2 Constant cell<<
     5 Constant cell>bit
     8 Constant bits/byte
+    8 Constant float
 false Constant endian
 ( true=big, false=little )

main.c

 /*
-  $Id: main.c,v 1.5 1994-05-18 17:29:56 pazsan Exp $
+  $Id: main.c,v 1.6 1994-06-17 12:35:13 anton Exp $
   Copyright 1993 by the ANSI figForth Development Group
 */
 
@@ -123,6 +123,11 @@ int main(int argc, char **argv, char **env)
 	Cell environ[3] = {(Cell)argc, (Cell)argv, (Cell)env};
 	char* imagepath;
 
+#if defined(i386) && defined(ALIGNMENT_CHECK)
+	/* turn on alignment checks on the 486.
+	 * on the 386 this should have no effect. */
+	__asm__("pushfl; popl %eax; orl $0x40000, %eax; pushl %eax; popfl;");
+#endif
 	if((int)(imagepath=getenv("FORTHBIN")))
 	{
 		strcpy(imagefile,imagepath);

primitives

@@ -79,54 +79,62 @@ cfa = xt;
 IF_TOS(TOS = sp[0]);
 NEXT1;
 
+branch-lp+!#	--	new	branch_lp_plus_store_number
+/* this will probably not be used */
+branch_adjust_lp:
+lp += (int)(ip[1]);
+goto branch;
+
 branch	--		fig
 branch:
 ip = (Xt *)(((int)ip)+(int)*ip);
 
-?branch		f --		f83	question_branch
-""also known as 0branch""
-if (f==0) {
-    IF_TOS(TOS = sp[0]);
-    goto branch;
-    }
+\ condbranch(forthname,restline,code)
+\ this is non-syntactical: code must open a brace that is close by the macro
+define(condbranch,
+$1	$2
+$3    goto branch;
+}
 else
     ip++;
 
-(next)	--		cmFORTH	paren_next
-if ((*rp)--) {
-    goto branch;
-} else {
-    ip++;
+$1-lp+!#	$2_lp_plus_store_number
+$3    goto branch_adjust_lp;
 }
+else
+    ip+=2;
 
-(loop)	--		fig	paren_loop
+)
+
+condbranch(?branch,f --		f83	question_branch,
+if (f==0) {
+    IF_TOS(TOS = sp[0]);
+)
+
+condbranch((next),--		cmFORTH	paren_next,
+if ((*rp)--) {
+)
+
+condbranch((loop),--		fig	paren_loop,
 int index = *rp+1;
 int limit = rp[1];
 if (index != limit) {
     *rp = index;
-    goto branch;
-} else {
-    ip++;
-}
+)
 
-(+loop)		n --		fig	paren_plus_loop
+condbranch((+loop),n --		fig	paren_plus_loop,
 /* !! check this thoroughly */
 int index = *rp;
 int olddiff = index-rp[1];
 /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
 /* dependent upon two's complement arithmetic */
-if ((olddiff^(olddiff+n))<0   /* the limit is crossed */
-    && (olddiff^n)<0          /* it is not a wrap-around effect */) {
-    /* break */
-    ip++;
-} else {
-    /* continue */
+if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */
+    || (olddiff^n)>=0          /* it is a wrap-around effect */) {
     *rp = index+n;
     IF_TOS(TOS = sp[0]);
-    goto branch;
-}
+)
 
-(s+loop)	n --		new	paren_symmetric_plus_loop
+condbranch((s+loop),n --		new	paren_symmetric_plus_loop,
 ""The run-time procedure compiled by S+LOOP. It loops until the index
 crosses the boundary between limit and limit-sign(n). I.e. a symmetric
 version of (+LOOP).""
@@ -141,10 +149,7 @@ if (n<0) {
 if (diff>=0 || newdiff<0) {
     *rp = oldindex+n;
     IF_TOS(TOS = sp[0]);
-    goto branch;
-} else {
-    ip++;
-}
+)
 
 unloop		--	core
 rp += 2;
@@ -460,14 +465,8 @@ fp!	f_addr --	new	fp_store
 fp = f_addr;
 
 ;s	--		core	exit
-/* use ;s as alias */
 ip = (Xt *)(*rp++);
 
-?exit	w --		core		question_exit
-/* use ;s as alias */
-if(w)
-	ip = (Xt *)(*rp++);
-
 >r	w --		core,fig	to_r
 *--rp = w;
 
@@ -824,7 +823,9 @@ else
 represent		r c_addr u -- n f1 f2	float
 char *sig;
 int flag;
-sig=ecvt(r, u, (int *)&n, &flag);
+int decpt;
+sig=ecvt(r, u, &decpt, &flag);
+n=decpt;
 f1=FLAG(flag!=0);
 f2=FLAG(isdigit(sig[0])!=0);
 memmove(c_addr,sig,u);
@@ -960,9 +961,27 @@ c2 = toupper(c1);
 @local#		-- w	new	fetch_local_number
 w = *(Cell *)(lp+(int)(*ip++));
 
+@local0	-- w	new	fetch_local_zero
+w = *(Cell *)(lp+0);
+
+@local4	-- w	new	fetch_local_four
+w = *(Cell *)(lp+4);
+
+@local8	-- w	new	fetch_local_eight
+w = *(Cell *)(lp+8);
+
+@local12	-- w	new	fetch_local_twelve
+w = *(Cell *)(lp+12);
+
 f@local#	-- r	new	f_fetch_local_number
 r = *(Float *)(lp+(int)(*ip++));
 
+f@local0	-- r	new	f_fetch_local_zero
+r = *(Float *)(lp+0);
+
+f@local8	-- r	new	f_fetch_local_eight
+r = *(Float *)(lp+8);
+
 laddr#		-- c_addr	new	laddr_number
 /* this can also be used to implement lp@ */
 c_addr = (Char *)(lp+(int)(*ip++));
@@ -973,6 +992,15 @@ local stack, a positive immediate argument drops memory from the local
 stack""
 lp += (int)(*ip++);
 
+-4lp+!	--	new	minus_four_lp_plus_store
+lp += -4;
+
+8lp+!	--	new	eight_lp_plus_store
+lp += 8;
+
+16lp+!	--	new	sixteen_lp_plus_store
+lp += 16;
+
 lp!	c_addr --	new	lp_store
 lp = (Address)c_addr;
 

toolsext.fs

@@ -19,7 +19,7 @@ CREATE Closenest 7 chars allot
                 IF   2drop 1+
                 ELSE    Closenest count compare 0= IF 1- THEN
                 THEN
-                ?dup 0= ?EXIT
+                ?dup 0= IF EXIT THEN
           REPEAT
           2drop refill 0=
         UNTIL drop ;
@@ -45,7 +45,7 @@ CREATE Closenest 7 chars allot
                      ELSE s" [THEN]" compare 0= IF 1- THEN
                      THEN
                 THEN
-                ?dup 0= ?EXIT
+                ?dup 0= IF EXIT THEN
           REPEAT
           2drop refill 0=
         UNTIL drop ; immediate