[gforth] / gforth / prim

# gforth: gforth/prim

### Diff for /gforth/prim between version 1.51 and 1.52

version 1.51, Tue Aug 8 12:37:05 2000 UTC version 1.52, Wed Aug 9 20:04:06 2000 UTC
 Line 445
 Line 445
\ digit is high-level: 0/0%  \ digit is high-level: 0/0%

move    ( c_from c_to ucount -- )               core  move    ( c_from c_to ucount -- )               core
""Copy the contents of @i{ucount} address units at @i{c-from} to  ""Copy the contents of @i{ucount} aus at @i{c-from} to
@i{c-to}. @code{move} works correctly even if the two areas overlap.""  @i{c-to}. @code{move} works correctly even if the two areas overlap.""
memmove(c_to,c_from,ucount);  memmove(c_to,c_from,ucount);
/* make an Ifdef for bsd and others? */  /* make an Ifdef for bsd and others? */
:  :
 Line 475
 Line 476
DO  1- dup c@ I c!  -1 +LOOP  drop ;   DO  1- dup c@ I c!  -1 +LOOP  drop ;

fill    ( c_addr u c -- )       core  fill    ( c_addr u c -- )       core
"" If @i{u}>0, store character @i{c} in each of @i{u} consecutive  ""Store @i{c} in @i{u} chars starting at @i{c-addr}.""
:  :
-rot bounds   -rot bounds
 Line 600
 Line 600
:  :
2dup > IF swap THEN drop ;   2dup > IF swap THEN drop ;

abs     ( n1 -- n2 )    core  abs     ( n -- u )      core
if (n1<0)  if (n<0)
n2 = -n1;    u = -n;
else  else
n2 = n1;    u = n;
:  :
dup 0< IF negate THEN ;   dup 0< IF negate THEN ;

 Line 630
 Line 630
>r s>d r> fm/mod ;   >r s>d r> fm/mod ;

2*      ( n1 -- n2 )            core            two_star  2*      ( n1 -- n2 )            core            two_star
""Shift left by 1; also works on unsigned numbers""
n2 = 2*n1;  n2 = 2*n1;
:  :
dup + ;   dup + ;

2/      ( n1 -- n2 )            core            two_slash  2/      ( n1 -- n2 )            core            two_slash
/* !! is this still correct? */  ""Arithmetic shift right by 1.  For signed numbers this is a floored
division by 2 (note that @code{/} not necessarily floors).""
n2 = n1>>1;  n2 = n1>>1;
:  :
dup MINI and IF 1 ELSE 0 THEN   dup MINI and IF 1 ELSE 0 THEN
 Line 777
 Line 779
invert swap negate tuck 0= - ;   invert swap negate tuck 0= - ;

d2*     ( d1 -- d2 )            double          d_two_star  d2*     ( d1 -- d2 )            double          d_two_star
""Shift left by 1; also works on unsigned numbers""
#ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
d2.lo = d1.lo<<1;  d2.lo = d1.lo<<1;
d2.hi = (d1.hi<<1) | (d1.lo>>(CELL_BITS-1));  d2.hi = (d1.hi<<1) | (d1.lo>>(CELL_BITS-1));
 Line 787
 Line 790
2dup d+ ;   2dup d+ ;

d2/     ( d1 -- d2 )            double          d_two_slash  d2/     ( d1 -- d2 )            double          d_two_slash
""Arithmetic shift right by 1.  For signed numbers this is a floored
division by 2.""
#ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
d2.hi = d1.hi>>1;  d2.hi = d1.hi>>1;
d2.lo= (d1.lo>>1) | (d1.hi<<(CELL_BITS-1));  d2.lo= (d1.lo>>1) | (d1.hi<<(CELL_BITS-1));
 Line 939
 Line 944
around from @code{max-u} to 0 for unsigned, and from @code{max-n} to  around from @code{max-u} to 0 for unsigned, and from @code{max-n} to
min-n for signed numbers); now consider the range from u2 towards  min-n for signed numbers); now consider the range from u2 towards
increasing numbers up to and excluding u3 (giving an empty range if  increasing numbers up to and excluding u3 (giving an empty range if
u2=u3; if u1 is in this range, @code{within} returns true.""  u2=u3); if u1 is in this range, @code{within} returns true.""
f = FLAG(u1-u2 < u3-u2);  f = FLAG(u1-u2 < u3-u2);
:  :
over - >r - r> u< ;   over - >r - r> u< ;
 Line 972
 Line 977
SET_IP((Xt *)(*rp++));  SET_IP((Xt *)(*rp++));

>r      ( w -- )                core    to_r  >r      ( w -- )                core    to_r
""@code{( R: -- w )}""
*--rp = w;  *--rp = w;
:  :
(>r) ;   (>r) ;
: (>r)  rp@ cell+ @ rp@ ! rp@ cell+ ! ;  : (>r)  rp@ cell+ @ rp@ ! rp@ cell+ ! ;

r>      ( -- w )                core    r_from  r>      ( -- w )                core    r_from
""@code{( R: w -- )}""
w = *rp++;  w = *rp++;
:  :
rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ;   rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ;
Create (rdrop) ' ;s A,  Create (rdrop) ' ;s A,

rdrop   ( -- )          gforth  rdrop   ( -- )          gforth
""@code{( R: w -- )}""
rp++;  rp++;
:  :
r> r> drop >r ;   r> r> drop >r ;

2>r     ( w1 w2 -- )    core-ext        two_to_r  2>r     ( w1 w2 -- )    core-ext        two_to_r
""@code{( R: -- w1 w2 )}""
*--rp = w1;  *--rp = w1;
*--rp = w2;  *--rp = w2;
:  :
swap r> swap >r swap >r >r ;   swap r> swap >r swap >r >r ;

2r>     ( -- w1 w2 )    core-ext        two_r_from  2r>     ( -- w1 w2 )    core-ext        two_r_from
""@code{( R: w1 w2 -- )}""
w2 = *rp++;  w2 = *rp++;
w1 = *rp++;  w1 = *rp++;
:  :
r> r> swap r> swap >r swap ;   r> r> swap r> swap >r swap ;

2r@     ( -- w1 w2 )    core-ext        two_r_fetch  2r@     ( -- w1 w2 )    core-ext        two_r_fetch
""@code{( R: w1 w2 -- w1 w2 )}""
w2 = rp[0];  w2 = rp[0];
w1 = rp[1];  w1 = rp[1];
:  :
i' j ;   i' j ;

2rdrop  ( -- )          gforth  two_r_drop  2rdrop  ( -- )          gforth  two_r_drop
""@code{( R: w1 w2 -- )}""
rp+=2;  rp+=2;
:  :
r> r> drop r> drop >r ;   r> r> drop r> drop >r ;
 Line 1050
 Line 1062
swap over ;   swap over ;

?dup    ( w -- w )                      core    question_dupe  ?dup    ( w -- 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 (w!=0) {
IF_TOS(*sp-- = w;)    IF_TOS(*sp-- = w;)
#ifndef USE_TOS  #ifndef USE_TOS
 Line 1060
 Line 1074
dup IF dup THEN ;   dup IF dup THEN ;

pick    ( u -- w )                      core-ext  pick    ( u -- w )                      core-ext
""Actually the stack effect is @code{ x0 ... xu u -- x0 ... xu x0 }.""
w = sp[u+1];  w = sp[u+1];
:  :
1+ cells sp@ + @ ;   1+ cells sp@ + @ ;
 Line 1095
 Line 1110
\ toggle is high-level: 0.11/0.42%  \ toggle is high-level: 0.11/0.42%

@       ( a_addr -- w )         core    fetch  @       ( a_addr -- w )         core    fetch

!       ( w a_addr -- )         core    store  !       ( w a_addr -- )         core    store
"" Write the value @i{w} to the cell at address @i{a-addr}.""  ""Store @i{w} into the cell at @i{a-addr}.""

+!      ( n a_addr -- )         core    plus_store  +!      ( n a_addr -- )         core    plus_store
:  :
tuck @ + swap ! ;   tuck @ + swap ! ;

c@      ( c_addr -- c )         core    c_fetch  c@      ( c_addr -- c )         core    c_fetch
:  :
[ bigendian [IF] ]  [ bigendian [IF] ]
 Line 1135
 Line 1150
: 8>> 2/ 2/ 2/ 2/  2/ 2/ 2/ 2/ ;  : 8>> 2/ 2/ 2/ 2/  2/ 2/ 2/ 2/ ;

c!      ( c c_addr -- )         core    c_store  c!      ( c c_addr -- )         core    c_store
"" Write the value @i{c} to the char at address @i{c-addr}.""  ""Store @i{c} into the char at @i{c-addr}.""
:  :
[ bigendian [IF] ]  [ bigendian [IF] ]
 Line 1165
 Line 1180
: 8<< 2* 2* 2* 2*  2* 2* 2* 2* ;  : 8<< 2* 2* 2* 2*  2* 2* 2* 2* ;

2!      ( w1 w2 a_addr -- )             core    two_store  2!      ( w1 w2 a_addr -- )             core    two_store
"" Write the value @i{w1, w2} to the double at address @i{a-addr}.""  ""Store @i{w2} into the cell at @i{c-addr} and @i{w1} into the next cell.""
:  :
tuck ! cell+ ! ;   tuck ! cell+ ! ;

2@      ( a_addr -- w1 w2 )             core    two_fetch  2@      ( a_addr -- w1 w2 )             core    two_fetch
"" Read from the double at address @i{a-addr}, and return its contents, @i{w1, w2}.""  ""@i{w2} is the content of the cell stored at @i{a-addr}, @i{w1} is
the content of the next cell.""
:  :
dup cell+ @ swap @ ;   dup cell+ @ swap @ ;

"" Increment @i{a-addr1} by the number of address units corresponding to the size of  ""@code{1 cells +}""
:  :
cell + ;   cell + ;

cells   ( n1 -- n2 )            core  cells   ( n1 -- n2 )            core
"" @i{n2} is the number of address units corresponding to @i{n1} cells.""  "" @i{n2} is the number of address units of @i{n1} cells.""
n2 = n1 * sizeof(Cell);  n2 = n1 * sizeof(Cell);
:  :
[ cell   [ cell
 Line 1197
 Line 1212
drop ] ;   drop ] ;

"" Increment @i{c-addr1} by the number of address units corresponding to the size of  ""@code{1 chars +}.""
:  :
1+ ;   1+ ;
 Line 1526
 Line 1540
contents of the data space is undefined. If the allocation is successful,  contents of the data space is undefined. If the allocation is successful,
is 0. If the allocation fails, @i{a-addr} is undefined and @i{wior}  is 0. If the allocation fails, @i{a-addr} is undefined and @i{wior}
is an implementation-defined I/O result code.""  is a non-zero I/O result code.""

free    ( a_addr -- wior )              memory  free    ( a_addr -- wior )              memory
""Return the region of data space starting at @i{a-addr} to the system.  ""Return the region of data space starting at @i{a-addr} to the system.
The regon must originally have been obtained using @code{allocate} or  The region must originally have been obtained using @code{allocate} or
@code{resize}. If the operational is successful, @i{wior} is 0.  @code{resize}. If the operational is successful, @i{wior} is 0.
If the operation fails, @i{wior} is an implementation-defined  If the operation fails, @i{wior} is a non-zero I/O result code.""
I/O result code.""
wior = 0;  wior = 0;

 Line 1543
 Line 1556
""Change the size of the allocated area at @i{a-addr1} to @i{u}  ""Change the size of the allocated area at @i{a-addr1} to @i{u}
address units, possibly moving the contents to a different  address units, possibly moving the contents to a different
If the operational is successful, @i{wior} is 0.  If the operation is successful, @i{wior} is 0.
If the operation fails, @i{wior} is an implementation-defined  If the operation fails, @i{wior} is a non-zero
I/O result code. If @i{a-addr1} is 0, Gforth's (but not the Standard)  I/O result code. If @i{a-addr1} is 0, Gforth's (but not the Standard)
/* the following check is not necessary on most OSs, but it is needed  /* the following check is not necessary on most OSs, but it is needed
 Line 1743
 Line 1756
#endif  #endif

f!      ( r f_addr -- ) float   f_store  f!      ( r f_addr -- ) float   f_store

f@      ( f_addr -- r ) float   f_fetch  f@      ( f_addr -- r ) float   f_fetch

df@     ( df_addr -- r )        float-ext       d_f_fetch  df@     ( df_addr -- r )        float-ext       d_f_fetch
 Line 1759
 Line 1772
#endif  #endif

df!     ( r df_addr -- )        float-ext       d_f_store  df!     ( r df_addr -- )        float-ext       d_f_store
"" Store the double-precision IEEE floating-point value @i{r} to the address @i{df-addr}.""  ""Store @i{r} as double-precision IEEE floating-point value to the
#ifdef IEEE_FP  #ifdef IEEE_FP
#else  #else
 Line 1775
 Line 1789
#endif  #endif

sf!     ( r sf_addr -- )        float-ext       s_f_store  sf!     ( r sf_addr -- )        float-ext       s_f_store
"" Store the single-precision IEEE floating-point value @i{r} to the address @i{sf-addr}.""  ""Store @i{r} as single-precision IEEE floating-point value to the
#ifdef IEEE_FP  #ifdef IEEE_FP
#else  #else
 Line 1816
 Line 1831
ftuck   ( r1 r2 -- r2 r1 r2 )   gforth  f_tuck  ftuck   ( r1 r2 -- r2 r1 r2 )   gforth  f_tuck

"" Increment @i{f-addr1} by the number of address units corresponding to the size of  ""@code{1 floats +}.""
one floating-point number, to give @i{f-addr2}.""

floats  ( n1 -- n2 )    float  floats  ( n1 -- n2 )    float
""@i{n2} is the number of address units corresponding to @i{n1} floating-point numbers.""  ""@i{n2} is the number of address units of @i{n1} floats.""
n2 = n1*sizeof(Float);  n2 = n1*sizeof(Float);

floor   ( r1 -- r2 )    float  floor   ( r1 -- r2 )    float
 Line 2016
 Line 2030
r> IF  fnegate  THEN ;   r> IF  fnegate  THEN ;

sfloats ( n1 -- n2 )    float-ext       s_floats  sfloats ( n1 -- n2 )    float-ext       s_floats
""@i{n2} is the number of address units corresponding to @i{n1}  ""@i{n2} is the number of address units of @i{n1}
single-precision IEEE floating-point numbers.""  single-precision IEEE floating-point numbers.""
n2 = n1*sizeof(SFloat);  n2 = n1*sizeof(SFloat);

dfloats ( n1 -- n2 )    float-ext       d_floats  dfloats ( n1 -- n2 )    float-ext       d_floats
""@i{n2} is the number of address units corresponding to @i{n1}  ""@i{n2} is the number of address units of @i{n1}
double-precision IEEE floating-point numbers.""  double-precision IEEE floating-point numbers.""
n2 = n1*sizeof(DFloat);  n2 = n1*sizeof(DFloat);

 Line 2113
 Line 2127
*(Float *)lp = r;  *(Float *)lp = r;

fpick   ( u -- r )              gforth  fpick   ( u -- 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+1]; /* +1, because update of fp happens before this fragment */
:  :
floats fp@ + f@ ;   floats fp@ + f@ ;

Generate output suitable for use with a patch program
Legend:
 Removed from v.1.51 changed lines Added in v.1.52