File:  [gforth] / gforth / engine / support.c
Revision 1.38: download - view: text, annotated - select for diffs
Sat Nov 1 22:19:30 2008 UTC (11 years, 3 months ago) by anton
Branches: MAIN
CVS tags: v0-7-0, HEAD
updated copyright years

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

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