File:  [gforth] / gforth / engine / support.c
Revision 1.51: download - view: text, annotated - select for diffs
Mon Dec 31 15:25:19 2012 UTC (8 years, 5 months ago) by anton
Branches: MAIN
CVS tags: HEAD
updated copyright year

    1: /* Gforth support functions
    2: 
    3:   Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2006,2007,2008,2009,2010,2011,2012 Free Software Foundation, Inc.
    4: 
    5:   This file is part of Gforth.
    6: 
    7:   Gforth is free software; you can redistribute it and/or
    8:   modify it under the terms of the GNU General Public License
    9:   as published by the Free Software Foundation, either version 3
   10:   of the License, or (at your option) any later version.
   11: 
   12:   This program is distributed in the hope that it will be useful,
   13:   but WITHOUT ANY WARRANTY; without even the implied warranty of
   14:   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15:   GNU General Public License for more details.
   16: 
   17:   You should have received a copy of the GNU General Public License
   18:   along with this program; if not, see http://www.gnu.org/licenses/.
   19: */
   20: 
   21: #include "config.h"
   22: #include "forth.h"
   23: #include "io.h"
   24: #include <stdlib.h>
   25: #include <string.h>
   26: #include <sys/time.h>
   27: #include <unistd.h>
   28: #include <pwd.h>
   29: #include <assert.h>
   30: #ifndef STANDALONE
   31: #include <dirent.h>
   32: #include <math.h>
   33: #include <ctype.h>
   34: #include <errno.h>
   35: #include <sys/types.h>
   36: #include <sys/stat.h>
   37: #include <fcntl.h>
   38: #include <time.h>
   39: #endif
   40: #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */
   41: #include <dlfcn.h>
   42: #endif
   43: 
   44: #ifdef HAS_FILE
   45: char *cstr(Char *from, UCell size)
   46: /* return a C-string corresponding to the Forth string ( FROM SIZE ).
   47:    the C-string lives until free */
   48: {
   49:   char * string = malloc(size+1);
   50:   memcpy(string,from,size);
   51:   string[size]='\0';
   52:   return string;
   53: }
   54: 
   55: char *tilde_cstr(Char *from, UCell size)
   56: /* like cstr(), but perform tilde expansion on the string */
   57: {
   58:   char *s1,*s2;
   59:   int s1_len, s2_len;
   60:   struct passwd *getpwnam (), *user_entry;
   61: 
   62:   if (size<1 || from[0]!='~')
   63:     return cstr(from, size);
   64:   if (size<2 || from[1]=='/') {
   65:     s1 = (char *)getenv ("HOME");
   66:     if(s1 == NULL)
   67: #if defined(_WIN32) || defined (MSDOS)
   68:       s1 = (char *)getenv ("TEMP");
   69:       if(s1 == NULL)
   70:          s1 = (char *)getenv ("TMP");
   71:          if(s1 == NULL)
   72: #endif
   73:       s1 = "";
   74:     s2 = (char *)from+1;
   75:     s2_len = size-1;
   76:   } else {
   77:     UCell i;
   78:     for (i=1; i<size && from[i]!='/'; i++)
   79:       ;
   80:     if (i==2 && from[1]=='+') /* deal with "~+", i.e., the wd */
   81:       return cstr(from+3, size<3?0:size-3);
   82:     {
   83:       char user[i];
   84:       memcpy(user,from+1,i-1);
   85:       user[i-1]='\0';
   86:       user_entry=getpwnam(user);
   87:     }
   88:     if (user_entry==NULL)
   89:       return cstr(from, size);
   90:     s1 = user_entry->pw_dir;
   91:     s2 = (char *)from+i;
   92:     s2_len = size-i;
   93:   }
   94:   s1_len = strlen(s1);
   95:   if (s1_len>1 && s1[s1_len-1]=='/')
   96:     s1_len--;
   97:   {
   98:     char path[s1_len+s2_len];
   99:     memcpy(path,s1,s1_len);
  100:     memcpy(path+s1_len,s2,s2_len);
  101:     return cstr((Char *)path,s1_len+s2_len);
  102:   }
  103: }
  104: 
  105: Cell opencreate_file(char *s, Cell wfam, int flags, Cell *wiorp)
  106: {
  107:   Cell fd;
  108:   Cell wfileid;
  109:   fd = open(s, flags|ufileattr[wfam], 0666);
  110:   if (fd != -1) {
  111:     wfileid = (Cell)fdopen(fd, fileattr[wfam]);
  112:     *wiorp = IOR(wfileid == 0);
  113:   } else {
  114:     wfileid = 0;
  115:     *wiorp = IOR(1);
  116:   }
  117:   return wfileid;
  118: }
  119: #endif /* defined(HAS_FILE) */
  120: 
  121: DCell timeval2us(struct timeval *tvp)
  122: {
  123: #ifndef BUGGY_LONG_LONG
  124:   return (tvp->tv_sec*(DCell)1000000)+tvp->tv_usec;
  125: #else
  126:   DCell d2;
  127:   DCell d1=mmul(tvp->tv_sec,1000000);
  128:   d2.lo = d1.lo+tvp->tv_usec;
  129:   d2.hi = d1.hi + (d2.lo<d1.lo);
  130:   return d2;
  131: #endif
  132: }
  133: 
  134: DCell timespec2ns(struct timespec *tvp)
  135: {
  136: #ifndef BUGGY_LONG_LONG
  137:   return (tvp->tv_sec*(DCell)1000000000LL)+tvp->tv_nsec;
  138: #else
  139:   DCell d2;
  140:   DCell d1=mmul(tvp->tv_sec,1000000000);
  141:   d2.lo = d1.lo+tvp->tv_nsec;
  142:   d2.hi = d1.hi + (d2.lo<d1.lo);
  143:   return d2;
  144: #endif
  145: }
  146: 
  147: DCell double2ll(Float r)
  148: {
  149: #ifndef BUGGY_LONG_LONG
  150:   return (DCell)(r);
  151: #else
  152:   double ldexp(double x, int exp);
  153:   DCell d;
  154:   if (r<0) {
  155:     d.hi = ldexp(-r,-(int)(CELL_BITS));
  156:     d.lo = (-r)-ldexp((Float)d.hi,CELL_BITS);
  157:     return dnegate(d);
  158:   }
  159:   d.hi = ldexp(r,-(int)(CELL_BITS));
  160:   d.lo = r-ldexp((Float)d.hi,CELL_BITS);
  161:   return d;
  162: #endif
  163: }
  164: 
  165: void cmove(Char *c_from, Char *c_to, UCell u)
  166: {
  167:   while (u-- > 0)
  168:     *c_to++ = *c_from++;
  169: }
  170: 
  171: void cmove_up(Char *c_from, Char *c_to, UCell u)
  172: {
  173:   while (u-- > 0)
  174:     c_to[u] = c_from[u];
  175: }
  176: 
  177: Cell compare(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2)
  178: {
  179:   Cell n;
  180: 
  181:   n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
  182:   if (n==0)
  183:     n = u1-u2;
  184:   if (n<0)
  185:     n = -1;
  186:   else if (n>0)
  187:     n = 1;
  188:   return n;
  189: }
  190: 
  191: Cell memcasecmp(const Char *s1, const Char *s2, Cell n)
  192: {
  193:   Cell i;
  194: 
  195:   for (i=0; i<n; i++) {
  196:     Char c1=toupper(s1[i]);
  197:     Char c2=toupper(s2[i]);
  198:     if (c1 != c2) {
  199:       if (c1 < c2)
  200: 	return -1;
  201:       else
  202: 	return 1;
  203:     }
  204:   }
  205:   return 0;
  206: }
  207: 
  208: Cell capscompare(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2)
  209: {
  210:   Cell n;
  211: 
  212:   n = memcasecmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
  213:   if (n==0)
  214:     n = u1-u2;
  215:   if (n<0)
  216:     n = -1;
  217:   else if (n>0)
  218:     n = 1;
  219:   return n;
  220: }
  221: 
  222: struct Longname *listlfind(Char *c_addr, UCell u, struct Longname *longname1)
  223: {
  224:   for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next))
  225:     if ((UCell)LONGNAME_COUNT(longname1)==u &&
  226: 	memcasecmp(c_addr, (Char *)(longname1->name), u)== 0 /* or inline? */)
  227:       break;
  228:   return longname1;
  229: }
  230: 
  231: struct Longname *hashlfind(Char *c_addr, UCell u, Cell *a_addr)
  232: {
  233:   struct Longname *longname1;
  234: 
  235:   while(a_addr != NULL) {
  236:     longname1=(struct Longname *)(a_addr[1]);
  237:     a_addr=(Cell *)(a_addr[0]);
  238:     if ((UCell)LONGNAME_COUNT(longname1)==u &&
  239: 	memcasecmp(c_addr, (Char *)(longname1->name), u)== 0 /* or inline? */) {
  240:       return longname1;
  241:     }
  242:   }
  243:   return NULL;
  244: }
  245: 
  246: struct Longname *tablelfind(Char *c_addr, UCell u, Cell *a_addr)
  247: {
  248:   struct Longname *longname1;
  249:   while(a_addr != NULL) {
  250:     longname1=(struct Longname *)(a_addr[1]);
  251:     a_addr=(Cell *)(a_addr[0]);
  252:     if ((UCell)LONGNAME_COUNT(longname1)==u &&
  253: 	memcmp(c_addr, longname1->name, u)== 0 /* or inline? */) {
  254:       return longname1;
  255:     }
  256:   }
  257:   return NULL;
  258: }
  259: 
  260: UCell hashkey1(Char *c_addr, UCell u, UCell ubits)
  261: /* this hash function rotates the key at every step by rot bits within
  262:    ubits bits and xors it with the character. This function does ok in
  263:    the chi-sqare-test.  Rot should be <=7 (preferably <=5) for
  264:    ASCII strings (larger if ubits is large), and should share no
  265:    divisors with ubits.
  266: */
  267: {
  268:   static char rot_values[] = {5,0,1,2,3,4,5,5,5,5,3,5,5,5,5,7,5,5,5,5,7,5,5,5,5,6,5,5,5,5,7,5,5};
  269:   unsigned rot = rot_values[ubits];
  270:   Char *cp = c_addr;
  271:   UCell ukey;
  272: 
  273:   for (ukey=0; cp<c_addr+u; cp++)
  274:     ukey = ((((ukey<<rot) | (ukey>>(ubits-rot))) 
  275: 	     ^ toupper(*cp))
  276: 	    & ((1<<ubits)-1));
  277:   return ukey;
  278: }
  279: 
  280: struct Cellpair parse_white(Char *c_addr1, UCell u1)
  281: {
  282:   /* use !isgraph instead of isspace? */
  283:   struct Cellpair result;
  284:   Char *c_addr2;
  285:   Char *endp = c_addr1+u1;
  286:   while (c_addr1<endp && isspace(*c_addr1))
  287:     c_addr1++;
  288:   if (c_addr1<endp) {
  289:     for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++)
  290:       ;
  291:     result.n1 = (Cell)c_addr2;
  292:     result.n2 = c_addr1-c_addr2;
  293:   } else {
  294:     result.n1 = (Cell)c_addr1;
  295:     result.n2 = 0;
  296:   }
  297:   return result;
  298: }
  299: 
  300: #ifdef HAS_FILE
  301: Cell rename_file(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2)
  302: {
  303:   char *s1=tilde_cstr(c_addr2, u2);
  304:   char *s2=tilde_cstr(c_addr1, u1);
  305:   return IOR(rename(s2, s1)==-1);
  306:   free(s1);
  307:   free(s2);
  308: }
  309: 
  310: struct Cellquad read_line(Char *c_addr, UCell u1, FILE *wfileid)
  311: {
  312:   UCell u2, u3;
  313:   Cell flag, wior;
  314:   Cell c;
  315:   struct Cellquad r;
  316: 
  317:   flag=-1;
  318:   u3=0;
  319:   if (u1>0)
  320:     gf_regetc(wfileid);
  321:   for(u2=0; u2<u1; u2++) {
  322:     c = getc(wfileid);
  323:     u3++;
  324:     if (c=='\n') break;
  325:     if (c=='\r') {
  326:       if ((c = getc(wfileid))!='\n')
  327: 	gf_ungetc(c,wfileid);
  328:       else
  329: 	u3++;
  330:       break;
  331:     }
  332:     if (c==EOF) {
  333:       flag=FLAG(u2!=0);
  334:       break;
  335:     }
  336:     c_addr[u2] = (Char)c;
  337:   }
  338:   wior=FILEIO(ferror(wfileid));
  339:   r.n1 = u2;
  340:   r.n2 = flag;
  341:   r.n3 = u3;
  342:   r.n4 = wior;
  343:   return r;
  344: }
  345: 
  346: struct Cellpair file_status(Char *c_addr, UCell u)
  347: {
  348:   struct Cellpair r;
  349:   Cell wfam;
  350:   Cell wior;
  351:   char *filename=tilde_cstr(c_addr, u);
  352: 
  353:   if (access (filename, F_OK) != 0) {
  354:     wfam=0;
  355:     wior=IOR(1);
  356:   }
  357:   else if (access (filename, R_OK | W_OK) == 0) {
  358:     wfam=2; /* r/w */
  359:     wior=0;
  360:   }
  361:   else if (access (filename, R_OK) == 0) {
  362:     wfam=0; /* r/o */
  363:     wior=0;
  364:   }
  365:   else if (access (filename, W_OK) == 0) {
  366:     wfam=4; /* w/o */
  367:     wior=0;
  368:   }
  369:   else {
  370:     wfam=1; /* well, we cannot access the file, but better deliver a
  371: 	       legal access mode (r/o bin), so we get a decent error
  372: 	       later upon open. */
  373:     wior=0;
  374:   }
  375:   r.n1 = wfam;
  376:   r.n2 = wior;
  377:   free(filename);
  378:   return r;
  379: }
  380: 
  381: Cell to_float(Char *c_addr, UCell u, Float *rp, Char dot)
  382: {
  383:   /* convertible string := <significand>[<exponent>]
  384:      <significand> := [<sign>]{<digits>[.<digits0>] | .<digits> }
  385:      <exponent>    := <marker><digits0>
  386:      <marker>      := {<e-form> | <sign-form>}
  387:      <e-form>      := <e-char>[<sign-form>]
  388:      <sign-form>   := { + | - }
  389:      <e-char>      := { D | d | E | e }
  390:   */
  391:   Char *s = c_addr;
  392:   Char c;
  393:   Char *send = c_addr+u;
  394:   UCell ndigits = 0;
  395:   UCell ndots = 0;
  396:   UCell edigits = 0;
  397:   char cnum[u+3]; /* append at most "e0\0" */
  398:   char *t=cnum;
  399:   char *endconv;
  400:   Float r;
  401:   
  402:   if (s >= send) /* treat empty string as 0e */
  403:     goto return0;
  404:   switch ((c=*s)) {
  405:   case ' ':
  406:     /* "A string of blanks should be treated as a special case
  407:        representing zero."*/
  408:     for (s++; s<send; )
  409:       if (*s++ != ' ')
  410:         goto error;
  411:     goto return0;
  412:   case '-':
  413:   case '+': *t++ = c; s++; goto aftersign;
  414:   }
  415:   aftersign: 
  416:   if (s >= send)
  417:     goto exponent;
  418:   if((c=*s)==dot) { *t++ = '.'; ndots++; s++; goto aftersign; }
  419:   switch (c) {
  420:   case '0' ... '9': *t++ = c; ndigits++; s++; goto aftersign;
  421:   default:                                    goto exponent;
  422:   }
  423:  exponent:
  424:   if (ndigits < 1 || ndots > 1)
  425:     goto error;
  426:   *t++ = 'E';
  427:   if (s >= send)
  428:     goto done;
  429:   switch (c=*s) {
  430:   case 'D':
  431:   case 'd':
  432:   case 'E':
  433:   case 'e': s++; break;
  434:   }
  435:   if (s >= send)
  436:     goto done;
  437:   switch (c=*s) {
  438:   case '+':
  439:   case '-': *t++ = c; s++; break;
  440:   }
  441:  edigits0:
  442:   if (s >= send)
  443:     goto done;
  444:   switch (c=*s) {
  445:   case '0' ... '9': *t++ = c; s++; edigits++; goto edigits0;
  446:   default: goto error;
  447:   }
  448:  done:
  449:   if (edigits == 0)
  450:     *t++ = '0';
  451:   *t++ = '\0';
  452:   assert(t-cnum <= u+3);
  453:   r = strtod(cnum, &endconv);
  454:   assert(*endconv == '\0');
  455:   *rp = r;
  456:   return -1;
  457:  return0:
  458:   *rp = 0.0;
  459:   return -1;
  460:  error:
  461:   *rp = 0.0;
  462:   return 0;
  463: }
  464: #endif
  465: 
  466: #ifdef HAS_FLOATING
  467: Float v_star(Float *f_addr1, Cell nstride1, Float *f_addr2, Cell nstride2, UCell ucount)
  468: {
  469:   Float r;
  470: 
  471:   for (r=0.; ucount>0; ucount--) {
  472:     r += *f_addr1 * *f_addr2;
  473:     f_addr1 = (Float *)(((Address)f_addr1)+nstride1);
  474:     f_addr2 = (Float *)(((Address)f_addr2)+nstride2);
  475:   }
  476:   return r;
  477: }
  478: 
  479: void faxpy(Float ra, Float *f_x, Cell nstridex, Float *f_y, Cell nstridey, UCell ucount)
  480: {
  481:   for (; ucount>0; ucount--) {
  482:     *f_y += ra * *f_x;
  483:     f_x = (Float *)(((Address)f_x)+nstridex);
  484:     f_y = (Float *)(((Address)f_y)+nstridey);
  485:   }
  486: }
  487: #endif
  488: 
  489: UCell lshift(UCell u1, UCell n)
  490: {
  491:   return u1 << n;
  492: }
  493: 
  494: UCell rshift(UCell u1, UCell n)
  495: {
  496:   return u1 >> n;
  497: }
  498: 
  499: #ifndef STANDALONE
  500: int gforth_system(Char *c_addr, UCell u)
  501: {
  502:   int retval;
  503:   char *prefix = getenv("GFORTHSYSTEMPREFIX") ? : DEFAULTSYSTEMPREFIX;
  504:   size_t prefixlen = strlen(prefix);
  505:   char buffer[prefixlen+u+1];
  506:   int MAYBE_UNUSED old_tp;
  507:   fflush(stdout);
  508: #ifndef MSDOS
  509:   old_tp=terminal_prepped;
  510:   deprep_terminal();
  511: #endif
  512:   memcpy(buffer,prefix,prefixlen);
  513:   memcpy(buffer+prefixlen,c_addr,u);
  514:   buffer[prefixlen+u]='\0';
  515:   retval=system(buffer); /* ~ expansion on first part of string? */
  516: #ifndef MSDOS
  517:   if (old_tp)
  518:     prep_terminal();
  519: #endif
  520:   return retval;
  521: }
  522: 
  523: void gforth_ms(UCell u)
  524: {
  525: #ifdef HAVE_NANOSLEEP
  526:   struct timespec time_req;
  527:   time_req.tv_sec=u/1000;
  528:   time_req.tv_nsec=1000000*(u%1000);
  529:   while(nanosleep(&time_req, &time_req));
  530: #else /* !defined(HAVE_NANOSLEEP) */
  531:   struct timeval timeout;
  532:   timeout.tv_sec=u/1000;
  533:   timeout.tv_usec=1000*(u%1000);
  534:   (void)select(0,0,0,0,&timeout);
  535: #endif /* !defined(HAVE_NANOSLEEP) */
  536: }
  537: 
  538: UCell gforth_dlopen(Char *c_addr, UCell u)
  539: {
  540:   char * file=tilde_cstr(c_addr, u);
  541:   UCell lib;
  542: #if defined(HAVE_LIBLTDL)
  543:   lib = (UCell)lt_dlopen(file);
  544:   free(file);
  545:   if(lib) return lib;
  546: #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
  547: #ifndef RTLD_GLOBAL
  548: #define RTLD_GLOBAL 0
  549: #endif
  550:   lib = (UCell)dlopen(file, RTLD_GLOBAL);
  551:   free(file);
  552:   if(lib) return lib;
  553:   fprintf(stderr, "%s\n", dlerror());
  554: #elif defined(_WIN32)
  555:   lib = (UCell) GetModuleHandle(file);
  556:   free(file);
  557:   if(lib) return lib;
  558: #endif
  559:   return 0;
  560: }
  561: 
  562: #endif /* !defined(STANDALONE) */
  563: 
  564: 
  565: /* mixed division support; should usually be faster than gcc's
  566:    double-by-double division (and gcc typically does not generate
  567:    double-by-single division because of exception handling issues. If
  568:    the architecture has double-by-single division, you should define
  569:    ASM_SM_SLASH_REM and ASM_UM_SLASH_MOD appropriately. */
  570: 
  571: /* Type definitions for longlong.h (according to the comments at the start):
  572:    declarations taken from libgcc2.h */
  573: 
  574: typedef unsigned int UQItype	__attribute__ ((mode (QI)));
  575: typedef 	 int SItype	__attribute__ ((mode (SI)));
  576: typedef unsigned int USItype	__attribute__ ((mode (SI)));
  577: typedef		 int DItype	__attribute__ ((mode (DI)));
  578: typedef unsigned int UDItype	__attribute__ ((mode (DI)));
  579: typedef UCell UWtype;
  580: #if (SIZEOF_CHAR_P == 4)
  581: typedef unsigned int UHWtype __attribute__ ((mode (HI)));
  582: #endif
  583: #if (SIZEOF_CHAR_P == 8)
  584: typedef USItype UHWtype;
  585: #endif
  586: #ifndef BUGGY_LONG_LONG
  587: typedef UDCell UDWtype;
  588: #endif
  589: #define W_TYPE_SIZE (SIZEOF_CHAR_P * 8)
  590: 
  591: #include "longlong.h"
  592: 
  593: 
  594: #if defined(udiv_qrnnd) && !defined(__alpha) && UDIV_NEEDS_NORMALIZATION
  595: 
  596: #if defined(count_leading_zeros)
  597: const UQItype __clz_tab[256] =
  598: {
  599:   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,
  600:   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,
  601:   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,
  602:   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,
  603:   8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
  604:   8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
  605:   8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
  606:   8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8
  607: };
  608: #endif
  609: 
  610: static Cell MAYBE_UNUSED nlz(UCell x)
  611:      /* number of leading zeros, adapted from "Hacker's Delight" */
  612: {
  613:    Cell n;
  614: 
  615: #if !defined(COUNT_LEADING_ZEROS_0)
  616:    if (x == 0) return(CELL_BITS);
  617: #endif
  618: #if defined(count_leading_zeros)
  619:    count_leading_zeros(n,x);
  620: #else
  621:    n = 0;
  622: #if (SIZEOF_CHAR_P > 4)
  623:    if (x <= 0xffffffff) 
  624:      n+=32;
  625:    else
  626:      x >>= 32;
  627: #endif
  628:    if (x <= 0x0000FFFF) {n = n +16; x = x <<16;}
  629:    if (x <= 0x00FFFFFF) {n = n + 8; x = x << 8;}
  630:    if (x <= 0x0FFFFFFF) {n = n + 4; x = x << 4;}
  631:    if (x <= 0x3FFFFFFF) {n = n + 2; x = x << 2;}
  632:    if (x <= 0x7FFFFFFF) {n = n + 1;}
  633: #endif
  634:    return n;
  635: }
  636: #endif /*defined(udiv_qrnnd) && !defined(__alpha) && UDIV_NEEDS_NORMALIZATION*/
  637: 
  638: #if !defined(ASM_UM_SLASH_MOD)
  639: UDCell umdiv (UDCell u, UCell v)
  640: /* Divide unsigned double by single precision using shifts and subtracts.
  641:    Return quotient in lo, remainder in hi. */
  642: {
  643:   UDCell res;
  644: #if defined(udiv_qrnnd) && !defined(__alpha)
  645: #if 0
  646:    This code is slower on an Alpha (timings with gcc-3.3.5):
  647:           other     this
  648:    */      5205 ms  5741 ms 
  649:    */mod   5167 ms  5717 ms 
  650:    fm/mod  5467 ms  5312 ms 
  651:    sm/rem  4734 ms  5278 ms 
  652:    um/mod  4490 ms  5020 ms 
  653:    m*/    15557 ms 17151 ms
  654: #endif /* 0 */
  655:   UCell q,r,u0,u1;
  656:   UCell MAYBE_UNUSED lz;
  657:   
  658:   vm_ud2twoCell(u,u0,u1);
  659:   if (v==0)
  660:     throw(BALL_DIVZERO);
  661:   if (u1>=v)
  662:     throw(BALL_RESULTRANGE);
  663: #if UDIV_NEEDS_NORMALIZATION
  664:   lz = nlz(v);
  665:   v <<= lz;
  666:   u = UDLSHIFT(u,lz);
  667:   vm_ud2twoCell(u,u0,u1);
  668: #endif
  669:   udiv_qrnnd(q,r,u1,u0,v);
  670: #if UDIV_NEEDS_NORMALIZATION
  671:   r >>= lz;
  672: #endif
  673:   vm_twoCell2ud(q,r,res);
  674: #else /* !(defined(udiv_qrnnd) && !defined(__alpha)) */
  675:   /* simple restoring subtract-and-shift algorithm, might be faster on Alpha */
  676:   int i = CELL_BITS, c = 0;
  677:   UCell q = 0;
  678:   UCell h, l;
  679: 
  680:   vm_ud2twoCell(u,l,h);
  681:   if (v==0)
  682:     throw(BALL_DIVZERO);
  683:   if (h>=v)
  684:     throw(BALL_RESULTRANGE);
  685:   for (;;)
  686:     {
  687:       if (c || h >= v)
  688: 	{
  689: 	  q++;
  690: 	  h -= v;
  691: 	}
  692:       if (--i < 0)
  693: 	break;
  694:       c = HIGHBIT (h);
  695:       h <<= 1;
  696:       h += HIGHBIT (l);
  697:       l <<= 1;
  698:       q <<= 1;
  699:     }
  700:   vm_twoCell2ud(q,h,res);
  701: #endif /* !(defined(udiv_qrnnd) && !defined(__alpha)) */
  702:   return res;
  703: }
  704: #endif
  705: 
  706: #if !defined(ASM_SM_SLASH_REM)
  707: #if  defined(ASM_UM_SLASH_MOD)
  708: /* define it if it is not defined above */
  709: static UDCell MAYBE_UNUSED umdiv (UDCell u, UCell v)
  710: {
  711:   UDCell res;
  712:   UCell u0,u1;
  713:   vm_ud2twoCell(u,u0,u1);
  714:   ASM_UM_SLASH_MOD(u0,u1,v,r,q);
  715:   vm_twoCell2ud(q,r,res);
  716:   return res;
  717: }
  718: #endif /* defined(ASM_UM_SLASH_MOD) */
  719: 
  720: #ifndef BUGGY_LONG_LONG
  721: #define dnegate(x) (-(x))
  722: #endif
  723: 
  724: DCell smdiv (DCell num, Cell denom)
  725:      /* symmetric divide procedure, mixed prec */
  726: {
  727:   DCell res;
  728: #if defined(sdiv_qrnnd)
  729:   /* #warning "using sdiv_qrnnd" */
  730:   Cell u1,q,r
  731:   UCell u0;
  732:   UCell MAYBE_UNUSED lz;
  733:   
  734:   vm_d2twoCell(u,u0,u1);
  735:   if (v==0)
  736:     throw(BALL_DIVZERO);
  737:   if (u1>=v)
  738:     throw(BALL_RESULTRANGE);
  739:   sdiv_qrnnd(q,r,u1,u0,v);
  740:   vm_twoCell2d(q,r,res);
  741: #else
  742:   UDCell ures;
  743:   UCell l, q, r;
  744:   Cell h;
  745:   Cell denomsign=denom;
  746: 
  747:   vm_d2twoCell(num,l,h);
  748:   if (h < 0)
  749:     num = dnegate (num);
  750:   if (denomsign < 0)
  751:     denom = -denom;
  752:   ures = umdiv(D2UD(num), denom);
  753:   vm_ud2twoCell(ures,q,r);
  754:   if ((h^denomsign)<0) {
  755:     q = -q;
  756:     if (((Cell)q) > 0) /* note: == 0 is possible */
  757:       throw(BALL_RESULTRANGE);
  758:   } else {
  759:     if (((Cell)q) < 0)
  760:       throw(BALL_RESULTRANGE);
  761:   }
  762:   if (h<0)
  763:     r = -r;
  764:   vm_twoCell2d(q,r,res);
  765: #endif
  766:   return res;
  767: }
  768: 
  769: DCell fmdiv (DCell num, Cell denom)
  770:      /* floored divide procedure, mixed prec */
  771: {
  772:   /* I have this technique from Andrew Haley */
  773:   DCell res;
  774:   UDCell ures;
  775:   Cell denomsign=denom;
  776:   Cell numsign;
  777:   UCell q,r;
  778: 
  779:   if (denom < 0) {
  780:     denom = -denom;
  781:     num = dnegate(num);
  782:   }
  783:   numsign = DHI(num);
  784:   if (numsign < 0)
  785:     DHI_IS(num,DHI(num)+denom);
  786:   ures = umdiv(D2UD(num),denom);
  787:   vm_ud2twoCell(ures,q,r);
  788:   if ((numsign^((Cell)q)) < 0)
  789:     throw(BALL_RESULTRANGE);
  790:   if (denomsign<0)
  791:     r = -r;
  792:   vm_twoCell2d(q,r,res);
  793:   return res;
  794: }
  795: #endif

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