[gforth] / gforth / Attic / primitives

# gforth: gforth/Attic/primitives

### Diff for /gforth/Attic/primitives between version 1.13 and 1.21

version 1.13, Thu Jul 21 10:52:48 1994 UTC version 1.21, Tue Oct 18 15:51:21 1994 UTC
 Line 70
 Line 70

noop    --              fig  noop    --              fig
;  ;
:
;

lit     -- w            fig  lit     -- w            fig
w = (Cell)*ip++;  w = (Cell)*ip++;
 Line 88
 Line 90
branch  --              fig  branch  --              fig
branch:  branch:
ip = (Xt *)(((int)ip)+(int)*ip);  ip = (Xt *)(((int)ip)+(int)*ip);
:
r> dup @ + >r ;

\ condbranch(forthname,restline,code)  \ condbranch(forthname,restline,code)
\ this is non-syntactical: code must open a brace that is close by the macro  \ this is non-syntactical: code must open a brace that is close by the macro
 Line 125
 Line 129
condbranch((+loop),n --         fig     paren_plus_loop,  condbranch((+loop),n --         fig     paren_plus_loop,
/* !! check this thoroughly */  /* !! check this thoroughly */
int index = *rp;  int index = *rp;
int olddiff = index-rp[1];
/* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */  /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
/* dependent upon two's complement arithmetic */  /* dependent upon two's complement arithmetic */
int olddiff = index-rp[1];
#ifdef undefined
if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */  if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */
|| (olddiff^n)>=0          /* it is a wrap-around effect */) {      || (olddiff^n)>=0          /* it is a wrap-around effect */) {
#else
#ifndef MAXINT
#define MAXINT ((1<<(8*sizeof(Cell)-1))-1)
#endif
if(((olddiff^MAXINT) >= n) ^ ((olddiff+n) < 0)) {
#endif
#ifdef i386
*rp += n;
#else
*rp = index+n;      *rp = index+n;
#endif
IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
)  )

 Line 139
 Line 154
crosses the boundary between limit and limit-sign(n). I.e. a symmetric  crosses the boundary between limit and limit-sign(n). I.e. a symmetric
version of (+LOOP).""  version of (+LOOP).""
/* !! check this thoroughly */  /* !! check this thoroughly */
int oldindex = *rp;  int index = *rp;
int diff = oldindex-rp[1];  int diff = index-rp[1];
int newdiff = diff+n;  int newdiff = diff+n;
if (n<0) {  if (n<0) {
diff = -diff;      diff = -diff;
newdiff = - newdiff;      newdiff = - newdiff;
}  }
if (diff>=0 || newdiff<0) {  if (diff>=0 || newdiff<0) {
*rp = oldindex+n;  #ifdef i386
*rp += n;
#else
*rp = index + n;
#endif
IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
)  )

unloop          --      core  unloop          --      core
rp += 2;  rp += 2;
:
r> rdrop rdrop >r ;

(for)   ncount --               cmFORTH         paren_for  (for)   ncount --               cmFORTH         paren_for
/* or (for) = >r -- collides with unloop! */  /* or (for) = >r -- collides with unloop! */
*--rp = 0;  *--rp = 0;
*--rp = ncount;  *--rp = ncount;
:
r> swap 0 >r >r >r ;

(do)    nlimit nstart --                fig             paren_do  (do)    nlimit nstart --                fig             paren_do
/* or do it in high-level? 0.09/0.23% */  /* or do it in high-level? 0.09/0.23% */
 Line 193
 Line 216
emitcounter += n;  emitcounter += n;

key     -- n            fig  (key)   -- n            fig     paren_key
fflush(stdout);  fflush(stdout);
/* !! noecho */  /* !! noecho */
n = key();  n = key();
 Line 204
 Line 227

cr      --              fig  cr      --              fig
puts("");  puts("");
:
\$0A emit ;

move    c_from c_to ucount --           core  move    c_from c_to ucount --           core
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? */
:
>r 2dup u< IF r> cmove> ELSE r> cmove THEN ;

cmove   c_from c_to u --        string  cmove   c_from c_to u --        string
while (u-- > 0)  while (u-- > 0)
*c_to++ = *c_from++;    *c_to++ = *c_from++;
:
bounds ?DO  dup c@ I c! 1+  LOOP  drop ;

cmove>  c_from c_to u --        string  c_move_up  cmove>  c_from c_to u --        string  c_move_up
while (u-- > 0)  while (u-- > 0)
c_to[u] = c_from[u];    c_to[u] = c_from[u];
:
dup 0= IF  drop 2drop exit  THEN
rot over + -rot bounds swap 1-
DO  1- dup c@ I c!  -1 +LOOP  drop ;

fill    c_addr u c --   core  fill    c_addr u c --   core
:
-rot bounds
?DO  dup I c!  LOOP  drop ;

 Line 228
 Line 264
n = -1;    n = -1;
else if (n>0)  else if (n>0)
n = 1;    n = 1;
:
rot 2dup - >r min swap -text dup
IF    rdrop
ELSE  drop r@ 0>
IF    rdrop -1
ELSE  r> 1 and
THEN
THEN ;

 Line 235
 Line 279
n = -1;    n = -1;
else if (n>0)  else if (n>0)
n = 1;    n = 1;
:
swap bounds
?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0
ELSE  c@ I c@ - unloop  THEN  -text-flag ;
: -text-flag ( n -- -1/0/1 )
dup 0< IF  drop -1  ELSE  0>  IF  1  ELSE  0  THEN  THEN  ;

Char c1, c2;  Char c1, c2;
 Line 253
 Line 303
break;      break;
}    }
}  }
:
swap bounds
?DO  dup c@ toupper I c@ toupper = WHILE  1+  LOOP  drop 0
ELSE  c@ toupper I c@ toupper - unloop  THEN  -text-flag ;

u2 = u1;  u2 = u1;
u2--;    u2--;
:
BEGIN  1- 2dup + c@ bl =  WHILE
dup  0= UNTIL  ELSE  1+  THEN ;

u2 = u1-n;  u2 = u1-n;
:
tuck - >r + r> dup 0< IF  - 0  THEN ;

+       n1 n2 -- n              core,fig        plus  +       n1 n2 -- n              core,fig        plus
n = n1+n2;  n = n1+n2;

-       n1 n2 -- n              core,fig        minus  -       n1 n2 -- n              core,fig        minus
n = n1-n2;  n = n1-n2;
:
negate + ;

negate  n1 -- n2                core,fig  negate  n1 -- n2                core,fig
/* use minus as alias */  /* use minus as alias */
n2 = -n1;  n2 = -n1;
:
invert 1+ ;

1+      n1 -- n2                core            one_plus  1+      n1 -- n2                core            one_plus
n2 = n1+1;  n2 = n1+1;
:
1 + ;

1-      n1 -- n2                core            one_minus  1-      n1 -- n2                core            one_minus
n2 = n1-1;  n2 = n1-1;
:
1 - ;

max     n1 n2 -- n      core  max     n1 n2 -- n      core
if (n1<n2)  if (n1<n2)
 Line 285
 Line 352
else  else
n = n1;    n = n1;
:  :
2dup < if   2dup < IF swap THEN drop ;
swap drop
else
drop
endif ;

min     n1 n2 -- n      core  min     n1 n2 -- n      core
if (n1<n2)  if (n1<n2)
n = n1;    n = n1;
else  else
n = n2;    n = n2;
:
2dup > IF swap THEN drop ;

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

*       n1 n2 -- n              core,fig        star  *       n1 n2 -- n              core,fig        star
n = n1*n2;  n = n1*n2;
:
um* drop ;

/       n1 n2 -- n              core,fig        slash  /       n1 n2 -- n              core,fig        slash
n = n1/n2;  n = n1/n2;
:
/mod nip ;

mod     n1 n2 -- n              core  mod     n1 n2 -- n              core
n = n1%n2;  n = n1%n2;
:
/mod drop ;

/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! */
:
>r s>d r> fm/mod ;

2*      n1 -- n2                core            two_star  2*      n1 -- n2                core            two_star
n2 = 2*n1;  n2 = 2*n1;
:
dup + ;

2/      n1 -- n2                core            two_slash  2/      n1 -- n2                core            two_slash
/* !! is this still correct? */  /* !! is this still correct? */
 Line 344
 Line 421
n3++;    n3++;
n2-=n1;    n2-=n1;
}  }
:
over >r dup >r abs -rot
dabs rot um/mod
r> 0< IF       negate       THEN
r> 0< IF  swap negate swap  THEN ;

m*      n1 n2 -- d              core    m_star  m*      n1 n2 -- d              core    m_star
d = (DCell)n1 * (DCell)n2;  d = (DCell)n1 * (DCell)n2;
:
2dup      0< and >r
2dup swap 0< and >r
um* r> - r> - ;

um*     u1 u2 -- ud             core    u_m_star  um*     u1 u2 -- ud             core    u_m_star
/* use u* as alias */  /* use u* as alias */
 Line 355
 Line 441
um/mod  ud u1 -- u2 u3          core    u_m_slash_mod  um/mod  ud u1 -- u2 u3          core    u_m_slash_mod
u3 = ud/u1;  u3 = ud/u1;
u2 = ud%u1;  u2 = ud%u1;
:
dup IF  0 (um/mod)  THEN  nip ;
: (um/mod)  ( ud ud--ud u)
2dup >r >r  dup 0<
IF    2drop 0
ELSE  2dup d+  (um/mod)  2*  THEN
-rot  r> r> 2over 2over  du<
IF    2drop rot
ELSE  dnegate  d+  rot 1+  THEN ;

m+      d1 n -- d2              double          m_plus  m+      d1 n -- d2              double          m_plus
d2 = d1+n;  d2 = d1+n;
:
s>d d+ ;

d+      d1 d2 -- d              double,fig      d_plus  d+      d1 d2 -- d              double,fig      d_plus
d = d1+d2;  d = d1+d2;
:
>r swap >r over 2/ over 2/ + >r over 1 and over 1 and + 2/
r> + >r + r> 0< r> r> + swap - ;

d-      d1 d2 -- d              double          d_minus  d-      d1 d2 -- d              double          d_minus
d = d1-d2;  d = d1-d2;
:
dnegate d+ ;

dnegate d1 -- d2                double  dnegate d1 -- d2                double
/* use dminus as alias */  /* use dminus as alias */
d2 = -d1;  d2 = -d1;
:
invert swap negate tuck 0= - ;

dmax    d1 d2 -- d      double  dmax    d1 d2 -- d      double
if (d1<d2)  if (d1<d2)
d = d2;    d = d2;
else  else
d = d1;    d = d1;
:
2over 2over d> IF  2swap  THEN 2drop ;

dmin    d1 d2 -- d      double  dmin    d1 d2 -- d      double
if (d1<d2)  if (d1<d2)
d = d1;    d = d1;
else  else
d = d2;    d = d2;
:
2over 2over d< IF  2swap  THEN 2drop ;

dabs    d1 -- d2        double  dabs    d1 -- d2        double
if (d1<0)  if (d1<0)
d2 = -d1;    d2 = -d1;
else  else
d2 = d1;    d2 = d1;
:
dup 0< IF dnegate THEN ;

d2*     d1 -- d2                double          d_two_star  d2*     d1 -- d2                double          d_two_star
d2 = 2*d1;  d2 = 2*d1;
:
2dup d+ ;

d2/     d1 -- d2                double          d_two_slash  d2/     d1 -- d2                double          d_two_slash
/* !! is this still correct? */  /* !! is this still correct? */
d2 = d1>>1;  d2 = d1>>1;
:
dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] Literal and
r> IF  [ 1 8 cells 1- lshift ] Literal + THEN  swap ;

d>s     d -- n                  double          d_to_s  d>s     d -- n                  double          d_to_s
/* make this an alias for drop? */  /* make this an alias for drop? */
n = d;  n = d;
:
drop ;

and     w1 w2 -- w              core,fig  and     w1 w2 -- w              core,fig
w = w1&w2;  w = w1&w2;
 Line 409
 Line 526

invert  w1 -- w2                core  invert  w1 -- w2                core
w2 = ~w1;  w2 = ~w1;
:
-1 xor ;

rshift  u1 n -- u2              core  rshift  u1 n -- u2              core
u2 = u1>>n;    u2 = u1>>n;
 Line 448
 Line 567

within  u1 u2 u3 -- f           core-ext  within  u1 u2 u3 -- f           core-ext
f = FLAG(u1-u2 < u3-u2);  f = FLAG(u1-u2 < u3-u2);
:
over - >r - r> u< ;

/* works with and without TOS caching */  /* works with and without TOS caching */

 Line 488
 Line 609
i'      -- w            fig             i_tick  i'      -- w            fig             i_tick
w=rp[1];  w=rp[1];

2>r     w1 w2 --        core-ext        two_to_r
*--rp = w1;
*--rp = w2;

2r>     -- w1 w2        core-ext        two_r_from
w2 = *rp++;
w1 = *rp++;

2r@     -- w1 w2        core-ext        two_r_fetch
w2 = rp[0];
w1 = rp[1];

2rdrop  --              new     two_r_drop
rp+=2;

over    w1 w2 -- w1 w2 w1               core,fig  over    w1 w2 -- w1 w2 w1               core,fig

drop    w --            core,fig  drop    w --            core,fig
 Line 499
 Line 635
rot     w1 w2 w3 -- w2 w3 w1    core    rote  rot     w1 w2 w3 -- w2 w3 w1    core    rote

-rot    w1 w2 w3 -- w3 w1 w2    fig     not_rote  -rot    w1 w2 w3 -- w3 w1 w2    fig     not_rote
:
rot rot ;

nip     w1 w2 -- w2             core-ext  nip     w1 w2 -- w2             core-ext
:
swap drop ;

tuck    w1 w2 -- w2 w1 w2       core-ext  tuck    w1 w2 -- w2 w1 w2       core-ext
:
swap over ;

?dup    w -- w                  core    question_dupe  ?dup    w -- w                  core    question_dupe
if (w!=0) {  if (w!=0) {
 Line 511
 Line 653
*--sp = w;    *--sp = w;
#endif  #endif
}  }
:
dup IF dup THEN ;

pick    u -- w                  core-ext  pick    u -- w                  core-ext
w = sp[u+1];  w = sp[u+1];
:
1+ cells sp@ + @ ;

2drop   w1 w2 --                core    two_drop  2drop   w1 w2 --                core    two_drop
:
drop drop ;

2dup    w1 w2 -- w1 w2 w1 w2    core    two_dupe  2dup    w1 w2 -- w1 w2 w1 w2    core    two_dupe
:
over over ;

2over   w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2        core    two_over  2over   w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2        core    two_over
:
3 pick 3 pick ;

2swap   w1 w2 w3 w4 -- w3 w4 w1 w2      core    two_swap  2swap   w1 w2 w3 w4 -- w3 w4 w1 w2      core    two_swap
:
>r -rot r> -rot ;

2rot    w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2  double  two_rote  2rot    w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2  double  two_rote
:
>r >r 2swap r> r> 2swap ;

\ toggle is high-level: 0.11/0.42%  \ toggle is high-level: 0.11/0.42%

 Line 545
 Line 701
2!      w1 w2 a_addr --         core    two_store  2!      w1 w2 a_addr --         core    two_store
:
tuck ! cell+ ! ;

2@      a_addr -- w1 w2         core    two_fetch  2@      a_addr -- w1 w2         core    two_fetch
:
dup cell+ @ swap @ ;

d!      d a_addr --             double  d_store  d!      d a_addr --             double  d_store
/* !! alignment problems on some machines */  /* !! alignment problems on some machines */
 Line 559
 Line 719

:
[ cell ] Literal + ;

cells   n1 -- n2                core  cells   n1 -- n2                core
n2 = n1 * sizeof(Cell);  n2 = n1 * sizeof(Cell);
:
[ cell ]
[ 2/ dup ] [IF] 2* [THEN]
[ 2/ dup ] [IF] 2* [THEN]
[ 2/ dup ] [IF] 2* [THEN]
[ 2/ dup ] [IF] 2* [THEN]
[ drop ] ;

:
1+ ;

chars   n1 -- n2                core    cares  chars   n1 -- n2                core    cares
n2 = n1 * sizeof(Char);  n2 = n1 * sizeof(Char);
:
;

:
dup 1+ swap c@ ;

(bye)   n --    toolkit-ext     paren_bye  (bye)   n --    toolkit-ext     paren_bye
deprep_terminal();  return (Label *)n;
exit(n);

system  c_addr u -- n   own  system  c_addr u -- n   own

popen   c_addr u n -- wfileid   own  popen   c_addr u n -- wfileid   own
char pname[u+1];
static char* mode[2]={"r","w"};  static char* mode[2]={"r","w"};
wfileid=(Cell)popen(pname,mode[n]);

pclose  wfileid -- wior own  pclose  wfileid -- wior own
wior=pclose((FILE *)wfileid);  wior=pclose((FILE *)wfileid);

time&date       -- nyear nmonth nday nhour nmin nsec    ansi    time_and_date  time&date       -- nsec nmin nhour nday nmonth nyear    facility-ext    time_and_date
struct timeval time1;  struct timeval time1;
struct timezone zone1;  struct timezone zone1;
struct tm *ltime;  struct tm *ltime;
gettimeofday(&time1,&zone1);  gettimeofday(&time1,&zone1);
ltime=localtime(&time1.tv_sec);  ltime=localtime(&time1.tv_sec);
nyear =ltime->tm_year+1900;  nyear =ltime->tm_year+1900;
nmonth=ltime->tm_mon;  nmonth=ltime->tm_mon+1;
nday  =ltime->tm_mday;  nday  =ltime->tm_mday;
nhour =ltime->tm_hour;  nhour =ltime->tm_hour;
nmin  =ltime->tm_min;  nmin  =ltime->tm_min;
nsec  =ltime->tm_sec;  nsec  =ltime->tm_sec;

ms      n --    ansi  ms      n --    facility-ext
struct timeval timeout;  struct timeval timeout;
timeout.tv_sec=n/1000;  timeout.tv_sec=n/1000;
timeout.tv_usec=1000*(n%1000);  timeout.tv_usec=1000*(n%1000);
 Line 628
 Line 802
strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)        strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
break;      break;
f83name2=f83name1;  f83name2=f83name1;
:
BEGIN  dup  WHILE
>r dup r@ cell+ c@ \$1F and =
IF  2dup r@ cell+ char+ capscomp  0=
IF  2drop r>  EXIT  THEN  THEN
r> @
REPEAT  nip nip ;

F83Name *f83name1;  F83Name *f83name1;
 Line 643
 Line 824
break;          break;
}       }
}  }
:
BEGIN  dup  WHILE
2@ >r >r dup r@ cell+ c@ \$1F and =
IF  2dup r@ cell+ char+ capscomp 0=
IF  2drop r> rdrop  EXIT  THEN  THEN
rdrop r>
REPEAT nip nip ;

(hashkey)       c_addr u1 -- u2 new     paren_hashkey  (hashkey)       c_addr u1 -- u2 new     paren_hashkey
u2=0;  u2=0;
while(u1--)  while(u1--)
:
0 -rot bounds ?DO  I c@ toupper +  LOOP ;

(hashkey1)      c_addr u ubits -- ukey          new     paren_hashkey1
""ukey is the hash key for the string c_addr u fitting in ubits bits""
/* this hash function rotates the key at every step by rot bits within
ubits bits and xors it with the character. This function does ok in
the chi-sqare-test.  Rot should be <=7 (preferably <=5) for
ASCII strings (larger if ubits is large), and should share no
divisors with ubits.
*/
unsigned rot = ((char []){5,0,1,2,3,4,5,5,5,5,3,5,5,5,5,7,5,5,5,5,7,5,5,5,5,6,5,5,5,5,7,5,5})[ubits];
ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))
^ toupper(*cp))
& ((1<<ubits)-1));
:
dup rot-values + c@ over 1 swap lshift 1- >r
tuck - 2swap r> 0 2swap bounds
?DO  dup 4 pick lshift swap 3 pick rshift or
I c@ toupper xor
over and  LOOP
nip nip nip ;
Create rot-values
5 c, 0 c, 1 c, 2 c, 3 c,  4 c, 5 c, 5 c, 5 c, 5 c,
3 c, 5 c, 5 c, 5 c, 5 c,  7 c, 5 c, 5 c, 5 c, 5 c,
7 c, 5 c, 5 c, 5 c, 5 c,  6 c, 5 c, 5 c, 5 c, 5 c,
7 c, 5 c, 5 c,

/* use !isgraph instead of isspace? */  /* use !isgraph instead of isspace? */
 Line 663
 Line 880
u2 = 0;    u2 = 0;
}  }
:
BEGIN  dup  WHILE  over c@ bl <=  WHILE  1 /string
REPEAT  THEN  2dup
BEGIN  dup  WHILE  over c@ bl >   WHILE  1 /string
REPEAT  THEN  nip - ;

close-file      wfileid -- wior file    close_file  close-file      wfileid -- wior file    close_file
wior = FILEIO(fclose((FILE *)wfileid)==EOF);  wior = FILEIO(fclose((FILE *)wfileid)==EOF);

open-file       c_addr u ntype -- w2 wior       file    open_file  open-file       c_addr u ntype -- w2 wior       file    open_file
char fname[u+1];  w2 = (Cell)fopen(cstr(c_addr, u, 1), fileattr[ntype]);
w2 = (Cell)fopen(fname, fileattr[ntype]);
wior =  FILEEXIST(w2 == NULL);  wior =  FILEEXIST(w2 == NULL);

create-file     c_addr u ntype -- w2 wior       file    create_file  create-file     c_addr u ntype -- w2 wior       file    create_file
int     fd;  int     fd;
char fname[u+1];  fd = creat(cstr(c_addr, u, 1), 0644);
fd = creat(fname, 0666);
if (fd > -1) {  if (fd > -1) {
w2 = (Cell)fdopen(fd, fileattr[ntype]);    w2 = (Cell)fdopen(fd, fileattr[ntype]);
assert(w2 != NULL);    assert(w2 != NULL);
 Line 689
 Line 907
}  }

delete-file     c_addr u -- wior                file    delete_file  delete-file     c_addr u -- wior                file    delete_file

char fname1[u1+1];  char *s1=cstr(c_addr2, u2, 1);
char fname2[u2+1];  wior = FILEEXIST(rename(cstr(c_addr1, u1, 0), s1));
wior = FILEEXIST(rename(fname1, fname2));

file-position   wfileid -- ud wior      file    file_position  file-position   wfileid -- ud wior      file    file_position
/* !! use tell and lseek? */  /* !! use tell and lseek? */
 Line 870
 Line 1083
>float  c_addr u -- flag        float   to_float  >float  c_addr u -- flag        float   to_float
/* real signature: c_addr u -- r t / f */  /* real signature: c_addr u -- r t / f */
Float r;  Float r;
char number[u+1];  char *number=cstr(c_addr, u, 1);
char *endconv;  char *endconv;
r=strtod(number,&endconv);  r=strtod(number,&endconv);
if((flag=FLAG(!(int)*endconv)))  if((flag=FLAG(!(int)*endconv)))
{  {
 Line 915
 Line 1127

fexpm1          r1 -- r2        float-ext  fexpm1          r1 -- r2        float-ext
r2 =  r2 =
#ifdef expm1  #ifdef HAS_EXPM1
expm1(r1);          expm1(r1);
#else  #else
exp(r1)-1;          exp(r1)-1;
 Line 926
 Line 1138

flnp1           r1 -- r2        float-ext  flnp1           r1 -- r2        float-ext
r2 =  r2 =
#ifdef log1p  #ifdef HAS_LOG1P
log1p(r1);          log1p(r1);
#else  #else
log(r1+1);          log(r1+1);
 Line 967
 Line 1179
behaviour is uundefined""  behaviour is uundefined""
/* !! there is currently no way to determine whether a word is  /* !! there is currently no way to determine whether a word is
defining-word-defined */  defining-word-defined */

 Line 999
 Line 1211
w = *(Cell *)(lp+(int)(*ip++));  w = *(Cell *)(lp+(int)(*ip++));

@local0 -- w    new     fetch_local_zero  @local0 -- w    new     fetch_local_zero
w = *(Cell *)(lp+0);  w = *(Cell *)(lp+0*sizeof(Cell));

@local4 -- w    new     fetch_local_four  @local1 -- w    new     fetch_local_four
w = *(Cell *)(lp+4);  w = *(Cell *)(lp+1*sizeof(Cell));

@local8 -- w    new     fetch_local_eight  @local2 -- w    new     fetch_local_eight
w = *(Cell *)(lp+8);  w = *(Cell *)(lp+2*sizeof(Cell));

@local12        -- w    new     fetch_local_twelve  @local3 -- w    new     fetch_local_twelve
w = *(Cell *)(lp+12);  w = *(Cell *)(lp+3*sizeof(Cell));

f@local#        -- r    new     f_fetch_local_number  f@local#        -- r    new     f_fetch_local_number
r = *(Float *)(lp+(int)(*ip++));  r = *(Float *)(lp+(int)(*ip++));

f@local0        -- r    new     f_fetch_local_zero  f@local0        -- r    new     f_fetch_local_zero
r = *(Float *)(lp+0);  r = *(Float *)(lp+0*sizeof(Float));

f@local8        -- r    new     f_fetch_local_eight  f@local1        -- r    new     f_fetch_local_eight
r = *(Float *)(lp+8);  r = *(Float *)(lp+1*sizeof(Float));

/* this can also be used to implement lp@ */  /* this can also be used to implement lp@ */
 Line 1029
 Line 1241
stack""  stack""
lp += (int)(*ip++);  lp += (int)(*ip++);

-4lp+!  --      new     minus_four_lp_plus_store  lp-     --      new     minus_four_lp_plus_store
lp += -4;  lp += -sizeof(Cell);

8lp+!   --      new     eight_lp_plus_store  lp+     --      new     eight_lp_plus_store
lp += 8;  lp += sizeof(Float);

16lp+!  --      new     sixteen_lp_plus_store  lp+2    --      new     sixteen_lp_plus_store
lp += 16;  lp += 2*sizeof(Float);

 Line 1050
 Line 1262
*(Float *)lp = r;  *(Float *)lp = r;