[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 */
 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 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         c_addr1 u1 c_addr2 u2 -- n      string  compare         c_addr1 u1 c_addr2 u2 -- n      string
   ""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.""
 n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);  n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
 if (n==0)  if (n==0)
   n = u1-u2;    n = u1-u2;
Line 601 
Line 606 
 fp!     f_addr --       new     fp_store  fp!     f_addr --       new     fp_store
 fp = f_addr;  fp = f_addr;
   
 ;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--)
    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 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));
   
 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 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
 \ !! how about environmental queries DIRECT-THREADED,  \ !! how about environmental queries DIRECT-THREADED,
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 */
 a_addr = (Cell *)DOES_CODE(xt);  a_addr = (Cell *)DOES_CODE(xt);
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 
   
 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.23  
changed lines
  Added in v.1.31
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help