Annotation of gforth/engine/support.c, revision 1.39
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:
316: struct Cellquad read_line(Char *c_addr, UCell u1, Cell wfileid)
317: {
318: UCell u2, u3;
319: Cell flag, wior;
320: Cell c;
321: struct Cellquad r;
322:
323: flag=-1;
324: u3=0;
325: for(u2=0; u2<u1; u2++) {
326: c = getc((FILE *)wfileid);
327: u3++;
328: if (c=='\n') break;
329: if (c=='\r') {
330: if ((c = getc((FILE *)wfileid))!='\n')
331: ungetc(c,(FILE *)wfileid);
332: else
333: u3++;
334: break;
335: }
336: if (c==EOF) {
337: flag=FLAG(u2!=0);
338: break;
339: }
340: c_addr[u2] = (Char)c;
341: }
342: wior=FILEIO(ferror((FILE *)wfileid));
343: r.n1 = u2;
344: r.n2 = flag;
345: r.n3 = u3;
346: r.n4 = wior;
347: return r;
348: }
349:
350: struct Cellpair file_status(Char *c_addr, UCell u)
351: {
352: struct Cellpair r;
353: Cell wfam;
354: Cell wior;
355: char *filename=tilde_cstr(c_addr, u, 1);
356:
357: if (access (filename, F_OK) != 0) {
358: wfam=0;
359: wior=IOR(1);
360: }
361: else if (access (filename, R_OK | W_OK) == 0) {
362: wfam=2; /* r/w */
363: wior=0;
364: }
365: else if (access (filename, R_OK) == 0) {
366: wfam=0; /* r/o */
367: wior=0;
368: }
369: else if (access (filename, W_OK) == 0) {
370: wfam=4; /* w/o */
371: wior=0;
372: }
373: else {
374: wfam=1; /* well, we cannot access the file, but better deliver a
375: legal access mode (r/o bin), so we get a decent error
376: later upon open. */
377: wior=0;
378: }
379: r.n1 = wfam;
380: r.n2 = wior;
1.6 anton 381: return r;
1.5 anton 382: }
383:
384: Cell to_float(Char *c_addr, UCell u, Float *rp)
385: {
1.28 anton 386: /* convertible string := <significand>[<exponent>]
387: <significand> := [<sign>]{<digits>[.<digits0>] | .<digits> }
388: <exponent> := <marker><digits0>
389: <marker> := {<e-form> | <sign-form>}
390: <e-form> := <e-char>[<sign-form>]
391: <sign-form> := { + | - }
392: <e-char> := { D | d | E | e }
393: */
394: Char *s = c_addr;
395: Char c;
396: Char *send = c_addr+u;
397: UCell ndigits = 0;
398: UCell ndots = 0;
399: UCell edigits = 0;
400: char cnum[u+3]; /* append at most "e0\0" */
401: char *t=cnum;
402: char *endconv;
1.5 anton 403: Float r;
1.28 anton 404:
405: if (s >= send) /* treat empty string as 0e */
406: goto return0;
407: switch ((c=*s)) {
408: case ' ':
409: /* "A string of blanks should be treated as a special case
410: representing zero."*/
411: for (s++; s<send; )
412: if (*s++ != ' ')
413: goto error;
414: goto return0;
415: case '-':
416: case '+': *t++ = c; s++; goto aftersign;
417: }
418: aftersign:
419: if (s >= send)
420: goto exponent;
421: switch (c=*s) {
422: case '0' ... '9': *t++ = c; ndigits++; s++; goto aftersign;
423: case '.': *t++ = c; ndots++; s++; goto aftersign;
424: default: goto exponent;
425: }
426: exponent:
427: if (ndigits < 1 || ndots > 1)
428: goto error;
429: *t++ = 'E';
430: if (s >= send)
431: goto done;
432: switch (c=*s) {
433: case 'D':
1.5 anton 434: case 'd':
1.28 anton 435: case 'E':
436: case 'e': s++; break;
1.5 anton 437: }
1.28 anton 438: if (s >= send)
439: goto done;
440: switch (c=*s) {
441: case '+':
442: case '-': *t++ = c; s++; break;
443: }
444: edigits0:
445: if (s >= send)
446: goto done;
447: switch (c=*s) {
448: case '0' ... '9': *t++ = c; s++; edigits++; goto edigits0;
449: default: goto error;
450: }
451: done:
452: if (edigits == 0)
453: *t++ = '0';
454: *t++ = '\0';
455: assert(t-cnum <= u+3);
456: r = strtod(cnum, &endconv);
457: assert(*endconv == '\0');
1.5 anton 458: *rp = r;
1.28 anton 459: return -1;
460: return0:
461: *rp = 0.0;
462: return -1;
463: error:
464: *rp = 0.0;
465: return 0;
1.5 anton 466: }
1.22 pazsan 467: #endif
1.5 anton 468:
1.25 pazsan 469: #ifdef HAS_FLOATING
1.5 anton 470: Float v_star(Float *f_addr1, Cell nstride1, Float *f_addr2, Cell nstride2, UCell ucount)
471: {
472: Float r;
473:
474: for (r=0.; ucount>0; ucount--) {
475: r += *f_addr1 * *f_addr2;
476: f_addr1 = (Float *)(((Address)f_addr1)+nstride1);
477: f_addr2 = (Float *)(((Address)f_addr2)+nstride2);
478: }
479: return r;
480: }
481:
482: void faxpy(Float ra, Float *f_x, Cell nstridex, Float *f_y, Cell nstridey, UCell ucount)
483: {
484: for (; ucount>0; ucount--) {
485: *f_y += ra * *f_x;
486: f_x = (Float *)(((Address)f_x)+nstridex);
487: f_y = (Float *)(((Address)f_y)+nstridey);
488: }
1.1 anton 489: }
1.24 pazsan 490: #endif
1.9 pazsan 491:
492: UCell lshift(UCell u1, UCell n)
493: {
494: return u1 << n;
495: }
496:
497: UCell rshift(UCell u1, UCell n)
498: {
499: return u1 >> n;
1.10 anton 500: }
501:
1.24 pazsan 502: #ifndef STANDALONE
1.10 anton 503: int gforth_system(Char *c_addr, UCell u)
504: {
505: int retval;
506: char *prefix = getenv("GFORTHSYSTEMPREFIX") ? : DEFAULTSYSTEMPREFIX;
507: size_t prefixlen = strlen(prefix);
508: char buffer[prefixlen+u+1];
1.39 ! anton 509: fflush(stdout);
1.10 anton 510: #ifndef MSDOS
511: int old_tp=terminal_prepped;
512: deprep_terminal();
513: #endif
514: memcpy(buffer,prefix,prefixlen);
515: memcpy(buffer+prefixlen,c_addr,u);
516: buffer[prefixlen+u]='\0';
517: retval=system(buffer); /* ~ expansion on first part of string? */
518: #ifndef MSDOS
519: if (old_tp)
520: prep_terminal();
521: #endif
522: return retval;
1.9 pazsan 523: }
1.26 anton 524:
525: void gforth_ms(UCell u)
526: {
527: #ifdef HAVE_NANOSLEEP
528: struct timespec time_req;
529: time_req.tv_sec=u/1000;
530: time_req.tv_nsec=1000000*(u%1000);
531: while(nanosleep(&time_req, &time_req));
532: #else /* !defined(HAVE_NANOSLEEP) */
533: struct timeval timeout;
534: timeout.tv_sec=u/1000;
535: timeout.tv_usec=1000*(u%1000);
536: (void)select(0,0,0,0,&timeout);
537: #endif /* !defined(HAVE_NANOSLEEP) */
538: }
1.33 pazsan 539:
540: UCell gforth_dlopen(Char *c_addr, UCell u)
541: {
542: char * file=tilde_cstr(c_addr, u, 1);
1.36 pazsan 543: UCell lib;
1.34 pazsan 544: #if defined(HAVE_LIBLTDL)
545: lib = (UCell)lt_dlopen(file);
546: if(lib) return lib;
1.33 pazsan 547: #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
548: #ifndef RTLD_GLOBAL
549: #define RTLD_GLOBAL 0
550: #endif
1.34 pazsan 551: lib = (UCell)dlopen(file, RTLD_GLOBAL | RTLD_LAZY);
552: if(lib) return lib;
553: #elif defined(_WIN32)
554: lib = (UCell) GetModuleHandle(file);
555: if(lib) return lib;
556: #endif
1.33 pazsan 557: return 0;
558: }
559:
1.26 anton 560: #endif /* !defined(STANDALONE) */
561:
1.16 anton 562:
1.17 anton 563: /* mixed division support; should usually be faster than gcc's
1.16 anton 564: double-by-double division (and gcc typically does not generate
565: double-by-single division because of exception handling issues. If
566: the architecture has double-by-single division, you should define
1.17 anton 567: ASM_SM_SLASH_REM and ASM_UM_SLASH_MOD appropriately. */
1.16 anton 568:
1.17 anton 569: /* Type definitions for longlong.h (according to the comments at the start):
570: declarations taken from libgcc2.h */
571:
572: typedef unsigned int UQItype __attribute__ ((mode (QI)));
573: typedef int SItype __attribute__ ((mode (SI)));
574: typedef unsigned int USItype __attribute__ ((mode (SI)));
575: typedef int DItype __attribute__ ((mode (DI)));
576: typedef unsigned int UDItype __attribute__ ((mode (DI)));
577: typedef UCell UWtype;
578: #if (SIZEOF_CHAR_P == 4)
579: typedef unsigned int UHWtype __attribute__ ((mode (HI)));
580: #endif
581: #if (SIZEOF_CHAR_P == 8)
582: typedef USItype UHWtype;
583: #endif
584: #ifndef BUGGY_LONG_LONG
585: typedef UDCell UDWtype;
586: #endif
587: #define W_TYPE_SIZE (SIZEOF_CHAR_P * 8)
588:
589: #include "longlong.h"
590:
1.37 anton 591:
1.27 anton 592: #if defined(udiv_qrnnd) && !defined(__alpha) && UDIV_NEEDS_NORMALIZATION
1.37 anton 593:
594: #if defined(count_leading_zeros)
595: const UQItype __clz_tab[256] =
596: {
597: 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,
598: 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,
599: 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
600: 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: 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
602: 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
603: 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
604: 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: };
606: #endif
607:
1.17 anton 608: static Cell MAYBE_UNUSED nlz(UCell x)
1.16 anton 609: /* number of leading zeros, adapted from "Hacker's Delight" */
610: {
611: Cell n;
612:
1.17 anton 613: #if !defined(COUNT_LEADING_ZEROS_0)
1.16 anton 614: if (x == 0) return(CELL_BITS);
1.17 anton 615: #endif
616: #if defined(count_leading_zeros)
617: count_leading_zeros(n,x);
618: #else
1.16 anton 619: n = 0;
620: #if (SIZEOF_CHAR_P > 4)
1.27 anton 621: if (x <= 0xffffffff)
622: n+=32;
623: else
624: x >>= 32;
1.16 anton 625: #endif
626: if (x <= 0x0000FFFF) {n = n +16; x = x <<16;}
627: if (x <= 0x00FFFFFF) {n = n + 8; x = x << 8;}
628: if (x <= 0x0FFFFFFF) {n = n + 4; x = x << 4;}
629: if (x <= 0x3FFFFFFF) {n = n + 2; x = x << 2;}
630: if (x <= 0x7FFFFFFF) {n = n + 1;}
1.17 anton 631: #endif
1.16 anton 632: return n;
633: }
1.27 anton 634: #endif /*defined(udiv_qrnnd) && !defined(__alpha) && UDIV_NEEDS_NORMALIZATION*/
1.16 anton 635:
1.17 anton 636: #if !defined(ASM_UM_SLASH_MOD)
1.16 anton 637: UDCell umdiv (UDCell u, UCell v)
638: /* Divide unsigned double by single precision using shifts and subtracts.
639: Return quotient in lo, remainder in hi. */
640: {
1.17 anton 641: UDCell res;
1.27 anton 642: #if defined(udiv_qrnnd) && !defined(__alpha)
643: #if 0
644: This code is slower on an Alpha (timings with gcc-3.3.5):
645: other this
646: */ 5205 ms 5741 ms
647: */mod 5167 ms 5717 ms
648: fm/mod 5467 ms 5312 ms
649: sm/rem 4734 ms 5278 ms
650: um/mod 4490 ms 5020 ms
651: m*/ 15557 ms 17151 ms
652: #endif /* 0 */
1.17 anton 653: UCell q,r,u0,u1;
654: UCell MAYBE_UNUSED lz;
655:
656: vm_ud2twoCell(u,u0,u1);
657: if (v==0)
658: throw(BALL_DIVZERO);
659: if (u1>=v)
660: throw(BALL_RESULTRANGE);
661: #if UDIV_NEEDS_NORMALIZATION
662: lz = nlz(v);
663: v <<= lz;
1.19 anton 664: u = UDLSHIFT(u,lz);
1.17 anton 665: vm_ud2twoCell(u,u0,u1);
666: #endif
667: udiv_qrnnd(q,r,u1,u0,v);
668: #if UDIV_NEEDS_NORMALIZATION
669: r >>= lz;
670: #endif
671: vm_twoCell2ud(q,r,res);
1.27 anton 672: #else /* !(defined(udiv_qrnnd) && !defined(__alpha)) */
1.16 anton 673: /* simple restoring subtract-and-shift algorithm, might be faster on Alpha */
674: int i = CELL_BITS, c = 0;
675: UCell q = 0;
1.27 anton 676: UCell h, l;
1.16 anton 677:
678: vm_ud2twoCell(u,l,h);
679: if (v==0)
680: throw(BALL_DIVZERO);
681: if (h>=v)
682: throw(BALL_RESULTRANGE);
683: for (;;)
684: {
685: if (c || h >= v)
686: {
687: q++;
688: h -= v;
689: }
690: if (--i < 0)
691: break;
692: c = HIGHBIT (h);
693: h <<= 1;
694: h += HIGHBIT (l);
695: l <<= 1;
696: q <<= 1;
697: }
698: vm_twoCell2ud(q,h,res);
1.27 anton 699: #endif /* !(defined(udiv_qrnnd) && !defined(__alpha)) */
1.16 anton 700: return res;
701: }
702: #endif
703:
704: #if !defined(ASM_SM_SLASH_REM)
705: #if defined(ASM_UM_SLASH_MOD)
706: /* define it if it is not defined above */
1.17 anton 707: static UDCell MAYBE_UNUSED umdiv (UDCell u, UCell v)
1.16 anton 708: {
709: UDCell res;
710: UCell u0,u1;
711: vm_ud2twoCell(u,u0,u1);
712: ASM_UM_SLASH_MOD(u0,u1,v,r,q);
713: vm_twoCell2ud(q,r,res);
714: return res;
715: }
716: #endif /* defined(ASM_UM_SLASH_MOD) */
717:
718: #ifndef BUGGY_LONG_LONG
719: #define dnegate(x) (-(x))
720: #endif
721:
1.17 anton 722: DCell smdiv (DCell num, Cell denom)
723: /* symmetric divide procedure, mixed prec */
1.16 anton 724: {
725: DCell res;
1.17 anton 726: #if defined(sdiv_qrnnd)
1.32 anton 727: /* #warning "using sdiv_qrnnd" */
1.17 anton 728: Cell u1,q,r
729: UCell u0;
730: UCell MAYBE_UNUSED lz;
731:
732: vm_d2twoCell(u,u0,u1);
733: if (v==0)
734: throw(BALL_DIVZERO);
735: if (u1>=v)
736: throw(BALL_RESULTRANGE);
737: sdiv_qrnnd(q,r,u1,u0,v);
738: vm_twoCell2d(q,r,res);
739: #else
1.16 anton 740: UDCell ures;
741: UCell l, q, r;
742: Cell h;
743: Cell denomsign=denom;
744:
745: vm_d2twoCell(num,l,h);
746: if (h < 0)
747: num = dnegate (num);
748: if (denomsign < 0)
749: denom = -denom;
750: ures = umdiv(D2UD(num), denom);
751: vm_ud2twoCell(ures,q,r);
752: if ((h^denomsign)<0) {
753: q = -q;
754: if (((Cell)q) > 0) /* note: == 0 is possible */
755: throw(BALL_RESULTRANGE);
756: } else {
757: if (((Cell)q) < 0)
758: throw(BALL_RESULTRANGE);
759: }
760: if (h<0)
761: r = -r;
762: vm_twoCell2d(q,r,res);
1.17 anton 763: #endif
1.16 anton 764: return res;
765: }
766:
1.17 anton 767: DCell fmdiv (DCell num, Cell denom)
768: /* floored divide procedure, mixed prec */
1.16 anton 769: {
770: /* I have this technique from Andrew Haley */
771: DCell res;
772: UDCell ures;
773: Cell denomsign=denom;
774: Cell numsign;
775: UCell q,r;
776:
777: if (denom < 0) {
778: denom = -denom;
779: num = dnegate(num);
780: }
781: numsign = DHI(num);
782: if (numsign < 0)
783: DHI_IS(num,DHI(num)+denom);
784: ures = umdiv(D2UD(num),denom);
785: vm_ud2twoCell(ures,q,r);
786: if ((numsign^((Cell)q)) < 0)
787: throw(BALL_RESULTRANGE);
788: if (denomsign<0)
789: r = -r;
790: vm_twoCell2d(q,r,res);
791: return res;
792: }
793: #endif
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>