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