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

1.1       anton       1: /* Gforth support functions
                      2: 
1.38      anton       3:   Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2006,2007,2008 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: 
1.40    ! anton     316: struct Cellquad read_line(Char *c_addr, UCell u1, FILE *wfileid)
1.5       anton     317: {
                    318:   UCell u2, u3;
                    319:   Cell flag, wior;
                    320:   Cell c;
                    321:   struct Cellquad r;
                    322: 
                    323:   flag=-1;
                    324:   u3=0;
1.40    ! anton     325:   if (u1>0)
        !           326:     gf_regetc(wfileid);
1.5       anton     327:   for(u2=0; u2<u1; u2++) {
1.40    ! anton     328:     c = getc(wfileid);
1.5       anton     329:     u3++;
                    330:     if (c=='\n') break;
                    331:     if (c=='\r') {
1.40    ! anton     332:       if ((c = getc(wfileid))!='\n')
        !           333:        gf_ungetc(c,wfileid);
1.5       anton     334:       else
                    335:        u3++;
                    336:       break;
                    337:     }
                    338:     if (c==EOF) {
                    339:       flag=FLAG(u2!=0);
                    340:       break;
                    341:     }
                    342:     c_addr[u2] = (Char)c;
                    343:   }
1.40    ! anton     344:   wior=FILEIO(ferror(wfileid));
1.5       anton     345:   r.n1 = u2;
                    346:   r.n2 = flag;
                    347:   r.n3 = u3;
                    348:   r.n4 = wior;
                    349:   return r;
                    350: }
                    351: 
                    352: struct Cellpair file_status(Char *c_addr, UCell u)
                    353: {
                    354:   struct Cellpair r;
                    355:   Cell wfam;
                    356:   Cell wior;
                    357:   char *filename=tilde_cstr(c_addr, u, 1);
                    358: 
                    359:   if (access (filename, F_OK) != 0) {
                    360:     wfam=0;
                    361:     wior=IOR(1);
                    362:   }
                    363:   else if (access (filename, R_OK | W_OK) == 0) {
                    364:     wfam=2; /* r/w */
                    365:     wior=0;
                    366:   }
                    367:   else if (access (filename, R_OK) == 0) {
                    368:     wfam=0; /* r/o */
                    369:     wior=0;
                    370:   }
                    371:   else if (access (filename, W_OK) == 0) {
                    372:     wfam=4; /* w/o */
                    373:     wior=0;
                    374:   }
                    375:   else {
                    376:     wfam=1; /* well, we cannot access the file, but better deliver a
                    377:               legal access mode (r/o bin), so we get a decent error
                    378:               later upon open. */
                    379:     wior=0;
                    380:   }
                    381:   r.n1 = wfam;
                    382:   r.n2 = wior;
1.6       anton     383:   return r;
1.5       anton     384: }
                    385: 
                    386: Cell to_float(Char *c_addr, UCell u, Float *rp)
                    387: {
1.28      anton     388:   /* convertible string := <significand>[<exponent>]
                    389:      <significand> := [<sign>]{<digits>[.<digits0>] | .<digits> }
                    390:      <exponent>    := <marker><digits0>
                    391:      <marker>      := {<e-form> | <sign-form>}
                    392:      <e-form>      := <e-char>[<sign-form>]
                    393:      <sign-form>   := { + | - }
                    394:      <e-char>      := { D | d | E | e }
                    395:   */
                    396:   Char *s = c_addr;
                    397:   Char c;
                    398:   Char *send = c_addr+u;
                    399:   UCell ndigits = 0;
                    400:   UCell ndots = 0;
                    401:   UCell edigits = 0;
                    402:   char cnum[u+3]; /* append at most "e0\0" */
                    403:   char *t=cnum;
                    404:   char *endconv;
1.5       anton     405:   Float r;
1.28      anton     406:   
                    407:   if (s >= send) /* treat empty string as 0e */
                    408:     goto return0;
                    409:   switch ((c=*s)) {
                    410:   case ' ':
                    411:     /* "A string of blanks should be treated as a special case
                    412:        representing zero."*/
                    413:     for (s++; s<send; )
                    414:       if (*s++ != ' ')
                    415:         goto error;
                    416:     goto return0;
                    417:   case '-':
                    418:   case '+': *t++ = c; s++; goto aftersign;
                    419:   }
                    420:   aftersign: 
                    421:   if (s >= send)
                    422:     goto exponent;
                    423:   switch (c=*s) {
                    424:   case '0' ... '9': *t++ = c; ndigits++; s++; goto aftersign;
                    425:   case '.':         *t++ = c; ndots++;   s++; goto aftersign;
                    426:   default:                                    goto exponent;
                    427:   }
                    428:  exponent:
                    429:   if (ndigits < 1 || ndots > 1)
                    430:     goto error;
                    431:   *t++ = 'E';
                    432:   if (s >= send)
                    433:     goto done;
                    434:   switch (c=*s) {
                    435:   case 'D':
1.5       anton     436:   case 'd':
1.28      anton     437:   case 'E':
                    438:   case 'e': s++; break;
1.5       anton     439:   }
1.28      anton     440:   if (s >= send)
                    441:     goto done;
                    442:   switch (c=*s) {
                    443:   case '+':
                    444:   case '-': *t++ = c; s++; break;
                    445:   }
                    446:  edigits0:
                    447:   if (s >= send)
                    448:     goto done;
                    449:   switch (c=*s) {
                    450:   case '0' ... '9': *t++ = c; s++; edigits++; goto edigits0;
                    451:   default: goto error;
                    452:   }
                    453:  done:
                    454:   if (edigits == 0)
                    455:     *t++ = '0';
                    456:   *t++ = '\0';
                    457:   assert(t-cnum <= u+3);
                    458:   r = strtod(cnum, &endconv);
                    459:   assert(*endconv == '\0');
1.5       anton     460:   *rp = r;
1.28      anton     461:   return -1;
                    462:  return0:
                    463:   *rp = 0.0;
                    464:   return -1;
                    465:  error:
                    466:   *rp = 0.0;
                    467:   return 0;
1.5       anton     468: }
1.22      pazsan    469: #endif
1.5       anton     470: 
1.25      pazsan    471: #ifdef HAS_FLOATING
1.5       anton     472: Float v_star(Float *f_addr1, Cell nstride1, Float *f_addr2, Cell nstride2, UCell ucount)
                    473: {
                    474:   Float r;
                    475: 
                    476:   for (r=0.; ucount>0; ucount--) {
                    477:     r += *f_addr1 * *f_addr2;
                    478:     f_addr1 = (Float *)(((Address)f_addr1)+nstride1);
                    479:     f_addr2 = (Float *)(((Address)f_addr2)+nstride2);
                    480:   }
                    481:   return r;
                    482: }
                    483: 
                    484: void faxpy(Float ra, Float *f_x, Cell nstridex, Float *f_y, Cell nstridey, UCell ucount)
                    485: {
                    486:   for (; ucount>0; ucount--) {
                    487:     *f_y += ra * *f_x;
                    488:     f_x = (Float *)(((Address)f_x)+nstridex);
                    489:     f_y = (Float *)(((Address)f_y)+nstridey);
                    490:   }
1.1       anton     491: }
1.24      pazsan    492: #endif
1.9       pazsan    493: 
                    494: UCell lshift(UCell u1, UCell n)
                    495: {
                    496:   return u1 << n;
                    497: }
                    498: 
                    499: UCell rshift(UCell u1, UCell n)
                    500: {
                    501:   return u1 >> n;
1.10      anton     502: }
                    503: 
1.24      pazsan    504: #ifndef STANDALONE
1.10      anton     505: int gforth_system(Char *c_addr, UCell u)
                    506: {
                    507:   int retval;
                    508:   char *prefix = getenv("GFORTHSYSTEMPREFIX") ? : DEFAULTSYSTEMPREFIX;
                    509:   size_t prefixlen = strlen(prefix);
                    510:   char buffer[prefixlen+u+1];
1.39      anton     511:   fflush(stdout);
1.10      anton     512: #ifndef MSDOS
                    513:   int old_tp=terminal_prepped;
                    514:   deprep_terminal();
                    515: #endif
                    516:   memcpy(buffer,prefix,prefixlen);
                    517:   memcpy(buffer+prefixlen,c_addr,u);
                    518:   buffer[prefixlen+u]='\0';
                    519:   retval=system(buffer); /* ~ expansion on first part of string? */
                    520: #ifndef MSDOS
                    521:   if (old_tp)
                    522:     prep_terminal();
                    523: #endif
                    524:   return retval;
1.9       pazsan    525: }
1.26      anton     526: 
                    527: void gforth_ms(UCell u)
                    528: {
                    529: #ifdef HAVE_NANOSLEEP
                    530:   struct timespec time_req;
                    531:   time_req.tv_sec=u/1000;
                    532:   time_req.tv_nsec=1000000*(u%1000);
                    533:   while(nanosleep(&time_req, &time_req));
                    534: #else /* !defined(HAVE_NANOSLEEP) */
                    535:   struct timeval timeout;
                    536:   timeout.tv_sec=u/1000;
                    537:   timeout.tv_usec=1000*(u%1000);
                    538:   (void)select(0,0,0,0,&timeout);
                    539: #endif /* !defined(HAVE_NANOSLEEP) */
                    540: }
1.33      pazsan    541: 
                    542: UCell gforth_dlopen(Char *c_addr, UCell u)
                    543: {
                    544:   char * file=tilde_cstr(c_addr, u, 1);
1.36      pazsan    545:   UCell lib;
1.34      pazsan    546: #if defined(HAVE_LIBLTDL)
                    547:   lib = (UCell)lt_dlopen(file);
                    548:   if(lib) return lib;
1.33      pazsan    549: #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
                    550: #ifndef RTLD_GLOBAL
                    551: #define RTLD_GLOBAL 0
                    552: #endif
1.34      pazsan    553:   lib = (UCell)dlopen(file, RTLD_GLOBAL | RTLD_LAZY);
                    554:   if(lib) return lib;
                    555: #elif defined(_WIN32)
                    556:   lib = (UCell) GetModuleHandle(file);
                    557:   if(lib) return lib;
                    558: #endif
1.33      pazsan    559:   return 0;
                    560: }
                    561: 
1.26      anton     562: #endif /* !defined(STANDALONE) */
                    563: 
1.16      anton     564: 
1.17      anton     565: /* mixed division support; should usually be faster than gcc's
1.16      anton     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
1.17      anton     569:    ASM_SM_SLASH_REM and ASM_UM_SLASH_MOD appropriately. */
1.16      anton     570: 
1.17      anton     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: 
1.37      anton     593: 
1.27      anton     594: #if defined(udiv_qrnnd) && !defined(__alpha) && UDIV_NEEDS_NORMALIZATION
1.37      anton     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: 
1.17      anton     610: static Cell MAYBE_UNUSED nlz(UCell x)
1.16      anton     611:      /* number of leading zeros, adapted from "Hacker's Delight" */
                    612: {
                    613:    Cell n;
                    614: 
1.17      anton     615: #if !defined(COUNT_LEADING_ZEROS_0)
1.16      anton     616:    if (x == 0) return(CELL_BITS);
1.17      anton     617: #endif
                    618: #if defined(count_leading_zeros)
                    619:    count_leading_zeros(n,x);
                    620: #else
1.16      anton     621:    n = 0;
                    622: #if (SIZEOF_CHAR_P > 4)
1.27      anton     623:    if (x <= 0xffffffff) 
                    624:      n+=32;
                    625:    else
                    626:      x >>= 32;
1.16      anton     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;}
1.17      anton     633: #endif
1.16      anton     634:    return n;
                    635: }
1.27      anton     636: #endif /*defined(udiv_qrnnd) && !defined(__alpha) && UDIV_NEEDS_NORMALIZATION*/
1.16      anton     637: 
1.17      anton     638: #if !defined(ASM_UM_SLASH_MOD)
1.16      anton     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: {
1.17      anton     643:   UDCell res;
1.27      anton     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 */
1.17      anton     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;
1.19      anton     666:   u = UDLSHIFT(u,lz);
1.17      anton     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);
1.27      anton     674: #else /* !(defined(udiv_qrnnd) && !defined(__alpha)) */
1.16      anton     675:   /* simple restoring subtract-and-shift algorithm, might be faster on Alpha */
                    676:   int i = CELL_BITS, c = 0;
                    677:   UCell q = 0;
1.27      anton     678:   UCell h, l;
1.16      anton     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);
1.27      anton     701: #endif /* !(defined(udiv_qrnnd) && !defined(__alpha)) */
1.16      anton     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 */
1.17      anton     709: static UDCell MAYBE_UNUSED umdiv (UDCell u, UCell v)
1.16      anton     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: 
1.17      anton     724: DCell smdiv (DCell num, Cell denom)
                    725:      /* symmetric divide procedure, mixed prec */
1.16      anton     726: {
                    727:   DCell res;
1.17      anton     728: #if defined(sdiv_qrnnd)
1.32      anton     729:   /* #warning "using sdiv_qrnnd" */
1.17      anton     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
1.16      anton     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);
1.17      anton     765: #endif
1.16      anton     766:   return res;
                    767: }
                    768: 
1.17      anton     769: DCell fmdiv (DCell num, Cell denom)
                    770:      /* floored divide procedure, mixed prec */
1.16      anton     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>