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

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

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