Diff for /gforth/prim between versions 1.198 and 1.209

version 1.198, 2006/10/22 16:54:00 version 1.209, 2007/03/31 19:43:54
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 (CHECK_DIVISION && n2 == 0)  if (CHECK_DIVISION_SW && n2 == 0)
   throw(BALL_DIVZERO);    throw(BALL_DIVZERO);
 if (CHECK_DIVISION && n2 == -1 && n1 == CELL_MIN)  if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN)
   throw(BALL_RESULTRANGE);    throw(BALL_RESULTRANGE);
 if (FLOORED_DIV && ((n1^n2) < 0) && (n1%n2 != 0))  if (FLOORED_DIV && ((n1^n2) < 0) && (n1%n2 != 0))
   n--;    n--;
Line 820  if (FLOORED_DIV && ((n1^n2) < 0) && (n1% Line 820  if (FLOORED_DIV && ((n1^n2) < 0) && (n1%
   
 mod     ( n1 n2 -- n )          core  mod     ( n1 n2 -- n )          core
 n = n1%n2;  n = n1%n2;
 if (CHECK_DIVISION && n2 == 0)  if (CHECK_DIVISION_SW && n2 == 0)
   throw(BALL_DIVZERO);    throw(BALL_DIVZERO);
 if (CHECK_DIVISION && n2 == -1 && n1 == CELL_MIN)  if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN)
   throw(BALL_RESULTRANGE);    throw(BALL_RESULTRANGE);
 if(FLOORED_DIV && ((n1^n2) < 0) && n!=0) n += n2;  if(FLOORED_DIV && ((n1^n2) < 0) && n!=0) n += n2;
 :  :
Line 831  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 && n2 == 0)  if (CHECK_DIVISION_SW && n2 == 0)
   throw(BALL_DIVZERO);    throw(BALL_DIVZERO);
 if (CHECK_DIVISION && n2 == -1 && n1 == CELL_MIN)  if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN)
   throw(BALL_RESULTRANGE);    throw(BALL_RESULTRANGE);
 if (FLOORED_DIV && ((n1^n2) < 0) && n3!=0) {  if (FLOORED_DIV && ((n1^n2) < 0) && n3!=0) {
   n4--;    n4--;
Line 844  if (FLOORED_DIV && ((n1^n2) < 0) && n3!= Line 844  if (FLOORED_DIV && ((n1^n2) < 0) && n3!=
   
 */mod   ( n1 n2 n3 -- n4 n5 )   core    star_slash_mod  */mod   ( n1 n2 n3 -- n4 n5 )   core    star_slash_mod
 ""n1*n2=n3*n5+n4, with the intermediate result (n1*n2) being double.""  ""n1*n2=n3*n5+n4, with the intermediate result (n1*n2) being double.""
 DCell d5;  
 #ifdef BUGGY_LL_MUL  #ifdef BUGGY_LL_MUL
 DCell d = mmul(n1,n2);  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 */  
 d5 = d/n3;  
 n4 = d%n3;  
 if (CHECK_DIVISION && n3 == 0)  
   throw(BALL_DIVZERO);  
 if (FLOORED_DIV && ((DHI(d)^n3)<0) && n4!=0) {  if (FLOORED_DIV && ((DHI(d)^n3)<0) && n4!=0) {
   d5--;    if (CHECK_DIVISION && n5 == CELL_MIN)
       throw(BALL_RESULTRANGE);
     n5--;
   n4+=n3;    n4+=n3;
 }  }
 n5 = d5;  #else
 if (d5 != n5)  DCell r = FLOORED_DIV ? fmdiv(d,n3) : smdiv(d,n3);
   throw(BALL_RESULTRANGE);  n4=DHI(r);
   n5=DLO(r);
 #endif  #endif
 :  :
  >r m* r> fm/mod ;   >r m* r> fm/mod ;
   
 */      ( n1 n2 n3 -- n4 )      core    star_slash  */      ( n1 n2 n3 -- n4 )      core    star_slash
 ""n4=(n1*n2)/n3, with the intermediate result being double.""  ""n4=(n1*n2)/n3, with the intermediate result being double.""
 DCell d4;  
 #ifdef BUGGY_LL_MUL  #ifdef BUGGY_LL_MUL
 DCell d = mmul(n1,n2);  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);
 d4 = d/n3;  n4=DLO(r);
 if (CHECK_DIVISION && n3 == 0)  
   throw(BALL_DIVZERO);  
 if (FLOORED_DIV && ((DHI(d)^n3)<0) && (d%n3)!=0)  
   d4--;  
 n4 = d4;  
 if (d4 != n4)  
   throw(BALL_RESULTRANGE);  
 #endif  #endif
 :  :
  */mod nip ;   */mod nip ;
Line 915  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 (n3 == CELL_MIN)    if (CHECK_DIVISION && n3 == CELL_MIN)
     throw(BALL_RESULTRANGE);      throw(BALL_RESULTRANGE);
   n3--;    n3--;
   n2+=n1;    n2+=n1;
Line 929  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) {  
   if (n3 == CELL_MIN)  
     throw(BALL_RESULTRANGE);  
   n3--;  
   n2+=n1;  
 }  
 #else /* !defined(ASM_SM_SLASH_REM4) */  
 /* assumes that the processor uses either floored or symmetric division */  
 DCell d3 = d1/n1;  
 n2 = d1%n1;  
 if (CHECK_DIVISION && n1 == 0)  
   throw(BALL_DIVZERO);  
 /* note that this 1%-3>0 is optimized by the compiler */  
 if (1%-3>0 && ((DHI(d1)^n1)<0) && n2!=0) {  
   d3--;  
   n2+=n1;  
 }  
 n3 = d3;  
 if (d3 != n3)  
   throw(BALL_RESULTRANGE);  
 #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 962  if (d3 != n3) Line 927  if (d3 != n3)
   
 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 */  
 DCell d3 = d1/n1;  
 n2 = d1%n1;  
 if (CHECK_DIVISION && n1 == 0)  
   throw(BALL_DIVZERO);  
 /* note that this 1%-3<0 is optimized by the compiler */  
 if (1%-3<0 && ((DHI(d1)^n1)<0) && n2!=0) {  
   d3++;  
   n2-=n1;  
 }  
 n3 = d3;  
 if (d3 != n3)  
   throw(BALL_RESULTRANGE);  
 #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 1024  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) */  
 UDCell ud3 = ud/u1;  
 u2 = ud%u1;  
 if (CHECK_DIVISION && u1 == 0)  
   throw(BALL_DIVZERO);  
 u3 = ud3;  
 if (ud3 != u3)  
   throw(BALL_RESULTRANGE);  
 #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 1097  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 1716  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 1730  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
 with the window size.""  change with the window size.  Note that it depends on the OS whether
   this reflects the actual size and changes with the window size
   (currently only on Unix-like OSs).  On other OSs you just get a
   default, and can tell Gforth the terminal size by setting the
   environment variables @code{COLUMNS} and @code{LINES} before starting
   Gforth.""
 /* we could block SIGWINCH here to get a consistent size, but I don't  /* we could block SIGWINCH here to get a consistent size, but I don't
  think this is necessary or always beneficial */   think this is necessary or always beneficial */
 urows=rows;  urows=rows;
Line 2835  define(`uploop', Line 2766  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 2846  define(argdlist, Line 2778  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.198  
changed lines
  Added in v.1.209


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