[gforth] / gforth / Attic / primitives

# gforth: gforth/Attic/primitives

### Diff for /gforth/Attic/primitives between version 1.23 and 1.31

version 1.23, Thu Oct 27 16:32:22 1994 UTC version 1.31, Thu Jan 19 19:43:48 1995 UTC
 Line 96
 Line 96
branch-lp+!#    --      new     branch_lp_plus_store_number  branch-lp+!#    --      new     branch_lp_plus_store_number
/* this will probably not be used */  /* this will probably not be used */
lp += (int)(ip[1]);  lp += (Cell)(ip[1]);
goto branch;  goto branch;

branch  --              fig  branch  --              fig
branch:  branch:
ip = (Xt *)(((int)ip)+(int)*ip);  ip = (Xt *)(((Cell)ip)+(Cell)*ip);
:  :
r> dup @ + >r ;   r> dup @ + >r ;

 Line 132
 Line 132
)  )

condbranch((loop),--            fig     paren_loop,  condbranch((loop),--            fig     paren_loop,
int index = *rp+1;  Cell index = *rp+1;
int limit = rp[1];  Cell limit = rp[1];
if (index != limit) {  if (index != limit) {
*rp = index;      *rp = index;
)  )

condbranch((+loop),n --         fig     paren_plus_loop,  condbranch((+loop),n --         fig     paren_plus_loop,
/* !! check this thoroughly */  /* !! check this thoroughly */
int index = *rp;  Cell index = *rp;
/* 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];  Cell olddiff = index-rp[1];
#ifdef undefined  #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  #else
#ifndef MAXINT  #ifndef MAXINT
#define MAXINT ((1<<(8*sizeof(Cell)-1))-1)  #define MAXINT ((((Cell)1)<<(8*sizeof(Cell)-1))-1)
#endif  #endif
if(((olddiff^MAXINT) >= n) ^ ((olddiff+n) < 0)) {  if(((olddiff^MAXINT) >= n) ^ ((olddiff+n) < 0)) {
#endif  #endif
 Line 166
 Line 166
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 index = *rp;  Cell index = *rp;
int diff = index-rp[1];  Cell diff = index-rp[1];
int newdiff = diff+n;  Cell newdiff = diff+n;
if (n<0) {  if (n<0) {
diff = -diff;      diff = -diff;
newdiff = -newdiff;      newdiff = -newdiff;
 Line 269
 Line 269
?DO  dup I c!  LOOP  drop ;   ?DO  dup I c!  LOOP  drop ;

""Compare the strings lexicographically. If they are equal, n is 0; if
the first string is smaller, n is -1; if the first string is larger, n
is 1. Currently this is based on the machine's character
comparison. In the future, this may change to considering the current
locale and its collation order.""
if (n==0)  if (n==0)
n = u1-u2;    n = u1-u2;
 Line 601
 Line 606

;s      --              core    exit  ;s      --              fig     semis
ip = (Xt *)(*rp++);  ip = (Xt *)(*rp++);

>r      w --            core,fig        to_r  >r      w --            core,fig        to_r
 Line 749
 Line 754
:  :
1+ ;   1+ ;

(chars) n1 -- n2                core    cares  (chars)         n1 -- n2        gforth  paren_cares
n2 = n1 * sizeof(Char);  n2 = n1 * sizeof(Char);
:  :
;   ;
 Line 847
 Line 852
(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 ;   0 -rot bounds ?DO  I c@ toupper +  LOOP ;

 Line 906
 Line 911
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;  Cell    fd;
fd = creat(cstr(c_addr, u, 1), 0644);  fd = creat(cstr(c_addr, u, 1), 0644);
if (fd > -1) {  if (fd > -1) {
#ifdef __osf__
(void)close(fd);
w2 = (Cell)fopen(cstr(c_addr, u, 1), fileattr[ntype]);
#else
w2 = (Cell)fdopen(fd, fileattr[ntype]);    w2 = (Cell)fdopen(fd, fileattr[ntype]);
#endif
assert(w2 != NULL);    assert(w2 != NULL);
wior = 0;    wior = 0;
} else {  } else {
 Line 939
 Line 949
ud = buf.st_size;  ud = buf.st_size;

resize-file     ud wfileid -- wior      file    resize_file  resize-file     ud wfileid -- wior      file    resize_file
wior = FILEIO(ftruncate(fileno((FILE *)wfileid), (int)ud));  wior = FILEIO(ftruncate(fileno((FILE *)wfileid), (Cell)ud));

/* !! fread does not guarantee enough */  /* !! fread does not guarantee enough */
 Line 977
 Line 987
write-file      c_addr u1 wfileid -- wior       file    write_file  write-file      c_addr u1 wfileid -- wior       file    write_file
/* !! fwrite does not guarantee enough */  /* !! fwrite does not guarantee enough */
{  {
int u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);    Cell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));    wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
}  }

 Line 1041
 Line 1051
r3 = r1/r2;  r3 = r1/r2;

f**             r1 r2 -- r3     float-ext       f_star_star  f**             r1 r2 -- r3     float-ext       f_star_star
""@i{r3} is @i{r1} raised to the @i{r2}th power""
r3 = pow(r1,r2);  r3 = pow(r1,r2);

fnegate         r1 -- r2        float  fnegate         r1 -- r2        float
 Line 1063
 Line 1074
n2 = n1*sizeof(Float);  n2 = n1*sizeof(Float);

floor           r1 -- r2        float  floor           r1 -- r2        float
""round towards the next smaller integral value, i.e., round toward negative infinity""
/* !! unclear wording */  /* !! unclear wording */
r2 = floor(r1);  r2 = floor(r1);

fround          r1 -- r2        float  fround          r1 -- r2        float
""round to the nearest integral value""
/* !! unclear wording */  /* !! unclear wording */
#ifdef HAVE_RINT
r2 = rint(r1);  r2 = rint(r1);
#else
r2 = floor(r1+0.5);
/* !! This is not quite true to the rounding rules given in the standard */
#endif

fmax            r1 r2 -- r3     float  fmax            r1 r2 -- r3     float
if (r1<r2)  if (r1<r2)
 Line 1084
 Line 1102

represent               r c_addr u -- n f1 f2   float  represent               r c_addr u -- n f1 f2   float
char *sig;  char *sig;
int flag;  Cell flag;
int decpt;  Cell decpt;
sig=ecvt(r, u, &decpt, &flag);  sig=ecvt(r, u, &decpt, &flag);
n=decpt;  n=decpt;
f1=FLAG(flag!=0);  f1=FLAG(flag!=0);
 Line 1108
 Line 1126
}  }
number[u]='\0';  number[u]='\0';
r=strtod(number,&endconv);  r=strtod(number,&endconv);
if((flag=FLAG(!(int)*endconv)))  if((flag=FLAG(!(Cell)*endconv)))
{  {
IF_FTOS(fp[0] = FTOS);          IF_FTOS(fp[0] = FTOS);
fp += -1;          fp += -1;
 Line 1118
 Line 1136
{  {
*endconv='E';          *endconv='E';
r=strtod(number,&endconv);          r=strtod(number,&endconv);
if((flag=FLAG(!(int)*endconv)))          if((flag=FLAG(!(Cell)*endconv)))
{          {
IF_FTOS(fp[0] = FTOS);                  IF_FTOS(fp[0] = FTOS);
fp += -1;                  fp += -1;
 Line 1139
 Line 1157
r2 = atan(r1);  r2 = atan(r1);

fatan2          r1 r2 -- r3     float-ext  fatan2          r1 r2 -- r3     float-ext
""@i{r1/r2}=tan@i{r3}. The standard does not require, but probably
intends this to be the inverse of @code{fsincos}. In gforth it is.""
r3 = atan2(r1,r2);  r3 = atan2(r1,r2);

fcos            r1 -- r2        float-ext  fcos            r1 -- r2        float-ext
 Line 1148
 Line 1168
r2 = exp(r1);  r2 = exp(r1);

fexpm1          r1 -- r2        float-ext  fexpm1          r1 -- r2        float-ext
r2 =  ""@i{r2}=@i{e}**@i{r1}@minus{}1""
#ifdef HAS_EXPM1  #ifdef HAVE_EXPM1
expm1(r1);  extern double expm1(double);
r2 = expm1(r1);
#else  #else
exp(r1)-1;  r2 = exp(r1)-1.;
#endif  #endif

fln             r1 -- r2        float-ext  fln             r1 -- r2        float-ext
r2 = log(r1);  r2 = log(r1);

flnp1           r1 -- r2        float-ext  flnp1           r1 -- r2        float-ext
r2 =  ""@i{r2}=ln(@i{r1}+1)""
#ifdef HAS_LOG1P  #ifdef HAVE_LOG1P
log1p(r1);  extern double log1p(double);
r2 = log1p(r1);
#else  #else
log(r1+1);  r2 = log(r1+1.);
#endif  #endif

flog            r1 -- r2        float-ext  flog            r1 -- r2        float-ext
""the decimal logarithm""
r2 = log10(r1);  r2 = log10(r1);

falog           r1 -- r2        float-ext
""@i{r2}=10**@i{r1}""
#ifdef HAVE_POW10
extern double pow10(double);
r2 = pow10(r1);
#else
#ifndef M_LN10
#define M_LN10      2.30258509299404568402
#endif
r2 = exp(r1*M_LN10);
#endif

fsin            r1 -- r2        float-ext  fsin            r1 -- r2        float-ext
r2 = sin(r1);  r2 = sin(r1);

fsincos         r1 -- r2 r3     float-ext  fsincos         r1 -- r2 r3     float-ext
""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})""
r2 = sin(r1);  r2 = sin(r1);
r3 = cos(r1);  r3 = cos(r1);

 Line 1182
 Line 1218
ftan            r1 -- r2        float-ext  ftan            r1 -- r2        float-ext
r2 = tan(r1);  r2 = tan(r1);

fsinh           r1 -- r2        float-ext
r2 = sinh(r1);

fcosh           r1 -- r2        float-ext
r2 = cosh(r1);

ftanh           r1 -- r2        float-ext
r2 = tanh(r1);

fasinh          r1 -- r2        float-ext
r2 = asinh(r1);

facosh          r1 -- r2        float-ext
r2 = acosh(r1);

fatanh          r1 -- r2        float-ext
r2 = atanh(r1);

\ The following words access machine/OS/installation-dependent ANSI  \ The following words access machine/OS/installation-dependent ANSI
\   figForth internals  \   figForth internals
 Line 1198
 Line 1252
>does-code      xt -- a_addr            new     to_does_code  >does-code      xt -- a_addr            new     to_does_code
""If xt ist the execution token of a defining-word-defined word,  ""If xt ist the execution token of a defining-word-defined word,
a_addr is the start of the Forth code after the DOES>; Otherwise the  a_addr is the start of the Forth code after the DOES>; Otherwise the
behaviour is uundefined""  behaviour is undefined""
/* !! 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 1230
 Line 1284

\ local variable implementation primitives  \ local variable implementation primitives
@local#         -- w    new     fetch_local_number  @local#         -- w    new     fetch_local_number
w = *(Cell *)(lp+(int)(*ip++));  w = *(Cell *)(lp+(Cell)(*ip++));

@local0 -- w    new     fetch_local_zero  @local0 -- w    new     fetch_local_zero
w = *(Cell *)(lp+0*sizeof(Cell));  w = *(Cell *)(lp+0*sizeof(Cell));
 Line 1245
 Line 1299
w = *(Cell *)(lp+3*sizeof(Cell));  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+(Cell)(*ip++));

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

/* this can also be used to implement lp@ */  /* this can also be used to implement lp@ */

lp+!#   --      new     lp_plus_store_number  lp+!#   --      new     lp_plus_store_number
""used with negative immediate values it allocates memory on the  ""used with negative immediate values it allocates memory on the
local stack, a positive immediate argument drops memory from the local  local stack, a positive immediate argument drops memory from the local
stack""  stack""
lp += (int)(*ip++);  lp += (Cell)(*ip++);

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

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