--- gforth/prim	2000/09/09 20:32:58	1.59
+++ gforth/prim	2000/12/13 10:15:26	1.67
@@ -1,6 +1,6 @@
 \ Gforth primitives
 
-\ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
+\ Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.
 
 \ This file is part of Gforth.
 
@@ -16,7 +16,7 @@
 
 \ 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.
+\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 
 
 \ WARNING: This file is processed by m4. Make sure your identifiers
@@ -74,6 +74,31 @@
 \ xt.*		XT
 \ wid.*		WID
 \ f83name.*	F83Name *
+
+\E get-current prefixes set-current
+\E 
+\E s" Bool"		single data-stack type-prefix f
+\E s" Char"		single data-stack type-prefix c
+\E s" Cell"		single data-stack type-prefix n
+\E s" Cell"		single data-stack type-prefix w
+\E s" UCell"		single data-stack type-prefix u
+\E s" DCell"		double data-stack type-prefix d
+\E s" UDCell"		double data-stack type-prefix ud
+\E s" Float"		single fp-stack   type-prefix r
+\E s" Cell *"		single data-stack type-prefix a_
+\E s" Char *"		single data-stack type-prefix c_
+\E s" Float *"		single data-stack type-prefix f_
+\E s" DFloat *"		single data-stack type-prefix df_
+\E s" SFloat *"		single data-stack type-prefix sf_
+\E s" Xt"		single data-stack type-prefix xt
+\E s" WID"		single data-stack type-prefix wid
+\E s" struct F83Name *"	single data-stack type-prefix f83name
+\E 
+\E return-stack stack-prefix R:
+\E inst-stream  stack-prefix #
+\E 
+\E set-current
+
 \ 
 \ 
 \ 
@@ -117,14 +142,14 @@ INC_IP(1);
 execute	( xt -- )		core
 ""Perform the semantics represented by the execution token, @i{xt}.""
 ip=IP;
-IF_TOS(TOS = sp[0]);
+IF_spTOS(spTOS = sp[0]);
 EXEC(xt);
 
 perform	( a_addr -- )	gforth
 ""@code{@@ execute}.""
 /* and pfe */
 ip=IP;
-IF_TOS(TOS = sp[0]);
+IF_spTOS(spTOS = sp[0]);
 EXEC(*(Xt *)a_addr);
 :
  @ execute ;
@@ -134,7 +159,6 @@ EXEC(*(Xt *)a_addr);
 
 branch-lp+!#	( -- )	gforth	branch_lp_plus_store_number
 /* this will probably not be used */
-branch_adjust_lp:
 lp += (Cell)(IP[1]);
 goto branch;
 
@@ -151,7 +175,7 @@ SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST
 define(condbranch,
 $1	$2
 $3	SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
-	NEXT;
+TAIL;
 }
 else
     INC_IP(1);
@@ -160,7 +184,9 @@ $4
 \+glocals
 
 $1-lp+!#	$2_lp_plus_store_number
-$3    goto branch_adjust_lp;
+$3    lp += (Cell)(IP[1]);
+SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
+TAIL;
 }
 else
     INC_IP(2);
@@ -170,7 +196,6 @@ else
 
 condbranch(?branch,( f -- )		f83	question_branch,
 if (f==0) {
-    IF_TOS(TOS = sp[0]);
 ,:
  0= dup     \ !f !f
  r> dup @   \ !f !f IP branchoffset
@@ -187,7 +212,7 @@ if (f==0) {
 ""The run-time procedure compiled by @code{?DUP-IF}.""
 if (f==0) {
   sp++;
-  IF_TOS(TOS = sp[0]);
+  IF_spTOS(spTOS = sp[0]);
   SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
   NEXT;
 }
@@ -212,36 +237,29 @@ else
 \f[THEN]
 \fhas? skiploopprims 0= [IF]
 
-condbranch((next),( -- )		cmFORTH	paren_next,
-if ((*rp)--) {
+condbranch((next),( R:n1 -- R:n2 )		cmFORTH	paren_next,
+n2=n1-1;
+if (n1) {
 ,:
  r> r> dup 1- >r
  IF dup @ + >r ELSE cell+ >r THEN ;)
 
-condbranch((loop),( -- )		gforth	paren_loop,
-Cell index = *rp+1;
-Cell limit = rp[1];
-if (index != limit) {
-    *rp = index;
+condbranch((loop),( R:nlimit R:n1 -- R:nlimit R:n2 )	gforth	paren_loop,
+n2=n1+1;
+if (n2 != nlimit) {
 ,:
  r> r> 1+ r> 2dup =
  IF >r 1- >r cell+ >r
  ELSE >r >r dup @ + >r THEN ;)
 
-condbranch((+loop),( n -- )		gforth	paren_plus_loop,
+condbranch((+loop),( n R:nlimit R:n1 -- R:nlimit R:n2 )	gforth paren_plus_loop,
 /* !! check this thoroughly */
-Cell index = *rp;
 /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
 /* dependent upon two's complement arithmetic */
-Cell olddiff = index-rp[1];
+Cell olddiff = n1-nlimit;
+n2=n1+n;	
 if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */
     || (olddiff^n)>=0          /* it is a wrap-around effect */) {
-#ifdef i386
-    *rp += n;
-#else
-    *rp = index + n;
-#endif
-    IF_TOS(TOS = sp[0]);
 ,:
  r> swap
  r> r> 2dup - >r
@@ -252,66 +270,47 @@ if ((olddiff^(olddiff+n))>=0   /* the li
 
 \+xconds
 
-condbranch((-loop),( u -- )		gforth	paren_minus_loop,
-/* !! check this thoroughly */
-Cell index = *rp;
-UCell olddiff = index-rp[1];
+condbranch((-loop),( u R:nlimit R:n1 -- R:nlimit R:n2 )	gforth	paren_minus_loop,
+UCell olddiff = n1-nlimit;
+n2=n1-u;
 if (olddiff>u) {
-#ifdef i386
-    *rp -= u;
-#else
-    *rp = index - u;
-#endif
-    IF_TOS(TOS = sp[0]);
 ,)
 
-condbranch((s+loop),( n -- )		gforth	paren_symmetric_plus_loop,
+condbranch((s+loop),( n R:nlimit R:n1 -- R:nlimit R:n2 )		gforth	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).""
 /* !! check this thoroughly */
-Cell index = *rp;
-Cell diff = index-rp[1];
+Cell diff = n1-nlimit;
 Cell newdiff = diff+n;
 if (n<0) {
     diff = -diff;
     newdiff = -newdiff;
 }
+n2=n1+n;
 if (diff>=0 || newdiff<0) {
-#ifdef i386
-    *rp += n;
-#else
-    *rp = index + n;
-#endif
-    IF_TOS(TOS = sp[0]);
 ,)
 
 \+
 
-unloop	( -- )	core
-rp += 2;
+unloop	( R:w1 R:w2 -- )	core
+/* !! alias for 2rdrop */
 :
  r> rdrop rdrop >r ;
 
-(for)	( ncount -- )		cmFORTH		paren_for
+(for)	( ncount -- R:nlimit R:ncount )		cmFORTH		paren_for
 /* or (for) = >r -- collides with unloop! */
-*--rp = 0;
-*--rp = ncount;
+nlimit=0;
 :
  r> swap 0 >r >r >r ;
 
-(do)	( nlimit nstart -- )		gforth		paren_do
-/* or do it in high-level? 0.09/0.23% */
-*--rp = nlimit;
-*--rp = nstart;
+(do)	( nlimit nstart -- R:nlimit R:nstart )	gforth		paren_do
 :
  r> swap rot >r >r >r ;
 
-(?do)	( nlimit nstart -- )	gforth	paren_question_do
-*--rp = nlimit;
-*--rp = nstart;
+(?do)	( nlimit nstart -- R:nlimit R:nstart )	gforth	paren_question_do
 if (nstart == nlimit) {
-    IF_TOS(TOS = sp[0]);
+    IF_spTOS(spTOS = sp[0]);
     goto branch;
     }
 else {
@@ -327,11 +326,9 @@ else {
 
 \+xconds
 
-(+do)	( nlimit nstart -- )	gforth	paren_plus_do
-*--rp = nlimit;
-*--rp = nstart;
+(+do)	( nlimit nstart -- R:nlimit R:nstart )	gforth	paren_plus_do
 if (nstart >= nlimit) {
-    IF_TOS(TOS = sp[0]);
+    IF_spTOS(spTOS = sp[0]);
     goto branch;
     }
 else {
@@ -347,11 +344,9 @@ else {
      cell+
  THEN  >r ;
 
-(u+do)	( ulimit ustart -- )	gforth	paren_u_plus_do
-*--rp = ulimit;
-*--rp = ustart;
+(u+do)	( ulimit ustart -- R:ulimit R:ustart )	gforth	paren_u_plus_do
 if (ustart >= ulimit) {
-    IF_TOS(TOS = sp[0]);
+    IF_spTOS(spTOS = sp[0]);
     goto branch;
     }
 else {
@@ -367,11 +362,9 @@ else {
      cell+
  THEN  >r ;
 
-(-do)	( nlimit nstart -- )	gforth	paren_minus_do
-*--rp = nlimit;
-*--rp = nstart;
+(-do)	( nlimit nstart -- R:nlimit R:nstart )	gforth	paren_minus_do
 if (nstart <= nlimit) {
-    IF_TOS(TOS = sp[0]);
+    IF_spTOS(spTOS = sp[0]);
     goto branch;
     }
 else {
@@ -387,11 +380,9 @@ else {
      cell+
  THEN  >r ;
 
-(u-do)	( ulimit ustart -- )	gforth	paren_u_minus_do
-*--rp = ulimit;
-*--rp = ustart;
+(u-do)	( ulimit ustart -- R:ulimit R:ustart )	gforth	paren_u_minus_do
 if (ustart <= ulimit) {
-    IF_TOS(TOS = sp[0]);
+    IF_spTOS(spTOS = sp[0]);
     goto branch;
     }
 else {
@@ -412,29 +403,24 @@ else {
 \ don't make any assumptions where the return stack is!!
 \ implement this in machine code if it should run quickly!
 
-i	( -- n )		core
-n = *rp;
+i	( R:n -- R:n n )		core
 :
 \ rp@ cell+ @ ;
   r> r> tuck >r >r ;
 
-i'	( -- w )		gforth		i_tick
-""loop end value""
-w = rp[1];
+i'	( R:w R:w2 -- R:w R:w2 w )		gforth		i_tick
 :
 \ rp@ cell+ cell+ @ ;
   r> r> r> dup itmp ! >r >r >r itmp @ ;
 variable itmp
 
-j	( -- n )		core
-n = rp[2];
+j	( R:n R:d1 -- n R:n R:d1 )		core
 :
 \ rp@ cell+ cell+ cell+ @ ;
   r> r> r> r> dup itmp ! >r >r >r >r itmp @ ;
 [IFUNDEF] itmp variable itmp [THEN]
 
-k	( -- n )		gforth
-n = rp[4];
+k	( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 )		gforth
 :
 \ rp@ [ 5 cells ] Literal + @ ;
   r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ;
@@ -955,7 +941,7 @@ a_addr = sp+1;
 
 sp!	( a_addr -- )		gforth		sp_store
 sp = a_addr;
-/* works with and without TOS caching */
+/* works with and without spTOS caching */
 
 rp@	( -- a_addr )		gforth		rp_fetch
 a_addr = rp;
@@ -973,54 +959,37 @@ fp = f_addr;
 
 \+
 
-;s	( -- )		gforth	semis
+;s	( R:w -- )		gforth	semis
 ""The primitive compiled by @code{EXIT}.""
-SET_IP((Xt *)(*rp++));
+SET_IP((Xt *)w);
 
->r	( w -- )		core	to_r
-""@code{( R: -- w )}""
-*--rp = w;
+>r	( w -- R:w )		core	to_r
 :
  (>r) ;
 : (>r)  rp@ cell+ @ rp@ ! rp@ cell+ ! ;
 
-r>	( -- w )		core	r_from
-""@code{( R: w -- )}""
-w = *rp++;
+r>	( R:w -- w )		core	r_from
 :
  rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ;
 Create (rdrop) ' ;s A,
 
-rdrop	( -- )		gforth
-""@code{( R: w -- )}""
-rp++;
+rdrop	( R:w -- )		gforth
 :
  r> r> drop >r ;
 
-2>r	( w1 w2 -- )	core-ext	two_to_r
-""@code{( R: -- w1 w2 )}""
-*--rp = w1;
-*--rp = w2;
+2>r	( w1 w2 -- R:w1 R:w2 )	core-ext	two_to_r
 :
  swap r> swap >r swap >r >r ;
 
-2r>	( -- w1 w2 )	core-ext	two_r_from
-""@code{( R: w1 w2 -- )}""
-w2 = *rp++;
-w1 = *rp++;
+2r>	( R:w1 R:w2 -- w1 w2 )	core-ext	two_r_from
 :
  r> r> swap r> swap >r swap ;
 
-2r@	( -- w1 w2 )	core-ext	two_r_fetch
-""@code{( R: w1 w2 -- w1 w2 )}""
-w2 = rp[0];
-w1 = rp[1];
+2r@	( R:w1 R:w2 -- R:w1 R:w2 w1 w2 )	core-ext	two_r_fetch
 :
  i' j ;
 
-2rdrop	( -- )		gforth	two_r_drop
-""@code{( R: w1 w2 -- )}""
-rp+=2;
+2rdrop	(  R:w1 R:w2 -- )		gforth	two_r_drop
 :
  r> r> drop r> drop >r ;
 
@@ -1066,7 +1035,7 @@ tuck	( w1 w2 -- w2 w1 w2 )	core-ext
 ""Actually the stack effect is: @code{( w -- 0 | w w )}.  It performs a
 @code{dup} if w is nonzero.""
 if (w!=0) {
-  IF_TOS(*sp-- = w;)
+  IF_spTOS(*sp-- = w;)
 #ifndef USE_TOS
   *--sp = w;
 #endif
@@ -1584,14 +1553,14 @@ access the stack itself. The stack point
 variables @code{SP} and @code{FP}.""
 /* This is a first attempt at support for calls to C. This may change in
    the future */
-IF_FTOS(fp[0]=FTOS);
+IF_fpTOS(fp[0]=fpTOS);
 FP=fp;
 SP=sp;
 ((void (*)())w)();
 sp=SP;
 fp=FP;
-IF_TOS(TOS=sp[0]);
-IF_FTOS(FTOS=fp[0]);
+IF_spTOS(spTOS=sp[0]);
+IF_fpTOS(fpTOS=fp[0]);
 
 \+
 \+file
@@ -1646,21 +1615,17 @@ wior = FILEIO(u2<u1 && ferror((FILE *)wf
 if (wior)
   clearerr((FILE *)wfileid);
 
-(read-line)	( c_addr u1 wfileid -- u2 flag wior u3 )	file	read_line
-#if 1
+read-line	( c_addr u1 wfileid -- u2 flag wior )	file	read_line
+""this is only for backward compatibility""
 Cell c;
 flag=-1;
-u3=0;
 for(u2=0; u2<u1; u2++)
 {
    c = getc((FILE *)wfileid);
-   u3++;
    if (c=='\n') break;
    if (c=='\r') {
      if ((c = getc((FILE *)wfileid))!='\n')
        ungetc(c,(FILE *)wfileid);
-     else
-       u3++;
      break;
    }
    if (c==EOF) {
@@ -1670,20 +1635,6 @@ for(u2=0; u2<u1; u2++)
    c_addr[u2] = (Char)c;
 }
 wior=FILEIO(ferror((FILE *)wfileid));
-#else
-if ((flag=FLAG(!feof((FILE *)wfileid) &&
-	       fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) {
-  wior=FILEIO(ferror((FILE *)wfileid)!=0); /* !! ior? */
-  if (wior)
-    clearerr((FILE *)wfileid);
-  u2 = strlen(c_addr);
-  u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));
-}
-else {
-  wior=0;
-  u2=0;
-}
-#endif
 
 \+
 
@@ -1910,9 +1861,9 @@ number[u]='\0';
 r=strtod(number,&endconv);
 if((flag=FLAG(!(Cell)*endconv)))
 {
-   IF_FTOS(fp[0] = FTOS);
+   IF_fpTOS(fp[0] = fpTOS);
    fp += -1;
-   FTOS = sign ? -r : r;
+   fpTOS = sign ? -r : r;
 }
 else if(*endconv=='d' || *endconv=='D')
 {
@@ -1920,9 +1871,9 @@ else if(*endconv=='d' || *endconv=='D')
    r=strtod(number,&endconv);
    if((flag=FLAG(!(Cell)*endconv)))
      {
-	IF_FTOS(fp[0] = FTOS);
+	IF_fpTOS(fp[0] = fpTOS);
 	fp += -1;
-	FTOS = sign ? -r : r;
+	fpTOS = sign ? -r : r;
      }
 }
 
@@ -2214,12 +2165,12 @@ UP=up=(char *)a_addr;
 Variable UP
 
 wcall	( u -- )	gforth
-IF_FTOS(fp[0]=FTOS);
+IF_fpTOS(fp[0]=fpTOS);
 FP=fp;
 sp=(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP);
 fp=FP;
-IF_TOS(TOS=sp[0];)
-IF_FTOS(FTOS=fp[0]);
+IF_spTOS(spTOS=sp[0];)
+IF_fpTOS(fpTOS=fp[0]);
 
 \+file
 
@@ -2328,3 +2279,31 @@ for (; ucount>0; ucount--) {
  LOOP 2drop 2drop fdrop ;
 
 \+
+
+\+file
+
+(read-line)	( c_addr u1 wfileid -- u2 flag u3 wior )	file	paren_read_line
+Cell c;
+flag=-1;
+u3=0;
+for(u2=0; u2<u1; u2++)
+{
+   c = getc((FILE *)wfileid);
+   u3++;
+   if (c=='\n') break;
+   if (c=='\r') {
+     if ((c = getc((FILE *)wfileid))!='\n')
+       ungetc(c,(FILE *)wfileid);
+     else
+       u3++;
+     break;
+   }
+   if (c==EOF) {
+	flag=FLAG(u2!=0);
+	break;
+     }
+   c_addr[u2] = (Char)c;
+}
+wior=FILEIO(ferror((FILE *)wfileid));
+
+\+