[gforth] / gforth / Attic / primitives  

gforth: gforth/Attic/primitives

Diff for /gforth/Attic/primitives between version 1.28 and 1.37

version 1.28, Tue Jan 10 18:57:45 1995 UTC version 1.37, Fri Apr 14 18:56:58 1995 UTC
Line 86 
Line 86 
  ;   ;
   
 lit     -- w            fig  lit     -- w            fig
 w = (Cell)*ip++;  w = (Cell)NEXT_INST;
   INC_IP(1);
   
 execute         xt --           core,fig  execute         xt --           core,fig
   ip=IP;
 cfa = xt;  cfa = xt;
 IF_TOS(TOS = sp[0]);  IF_TOS(TOS = sp[0]);
 NEXT1;  NEXT1;
Line 96 
Line 98 
 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)NEXT_INST);
   NEXT_P0;
 :  :
  r> dup @ + >r ;   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 closed by the macro
 define(condbranch,  define(condbranch,
 $1      $2  $1      $2
 $3    goto branch;  $3      ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
           NEXT_P0;
           NEXT;
 }  }
 else  else
     ip++;      INC_IP(1);
   
 $1-lp+!#        $2_lp_plus_store_number  $1-lp+!#        $2_lp_plus_store_number
 $3    goto branch_adjust_lp;  $3    goto branch_adjust_lp;
 }  }
 else  else
     ip+=2;      INC_IP(2);
   
 )  )
   
Line 132 
Line 137 
 )  )
   
 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 171 
 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 209 
Line 214 
     goto branch;      goto branch;
     }      }
 else {  else {
     ip++;      INC_IP(1);
 }  }
   
 i       -- n            core,fig  i       -- n            core,fig
Line 608 
Line 613 
   
 ;s      --              fig     semis  ;s      --              fig     semis
 ip = (Xt *)(*rp++);  ip = (Xt *)(*rp++);
   NEXT_P0;
   
 >r      w --            core,fig        to_r  >r      w --            core,fig        to_r
 *--rp = w;  *--rp = w;
Line 780 
Line 786 
 wfileid=(Cell)popen(cstr(c_addr,u,1),mode[n]);  wfileid=(Cell)popen(cstr(c_addr,u,1),mode[n]);
   
 pclose  wfileid -- wior own  pclose  wfileid -- wior own
 wior=pclose((FILE *)wfileid);  wior=pclose((FILE *)wfileid); /* !! what to do with the result */
   
 time&date       -- nsec nmin nhour nday nmonth nyear    facility-ext    time_and_date  time&date       -- nsec nmin nhour nday nmonth nyear    facility-ext    time_and_date
 struct timeval time1;  struct timeval time1;
Line 803 
Line 809 
   
 allocate        u -- a_addr wior        memory  allocate        u -- a_addr wior        memory
 a_addr = (Cell *)malloc(u);  a_addr = (Cell *)malloc(u);
 wior = a_addr==NULL;    /* !! Define a return code */  wior = IOR(a_addr==NULL);
   
 free            a_addr -- wior          memory  free            a_addr -- wior          memory
 free(a_addr);  free(a_addr);
 wior = 0;  wior = 0;
   
 resize          a_addr1 u -- a_addr2 wior       memory  resize          a_addr1 u -- a_addr2 wior       memory
 a_addr2 = realloc(a_addr1, u);  ""Change the size of the allocated area at @i{a_addr1} to @i{u}
 wior = a_addr2==NULL;   /* !! Define a return code */  address units, possibly moving the contents to a different
   area. @i{a_addr2} is the address of the resulting area. If
   @code{a_addr2} is 0, gforth's (but not the standard) @code{resize}
   @code{allocate}s @i{u} address units.""
   /* the following check is not necessary on most OSs, but it is needed
      on SunOS 4.1.2. */
   if (a_addr1==NULL)
     a_addr2 = (Cell *)malloc(u);
   else
     a_addr2 = (Cell *)realloc(a_addr1, u);
   wior = IOR(a_addr2==NULL);      /* !! Define a return code */
   
 (f83find)       c_addr u f83name1 -- f83name2   new     paren_f83find  (f83find)       c_addr u f83name1 -- f83name2   new     paren_f83find
 for (; f83name1 != NULL; f83name1 = f83name1->next)  for (; f83name1 != NULL; f83name1 = f83name1->next)
Line 852 
Line 868 
 (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 904 
Line 920 
  REPEAT  THEN  nip - ;   REPEAT  THEN  nip - ;
   
 close-file      wfileid -- wior file    close_file  close-file      wfileid -- wior file    close_file
 wior = FILEIO(fclose((FILE *)wfileid)==EOF);  wior = IOR(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
 w2 = (Cell)fopen(cstr(c_addr, u, 1), fileattr[ntype]);  w2 = (Cell)fopen(cstr(c_addr, u, 1), fileattr[ntype]);
 wior =  FILEEXIST(w2 == NULL);  wior =  IOR(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 = open(cstr(c_addr, u, 1), O_CREAT|O_RDWR|O_TRUNC, 0666);
 if (fd > -1) {  if (fd != -1) {
   w2 = (Cell)fdopen(fd, fileattr[ntype]);    w2 = (Cell)fdopen(fd, fileattr[ntype]);
   assert(w2 != NULL);    wior = IOR(w2==NULL);
   wior = 0;  
 } else {  } else {
   assert(fd == -1);  
   wior = FILEIO(fd);  
   w2 = 0;    w2 = 0;
     wior = IOR(1);
 }  }
   
 delete-file     c_addr u -- wior                file    delete_file  delete-file     c_addr u -- wior                file    delete_file
 wior = FILEEXIST(unlink(cstr(c_addr, u, 1)));  wior = IOR(unlink(cstr(c_addr, u, 1))==-1);
   
 rename-file     c_addr1 u1 c_addr2 u2 -- wior   file-ext        rename_file  rename-file     c_addr1 u1 c_addr2 u2 -- wior   file-ext        rename_file
 char *s1=cstr(c_addr2, u2, 1);  char *s1=cstr(c_addr2, u2, 1);
 wior = FILEEXIST(rename(cstr(c_addr1, u1, 0), s1));  wior = IOR(rename(cstr(c_addr1, u1, 0), s1)==-1);
   
 file-position   wfileid -- ud wior      file    file_position  file-position   wfileid -- ud wior      file    file_position
 /* !! use tell and lseek? */  /* !! use tell and lseek? */
 ud = ftell((FILE *)wfileid);  ud = ftell((FILE *)wfileid);
 wior = 0; /* !! or wior = FLAG(ud<0) */  wior = IOR(ud==-1);
   
 reposition-file ud wfileid -- wior      file    reposition_file  reposition-file ud wfileid -- wior      file    reposition_file
 wior = FILEIO(fseek((FILE *)wfileid, (long)ud, SEEK_SET));  wior = IOR(fseek((FILE *)wfileid, (long)ud, SEEK_SET)==-1);
   
 file-size       wfileid -- ud wior      file    file_size  file-size       wfileid -- ud wior      file    file_size
 struct stat buf;  struct stat buf;
 wior = FILEEXIST(fstat(fileno((FILE *)wfileid), &buf));  wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1);
 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 = IOR(ftruncate(fileno((FILE *)wfileid), (Cell)ud)==-1);
   
 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 */
 u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid);  u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid);
 wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));  wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
 /* !! who performs clearerr((FILE *)wfileid); ? */  /* !! is the value of ferror errno-compatible? */
   if (wior)
     clearerr((FILE *)wfileid);
   
 read-line       c_addr u1 wfileid -- u2 flag wior       file    read_line  read-line       c_addr u1 wfileid -- u2 flag wior       file    read_line
 /*  /*
Line 970 
Line 986 
 */  */
 if ((flag=FLAG(!feof((FILE *)wfileid) &&  if ((flag=FLAG(!feof((FILE *)wfileid) &&
                fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) {                 fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) {
   wior=FILEIO(ferror((FILE *)wfileid));    wior=FILEIO(ferror((FILE *)wfileid)); /* !! ior? */
     if (wior)
       clearerr((FILE *)wfileid);
   u2 = strlen(c_addr);    u2 = strlen(c_addr);
   u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));    u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));
 }  }
Line 982 
Line 1000 
 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));
     if (wior)
       clearerr((FILE *)wfileid);
 }  }
   
 flush-file      wfileid -- wior         file-ext        flush_file  flush-file      wfileid -- wior         file-ext        flush_file
 wior = FILEIO(fflush((FILE *) wfileid));  wior = IOR(fflush((FILE *) wfileid)==EOF);
   
 comparisons(f, r1 r2, f_, r1, r2, new, new, float, new)  comparisons(f, r1 r2, f_, r1, r2, new, new, float, new)
 comparisons(f0, r, f_zero_, r, 0., float, new, float, new)  comparisons(f0, r, f_zero_, r, 0., float, new, float, new)
Line 1097 
Line 1117 
   
 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 1110 
Line 1130 
 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 1131 
Line 1151 
 {  {
         *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 1164 
Line 1184 
   
 fexpm1          r1 -- r2        float-ext  fexpm1          r1 -- r2        float-ext
 ""@i{r2}=@i{e}**@i{r1}@minus{}1""  ""@i{r2}=@i{e}**@i{r1}@minus{}1""
 r2 =  
 #ifdef HAVE_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
Line 1176 
Line 1196 
   
 flnp1           r1 -- r2        float-ext  flnp1           r1 -- r2        float-ext
 ""@i{r2}=ln(@i{r1}+1)""  ""@i{r2}=ln(@i{r1}+1)""
 r2 =  
 #ifdef HAVE_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""  ""the decimal logarithm""
 r2 = log10(r1);  r2 = log10(r1);
   
   falog           r1 -- r2        float-ext
   ""@i{r2}=10**@i{r1}""
   extern double pow10(double);
   r2 = pow10(r1);
   
 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 1199 
Line 1225 
   
 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 1248 
Line 1307 
   
 \ 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)NEXT_INST);
   INC_IP(1);
   
 @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 1263 
Line 1323 
 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)NEXT_INST);
   INC_IP(1);
   
 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 1273 
Line 1334 
   
 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)NEXT_INST);
   INC_IP(1);
   
 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)NEXT_INST;
   INC_IP(1);
   
 lp-     --      new     minus_four_lp_plus_store  lp-     --      new     minus_four_lp_plus_store
 lp += -sizeof(Cell);  lp += -sizeof(Cell);
Line 1303 
Line 1366 
   
 up!     a_addr --       new     up_store  up!     a_addr --       new     up_store
 up0=up=(char *)a_addr;  up0=up=(char *)a_addr;
   
   call-c  w --    new     call_c
   ""Call the C function pointed to by @i{w}. The C function has to
   access the stack itself. The stack pointers are exported in the gloabl
   variables @code{SP} and @code{FP}.""
   /* This is a first attempt at support for calls to C. This may change in
      the future */
   IF_FTOS(fp[0]=FTOS);
   FP=fp;
   SP=sp;
   ((void (*)())w)();
   sp=SP;
   fp=FP;
   IF_TOS(TOS=sp[0]);
   IF_FTOS(FTOS=fp[0]);
   
   strerror        n -- c_addr u   new
   c_addr = strerror(n);
   u = strlen(c_addr);

Generate output suitable for use with a patch program
Legend:
Removed from v.1.28  
changed lines
  Added in v.1.37
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help