Diff for /gforth/prim between versions 1.158 and 1.169

version 1.158, 2005/01/19 22:11:52 version 1.169, 2005/02/01 10:29:00
Line 191  goto *next_code; Line 191  goto *next_code;
 ip=IP; /* undo any ip updating that may have been performed by NEXT_P0 */  ip=IP; /* undo any ip updating that may have been performed by NEXT_P0 */
 #endif /* !defined(NO_IP) */  #endif /* !defined(NO_IP) */
 SUPER_END; /* !! probably unnecessary and may lead to measurement errors */  SUPER_END; /* !! probably unnecessary and may lead to measurement errors */
 EXEC(*(Xt *)PFA(CFA));  VM_JUMP(EXEC1(*(Xt *)PFA(CFA)));
   
 (dofield) ( n1 -- n2 )  gforth-internal paren_field  (dofield) ( n1 -- n2 )  gforth-internal paren_field
 ""run-time routine for fields""  ""run-time routine for fields""
Line 249  execute ( xt -- )  core Line 249  execute ( xt -- )  core
 #ifndef NO_IP  #ifndef NO_IP
 ip=IP;  ip=IP;
 #endif  #endif
 IF_spTOS(spTOS = sp[0]); /* inst_tail would produce a NEXT_P1 */  
 SUPER_END;  SUPER_END;
 EXEC(xt);  VM_JUMP(EXEC1(xt));
   
 perform ( a_addr -- )   gforth  perform ( a_addr -- )   gforth
 ""@code{@@ execute}.""  ""@code{@@ execute}.""
Line 259  perform ( a_addr -- ) gforth Line 258  perform ( a_addr -- ) gforth
 #ifndef NO_IP  #ifndef NO_IP
 ip=IP;  ip=IP;
 #endif  #endif
 IF_spTOS(spTOS = sp[0]); /* inst_tail would produce a NEXT_P1 */  
 SUPER_END;  SUPER_END;
 EXEC(*(Xt *)a_addr);  VM_JUMP(EXEC1(*(Xt *)a_addr));
 :  :
  @ execute ;   @ execute ;
   
Line 284  lit-perform ( #a_addr -- ) new lit_perfo Line 282  lit-perform ( #a_addr -- ) new lit_perfo
 ip=IP;  ip=IP;
 #endif  #endif
 SUPER_END;  SUPER_END;
 EXEC(*(Xt *)a_addr);  VM_JUMP(EXEC1(*(Xt *)a_addr));
   
 does-exec ( #a_cfa -- R:nest a_pfa )    new     does_exec  does-exec ( #a_cfa -- R:nest a_pfa )    new     does_exec
 #ifdef NO_IP  #ifdef NO_IP
Line 324  INST_TAIL; Line 322  INST_TAIL;
 JUMP(a_target);  JUMP(a_target);
 #else  #else
 SET_IP((Xt *)a_target);  SET_IP((Xt *)a_target);
 INST_TAIL;  
 NEXT_P2;  
 #endif  #endif
 SUPER_CONTINUE;  /* we do our own control flow, so don't append NEXT etc. */  
 :  :
  r> @ >r ;   r> @ >r ;
   
 \ condbranch(forthname,stackeffect,restline,code1,code2,forthcode)  \ condbranch(forthname,stackeffect,restline,code1,code2,forthcode)
 \ this is non-syntactical: code must open a brace that is closed by the macro  \ this is non-syntactical: code must open a brace that is closed by the macro
   \ condbranch(forthname,stackeffect,restline,code1,code2,forthcode)
   \ this is non-syntactical: code must open a brace that is closed by the macro
 define(condbranch,  define(condbranch,
 $1 ( `#'a_target $2 ) $3  $1 ( `#'a_target $2 ) $3
 $4      #ifdef NO_IP  $4      #ifdef NO_IP
Line 342  $5 #ifdef NO_IP Line 339  $5 #ifdef NO_IP
 JUMP(a_target);  JUMP(a_target);
 #else  #else
 SET_IP((Xt *)a_target);  SET_IP((Xt *)a_target);
   #endif
   }
   $6
   
   \+glocals
   
   $1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number
   $4      #ifdef NO_IP
   INST_TAIL;
   #endif
   $5      lp += nlocals;
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   #endif
   }
   
   \+
   )
   
   \ version that generates two jumps (not good for PR 15242 workaround)
   define(condbranch_twojump,
   $1 ( `#'a_target $2 ) $3
   $4      #ifdef NO_IP
   INST_TAIL;
   #endif
   $5      #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
 INST_TAIL; NEXT_P2;  INST_TAIL; NEXT_P2;
 #endif  #endif
 }  }
Line 491  if (nstart == nlimit) { Line 519  if (nstart == nlimit) {
     JUMP(a_target);      JUMP(a_target);
 #else  #else
     SET_IP((Xt *)a_target);      SET_IP((Xt *)a_target);
     INST_TAIL; NEXT_P2;  
 #endif  #endif
 }  }
 SUPER_CONTINUE;  
 :  :
   2dup =    2dup =
   IF   r> swap rot >r >r    IF   r> swap rot >r >r
Line 514  if (nstart >= nlimit) { Line 540  if (nstart >= nlimit) {
     JUMP(a_target);      JUMP(a_target);
 #else  #else
     SET_IP((Xt *)a_target);      SET_IP((Xt *)a_target);
     INST_TAIL; NEXT_P2;  
 #endif  #endif
 }  }
 SUPER_CONTINUE;  
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 537  if (ustart >= ulimit) { Line 561  if (ustart >= ulimit) {
 JUMP(a_target);  JUMP(a_target);
 #else  #else
 SET_IP((Xt *)a_target);  SET_IP((Xt *)a_target);
 INST_TAIL; NEXT_P2;  
 #endif  #endif
 }  }
 SUPER_CONTINUE;  
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 560  if (nstart <= nlimit) { Line 582  if (nstart <= nlimit) {
 JUMP(a_target);  JUMP(a_target);
 #else  #else
 SET_IP((Xt *)a_target);  SET_IP((Xt *)a_target);
 INST_TAIL; NEXT_P2;  
 #endif  #endif
 }  }
 SUPER_CONTINUE;  
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 583  if (ustart <= ulimit) { Line 603  if (ustart <= ulimit) {
 JUMP(a_target);  JUMP(a_target);
 #else  #else
 SET_IP((Xt *)a_target);  SET_IP((Xt *)a_target);
 INST_TAIL; NEXT_P2;  
 #endif  #endif
 }  }
 SUPER_CONTINUE;  
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 787  n = n1*n2; Line 805  n = n1*n2;
   
 /       ( n1 n2 -- n )          core    slash  /       ( n1 n2 -- n )          core    slash
 n = n1/n2;  n = n1/n2;
   if(FLOORED_DIV && ((n1^n2) < 0) && (n1%n2 != 0)) n--;
 :  :
  /mod nip ;   /mod nip ;
   
 mod     ( n1 n2 -- n )          core  mod     ( n1 n2 -- n )          core
 n = n1%n2;  n = n1%n2;
   if(FLOORED_DIV && ((n1^n2) < 0) && n!=0) n += n2;
 :  :
  /mod drop ;   /mod drop ;
   
 /mod    ( n1 n2 -- n3 n4 )              core            slash_mod  /mod    ( n1 n2 -- n3 n4 )              core            slash_mod
 n4 = n1/n2;  n4 = n1/n2;
 n3 = n1%n2; /* !! is this correct? look into C standard! */  n3 = n1%n2; /* !! is this correct? look into C standard! */
   if (FLOORED_DIV && ((n1^n2) < 0) && n3!=0) {
     n4--;
     n3+=n2;
   }
 :  :
  >r s>d r> fm/mod ;   >r s>d r> fm/mod ;
   
   */mod   ( n1 n2 n3 -- n4 n5 )   core    star_slash_mod
   ""n1*n2=n3*n5+n4, with the intermediate result (n1*n2) being double.""
   #ifdef BUGGY_LL_MUL
   DCell d = mmul(n1,n2);
   #else
   DCell d = (DCell)n1 * (DCell)n2;
   #endif
   #ifdef BUGGY_LL_DIV
   DCell r = fmdiv(d,n3);
   n4=DHI(r);
   n5=DLO(r);
   #else
   /* assumes that the processor uses either floored or symmetric division */
   n5 = d/n3;
   n4 = d%n3;
   if (FLOORED_DIV && ((DHI(d)^n3)<0) && n4!=0) {
     n5--;
     n4+=n3;
   }
   #endif
   :
    >r m* r> fm/mod ;
   
   */      ( n1 n2 n3 -- n4 )      core    star_slash
   ""n4=(n1*n2)/n3, with the intermediate result being double.""
   #ifdef BUGGY_LL_MUL
   DCell d = mmul(n1,n2);
   #else
   DCell d = (DCell)n1 * (DCell)n2;
   #endif
   #ifdef BUGGY_LL_DIV
   DCell r = fmdiv(d,n3);
   n4=DLO(r);
   #else
   /* assumes that the processor uses either floored or symmetric division */
   n4 = d/n3;
   if (FLOORED_DIV && ((DHI(d)^n3)<0) && (d%n3)!=0) n4--;
   #endif
   :
    */mod nip ;
   
 2*      ( n1 -- n2 )            core            two_star  2*      ( n1 -- n2 )            core            two_star
 ""Shift left by 1; also works on unsigned numbers""  ""Shift left by 1; also works on unsigned numbers""
 n2 = 2*n1;  n2 = 2*n1;
Line 821  n2 = n1>>1; Line 886  n2 = n1>>1;
 fm/mod  ( d1 n1 -- n2 n3 )              core            f_m_slash_mod  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}.""  ""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 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);  DCell r = fmdiv(d1,n1);
 n2=r.hi;  n2=DHI(r);
 n3=r.lo;  n3=DLO(r);
 #else  #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 */  /* assumes that the processor uses either floored or symmetric division */
 n3 = d1/n1;  n3 = d1/n1;
 n2 = d1%n1;  n2 = d1%n1;
 /* note that this 1%-3>0 is optimized by the compiler */  /* 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--;    n3--;
   n2+=n1;    n2+=n1;
 }  }
   #endif /* !defined(ASM_SM_SLASH_REM4) */
 #endif  #endif
 :  :
  dup >r dup 0< IF  negate >r dnegate r>  THEN   dup >r dup 0< IF  negate >r dnegate r>  THEN
Line 843  if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) Line 924  if (1%-3>0 && (d1<0) != (n1<0) && n2!=0)
 sm/rem  ( d1 n1 -- n2 n3 )              core            s_m_slash_rem  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.""  ""Symmetric division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, sign(@i{n2})=sign(@i{d1}) or 0.""
 #ifdef BUGGY_LL_DIV  #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);  DCell r = smdiv(d1,n1);
 n2=r.hi;  n2=DHI(r);
 n3=r.lo;  n3=DLO(r);
 #else  #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 */  /* assumes that the processor uses either floored or symmetric division */
 n3 = d1/n1;  n3 = d1/n1;
 n2 = d1%n1;  n2 = d1%n1;
 /* note that this 1%-3<0 is optimized by the compiler */  /* 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++;    n3++;
   n2-=n1;    n2-=n1;
 }  }
   #endif /* !defined(ASM_SM_SLASH_REM4) */
 #endif  #endif
 :  :
  over >r dup >r abs -rot   over >r dup >r abs -rot
Line 892  ud = (UDCell)u1 * (UDCell)u2; Line 981  ud = (UDCell)u1 * (UDCell)u2;
 um/mod  ( ud u1 -- u2 u3 )              core    u_m_slash_mod  um/mod  ( ud u1 -- u2 u3 )              core    u_m_slash_mod
 ""ud=u3*u1+u2, u1>u2>=0""  ""ud=u3*u1+u2, u1>u2>=0""
 #ifdef BUGGY_LL_DIV  #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);  UDCell r = umdiv(ud,u1);
 u2=r.hi;  u2=DHI(r);
 u3=r.lo;  u3=DLO(r);
 #else  #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;  u3 = ud/u1;
 u2 = ud%u1;  u2 = ud%u1;
   #endif /* !defined(ASM_UM_SLASH_MOD4) */
 #endif  #endif
 :  :
    0 swap [ 8 cells 1 + ] literal 0     0 swap [ 8 cells 1 + ] literal 0

Removed from v.1.158  
changed lines
  Added in v.1.169


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>