Diff for /gforth/engine/support.c between versions 1.20 and 1.51

version 1.20, 2007/02/15 13:48:26 version 1.51, 2012/12/31 15:25:19
Line 1 Line 1
 /* Gforth support functions  /* Gforth support functions
   
   Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2006 Free Software Foundation, Inc.    Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2006,2007,2008,2009,2010,2011,2012 Free Software Foundation, Inc.
   
   This file is part of Gforth.    This file is part of Gforth.
   
   Gforth is free software; you can redistribute it and/or    Gforth is free software; you can redistribute it and/or
   modify it under the terms of the GNU General Public License    modify it under the terms of the GNU General Public License
   as published by the Free Software Foundation; either version 2    as published by the Free Software Foundation, either version 3
   of the License, or (at your option) any later version.    of the License, or (at your option) any later version.
   
   This program is distributed in the hope that it will be useful,    This program is distributed in the hope that it will be useful,
Line 15 Line 15
   GNU General Public License for more details.    GNU General Public License for more details.
   
   You should have received a copy of the GNU General Public License    You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software    along with this program; if not, see http://www.gnu.org/licenses/.
   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.  
 */  */
   
 #include "config.h"  #include "config.h"
Line 27 Line 26
 #include <sys/time.h>  #include <sys/time.h>
 #include <unistd.h>  #include <unistd.h>
 #include <pwd.h>  #include <pwd.h>
   #include <assert.h>
   #ifndef STANDALONE
 #include <dirent.h>  #include <dirent.h>
 #include <math.h>  #include <math.h>
 #include <ctype.h>  #include <ctype.h>
 #include <errno.h>  #include <errno.h>
   #include <sys/types.h>
   #include <sys/stat.h>
   #include <fcntl.h>
   #include <time.h>
   #endif
   #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */
   #include <dlfcn.h>
   #endif
   
 #ifdef HAS_FILE  #ifdef HAS_FILE
 char *cstr(Char *from, UCell size, int clear)  char *cstr(Char *from, UCell size)
 /* return a C-string corresponding to the Forth string ( FROM SIZE ).  /* return a C-string corresponding to the Forth string ( FROM SIZE ).
    the C-string lives until the next call of cstr with CLEAR being true */     the C-string lives until free */
 {  {
   static struct cstr_buffer {    char * string = malloc(size+1);
     char *buffer;    memcpy(string,from,size);
     size_t size;    string[size]='\0';
   } *buffers=NULL;    return string;
   static int nbuffers=0;  
   static int used=0;  
   struct cstr_buffer *b;  
   
   if (buffers==NULL)  
     buffers=malloc(0);  
   if (clear)  
     used=0;  
   if (used>=nbuffers) {  
     buffers=realloc(buffers,sizeof(struct cstr_buffer)*(used+1));  
     buffers[used]=(struct cstr_buffer){malloc(0),0};  
     nbuffers=used+1;  
   }  
   b=&buffers[used];  
   if (size+1 > b->size) {  
     b->buffer = realloc(b->buffer,size+1);  
     b->size = size+1;  
   }  
   memcpy(b->buffer,from,size);  
   b->buffer[size]='\0';  
   used++;  
   return b->buffer;  
 }  }
   
 char *tilde_cstr(Char *from, UCell size, int clear)  char *tilde_cstr(Char *from, UCell size)
 /* like cstr(), but perform tilde expansion on the string */  /* like cstr(), but perform tilde expansion on the string */
 {  {
   char *s1,*s2;    char *s1,*s2;
Line 73  char *tilde_cstr(Char *from, UCell size, Line 60  char *tilde_cstr(Char *from, UCell size,
   struct passwd *getpwnam (), *user_entry;    struct passwd *getpwnam (), *user_entry;
   
   if (size<1 || from[0]!='~')    if (size<1 || from[0]!='~')
     return cstr(from, size, clear);      return cstr(from, size);
   if (size<2 || from[1]=='/') {    if (size<2 || from[1]=='/') {
     s1 = (char *)getenv ("HOME");      s1 = (char *)getenv ("HOME");
     if(s1 == NULL)      if(s1 == NULL)
Line 91  char *tilde_cstr(Char *from, UCell size, Line 78  char *tilde_cstr(Char *from, UCell size,
     for (i=1; i<size && from[i]!='/'; i++)      for (i=1; i<size && from[i]!='/'; i++)
       ;        ;
     if (i==2 && from[1]=='+') /* deal with "~+", i.e., the wd */      if (i==2 && from[1]=='+') /* deal with "~+", i.e., the wd */
       return cstr(from+3, size<3?0:size-3,clear);        return cstr(from+3, size<3?0:size-3);
     {      {
       char user[i];        char user[i];
       memcpy(user,from+1,i-1);        memcpy(user,from+1,i-1);
Line 99  char *tilde_cstr(Char *from, UCell size, Line 86  char *tilde_cstr(Char *from, UCell size,
       user_entry=getpwnam(user);        user_entry=getpwnam(user);
     }      }
     if (user_entry==NULL)      if (user_entry==NULL)
       return cstr(from, size, clear);        return cstr(from, size);
     s1 = user_entry->pw_dir;      s1 = user_entry->pw_dir;
     s2 = (char *)from+i;      s2 = (char *)from+i;
     s2_len = size-i;      s2_len = size-i;
Line 111  char *tilde_cstr(Char *from, UCell size, Line 98  char *tilde_cstr(Char *from, UCell size,
     char path[s1_len+s2_len];      char path[s1_len+s2_len];
     memcpy(path,s1,s1_len);      memcpy(path,s1,s1_len);
     memcpy(path+s1_len,s2,s2_len);      memcpy(path+s1_len,s2,s2_len);
     return cstr((Char *)path,s1_len+s2_len,clear);      return cstr((Char *)path,s1_len+s2_len);
   }    }
 }  }
 #endif  
   Cell opencreate_file(char *s, Cell wfam, int flags, Cell *wiorp)
   {
     Cell fd;
     Cell wfileid;
     fd = open(s, flags|ufileattr[wfam], 0666);
     if (fd != -1) {
       wfileid = (Cell)fdopen(fd, fileattr[wfam]);
       *wiorp = IOR(wfileid == 0);
     } else {
       wfileid = 0;
       *wiorp = IOR(1);
     }
     return wfileid;
   }
   #endif /* defined(HAS_FILE) */
   
 DCell timeval2us(struct timeval *tvp)  DCell timeval2us(struct timeval *tvp)
 {  {
Line 129  DCell timeval2us(struct timeval *tvp) Line 131  DCell timeval2us(struct timeval *tvp)
 #endif  #endif
 }  }
   
   DCell timespec2ns(struct timespec *tvp)
   {
   #ifndef BUGGY_LONG_LONG
     return (tvp->tv_sec*(DCell)1000000000LL)+tvp->tv_nsec;
   #else
     DCell d2;
     DCell d1=mmul(tvp->tv_sec,1000000000);
     d2.lo = d1.lo+tvp->tv_nsec;
     d2.hi = d1.hi + (d2.lo<d1.lo);
     return d2;
   #endif
   }
   
 DCell double2ll(Float r)  DCell double2ll(Float r)
 {  {
 #ifndef BUGGY_LONG_LONG  #ifndef BUGGY_LONG_LONG
Line 282  struct Cellpair parse_white(Char *c_addr Line 297  struct Cellpair parse_white(Char *c_addr
   return result;    return result;
 }  }
   
   #ifdef HAS_FILE
 Cell rename_file(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2)  Cell rename_file(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2)
 {  {
   char *s1=tilde_cstr(c_addr2, u2, 1);    char *s1=tilde_cstr(c_addr2, u2);
   return IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);    char *s2=tilde_cstr(c_addr1, u1);
     return IOR(rename(s2, s1)==-1);
     free(s1);
     free(s2);
 }  }
   
 struct Cellquad read_line(Char *c_addr, UCell u1, Cell wfileid)  struct Cellquad read_line(Char *c_addr, UCell u1, FILE *wfileid)
 {  {
   UCell u2, u3;    UCell u2, u3;
   Cell flag, wior;    Cell flag, wior;
Line 297  struct Cellquad read_line(Char *c_addr, Line 316  struct Cellquad read_line(Char *c_addr,
   
   flag=-1;    flag=-1;
   u3=0;    u3=0;
     if (u1>0)
       gf_regetc(wfileid);
   for(u2=0; u2<u1; u2++) {    for(u2=0; u2<u1; u2++) {
     c = getc((FILE *)wfileid);      c = getc(wfileid);
     u3++;      u3++;
     if (c=='\n') break;      if (c=='\n') break;
     if (c=='\r') {      if (c=='\r') {
       if ((c = getc((FILE *)wfileid))!='\n')        if ((c = getc(wfileid))!='\n')
         ungetc(c,(FILE *)wfileid);          gf_ungetc(c,wfileid);
       else        else
         u3++;          u3++;
       break;        break;
Line 314  struct Cellquad read_line(Char *c_addr, Line 335  struct Cellquad read_line(Char *c_addr,
     }      }
     c_addr[u2] = (Char)c;      c_addr[u2] = (Char)c;
   }    }
   wior=FILEIO(ferror((FILE *)wfileid));    wior=FILEIO(ferror(wfileid));
   r.n1 = u2;    r.n1 = u2;
   r.n2 = flag;    r.n2 = flag;
   r.n3 = u3;    r.n3 = u3;
Line 327  struct Cellpair file_status(Char *c_addr Line 348  struct Cellpair file_status(Char *c_addr
   struct Cellpair r;    struct Cellpair r;
   Cell wfam;    Cell wfam;
   Cell wior;    Cell wior;
   char *filename=tilde_cstr(c_addr, u, 1);    char *filename=tilde_cstr(c_addr, u);
   
   if (access (filename, F_OK) != 0) {    if (access (filename, F_OK) != 0) {
     wfam=0;      wfam=0;
Line 353  struct Cellpair file_status(Char *c_addr Line 374  struct Cellpair file_status(Char *c_addr
   }    }
   r.n1 = wfam;    r.n1 = wfam;
   r.n2 = wior;    r.n2 = wior;
     free(filename);
   return r;    return r;
 }  }
   
 Cell to_float(Char *c_addr, UCell u, Float *rp)  Cell to_float(Char *c_addr, UCell u, Float *rp, Char dot)
 {  {
   Float r;    /* convertible string := <significand>[<exponent>]
   Cell flag;       <significand> := [<sign>]{<digits>[.<digits0>] | .<digits> }
   char *number=cstr(c_addr, u, 1);       <exponent>    := <marker><digits0>
        <marker>      := {<e-form> | <sign-form>}
        <e-form>      := <e-char>[<sign-form>]
        <sign-form>   := { + | - }
        <e-char>      := { D | d | E | e }
     */
     Char *s = c_addr;
     Char c;
     Char *send = c_addr+u;
     UCell ndigits = 0;
     UCell ndots = 0;
     UCell edigits = 0;
     char cnum[u+3]; /* append at most "e0\0" */
     char *t=cnum;
   char *endconv;    char *endconv;
   int sign = 0;    Float r;
   if(number[0]==' ') {    
     UCell i;    if (s >= send) /* treat empty string as 0e */
     for (i=1; i<u; i++)      goto return0;
       if (number[i] != ' ')    switch ((c=*s)) {
         return 0;    case ' ':
     *rp = 0.0;      /* "A string of blanks should be treated as a special case
     return -1;         representing zero."*/
   }      for (s++; s<send; )
   if(number[0]=='-') {        if (*s++ != ' ')
     sign = 1;          goto error;
     number++;      goto return0;
     u--;    case '-':
     if (u==0)    case '+': *t++ = c; s++; goto aftersign;
       return 0;    }
   }    aftersign: 
   switch(number[u-1]) {    if (s >= send)
   case 'd':      goto exponent;
     if((c=*s)==dot) { *t++ = '.'; ndots++; s++; goto aftersign; }
     switch (c) {
     case '0' ... '9': *t++ = c; ndigits++; s++; goto aftersign;
     default:                                    goto exponent;
     }
    exponent:
     if (ndigits < 1 || ndots > 1)
       goto error;
     *t++ = 'E';
     if (s >= send)
       goto done;
     switch (c=*s) {
   case 'D':    case 'D':
   case 'e':    case 'd':
   case 'E':      case 'E':
     u--;    case 'e': s++; break;
     break;  
   }  
   number[u]='\0';  
   r=strtod(number,&endconv);  
   flag=FLAG((*endconv)=='\0');  
   if(flag) {  
     if (sign)  
       r = -r;  
   } else if(*endconv=='d' || *endconv=='D') {  
     *endconv='E';  
     r=strtod(number,&endconv);  
     flag=FLAG((*endconv)=='\0');  
     if (flag) {  
       if (sign)  
         r = -r;  
     }  
   }    }
     if (s >= send)
       goto done;
     switch (c=*s) {
     case '+':
     case '-': *t++ = c; s++; break;
     }
    edigits0:
     if (s >= send)
       goto done;
     switch (c=*s) {
     case '0' ... '9': *t++ = c; s++; edigits++; goto edigits0;
     default: goto error;
     }
    done:
     if (edigits == 0)
       *t++ = '0';
     *t++ = '\0';
     assert(t-cnum <= u+3);
     r = strtod(cnum, &endconv);
     assert(*endconv == '\0');
   *rp = r;    *rp = r;
   return flag;    return -1;
    return0:
     *rp = 0.0;
     return -1;
    error:
     *rp = 0.0;
     return 0;
 }  }
   #endif
   
   #ifdef HAS_FLOATING
 Float v_star(Float *f_addr1, Cell nstride1, Float *f_addr2, Cell nstride2, UCell ucount)  Float v_star(Float *f_addr1, Cell nstride1, Float *f_addr2, Cell nstride2, UCell ucount)
 {  {
   Float r;    Float r;
Line 425  void faxpy(Float ra, Float *f_x, Cell ns Line 484  void faxpy(Float ra, Float *f_x, Cell ns
     f_y = (Float *)(((Address)f_y)+nstridey);      f_y = (Float *)(((Address)f_y)+nstridey);
   }    }
 }  }
   #endif
   
 UCell lshift(UCell u1, UCell n)  UCell lshift(UCell u1, UCell n)
 {  {
Line 436  UCell rshift(UCell u1, UCell n) Line 496  UCell rshift(UCell u1, UCell n)
   return u1 >> n;    return u1 >> n;
 }  }
   
   #ifndef STANDALONE
 int gforth_system(Char *c_addr, UCell u)  int gforth_system(Char *c_addr, UCell u)
 {  {
   int retval;    int retval;
   char *prefix = getenv("GFORTHSYSTEMPREFIX") ? : DEFAULTSYSTEMPREFIX;    char *prefix = getenv("GFORTHSYSTEMPREFIX") ? : DEFAULTSYSTEMPREFIX;
   size_t prefixlen = strlen(prefix);    size_t prefixlen = strlen(prefix);
   char buffer[prefixlen+u+1];    char buffer[prefixlen+u+1];
     int MAYBE_UNUSED old_tp;
     fflush(stdout);
 #ifndef MSDOS  #ifndef MSDOS
   int old_tp=terminal_prepped;    old_tp=terminal_prepped;
   deprep_terminal();    deprep_terminal();
 #endif  #endif
   memcpy(buffer,prefix,prefixlen);    memcpy(buffer,prefix,prefixlen);
Line 457  int gforth_system(Char *c_addr, UCell u) Line 520  int gforth_system(Char *c_addr, UCell u)
   return retval;    return retval;
 }  }
   
   void gforth_ms(UCell u)
   {
   #ifdef HAVE_NANOSLEEP
     struct timespec time_req;
     time_req.tv_sec=u/1000;
     time_req.tv_nsec=1000000*(u%1000);
     while(nanosleep(&time_req, &time_req));
   #else /* !defined(HAVE_NANOSLEEP) */
     struct timeval timeout;
     timeout.tv_sec=u/1000;
     timeout.tv_usec=1000*(u%1000);
     (void)select(0,0,0,0,&timeout);
   #endif /* !defined(HAVE_NANOSLEEP) */
   }
   
   UCell gforth_dlopen(Char *c_addr, UCell u)
   {
     char * file=tilde_cstr(c_addr, u);
     UCell lib;
   #if defined(HAVE_LIBLTDL)
     lib = (UCell)lt_dlopen(file);
     free(file);
     if(lib) return lib;
   #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
   #ifndef RTLD_GLOBAL
   #define RTLD_GLOBAL 0
   #endif
     lib = (UCell)dlopen(file, RTLD_GLOBAL);
     free(file);
     if(lib) return lib;
     fprintf(stderr, "%s\n", dlerror());
   #elif defined(_WIN32)
     lib = (UCell) GetModuleHandle(file);
     free(file);
     if(lib) return lib;
   #endif
     return 0;
   }
   
   #endif /* !defined(STANDALONE) */
   
   
 /* mixed division support; should usually be faster than gcc's  /* mixed division support; should usually be faster than gcc's
    double-by-double division (and gcc typically does not generate     double-by-double division (and gcc typically does not generate
    double-by-single division because of exception handling issues. If     double-by-single division because of exception handling issues. If
Line 485  typedef UDCell UDWtype; Line 590  typedef UDCell UDWtype;
   
 #include "longlong.h"  #include "longlong.h"
   
   
   #if defined(udiv_qrnnd) && !defined(__alpha) && UDIV_NEEDS_NORMALIZATION
   
   #if defined(count_leading_zeros)
   const UQItype __clz_tab[256] =
   {
     0,1,2,2,3,3,3,3,4,4,4,4,4,4,4,4,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,
     6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,
     7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
     7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
     8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
     8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
     8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
     8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8
   };
   #endif
   
 static Cell MAYBE_UNUSED nlz(UCell x)  static Cell MAYBE_UNUSED nlz(UCell x)
      /* number of leading zeros, adapted from "Hacker's Delight" */       /* number of leading zeros, adapted from "Hacker's Delight" */
 {  {
Line 496  static Cell MAYBE_UNUSED nlz(UCell x) Line 618  static Cell MAYBE_UNUSED nlz(UCell x)
 #if defined(count_leading_zeros)  #if defined(count_leading_zeros)
    count_leading_zeros(n,x);     count_leading_zeros(n,x);
 #else  #else
 #warning "count_leading_zeros undefined (should not happen)"  
    n = 0;     n = 0;
 #if (SIZEOF_CHAR_P > 4)  #if (SIZEOF_CHAR_P > 4)
    if (x <= 0xffffffff) {n+=32; x <<= 32;}     if (x <= 0xffffffff) 
 #error this can't be correct       n+=32;
      else
        x >>= 32;
 #endif  #endif
    if (x <= 0x0000FFFF) {n = n +16; x = x <<16;}     if (x <= 0x0000FFFF) {n = n +16; x = x <<16;}
    if (x <= 0x00FFFFFF) {n = n + 8; x = x << 8;}     if (x <= 0x00FFFFFF) {n = n + 8; x = x << 8;}
Line 510  static Cell MAYBE_UNUSED nlz(UCell x) Line 633  static Cell MAYBE_UNUSED nlz(UCell x)
 #endif  #endif
    return n;     return n;
 }  }
   #endif /*defined(udiv_qrnnd) && !defined(__alpha) && UDIV_NEEDS_NORMALIZATION*/
   
 #if !defined(ASM_UM_SLASH_MOD)  #if !defined(ASM_UM_SLASH_MOD)
 UDCell umdiv (UDCell u, UCell v)  UDCell umdiv (UDCell u, UCell v)
Line 517  UDCell umdiv (UDCell u, UCell v) Line 641  UDCell umdiv (UDCell u, UCell v)
    Return quotient in lo, remainder in hi. */     Return quotient in lo, remainder in hi. */
 {  {
   UDCell res;    UDCell res;
 #if defined(udiv_qrnnd)  #if defined(udiv_qrnnd) && !defined(__alpha)
   #if 0
      This code is slower on an Alpha (timings with gcc-3.3.5):
             other     this
      */      5205 ms  5741 ms 
      */mod   5167 ms  5717 ms 
      fm/mod  5467 ms  5312 ms 
      sm/rem  4734 ms  5278 ms 
      um/mod  4490 ms  5020 ms 
      m*/    15557 ms 17151 ms
   #endif /* 0 */
   UCell q,r,u0,u1;    UCell q,r,u0,u1;
   UCell MAYBE_UNUSED lz;    UCell MAYBE_UNUSED lz;
       
Line 537  UDCell umdiv (UDCell u, UCell v) Line 671  UDCell umdiv (UDCell u, UCell v)
   r >>= lz;    r >>= lz;
 #endif  #endif
   vm_twoCell2ud(q,r,res);    vm_twoCell2ud(q,r,res);
 #else /* !(defined(udiv_qrnnd) */  #else /* !(defined(udiv_qrnnd) && !defined(__alpha)) */
 #warning "udiv_qrnnd undefined (should not happen)"  
   /* simple restoring subtract-and-shift algorithm, might be faster on Alpha */    /* simple restoring subtract-and-shift algorithm, might be faster on Alpha */
   int i = CELL_BITS, c = 0;    int i = CELL_BITS, c = 0;
   UCell q = 0;    UCell q = 0;
   Ucell h, l;    UCell h, l;
   
   vm_ud2twoCell(u,l,h);    vm_ud2twoCell(u,l,h);
   if (v==0)    if (v==0)
Line 565  UDCell umdiv (UDCell u, UCell v) Line 698  UDCell umdiv (UDCell u, UCell v)
       q <<= 1;        q <<= 1;
     }      }
   vm_twoCell2ud(q,h,res);    vm_twoCell2ud(q,h,res);
 #endif /* !(defined(udiv_qrnnd) && */  #endif /* !(defined(udiv_qrnnd) && !defined(__alpha)) */
   return res;    return res;
 }  }
 #endif  #endif
Line 593  DCell smdiv (DCell num, Cell denom) Line 726  DCell smdiv (DCell num, Cell denom)
 {  {
   DCell res;    DCell res;
 #if defined(sdiv_qrnnd)  #if defined(sdiv_qrnnd)
 #warning "using sdiv_qrnnd"    /* #warning "using sdiv_qrnnd" */
   Cell u1,q,r    Cell u1,q,r
   UCell u0;    UCell u0;
   UCell MAYBE_UNUSED lz;    UCell MAYBE_UNUSED lz;

Removed from v.1.20  
changed lines
  Added in v.1.51


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>