Diff for /gforth/prim between versions 1.196 and 1.208

version 1.196, 2006/10/13 17:15:27 version 1.208, 2007/03/25 21:30:59
Line 1 Line 1
 \ Gforth primitives  \ Gforth primitives
   
 \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 809  n = n1*n2; Line 809  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--;  if (CHECK_DIVISION_SW && n2 == 0)
     throw(BALL_DIVZERO);
   if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN)
     throw(BALL_RESULTRANGE);
   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 (CHECK_DIVISION_SW && n2 == 0)
     throw(BALL_DIVZERO);
   if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN)
     throw(BALL_RESULTRANGE);
 if(FLOORED_DIV && ((n1^n2) < 0) && n!=0) n += n2;  if(FLOORED_DIV && ((n1^n2) < 0) && n!=0) n += n2;
 :  :
  /mod drop ;   /mod drop ;
Line 822  if(FLOORED_DIV && ((n1^n2) < 0) && n!=0) Line 831  if(FLOORED_DIV && ((n1^n2) < 0) && n!=0)
 /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 (CHECK_DIVISION_SW && n2 == 0)
     throw(BALL_DIVZERO);
   if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN)
     throw(BALL_RESULTRANGE);
 if (FLOORED_DIV && ((n1^n2) < 0) && n3!=0) {  if (FLOORED_DIV && ((n1^n2) < 0) && n3!=0) {
   n4--;    n4--;
   n3+=n2;    n3+=n2;
Line 836  DCell d = mmul(n1,n2); Line 849  DCell d = mmul(n1,n2);
 #else  #else
 DCell d = (DCell)n1 * (DCell)n2;  DCell d = (DCell)n1 * (DCell)n2;
 #endif  #endif
 #ifdef BUGGY_LL_DIV  #ifdef ASM_SM_SLASH_REM
 DCell r = fmdiv(d,n3);  ASM_SM_SLASH_REM(DLO(d), DHI(d), n3, n4, n5);
 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) {  if (FLOORED_DIV && ((DHI(d)^n3)<0) && n4!=0) {
     if (CHECK_DIVISION && n5 == CELL_MIN)
       throw(BALL_RESULTRANGE);
   n5--;    n5--;
   n4+=n3;    n4+=n3;
 }  }
   #else
   DCell r = FLOORED_DIV ? fmdiv(d,n3) : smdiv(d,n3);
   n4=DHI(r);
   n5=DLO(r);
 #endif  #endif
 :  :
  >r m* r> fm/mod ;   >r m* r> fm/mod ;
Line 859  DCell d = mmul(n1,n2); Line 872  DCell d = mmul(n1,n2);
 #else  #else
 DCell d = (DCell)n1 * (DCell)n2;  DCell d = (DCell)n1 * (DCell)n2;
 #endif  #endif
 #ifdef BUGGY_LL_DIV  #ifdef ASM_SM_SLASH_REM
 DCell r = fmdiv(d,n3);  Cell remainder;
 n4=DLO(r);  ASM_SM_SLASH_REM(DLO(d), DHI(d), n3, remainder, n4);
   if (FLOORED_DIV && ((DHI(d)^n3)<0) && remainder!=0) {
     if (CHECK_DIVISION && n4 == CELL_MIN)
       throw(BALL_RESULTRANGE);
     n4--;
   }
 #else  #else
 /* assumes that the processor uses either floored or symmetric division */  DCell r = FLOORED_DIV ? fmdiv(d,n3) : smdiv(d,n3);
 n4 = d/n3;  n4=DLO(r);
 if (FLOORED_DIV && ((DHI(d)^n3)<0) && (d%n3)!=0) n4--;  
 #endif  #endif
 :  :
  */mod nip ;   */mod nip ;
Line 889  n2 = n1>>1; Line 906  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 ASM_SM_SLASH_REM  #ifdef ASM_SM_SLASH_REM
 ASM_SM_SLASH_REM(d1.lo, d1.hi, n1, n2, n3);  ASM_SM_SLASH_REM(DLO(d1), DHI(d1), n1, n2, n3);
 if (((DHI(d1)^n1)<0) && n2!=0) {  if (((DHI(d1)^n1)<0) && n2!=0) {
     if (CHECK_DIVISION && n3 == CELL_MIN)
       throw(BALL_RESULTRANGE);
   n3--;    n3--;
   n2+=n1;    n2+=n1;
 }  }
Line 901  DCell r = fmdiv(d1,n1); Line 919  DCell r = fmdiv(d1,n1);
 n2=DHI(r);  n2=DHI(r);
 n3=DLO(r);  n3=DLO(r);
 #endif /* !defined(ASM_SM_SLASH_REM) */  #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 && ((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   dup >r dup 0< IF  negate >r dnegate r>  THEN
  over       0< IF  tuck + swap  THEN   over       0< IF  tuck + swap  THEN
Line 927  if (1%-3>0 && ((DHI(d1)^n1)<0) && n2!=0) Line 927  if (1%-3>0 && ((DHI(d1)^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 ASM_SM_SLASH_REM  #ifdef ASM_SM_SLASH_REM
 ASM_SM_SLASH_REM(d1.lo, d1.hi, n1, n2, n3);  ASM_SM_SLASH_REM(DLO(d1), DHI(d1), n1, n2, n3);
 #else /* !defined(ASM_SM_SLASH_REM) */  #else /* !defined(ASM_SM_SLASH_REM) */
 DCell r = smdiv(d1,n1);  DCell r = smdiv(d1,n1);
 n2=DHI(r);  n2=DHI(r);
 n3=DLO(r);  n3=DLO(r);
 #endif /* !defined(ASM_SM_SLASH_REM) */  #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 && ((DHI(d1)^n1)<0) && n2!=0) {  
   n3++;  
   n2-=n1;  
 }  
 #endif /* !defined(ASM_SM_SLASH_REM4) */  
 #endif  
 :  :
  over >r dup >r abs -rot   over >r dup >r abs -rot
  dabs rot um/mod   dabs rot um/mod
Line 984  ud = (UDCell)u1 * (UDCell)u2; Line 969  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 ASM_UM_SLASH_MOD  #ifdef ASM_UM_SLASH_MOD
 ASM_UM_SLASH_MOD(ud.lo, ud.hi, u1, u2, u3);  ASM_UM_SLASH_MOD(DLO(ud), DHI(ud), u1, u2, u3);
 #else /* !defined(ASM_UM_SLASH_MOD) */  #else /* !defined(ASM_UM_SLASH_MOD) */
 UDCell r = umdiv(ud,u1);  UDCell r = umdiv(ud,u1);
 u2=DHI(r);  u2=DHI(r);
 u3=DLO(r);  u3=DLO(r);
 #endif /* !defined(ASM_UM_SLASH_MOD) */  #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     0 swap [ 8 cells 1 + ] literal 0
    ?DO /modstep     ?DO /modstep
Line 1052  d2 = -d1; Line 1028  d2 = -d1;
   
 d2*     ( d1 -- d2 )            double          d_two_star  d2*     ( d1 -- d2 )            double          d_two_star
 ""Shift left by 1; also works on unsigned numbers""  ""Shift left by 1; also works on unsigned numbers""
 #ifdef BUGGY_LL_SHIFT  d2 = DLSHIFT(d1,1);
 DLO_IS(d2, DLO(d1)<<1);  
 DHI_IS(d2, (DHI(d1)<<1) | (DLO(d1)>>(CELL_BITS-1)));  
 #else  
 d2 = 2*d1;  
 #endif  
 :  :
  2dup d+ ;   2dup d+ ;
   
Line 1671  f = key_query((FILE*)wfileid); Line 1642  f = key_query((FILE*)wfileid);
 f = key_query(stdin);  f = key_query(stdin);
 #endif  #endif
   
 \+os  
   
 stdin   ( -- wfileid )  gforth  stdin   ( -- wfileid )  gforth
 ""The standard input file of the Gforth process.""  ""The standard input file of the Gforth process.""
 wfileid = (Cell)stdin;  wfileid = (Cell)stdin;
Line 1685  stderr ( -- wfileid ) gforth Line 1654  stderr ( -- wfileid ) gforth
 ""The standard error output file of the Gforth process.""  ""The standard error output file of the Gforth process.""
 wfileid = (Cell)stderr;  wfileid = (Cell)stderr;
   
   \+os
   
 form    ( -- urows ucols )      gforth  form    ( -- urows ucols )      gforth
 ""The number of lines and columns in the terminal. These numbers may change  ""The number of lines and columns in the terminal. These numbers may change
 with the window size.""  with the window size.""
Line 2790  define(`uploop', Line 2761  define(`uploop',
 define(`_uploop',  define(`_uploop',
        `ifelse($1, `$3', `$5',         `ifelse($1, `$3', `$5',
                `$4`'define(`$1', incr($1))_uploop(`$1', `$2', `$3', `$4', `$5')')')                 `$4`'define(`$1', incr($1))_uploop(`$1', `$2', `$3', `$4', `$5')')')
   
 \ argflist(argnum): Forth argument list  \ argflist(argnum): Forth argument list
 define(argflist,  define(argflist,
        `ifelse($1, 0, `',         `ifelse($1, 0, `',
                `uploop(`_i', 1, $1, `format(`u%d ', _i)', `format(`u%d ', _i)')')')                 `uploop(`_i', 1, $1, ``u''`_i ', ``u''`_i')')')
 \ argdlist(argnum): declare C's arguments  \ argdlist(argnum): declare C's arguments
 define(argdlist,  define(argdlist,
        `ifelse($1, 0, `',         `ifelse($1, 0, `',
Line 2801  define(argdlist, Line 2773  define(argdlist,
 \ argclist(argnum): pass C's arguments  \ argclist(argnum): pass C's arguments
 define(argclist,  define(argclist,
        `ifelse($1, 0, `',         `ifelse($1, 0, `',
                `uploop(`_i', 1, $1, `format(`u%d, ', _i)', `format(`u%d', _i)')')')                 `uploop(`_i', 1, $1, ``u''`_i, ', ``u''`_i')')')
 \ icall(argnum)  \ icall(argnum)
 define(icall,  define(icall,
 `icall$1        ( argflist($1)u -- uret )       gforth  `icall$1        ( argflist($1) u -- uret )      gforth
 uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1));  uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1));
   
 ')  ')
 define(fcall,  define(fcall,
 `fcall$1        ( argflist($1)u -- rret )       gforth  `fcall$1        ( argflist($1) u -- rret )      gforth
 rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1));  rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1));
   
 ')  ')

Removed from v.1.196  
changed lines
  Added in v.1.208


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