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