[gforth] / gforth / engine / support.c  

gforth: gforth/engine/support.c

Diff for /gforth/engine/support.c between version 1.7 and 1.39

version 1.7, Sun Mar 9 15:17:04 2003 UTC version 1.39, Thu Jan 29 19:51:27 2009 UTC
Line 1 
Line 1 
 /* Gforth support functions  /* Gforth support functions
   
   Copyright (C) 1995,1996,1997,1998,2000,2003 Free Software Foundation, Inc.    Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2006,2007,2008 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"
 #include "forth.h"  #include "forth.h"
   #include "io.h"
 #include <stdlib.h>  #include <stdlib.h>
 #include <string.h>  #include <string.h>
 #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, int clear)
Line 76 
Line 86 
   if (size<2 || from[1]=='/') {    if (size<2 || from[1]=='/') {
     s1 = (char *)getenv ("HOME");      s1 = (char *)getenv ("HOME");
     if(s1 == NULL)      if(s1 == NULL)
   #if defined(_WIN32) || defined (MSDOS)
         s1 = (char *)getenv ("TEMP");
         if(s1 == NULL)
            s1 = (char *)getenv ("TMP");
            if(s1 == NULL)
   #endif
       s1 = "";        s1 = "";
     s2 = from+1;      s2 = (char *)from+1;
     s2_len = size-1;      s2_len = size-1;
   } else {    } else {
     UCell i;      UCell i;
Line 94 
Line 110 
     if (user_entry==NULL)      if (user_entry==NULL)
       return cstr(from, size, clear);        return cstr(from, size, clear);
     s1 = user_entry->pw_dir;      s1 = user_entry->pw_dir;
     s2 = from+i;      s2 = (char *)from+i;
     s2_len = size-i;      s2_len = size-i;
   }    }
   s1_len = strlen(s1);    s1_len = strlen(s1);
Line 104 
Line 120 
     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(path,s1_len+s2_len,clear);      return cstr((Char *)path,s1_len+s2_len,clear);
   }    }
 }  }
 #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 183 
Line 214 
   return 0;    return 0;
 }  }
   
   Cell capscompare(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2)
   {
     Cell n;
   
     n = memcasecmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
     if (n==0)
       n = u1-u2;
     if (n<0)
       n = -1;
     else if (n>0)
       n = 1;
     return n;
   }
   
 struct Longname *listlfind(Char *c_addr, UCell u, struct Longname *longname1)  struct Longname *listlfind(Char *c_addr, UCell u, struct Longname *longname1)
 {  {
   for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next))    for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next))
     if ((UCell)LONGNAME_COUNT(longname1)==u &&      if ((UCell)LONGNAME_COUNT(longname1)==u &&
         memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)          memcasecmp(c_addr, (Char *)(longname1->name), u)== 0 /* or inline? */)
       break;        break;
   return longname1;    return longname1;
 }  }
Line 200 
Line 245 
     longname1=(struct Longname *)(a_addr[1]);      longname1=(struct Longname *)(a_addr[1]);
     a_addr=(Cell *)(a_addr[0]);      a_addr=(Cell *)(a_addr[0]);
     if ((UCell)LONGNAME_COUNT(longname1)==u &&      if ((UCell)LONGNAME_COUNT(longname1)==u &&
         memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */) {          memcasecmp(c_addr, (Char *)(longname1->name), u)== 0 /* or inline? */) {
       return longname1;        return longname1;
     }      }
   }    }
Line 261 
Line 306 
   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, 1);
Line 337 
Line 383 
   
 Cell to_float(Char *c_addr, UCell u, Float *rp)  Cell to_float(Char *c_addr, UCell u, Float *rp)
 {  {
   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]=='-') {  
     sign = 1;    if (s >= send) /* treat empty string as 0e */
     number++;      goto return0;
     u--;    switch ((c=*s)) {
   }    case ' ':
   while(isspace((unsigned)(number[--u])) && u>0)      /* "A string of blanks should be treated as a special case
     ;         representing zero."*/
   switch(number[u]) {      for (s++; s<send; )
   case 'd':        if (*s++ != ' ')
           goto error;
       goto return0;
     case '-':
     case '+': *t++ = c; s++; goto aftersign;
     }
     aftersign:
     if (s >= send)
       goto exponent;
     switch (c=*s) {
     case '0' ... '9': *t++ = c; ndigits++; s++; goto aftersign;
     case '.':         *t++ = c; ndots++;   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':  break;    case 'E':
   default :  u++; break;    case 'e': s++; break;
   }  
   number[u]='\0';  
   r=strtod(number,&endconv);  
   if((flag=FLAG(!(Cell)*endconv))) {  
     if (sign)  
       r = -r;  
   } else if(*endconv=='d' || *endconv=='D') {  
     *endconv='E';  
     r=strtod(number,&endconv);  
     if((flag=FLAG(!(Cell)*endconv))) {  
       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 393 
Line 487 
     f_y = (Float *)(((Address)f_y)+nstridey);      f_y = (Float *)(((Address)f_y)+nstridey);
   }    }
 }  }
   #endif
   
   UCell lshift(UCell u1, UCell n)
   {
     return u1 << n;
   }
   
   UCell rshift(UCell u1, UCell n)
   {
     return u1 >> n;
   }
   
   #ifndef STANDALONE
   int gforth_system(Char *c_addr, UCell u)
   {
     int retval;
     char *prefix = getenv("GFORTHSYSTEMPREFIX") ? : DEFAULTSYSTEMPREFIX;
     size_t prefixlen = strlen(prefix);
     char buffer[prefixlen+u+1];
     fflush(stdout);
   #ifndef MSDOS
     int old_tp=terminal_prepped;
     deprep_terminal();
   #endif
     memcpy(buffer,prefix,prefixlen);
     memcpy(buffer+prefixlen,c_addr,u);
     buffer[prefixlen+u]='\0';
     retval=system(buffer); /* ~ expansion on first part of string? */
   #ifndef MSDOS
     if (old_tp)
       prep_terminal();
   #endif
     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, 1);
     UCell lib;
   #if defined(HAVE_LIBLTDL)
     lib = (UCell)lt_dlopen(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 | RTLD_LAZY);
     if(lib) return lib;
   #elif defined(_WIN32)
     lib = (UCell) GetModuleHandle(file);
     if(lib) return lib;
   #endif
     return 0;
   }
   
   #endif /* !defined(STANDALONE) */
   
   
   /* mixed division support; should usually be faster than gcc's
      double-by-double division (and gcc typically does not generate
      double-by-single division because of exception handling issues. If
      the architecture has double-by-single division, you should define
      ASM_SM_SLASH_REM and ASM_UM_SLASH_MOD appropriately. */
   
   /* Type definitions for longlong.h (according to the comments at the start):
      declarations taken from libgcc2.h */
   
   typedef unsigned int UQItype    __attribute__ ((mode (QI)));
   typedef          int SItype     __attribute__ ((mode (SI)));
   typedef unsigned int USItype    __attribute__ ((mode (SI)));
   typedef          int DItype     __attribute__ ((mode (DI)));
   typedef unsigned int UDItype    __attribute__ ((mode (DI)));
   typedef UCell UWtype;
   #if (SIZEOF_CHAR_P == 4)
   typedef unsigned int UHWtype __attribute__ ((mode (HI)));
   #endif
   #if (SIZEOF_CHAR_P == 8)
   typedef USItype UHWtype;
   #endif
   #ifndef BUGGY_LONG_LONG
   typedef UDCell UDWtype;
   #endif
   #define W_TYPE_SIZE (SIZEOF_CHAR_P * 8)
   
   #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)
        /* number of leading zeros, adapted from "Hacker's Delight" */
   {
      Cell n;
   
   #if !defined(COUNT_LEADING_ZEROS_0)
      if (x == 0) return(CELL_BITS);
   #endif
   #if defined(count_leading_zeros)
      count_leading_zeros(n,x);
   #else
      n = 0;
   #if (SIZEOF_CHAR_P > 4)
      if (x <= 0xffffffff)
        n+=32;
      else
        x >>= 32;
   #endif
      if (x <= 0x0000FFFF) {n = n +16; x = x <<16;}
      if (x <= 0x00FFFFFF) {n = n + 8; x = x << 8;}
      if (x <= 0x0FFFFFFF) {n = n + 4; x = x << 4;}
      if (x <= 0x3FFFFFFF) {n = n + 2; x = x << 2;}
      if (x <= 0x7FFFFFFF) {n = n + 1;}
   #endif
      return n;
   }
   #endif /*defined(udiv_qrnnd) && !defined(__alpha) && UDIV_NEEDS_NORMALIZATION*/
   
   #if !defined(ASM_UM_SLASH_MOD)
   UDCell umdiv (UDCell u, UCell v)
   /* Divide unsigned double by single precision using shifts and subtracts.
      Return quotient in lo, remainder in hi. */
   {
     UDCell res;
   #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 MAYBE_UNUSED lz;
   
     vm_ud2twoCell(u,u0,u1);
     if (v==0)
       throw(BALL_DIVZERO);
     if (u1>=v)
       throw(BALL_RESULTRANGE);
   #if UDIV_NEEDS_NORMALIZATION
     lz = nlz(v);
     v <<= lz;
     u = UDLSHIFT(u,lz);
     vm_ud2twoCell(u,u0,u1);
   #endif
     udiv_qrnnd(q,r,u1,u0,v);
   #if UDIV_NEEDS_NORMALIZATION
     r >>= lz;
   #endif
     vm_twoCell2ud(q,r,res);
   #else /* !(defined(udiv_qrnnd) && !defined(__alpha)) */
     /* simple restoring subtract-and-shift algorithm, might be faster on Alpha */
     int i = CELL_BITS, c = 0;
     UCell q = 0;
     UCell h, l;
   
     vm_ud2twoCell(u,l,h);
     if (v==0)
       throw(BALL_DIVZERO);
     if (h>=v)
       throw(BALL_RESULTRANGE);
     for (;;)
       {
         if (c || h >= v)
           {
             q++;
             h -= v;
           }
         if (--i < 0)
           break;
         c = HIGHBIT (h);
         h <<= 1;
         h += HIGHBIT (l);
         l <<= 1;
         q <<= 1;
       }
     vm_twoCell2ud(q,h,res);
   #endif /* !(defined(udiv_qrnnd) && !defined(__alpha)) */
     return res;
   }
   #endif
   
   #if !defined(ASM_SM_SLASH_REM)
   #if  defined(ASM_UM_SLASH_MOD)
   /* define it if it is not defined above */
   static UDCell MAYBE_UNUSED umdiv (UDCell u, UCell v)
   {
     UDCell res;
     UCell u0,u1;
     vm_ud2twoCell(u,u0,u1);
     ASM_UM_SLASH_MOD(u0,u1,v,r,q);
     vm_twoCell2ud(q,r,res);
     return res;
   }
   #endif /* defined(ASM_UM_SLASH_MOD) */
   
   #ifndef BUGGY_LONG_LONG
   #define dnegate(x) (-(x))
   #endif
   
   DCell smdiv (DCell num, Cell denom)
        /* symmetric divide procedure, mixed prec */
   {
     DCell res;
   #if defined(sdiv_qrnnd)
     /* #warning "using sdiv_qrnnd" */
     Cell u1,q,r
     UCell u0;
     UCell MAYBE_UNUSED lz;
   
     vm_d2twoCell(u,u0,u1);
     if (v==0)
       throw(BALL_DIVZERO);
     if (u1>=v)
       throw(BALL_RESULTRANGE);
     sdiv_qrnnd(q,r,u1,u0,v);
     vm_twoCell2d(q,r,res);
   #else
     UDCell ures;
     UCell l, q, r;
     Cell h;
     Cell denomsign=denom;
   
     vm_d2twoCell(num,l,h);
     if (h < 0)
       num = dnegate (num);
     if (denomsign < 0)
       denom = -denom;
     ures = umdiv(D2UD(num), denom);
     vm_ud2twoCell(ures,q,r);
     if ((h^denomsign)<0) {
       q = -q;
       if (((Cell)q) > 0) /* note: == 0 is possible */
         throw(BALL_RESULTRANGE);
     } else {
       if (((Cell)q) < 0)
         throw(BALL_RESULTRANGE);
     }
     if (h<0)
       r = -r;
     vm_twoCell2d(q,r,res);
   #endif
     return res;
   }
   
   DCell fmdiv (DCell num, Cell denom)
        /* floored divide procedure, mixed prec */
   {
     /* I have this technique from Andrew Haley */
     DCell res;
     UDCell ures;
     Cell denomsign=denom;
     Cell numsign;
     UCell q,r;
   
     if (denom < 0) {
       denom = -denom;
       num = dnegate(num);
     }
     numsign = DHI(num);
     if (numsign < 0)
       DHI_IS(num,DHI(num)+denom);
     ures = umdiv(D2UD(num),denom);
     vm_ud2twoCell(ures,q,r);
     if ((numsign^((Cell)q)) < 0)
       throw(BALL_RESULTRANGE);
     if (denomsign<0)
       r = -r;
     vm_twoCell2d(q,r,res);
     return res;
   }
   #endif

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help