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