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