Diff for /gforth/prim between versions 1.50 and 1.59

version 1.50, 2000/07/30 19:56:05 version 1.59, 2000/09/09 20:32:58
Line 121  IF_TOS(TOS = sp[0]); Line 121  IF_TOS(TOS = sp[0]);
EXEC(xt);  EXEC(xt);

perform ( a_addr -- )   gforth  perform ( a_addr -- )   gforth
""Equivalent to @code{@ execute}.""  ""@code{@@ execute}.""
/* and pfe */  /* and pfe */
ip=IP;  ip=IP;
IF_TOS(TOS = sp[0]);  IF_TOS(TOS = sp[0]);
Line 445  n = rp[4]; Line 445  n = rp[4];
\ 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  while (u-- > 0) Line 476  while (u-- > 0)
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  else Line 600  else
:  :
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  n3 = n1%n2; /* !! is this correct? look Line 630  n3 = n1%n2; /* !! is this correct? look
>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  d2 = -d1; Line 779  d2 = -d1;
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  d2 = 2*d1; Line 790  d2 = 2*d1;
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 814  w2 = ~w1; Line 819  w2 = ~w1;
MAXU xor ;   MAXU xor ;

rshift  ( u1 n -- u2 )          core    r_shift  rshift  ( u1 n -- u2 )          core    r_shift
""Logical shift right by @i{n} bits.""
u2 = u1>>n;    u2 = u1>>n;
:  :
0 ?DO 2/ MAXI and LOOP ;      0 ?DO 2/ MAXI and LOOP ;
Line 939  about this word is to consider the numbe Line 945  about this word is to consider the numbe
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< ;
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  tuck ( w1 w2 -- w2 w1 w2 ) core-ext Line 1063  tuck ( w1 w2 -- w2 w1 w2 ) core-ext
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  if (w!=0) { Line 1075  if (w!=0) {
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  w = sp[u+1]; Line 1111  w = sp[u+1];
\ 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] ]
: 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  c! ( c c_addr -- )  core c_store Line 1181  c! ( c c_addr -- )  core c_store
: 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  n2 = n1 * sizeof(Cell); Line 1213  n2 = n1 * sizeof(Cell);
drop ] ;   drop ] ;

"" Increment @i{c-addr1} by the number of address units corresponding to the size of  ""@code{1 chars +}.""
:  :
1+ ;   1+ ;
Line 1209  n2 = n1 * sizeof(Char); Line 1224  n2 = n1 * sizeof(Char);
;   ;

"" If @i{c-add1} is the address of a counted string return the length of  ""@i{c-addr2} is the first character and @i{u} the length of the
:  :
@ ;      @ ;

>does-code      ( xt -- a_addr )                gforth  to_does_code  >does-code      ( xt -- a_addr )                gforth  to_does_code
""If @i{xt} is the execution token of a defining-word-defined word,  ""If @i{xt} is the execution token of a child of a @code{DOES>} word,
@i{a-addr} is the start of the Forth code after the @code{DOES>};  @i{a-addr} is the start of the Forth code after the @code{DOES>};
Line 1379  CACHE_FLUSH(xt,(size_t)PFA(0)); Line 1394  CACHE_FLUSH(xt,(size_t)PFA(0));
! ;      ! ;

does-code!      ( a_addr xt -- )                gforth  does_code_store  does-code!      ( a_addr xt -- )                gforth  does_code_store
""Create a code field at @i{xt} for a defining-word-defined word; @i{a-addr}  ""Create a code field at @i{xt} for a child of a @code{DOES>}-word;
is the start of the Forth code after @code{DOES>}.""  @i{a-addr} is the start of the Forth code after @code{DOES>}.""
CACHE_FLUSH(xt,(size_t)PFA(0));  CACHE_FLUSH(xt,(size_t)PFA(0));
:  :
dodoes: over ! cell+ ! ;      dodoes: over ! cell+ ! ;

does-handler!   ( a_addr -- )   gforth  does_handler_store  does-handler!   ( a_addr -- )   gforth  does_handler_store
just behind a @code{DOES>}.""  @i{a-addr} points just behind a @code{DOES>}.""
:  :
Line 1489  in length."" Line 1504  in length.""

open-pipe       ( c_addr u ntype -- wfileid wior )      gforth  open_pipe  open-pipe       ( c_addr u wfam -- wfileid wior )       gforth  open_pipe
wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[ntype]); /* ~ expansion of 1st arg? */  wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[wfam]); /* ~ expansion of 1st arg? */
wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */  wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */

close-pipe      ( wfileid -- wretval wior )             gforth  close_pipe  close-pipe      ( wfileid -- wretval wior )             gforth  close_pipe
Line 1504  struct timeval time1; Line 1519  struct timeval time1;
struct timezone zone1;  struct timezone zone1;
struct tm *ltime;  struct tm *ltime;
gettimeofday(&time1,&zone1);  gettimeofday(&time1,&zone1);
/* !! Single Unix specification:
If tzp is not a null pointer, the behaviour is unspecified. */
ltime=localtime((time_t *)&time1.tv_sec);  ltime=localtime((time_t *)&time1.tv_sec);
nyear =ltime->tm_year+1900;  nyear =ltime->tm_year+1900;
nmonth=ltime->tm_mon+1;  nmonth=ltime->tm_mon+1;
Line 1524  allocate ( u -- a_addr wior ) memory Line 1541  allocate ( u -- a_addr wior ) memory
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;

""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 1583  IF_FTOS(FTOS=fp[0]); Line 1599  IF_FTOS(FTOS=fp[0]);
close-file      ( wfileid -- wior )             file    close_file  close-file      ( wfileid -- wior )             file    close_file
wior = IOR(fclose((FILE *)wfileid)==EOF);  wior = IOR(fclose((FILE *)wfileid)==EOF);

open-file       ( c_addr u ntype -- wfileid wior )      file    open_file  open-file       ( c_addr u wfam -- wfileid wior )       file    open_file
wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]);  wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[wfam]);
wior =  IOR(wfileid == 0);  wior =  IOR(wfileid == 0);

create-file     ( c_addr u ntype -- wfileid wior )      file    create_file  create-file     ( c_addr u wfam -- wfileid wior )       file    create_file
Cell    fd;  Cell    fd;
fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[ntype], 0666);  fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[wfam], 0666);
if (fd != -1) {  if (fd != -1) {
wfileid = (Cell)fdopen(fd, fileattr[ntype]);    wfileid = (Cell)fdopen(fd, fileattr[wfam]);
wior = IOR(wfileid == 0);    wior = IOR(wfileid == 0);
} else {  } else {
wfileid = 0;    wfileid = 0;
Line 1630  wior = FILEIO(u2<u1 && ferror((FILE *)wf Line 1646  wior = FILEIO(u2<u1 && ferror((FILE *)wf
if (wior)  if (wior)
clearerr((FILE *)wfileid);    clearerr((FILE *)wfileid);

#if 1  #if 1
Cell c;  Cell c;
flag=-1;  flag=-1;
u3=0;
for(u2=0; u2<u1; u2++)  for(u2=0; u2<u1; u2++)
{  {
c = getc((FILE *)wfileid);     c = getc((FILE *)wfileid);
u3++;
if (c=='\n') break;     if (c=='\n') break;
if (c=='\r') {     if (c=='\r') {
if ((c = getc((FILE *)wfileid))!='\n')       if ((c = getc((FILE *)wfileid))!='\n')
ungetc(c,(FILE *)wfileid);         ungetc(c,(FILE *)wfileid);
else
u3++;
break;       break;
}     }
if (c==EOF) {     if (c==EOF) {
Line 1694  PUTC(c); Line 1714  PUTC(c);
flush-file      ( wfileid -- wior )             file-ext        flush_file  flush-file      ( wfileid -- wior )             file-ext        flush_file
wior = IOR(fflush((FILE *) wfileid)==EOF);  wior = IOR(fflush((FILE *) wfileid)==EOF);

file-status     ( c_addr u -- ntype wior )      file-ext        file_status  file-status     ( c_addr u -- wfam wior )       file-ext        file_status
if (access (filename, F_OK) != 0) {  if (access (filename, F_OK) != 0) {
ntype=0;    wfam=0;
wior=IOR(1);    wior=IOR(1);
}  }
else if (access (filename, R_OK | W_OK) == 0) {  else if (access (filename, R_OK | W_OK) == 0) {
ntype=2; /* r/w */    wfam=2; /* r/w */
wior=0;    wior=0;
}  }
else if (access (filename, R_OK) == 0) {  else if (access (filename, R_OK) == 0) {
ntype=0; /* r/o */    wfam=0; /* r/o */
wior=0;    wior=0;
}  }
else if (access (filename, W_OK) == 0) {  else if (access (filename, W_OK) == 0) {
ntype=4; /* w/o */    wfam=4; /* w/o */
wior=0;    wior=0;
}  }
else {  else {
ntype=1; /* well, we cannot access the file, but better deliver a legal    wfam=1; /* well, we cannot access the file, but better deliver a legal
access mode (r/o bin), so we get a decent error later upon open. */              access mode (r/o bin), so we get a decent error later upon open. */
wior=0;    wior=0;
}  }
Line 1741  d = r; Line 1761  d = r;
#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
"" Fetch the double-precision IEEE floating-point value @i{r} from the address @i{df-addr}.""  ""Fetch the double-precision IEEE floating-point value @i{r} from the address @i{df-addr}.""
#ifdef IEEE_FP  #ifdef IEEE_FP
#else  #else
#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 1765  df! ( r df_addr -- ) float-ext d_f_store Line 1786  df! ( r df_addr -- ) float-ext d_f_store
#endif  #endif

sf@     ( sf_addr -- r )        float-ext       s_f_fetch  sf@     ( sf_addr -- r )        float-ext       s_f_fetch
"" Fetch the single-precision IEEE floating-point value @i{r} from the address @i{sf-addr}.""  ""Fetch the single-precision IEEE floating-point value @i{r} from the address @i{sf-addr}.""
#ifdef IEEE_FP  #ifdef IEEE_FP
#else  #else
#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 1814  fnip ( r1 r2 -- r2 ) gforth f_nip Line 1836  fnip ( r1 r2 -- r2 ) gforth f_nip
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 1860  f2=FLAG(isdigit((unsigned)(sig[0]))!=0); Line 1881  f2=FLAG(isdigit((unsigned)(sig[0]))!=0);

>float  ( c_addr u -- flag )    float   to_float  >float  ( c_addr u -- flag )    float   to_float
""Attempt to convert the character string @i{c-addr u} to  ""Actual stack effect: ( c_addr u -- r t | f ).  Attempt to convert the
internal floating-point representation. If the string  character string @i{c-addr u} to internal floating-point
represents a valid floating-point number @i{r} is placed  representation. If the string represents a valid floating-point number
on the floating-point stack and @i{flag} is true. Otherwise,  @i{r} is placed on the floating-point stack and @i{flag} is
@i{flag} is false. A string of blanks is a special case  true. Otherwise, @i{flag} is false. A string of blanks is a special
and represents the floating-point number 0.""  case and represents the floating-point number 0.""
/* real signature: c_addr u -- r t / f */  /* real signature: c_addr u -- r t / f */
Float r;  Float r;
Line 2014  r2 = atanh(r1); Line 2035  r2 = atanh(r1);
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);

:  :
[ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ;   [ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ;

:  :
Line 2111  lp -= sizeof(Float); Line 2132  lp -= sizeof(Float);
*(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@ ;
u=sizeof(newline);  u=sizeof(newline);
:  :
"newline count ;   "newline count ;
Create "newline 1 c, \$0A c,  Create "newline e? crlf [IF] 2 c, \$0D c, [ELSE] 1 c, [THEN] \$0A c,

\+os

utime   ( -- dtime )    gforth
""Report the current time in microseconds since some epoch.""
struct timeval time1;
gettimeofday(&time1,NULL);
dtime = timeval2us(&time1);

cputime ( -- duser dsystem ) gforth
""duser and dsystem are the respective user- and system-level CPU
times used since the start of the Forth system (excluding child
processes), in microseconds (the granularity may be much larger,
however).  On platforms without the getrusage call, it reports elapsed
time (since some epoch) for duser and 0 for dsystem.""
#ifdef HAVE_GETRUSAGE
struct rusage usage;
getrusage(RUSAGE_SELF, &usage);
duser = timeval2us(&usage.ru_utime);
dsystem = timeval2us(&usage.ru_stime);
#else
struct timeval time1;
gettimeofday(&time1,NULL);
duser = timeval2us(&time1);
#ifndef BUGGY_LONG_LONG
dsystem = (DCell)0;
#else
dsystem=(DCell){0,0};
#endif
#endif

\+

\+floating

v*      ( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star
""dot-product: r=v1*v2.  The first element of v1 is at f_addr1, the
next at f_addr1+nstride1 and so on (similar for v2). Both vectors have
ucount elements.""
for (r=0.; ucount>0; ucount--) {
}
:
>r swap 2swap swap 0e r> 0 ?DO
dup f@ over + 2swap dup f@ f* f+ over + 2swap
LOOP 2drop 2drop ;

faxpy   ( ra f_x nstridex f_y nstridey ucount -- )      gforth
""vy=ra*vx+vy""
for (; ucount>0; ucount--) {
*f_y += ra * *f_x;