Annotation of gforth/engine/support.c, revision 1.35

1.1       anton       1: /* Gforth support functions
                      2: 
1.30      anton       3:   Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2006,2007 Free Software Foundation, Inc.
1.1       anton       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
1.31      anton       9:   as published by the Free Software Foundation, either version 3
1.1       anton      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
1.31      anton      18:   along with this program; if not, see http://www.gnu.org/licenses/.
1.1       anton      19: */
                     20: 
                     21: #include "config.h"
                     22: #include "forth.h"
1.10      anton      23: #include "io.h"
1.1       anton      24: #include <stdlib.h>
                     25: #include <string.h>
                     26: #include <sys/time.h>
                     27: #include <unistd.h>
                     28: #include <pwd.h>
1.28      anton      29: #include <assert.h>
1.23      pazsan     30: #ifndef STANDALONE
1.1       anton      31: #include <dirent.h>
1.2       anton      32: #include <math.h>
1.5       anton      33: #include <ctype.h>
                     34: #include <errno.h>
1.32      anton      35: #include <sys/types.h>
                     36: #include <sys/stat.h>
                     37: #include <fcntl.h>
                     38: #include <time.h>
1.23      pazsan     39: #endif
1.34      pazsan     40: #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */
                     41: #include <dlfcn.h>
                     42: #endif
1.1       anton      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)
1.8       pazsan     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
1.1       anton      95:       s1 = "";
1.15      pazsan     96:     s2 = (char *)from+1;
1.1       anton      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;
1.15      pazsan    113:     s2 = (char *)from+i;
1.1       anton     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);
1.15      pazsan    123:     return cstr((Char *)path,s1_len+s2_len,clear);
1.1       anton     124:   }
                    125: }
1.29      anton     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) */
1.1       anton     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: 
1.2       anton     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
1.5       anton     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: 
1.14      pazsan    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: 
1.5       anton     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 &&
1.15      pazsan    235:        memcasecmp(c_addr, (Char *)(longname1->name), u)== 0 /* or inline? */)
1.5       anton     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 &&
1.15      pazsan    248:        memcasecmp(c_addr, (Char *)(longname1->name), u)== 0 /* or inline? */) {
1.5       anton     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:       ;
1.6       anton     300:     result.n1 = (Cell)c_addr2;
1.5       anton     301:     result.n2 = c_addr1-c_addr2;
                    302:   } else {
1.6       anton     303:     result.n1 = (Cell)c_addr1;
1.5       anton     304:     result.n2 = 0;
                    305:   }
                    306:   return result;
                    307: }
                    308: 
1.22      pazsan    309: #ifdef HAS_FILE
1.5       anton     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;
1.6       anton     381:   return r;
1.5       anton     382: }
                    383: 
                    384: Cell to_float(Char *c_addr, UCell u, Float *rp)
                    385: {
1.28      anton     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;
1.5       anton     403:   Float r;
1.28      anton     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':
1.5       anton     434:   case 'd':
1.28      anton     435:   case 'E':
                    436:   case 'e': s++; break;
1.5       anton     437:   }
1.28      anton     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');
1.5       anton     458:   *rp = r;
1.28      anton     459:   return -1;
                    460:  return0:
                    461:   *rp = 0.0;
                    462:   return -1;
                    463:  error:
                    464:   *rp = 0.0;
                    465:   return 0;
1.5       anton     466: }
1.22      pazsan    467: #endif
1.5       anton     468: 
1.25      pazsan    469: #ifdef HAS_FLOATING
1.5       anton     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:   }
1.1       anton     489: }
1.24      pazsan    490: #endif
1.9       pazsan    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;
1.10      anton     500: }
                    501: 
1.24      pazsan    502: #ifndef STANDALONE
1.10      anton     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;
1.9       pazsan    522: }
1.26      anton     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: }
1.33      pazsan    538: 
                    539: UCell gforth_dlopen(Char *c_addr, UCell u)
                    540: {
                    541:   char * file=tilde_cstr(c_addr, u, 1);
1.35    ! pazsan    542:   Ucell lib;
1.34      pazsan    543: #if defined(HAVE_LIBLTDL)
                    544:   lib = (UCell)lt_dlopen(file);
                    545:   if(lib) return lib;
1.33      pazsan    546: #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
                    547: #ifndef RTLD_GLOBAL
                    548: #define RTLD_GLOBAL 0
                    549: #endif
1.34      pazsan    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
1.33      pazsan    556:   return 0;
                    557: }
                    558: 
1.26      anton     559: #endif /* !defined(STANDALONE) */
                    560: 
1.16      anton     561: 
1.17      anton     562: /* mixed division support; should usually be faster than gcc's
1.16      anton     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
1.17      anton     566:    ASM_SM_SLASH_REM and ASM_UM_SLASH_MOD appropriately. */
1.16      anton     567: 
1.17      anton     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: 
1.27      anton     590: #if defined(udiv_qrnnd) && !defined(__alpha) && UDIV_NEEDS_NORMALIZATION
1.17      anton     591: static Cell MAYBE_UNUSED nlz(UCell x)
1.16      anton     592:      /* number of leading zeros, adapted from "Hacker's Delight" */
                    593: {
                    594:    Cell n;
                    595: 
1.17      anton     596: #if !defined(COUNT_LEADING_ZEROS_0)
1.16      anton     597:    if (x == 0) return(CELL_BITS);
1.17      anton     598: #endif
                    599: #if defined(count_leading_zeros)
                    600:    count_leading_zeros(n,x);
                    601: #else
1.16      anton     602:    n = 0;
                    603: #if (SIZEOF_CHAR_P > 4)
1.27      anton     604:    if (x <= 0xffffffff) 
                    605:      n+=32;
                    606:    else
                    607:      x >>= 32;
1.16      anton     608: #endif
                    609:    if (x <= 0x0000FFFF) {n = n +16; x = x <<16;}
                    610:    if (x <= 0x00FFFFFF) {n = n + 8; x = x << 8;}
                    611:    if (x <= 0x0FFFFFFF) {n = n + 4; x = x << 4;}
                    612:    if (x <= 0x3FFFFFFF) {n = n + 2; x = x << 2;}
                    613:    if (x <= 0x7FFFFFFF) {n = n + 1;}
1.17      anton     614: #endif
1.16      anton     615:    return n;
                    616: }
1.27      anton     617: #endif /*defined(udiv_qrnnd) && !defined(__alpha) && UDIV_NEEDS_NORMALIZATION*/
1.16      anton     618: 
1.17      anton     619: #if !defined(ASM_UM_SLASH_MOD)
1.16      anton     620: UDCell umdiv (UDCell u, UCell v)
                    621: /* Divide unsigned double by single precision using shifts and subtracts.
                    622:    Return quotient in lo, remainder in hi. */
                    623: {
1.17      anton     624:   UDCell res;
1.27      anton     625: #if defined(udiv_qrnnd) && !defined(__alpha)
                    626: #if 0
                    627:    This code is slower on an Alpha (timings with gcc-3.3.5):
                    628:           other     this
                    629:    */      5205 ms  5741 ms 
                    630:    */mod   5167 ms  5717 ms 
                    631:    fm/mod  5467 ms  5312 ms 
                    632:    sm/rem  4734 ms  5278 ms 
                    633:    um/mod  4490 ms  5020 ms 
                    634:    m*/    15557 ms 17151 ms
                    635: #endif /* 0 */
1.17      anton     636:   UCell q,r,u0,u1;
                    637:   UCell MAYBE_UNUSED lz;
                    638:   
                    639:   vm_ud2twoCell(u,u0,u1);
                    640:   if (v==0)
                    641:     throw(BALL_DIVZERO);
                    642:   if (u1>=v)
                    643:     throw(BALL_RESULTRANGE);
                    644: #if UDIV_NEEDS_NORMALIZATION
                    645:   lz = nlz(v);
                    646:   v <<= lz;
1.19      anton     647:   u = UDLSHIFT(u,lz);
1.17      anton     648:   vm_ud2twoCell(u,u0,u1);
                    649: #endif
                    650:   udiv_qrnnd(q,r,u1,u0,v);
                    651: #if UDIV_NEEDS_NORMALIZATION
                    652:   r >>= lz;
                    653: #endif
                    654:   vm_twoCell2ud(q,r,res);
1.27      anton     655: #else /* !(defined(udiv_qrnnd) && !defined(__alpha)) */
1.16      anton     656:   /* simple restoring subtract-and-shift algorithm, might be faster on Alpha */
                    657:   int i = CELL_BITS, c = 0;
                    658:   UCell q = 0;
1.27      anton     659:   UCell h, l;
1.16      anton     660: 
                    661:   vm_ud2twoCell(u,l,h);
                    662:   if (v==0)
                    663:     throw(BALL_DIVZERO);
                    664:   if (h>=v)
                    665:     throw(BALL_RESULTRANGE);
                    666:   for (;;)
                    667:     {
                    668:       if (c || h >= v)
                    669:        {
                    670:          q++;
                    671:          h -= v;
                    672:        }
                    673:       if (--i < 0)
                    674:        break;
                    675:       c = HIGHBIT (h);
                    676:       h <<= 1;
                    677:       h += HIGHBIT (l);
                    678:       l <<= 1;
                    679:       q <<= 1;
                    680:     }
                    681:   vm_twoCell2ud(q,h,res);
1.27      anton     682: #endif /* !(defined(udiv_qrnnd) && !defined(__alpha)) */
1.16      anton     683:   return res;
                    684: }
                    685: #endif
                    686: 
                    687: #if !defined(ASM_SM_SLASH_REM)
                    688: #if  defined(ASM_UM_SLASH_MOD)
                    689: /* define it if it is not defined above */
1.17      anton     690: static UDCell MAYBE_UNUSED umdiv (UDCell u, UCell v)
1.16      anton     691: {
                    692:   UDCell res;
                    693:   UCell u0,u1;
                    694:   vm_ud2twoCell(u,u0,u1);
                    695:   ASM_UM_SLASH_MOD(u0,u1,v,r,q);
                    696:   vm_twoCell2ud(q,r,res);
                    697:   return res;
                    698: }
                    699: #endif /* defined(ASM_UM_SLASH_MOD) */
                    700: 
                    701: #ifndef BUGGY_LONG_LONG
                    702: #define dnegate(x) (-(x))
                    703: #endif
                    704: 
1.17      anton     705: DCell smdiv (DCell num, Cell denom)
                    706:      /* symmetric divide procedure, mixed prec */
1.16      anton     707: {
                    708:   DCell res;
1.17      anton     709: #if defined(sdiv_qrnnd)
1.32      anton     710:   /* #warning "using sdiv_qrnnd" */
1.17      anton     711:   Cell u1,q,r
                    712:   UCell u0;
                    713:   UCell MAYBE_UNUSED lz;
                    714:   
                    715:   vm_d2twoCell(u,u0,u1);
                    716:   if (v==0)
                    717:     throw(BALL_DIVZERO);
                    718:   if (u1>=v)
                    719:     throw(BALL_RESULTRANGE);
                    720:   sdiv_qrnnd(q,r,u1,u0,v);
                    721:   vm_twoCell2d(q,r,res);
                    722: #else
1.16      anton     723:   UDCell ures;
                    724:   UCell l, q, r;
                    725:   Cell h;
                    726:   Cell denomsign=denom;
                    727: 
                    728:   vm_d2twoCell(num,l,h);
                    729:   if (h < 0)
                    730:     num = dnegate (num);
                    731:   if (denomsign < 0)
                    732:     denom = -denom;
                    733:   ures = umdiv(D2UD(num), denom);
                    734:   vm_ud2twoCell(ures,q,r);
                    735:   if ((h^denomsign)<0) {
                    736:     q = -q;
                    737:     if (((Cell)q) > 0) /* note: == 0 is possible */
                    738:       throw(BALL_RESULTRANGE);
                    739:   } else {
                    740:     if (((Cell)q) < 0)
                    741:       throw(BALL_RESULTRANGE);
                    742:   }
                    743:   if (h<0)
                    744:     r = -r;
                    745:   vm_twoCell2d(q,r,res);
1.17      anton     746: #endif
1.16      anton     747:   return res;
                    748: }
                    749: 
1.17      anton     750: DCell fmdiv (DCell num, Cell denom)
                    751:      /* floored divide procedure, mixed prec */
1.16      anton     752: {
                    753:   /* I have this technique from Andrew Haley */
                    754:   DCell res;
                    755:   UDCell ures;
                    756:   Cell denomsign=denom;
                    757:   Cell numsign;
                    758:   UCell q,r;
                    759: 
                    760:   if (denom < 0) {
                    761:     denom = -denom;
                    762:     num = dnegate(num);
                    763:   }
                    764:   numsign = DHI(num);
                    765:   if (numsign < 0)
                    766:     DHI_IS(num,DHI(num)+denom);
                    767:   ures = umdiv(D2UD(num),denom);
                    768:   vm_ud2twoCell(ures,q,r);
                    769:   if ((numsign^((Cell)q)) < 0)
                    770:     throw(BALL_RESULTRANGE);
                    771:   if (denomsign<0)
                    772:     r = -r;
                    773:   vm_twoCell2d(q,r,res);
                    774:   return res;
                    775: }
                    776: #endif

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