[BACK]Return to support.c CVS log [TXT] [DIR] Up to [gforth] / gforth / engine

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

version 1.7, 2003/03/09 15:17:04 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 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"
 #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)
 /* 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 72  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)
   #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;
     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 92  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 = from+i;      s2 = (char *)from+i;
     s2_len = size-i;      s2_len = size-i;
   }    }
   s1_len = strlen(s1);    s1_len = strlen(s1);
Line 104  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(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 122  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 183  Cell memcasecmp(const Char *s1, const Ch Line 205  Cell memcasecmp(const Char *s1, const Ch
   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  struct Longname *hashlfind(Char *c_addr, Line 236  struct Longname *hashlfind(Char *c_addr,
     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  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 276  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 293  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 306  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 332  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]=='-') {    
     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;
     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':  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  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)
   {
     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];
     int MAYBE_UNUSED old_tp;
     fflush(stdout);
   #ifndef MSDOS
     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);
     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
      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
Removed from v.1.7  
changed lines
  Added in v.1.51

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