[gforth] / gforth / Attic / primitives  

gforth: gforth/Attic/primitives

Diff for /gforth/Attic/primitives between version 1.26 and 1.33

version 1.26, Mon Dec 12 17:10:49 1994 UTC version 1.33, Thu Feb 2 18:13:09 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 */
 branch_adjust_lp:  branch_adjust_lp:
 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 109 
Line 109 
 \ 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
 define(condbranch,  define(condbranch,
 $1      $2  $1      $2
 $3    goto branch;  $3      ip = (Xt *)(((Cell)ip)+(Cell)*ip); NEXT;
 }  }
 else  else
     ip++;      ip++;
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  #ifndef 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 852 
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--)
    u2+=(int)toupper(*c_addr++);     u2+=(Cell)toupper(*c_addr++);
 :  :
  0 -rot bounds ?DO  I c@ toupper +  LOOP ;   0 -rot bounds ?DO  I c@ toupper +  LOOP ;
   
Line 911 
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) {
   w2 = (Cell)fdopen(fd, fileattr[ntype]);    w2 = (Cell)fdopen(fd, fileattr[ntype]);
Line 944 
Line 944 
 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));
   
 read-file       c_addr u1 wfileid -- u2 wior    file    read_file  read-file       c_addr u1 wfileid -- u2 wior    file    read_file
 /* !! fread does not guarantee enough */  /* !! fread does not guarantee enough */
Line 982 
Line 982 
 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 1046 
Line 1046 
 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 1068 
Line 1069 
 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  #ifdef HAVE_RINT
 r2 = rint(r1);  r2 = rint(r1);
Line 1094 
Line 1097 
   
 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=(r==0 ? 1 : decpt);
 f1=FLAG(flag!=0);  f1=FLAG(flag!=0);
 f2=FLAG(isdigit(sig[0])!=0);  f2=FLAG(isdigit(sig[0])!=0);
 memmove(c_addr,sig,u);  memmove(c_addr,sig,u);
Line 1107 
Line 1110 
 Float r;  Float r;
 char *number=cstr(c_addr, u, 1);  char *number=cstr(c_addr, u, 1);
 char *endconv;  char *endconv;
 while(isspace(number[u-1])) u--;  while(isspace(number[--u]) && u>0);
 switch(number[u-1])  switch(number[u])
 {  {
         case 'd':          case 'd':
         case 'D':          case 'D':
         case 'e':          case 'e':
         case 'E': u--; break;     case 'E':  break;
         default: break;     default :  u++; break;
 }  }
 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 1128 
Line 1131 
 {  {
         *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 1149 
Line 1152 
 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 1158 
Line 1163 
 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 1191 
Line 1212 
   
 ftan            r1 -- r2        float-ext  ftan            r1 -- r2        float-ext
 r2 = tan(r1);  r2 = tan(r1);
   :
    fsincos f/ ;
   
   fsinh           r1 -- r2        float-ext
   r2 = sinh(r1);
   :
    fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ;
   
   fcosh           r1 -- r2        float-ext
   r2 = cosh(r1);
   :
    fexp fdup 1/f f+ f2/ ;
   
   ftanh           r1 -- r2        float-ext
   r2 = tanh(r1);
   :
    f2* fexpm1 fdup 2. d>f f+ f/ ;
   
   fasinh          r1 -- r2        float-ext
   r2 = asinh(r1);
   :
    fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ;
   
   facosh          r1 -- r2        float-ext
   r2 = acosh(r1);
   :
    fdup fdup f* 1. d>f f- fsqrt f+ fln ;
   
   fatanh          r1 -- r2        float-ext
   r2 = atanh(r1);
   :
    fdup f0< >r fabs 1. d>f fover f- f/  f2* flnp1 f2/
    r> IF  fnegate  THEN ;
   
 \ The following words access machine/OS/installation-dependent ANSI  \ The following words access machine/OS/installation-dependent ANSI
 \   figForth internals  \   figForth internals
Line 1208 
Line 1262 
 >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 */
 a_addr = (Cell *)DOES_CODE(xt);  a_addr = (Cell *)DOES_CODE(xt);
Line 1240 
Line 1294 
   
 \ 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 1255 
Line 1309 
 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 1265 
Line 1319 
   
 laddr#          -- c_addr       new     laddr_number  laddr#          -- c_addr       new     laddr_number
 /* this can also be used to implement lp@ */  /* this can also be used to implement lp@ */
 c_addr = (Char *)(lp+(int)(*ip++));  c_addr = (Char *)(lp+(Cell)(*ip++));
   
 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.26  
changed lines
  Added in v.1.33
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help