--- gforth/prim	2005/01/26 22:06:03	1.164
+++ gforth/prim	2005/08/02 12:00:51	1.174
@@ -100,6 +100,8 @@
 \E s" struct F83Name *"	single data-stack type-prefix f83name
 \E s" struct Longname *" single data-stack type-prefix longname
 \E 
+\E data-stack   stack-prefix S:
+\E fp-stack     stack-prefix F:
 \E return-stack stack-prefix R:
 \E inst-stream  stack-prefix #
 \E 
@@ -138,7 +140,7 @@
 
 \ Stack caching setup
 
-ifdef(`M4_ENGINE_FAST', `include(cache1.vmg)', `include(cache0.vmg)')
+ifdef(`STACK_CACHE_FILE', `include(STACK_CACHE_FILE)', `include(cache0.vmg)')
 
 \ these m4 macros would collide with identifiers
 undefine(`index')
@@ -291,7 +293,6 @@ assert(0);
 #else
 a_pfa = PFA(a_cfa);
 nest = (Cell)IP;
-IF_spTOS(spTOS = sp[0]);
 #ifdef DEBUG
     {
       CFA_TO_NAME(a_cfa);
@@ -408,37 +409,31 @@ condbranch(?branch,f --,f83	question_bra
 
 \+xconds
 
-?dup-?branch	( #a_target f -- f )	new	question_dupe_question_branch
+?dup-?branch	( #a_target f -- S:... )	new	question_dupe_question_branch
 ""The run-time procedure compiled by @code{?DUP-IF}.""
 if (f==0) {
-  sp++;
-  IF_spTOS(spTOS = sp[0]);
 #ifdef NO_IP
 INST_TAIL;
 JUMP(a_target);
 #else
 SET_IP((Xt *)a_target);
-  INST_TAIL; NEXT_P2;
 #endif
+} else {
+sp--;
+sp[0]=f;
 }
-SUPER_CONTINUE;
 
-?dup-0=-?branch ( #a_target f -- ) new	question_dupe_zero_equals_question_branch
+?dup-0=-?branch ( #a_target f -- S:... ) new	question_dupe_zero_equals_question_branch
 ""The run-time procedure compiled by @code{?DUP-0=-IF}.""
-/* the approach taken here of declaring the word as having the stack
-effect ( f -- ) and correcting for it in the branch-taken case costs a
-few cycles in that case, but is easy to convert to a CONDBRANCH
-invocation */
 if (f!=0) {
   sp--;
+  sp[0]=f;
 #ifdef NO_IP
   JUMP(a_target);
 #else
   SET_IP((Xt *)a_target);
-  NEXT;
 #endif
 }
-SUPER_CONTINUE;
 
 \+
 \fhas? skiploopprims 0= [IF]
@@ -805,20 +800,20 @@ n = n1*n2;
 
 /	( n1 n2 -- n )		core	slash
 n = n1/n2;
-if(FLOORED_DIV && (n1 < 0) != (n2 < 0) && (n1%n2 != 0)) n--;
+if(FLOORED_DIV && ((n1^n2) < 0) && (n1%n2 != 0)) n--;
 :
  /mod nip ;
 
 mod	( n1 n2 -- n )		core
 n = n1%n2;
-if(FLOORED_DIV && (n1 < 0) != (n2 < 0) && n!=0) n += n2;
+if(FLOORED_DIV && ((n1^n2) < 0) && n!=0) n += n2;
 :
  /mod drop ;
 
 /mod	( n1 n2 -- n3 n4 )		core		slash_mod
 n4 = n1/n2;
 n3 = n1%n2; /* !! is this correct? look into C standard! */
-if (FLOORED_DIV && (n1<0) != (n2<0) && n3!=0) {
+if (FLOORED_DIV && ((n1^n2) < 0) && n3!=0) {
   n4--;
   n3+=n2;
 }
@@ -840,7 +835,7 @@ n5=DLO(r);
 /* assumes that the processor uses either floored or symmetric division */
 n5 = d/n3;
 n4 = d%n3;
-if (FLOORED_DIV && (d<0) != (n3<0) && n4!=0) {
+if (FLOORED_DIV && ((DHI(d)^n3)<0) && n4!=0) {
   n5--;
   n4+=n3;
 }
@@ -857,11 +852,11 @@ DCell d = (DCell)n1 * (DCell)n2;
 #endif
 #ifdef BUGGY_LL_DIV
 DCell r = fmdiv(d,n3);
-n4=DHI(r);
+n4=DLO(r);
 #else
 /* assumes that the processor uses either floored or symmetric division */
 n4 = d/n3;
-if (FLOORED_DIV && (d<0) != (n3<0) && (d%n3)!=0) n4--;
+if (FLOORED_DIV && ((DHI(d)^n3)<0) && (d%n3)!=0) n4--;
 #endif
 :
  */mod nip ;
@@ -886,18 +881,34 @@ n2 = n1>>1;
 fm/mod	( d1 n1 -- n2 n3 )		core		f_m_slash_mod
 ""Floored division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, @i{n1}>@i{n2}>=0 or 0>=@i{n2}>@i{n1}.""
 #ifdef BUGGY_LL_DIV
+#ifdef ASM_SM_SLASH_REM
+ASM_SM_SLASH_REM(d1.lo, d1.hi, n1, n2, n3);
+if (((DHI(d1)^n1)<0) && n2!=0) {
+  n3--;
+  n2+=n1;
+}
+#else /* !defined(ASM_SM_SLASH_REM) */
 DCell r = fmdiv(d1,n1);
 n2=DHI(r);
 n3=DLO(r);
+#endif /* !defined(ASM_SM_SLASH_REM) */
 #else
+#ifdef ASM_SM_SLASH_REM4
+ASM_SM_SLASH_REM4(d1, n1, n2, n3);
+if (((DHI(d1)^n1)<0) && n2!=0) {
+  n3--;
+  n2+=n1;
+}
+#else /* !defined(ASM_SM_SLASH_REM4) */
 /* assumes that the processor uses either floored or symmetric division */
 n3 = d1/n1;
 n2 = d1%n1;
 /* note that this 1%-3>0 is optimized by the compiler */
-if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) {
+if (1%-3>0 && ((DHI(d1)^n1)<0) && n2!=0) {
   n3--;
   n2+=n1;
 }
+#endif /* !defined(ASM_SM_SLASH_REM4) */
 #endif
 :
  dup >r dup 0< IF  negate >r dnegate r>  THEN
@@ -908,18 +919,26 @@ if (1%-3>0 && (d1<0) != (n1<0) && n2!=0)
 sm/rem	( d1 n1 -- n2 n3 )		core		s_m_slash_rem
 ""Symmetric division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, sign(@i{n2})=sign(@i{d1}) or 0.""
 #ifdef BUGGY_LL_DIV
+#ifdef ASM_SM_SLASH_REM
+ASM_SM_SLASH_REM(d1.lo, d1.hi, n1, n2, n3);
+#else /* !defined(ASM_SM_SLASH_REM) */
 DCell r = smdiv(d1,n1);
 n2=DHI(r);
 n3=DLO(r);
+#endif /* !defined(ASM_SM_SLASH_REM) */
 #else
+#ifdef ASM_SM_SLASH_REM4
+ASM_SM_SLASH_REM4(d1, n1, n2, n3);
+#else /* !defined(ASM_SM_SLASH_REM4) */
 /* assumes that the processor uses either floored or symmetric division */
 n3 = d1/n1;
 n2 = d1%n1;
 /* note that this 1%-3<0 is optimized by the compiler */
-if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) {
+if (1%-3<0 && ((DHI(d1)^n1)<0) && n2!=0) {
   n3++;
   n2-=n1;
 }
+#endif /* !defined(ASM_SM_SLASH_REM4) */
 #endif
 :
  over >r dup >r abs -rot
@@ -957,12 +976,20 @@ ud = (UDCell)u1 * (UDCell)u2;
 um/mod	( ud u1 -- u2 u3 )		core	u_m_slash_mod
 ""ud=u3*u1+u2, u1>u2>=0""
 #ifdef BUGGY_LL_DIV
+#ifdef ASM_UM_SLASH_MOD
+ASM_UM_SLASH_MOD(ud.lo, ud.hi, u1, u2, u3);
+#else /* !defined(ASM_UM_SLASH_MOD) */
 UDCell r = umdiv(ud,u1);
 u2=DHI(r);
 u3=DLO(r);
+#endif /* !defined(ASM_UM_SLASH_MOD) */
 #else
+#ifdef ASM_UM_SLASH_MOD4
+ASM_UM_SLASH_MOD4(ud, u1, u2, u3);
+#else /* !defined(ASM_UM_SLASH_MOD4) */
 u3 = ud/u1;
 u2 = ud%u1;
+#endif /* !defined(ASM_UM_SLASH_MOD4) */
 #endif
 :
    0 swap [ 8 cells 1 + ] literal 0
@@ -1207,12 +1234,11 @@ UP=up=(char *)a_addr;
  up ! ;
 Variable UP
 
-sp@	( -- a_addr )		gforth		sp_fetch
-a_addr = sp+1;
+sp@	( S:... -- a_addr )		gforth		sp_fetch
+a_addr = sp;
 
-sp!	( a_addr -- )		gforth		sp_store
+sp!	( a_addr -- S:... )		gforth		sp_store
 sp = a_addr;
-/* works with and without spTOS caching */
 
 rp@	( -- a_addr )		gforth		rp_fetch
 a_addr = rp;
@@ -1222,10 +1248,10 @@ rp = a_addr;
 
 \+floating
 
-fp@	( -- f_addr )	gforth	fp_fetch
+fp@	( f:... -- f_addr )	gforth	fp_fetch
 f_addr = fp;
 
-fp!	( f_addr -- )	gforth	fp_store
+fp!	( f_addr -- f:... )	gforth	fp_store
 fp = f_addr;
 
 \+
@@ -1298,21 +1324,18 @@ tuck	( w1 w2 -- w2 w1 w2 )	core-ext
 :
  swap over ;
 
-?dup	( w -- w )			core	question_dupe
+?dup	( w -- S:... w )	core	question_dupe
 ""Actually the stack effect is: @code{( w -- 0 | w w )}.  It performs a
 @code{dup} if w is nonzero.""
 if (w!=0) {
-  IF_spTOS(*sp-- = w;)
-#ifndef USE_TOS
   *--sp = w;
-#endif
 }
 :
  dup IF dup THEN ;
 
-pick	( u -- w )			core-ext
+pick	( S:... u -- S:... w )		core-ext
 ""Actually the stack effect is @code{ x0 ... xu u -- x0 ... xu x0 }.""
-w = sp[u+1];
+w = sp[u];
 :
  1+ cells sp@ + @ ;
 
@@ -1759,20 +1782,17 @@ strsignal	( n -- c_addr u )	gforth
 c_addr = (Address)strsignal(n);
 u = strlen(c_addr);
 
-call-c	( w -- )	gforth	call_c
+call-c	( ... w -- ... )	gforth	call_c
 ""Call the C function pointed to by @i{w}. The C function has to
 access the stack itself. The stack pointers are exported in the global
 variables @code{SP} and @code{FP}.""
 /* This is a first attempt at support for calls to C. This may change in
    the future */
-IF_fpTOS(fp[0]=fpTOS);
 FP=fp;
 SP=sp;
 ((void (*)())w)();
 sp=SP;
 fp=FP;
-IF_spTOS(spTOS=sp[0]);
-IF_fpTOS(fpTOS=fp[0]);
 
 \+
 \+file
@@ -2118,10 +2138,13 @@ f2=FLAG(isdigit((unsigned)(sig[0]))!=0);
 siglen=strlen(sig);
 if (siglen>u) /* happens in glibc-2.1.3 if 999.. is rounded up */
   siglen=u;
+if (!f2) /* workaround Cygwin trailing 0s for Inf and Nan */
+  for (; sig[siglen-1]=='0'; siglen--);
+    ;
 memcpy(c_addr,sig,siglen);
 memset(c_addr+siglen,f2?'0':' ',u-siglen);
 
->float	( c_addr u -- flag )	float	to_float
+>float	( c_addr u -- f:... flag )	float	to_float
 ""Actual stack effect: ( c_addr u -- r t | f ).  Attempt to convert the
 character string @i{c-addr u} to internal floating-point
 representation. If the string represents a valid floating-point number
@@ -2131,9 +2154,8 @@ case and represents the floating-point n
 Float r;
 flag = to_float(c_addr, u, &r);
 if (flag) {
-  IF_fpTOS(fp[0] = fpTOS);
-  fp += -1;
-  fpTOS = r;
+  fp--;
+  fp[0]=r;
 }
 
 fabs	( r1 -- r2 )	float-ext	f_abs
@@ -2359,9 +2381,9 @@ f>l	( r -- )	gforth	f_to_l
 lp -= sizeof(Float);
 *(Float *)lp = r;
 
-fpick	( u -- r )		gforth
+fpick	( f:... u -- f:... r )		gforth
 ""Actually the stack effect is @code{ r0 ... ru u -- r0 ... ru r0 }.""
-r = fp[u+1]; /* +1, because update of fp happens before this fragment */
+r = fp[u];
 :
  floats fp@ + f@ ;
 
@@ -2399,13 +2421,10 @@ u3 = 0;
 #  endif
 #endif
 
-wcall	( u -- )	gforth
-IF_fpTOS(fp[0]=fpTOS);
+wcall	( ... u -- ... )	gforth
 FP=fp;
 sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &FP);
 fp=FP;
-IF_spTOS(spTOS=sp[0];)
-IF_fpTOS(fpTOS=fp[0]);
 
 \+FFCALL
 
@@ -2469,30 +2488,30 @@ av_longlong(alist, d);
 av-ptr-r	( R:c_addr -- )	gforth  av_ptr_r
 av_ptr(alist, void*, c_addr);
 
-av-call-void	( -- )	gforth  av_call_void
+av-call-void	( ... -- ... )	gforth  av_call_void
 SAVE_REGS
 av_call(alist);
 REST_REGS
 
-av-call-int	( -- w )	gforth  av_call_int
+av-call-int	( ... -- ... w )	gforth  av_call_int
 SAVE_REGS
 av_call(alist);
 REST_REGS
 w = irv;
 
-av-call-float	( -- r )	gforth  av_call_float
+av-call-float	( ... -- ... r )	gforth  av_call_float
 SAVE_REGS
 av_call(alist);
 REST_REGS
 r = frv;
 
-av-call-double	( -- r )	gforth  av_call_double
+av-call-double	( ... -- ... r )	gforth  av_call_double
 SAVE_REGS
 av_call(alist);
 REST_REGS
 r = drv;
 
-av-call-longlong	( -- d )	gforth  av_call_longlong
+av-call-longlong	( ... -- ... d )	gforth  av_call_longlong
 SAVE_REGS
 av_call(alist);
 REST_REGS
@@ -2503,7 +2522,7 @@ DHI_IS(d, 0);
 d = llrv;
 #endif
 
-av-call-ptr	( -- c_addr )	gforth  av_call_ptr
+av-call-ptr	( ... -- ... c_addr )	gforth  av_call_ptr
 SAVE_REGS
 av_call(alist);
 REST_REGS
@@ -2629,13 +2648,12 @@ compile-prim1 ( a_prim -- ) gforth compi
 ""compile prim (incl. immargs) at @var{a_prim}""
 compile_prim1(a_prim);
 
-finish-code ( -- ) gforth finish_code
+finish-code ( ... -- ... ) gforth finish_code
 ""Perform delayed steps in code generation (branch resolution, I-cache
 flushing).""
-IF_spTOS(sp[0]=spTOS); /* workaround for failing to save spTOS
-			  (gcc-2.95.1, gforth-fast --enable-force-reg) */
+/* The ... above are a workaround for a bug in gcc-2.95, which fails
+   to save spTOS (gforth-fast --enable-force-reg) */
 finish_code();
-IF_spTOS(spTOS=sp[0]);
 
 forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode
 f = forget_dyncode(c_code);
@@ -2670,7 +2688,7 @@ a_addr = groups;
 
 \g static_super
 
-ifdef(`M4_ENGINE_FAST',
+ifdef(`STACK_CACHE_FILE',
 `include(peeprules.vmg)')
 
 \g end