Diff for /gforth/prim between versions 1.200 and 1.209

version 1.200, 2006/10/27 21:47:01 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 849  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 */  
 DCell d5 = d/n3;  
 n4 = d%n3;  
 if (CHECK_DIVISION_SW && 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 (CHECK_DIVISION && 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 ;
Line 877  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);
 DCell d4 = d/n3;  n4=DLO(r);
 if (CHECK_DIVISION_SW && n3 == 0)  
   throw(BALL_DIVZERO);  
 if (FLOORED_DIV && ((DHI(d)^n3)<0) && (d%n3)!=0)  
   d4--;  
 n4 = d4;  
 if (CHECK_DIVISION && d4 != n4)  
   throw(BALL_RESULTRANGE);  
 #endif  #endif
 :  :
  */mod nip ;   */mod nip ;
Line 913  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)    if (CHECK_DIVISION && n3 == CELL_MIN)
     throw(BALL_RESULTRANGE);      throw(BALL_RESULTRANGE);
Line 927  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 (CHECK_DIVISION && 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_SW && 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 (CHECK_DIVISION && 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 960  if (CHECK_DIVISION && d3 != n3) Line 927  if (CHECK_DIVISION && 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_SW && 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 (CHECK_DIVISION && 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 1022  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_SW && u1 == 0)  
   throw(BALL_DIVZERO);  
 u3 = ud3;  
 if (CHECK_DIVISION && 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 1095  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 1714  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 1728  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 2833  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 2844  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.200  
changed lines
  Added in v.1.209


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