1: /* Gforth support functions
2:
3: Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2006,2007,2008,2009,2010,2011,2012 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: #include <sys/types.h>
36: #include <sys/stat.h>
37: #include <fcntl.h>
38: #include <time.h>
39: #endif
40: #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */
41: #include <dlfcn.h>
42: #endif
43:
44: #ifdef HAS_FILE
45: char *cstr(Char *from, UCell size)
46: /* return a C-string corresponding to the Forth string ( FROM SIZE ).
47: the C-string lives until free */
48: {
49: char * string = malloc(size+1);
50: memcpy(string,from,size);
51: string[size]='\0';
52: return string;
53: }
54:
55: char *tilde_cstr(Char *from, UCell size)
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]!='~')
63: return cstr(from, size);
64: if (size<2 || from[1]=='/') {
65: s1 = (char *)getenv ("HOME");
66: if(s1 == NULL)
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
73: s1 = "";
74: s2 = (char *)from+1;
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 */
81: return cstr(from+3, size<3?0:size-3);
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)
89: return cstr(from, size);
90: s1 = user_entry->pw_dir;
91: s2 = (char *)from+i;
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);
101: return cstr((Char *)path,s1_len+s2_len);
102: }
103: }
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) */
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:
134: DCell timespec2ns(struct timespec *tvp)
135: {
136: #ifndef BUGGY_LONG_LONG
137: return (tvp->tv_sec*(DCell)1000000000LL)+tvp->tv_nsec;
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:
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
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:
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:
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 &&
226: memcasecmp(c_addr, (Char *)(longname1->name), u)== 0 /* or inline? */)
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 &&
239: memcasecmp(c_addr, (Char *)(longname1->name), u)== 0 /* or inline? */) {
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: ;
291: result.n1 = (Cell)c_addr2;
292: result.n2 = c_addr1-c_addr2;
293: } else {
294: result.n1 = (Cell)c_addr1;
295: result.n2 = 0;
296: }
297: return result;
298: }
299:
300: #ifdef HAS_FILE
301: Cell rename_file(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2)
302: {
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);
308: }
309:
310: struct Cellquad read_line(Char *c_addr, UCell u1, FILE *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: if (u1>0)
320: gf_regetc(wfileid);
321: for(u2=0; u2<u1; u2++) {
322: c = getc(wfileid);
323: u3++;
324: if (c=='\n') break;
325: if (c=='\r') {
326: if ((c = getc(wfileid))!='\n')
327: gf_ungetc(c,wfileid);
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: }
338: wior=FILEIO(ferror(wfileid));
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;
351: char *filename=tilde_cstr(c_addr, u);
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;
377: free(filename);
378: return r;
379: }
380:
381: Cell to_float(Char *c_addr, UCell u, Float *rp, Char dot)
382: {
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;
400: Float r;
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: if((c=*s)==dot) { *t++ = '.'; ndots++; s++; goto aftersign; }
419: switch (c) {
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':
431: case 'd':
432: case 'E':
433: case 'e': s++; break;
434: }
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');
455: *rp = r;
456: return -1;
457: return0:
458: *rp = 0.0;
459: return -1;
460: error:
461: *rp = 0.0;
462: return 0;
463: }
464: #endif
465:
466: #ifdef HAS_FLOATING
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: }
486: }
487: #endif
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;
497: }
498:
499: #ifndef STANDALONE
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: int MAYBE_UNUSED old_tp;
507: fflush(stdout);
508: #ifndef MSDOS
509: old_tp=terminal_prepped;
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;
521: }
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: }
537:
538: UCell gforth_dlopen(Char *c_addr, UCell u)
539: {
540: char * file=tilde_cstr(c_addr, u);
541: UCell lib;
542: #if defined(HAVE_LIBLTDL)
543: lib = (UCell)lt_dlopen(file);
544: free(file);
545: if(lib) return lib;
546: #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
547: #ifndef RTLD_GLOBAL
548: #define RTLD_GLOBAL 0
549: #endif
550: lib = (UCell)dlopen(file, RTLD_GLOBAL);
551: free(file);
552: if(lib) return lib;
553: fprintf(stderr, "%s\n", dlerror());
554: #elif defined(_WIN32)
555: lib = (UCell) GetModuleHandle(file);
556: free(file);
557: if(lib) return lib;
558: #endif
559: return 0;
560: }
561:
562: #endif /* !defined(STANDALONE) */
563:
564:
565: /* mixed division support; should usually be faster than gcc's
566: double-by-double division (and gcc typically does not generate
567: double-by-single division because of exception handling issues. If
568: the architecture has double-by-single division, you should define
569: ASM_SM_SLASH_REM and ASM_UM_SLASH_MOD appropriately. */
570:
571: /* Type definitions for longlong.h (according to the comments at the start):
572: declarations taken from libgcc2.h */
573:
574: typedef unsigned int UQItype __attribute__ ((mode (QI)));
575: typedef int SItype __attribute__ ((mode (SI)));
576: typedef unsigned int USItype __attribute__ ((mode (SI)));
577: typedef int DItype __attribute__ ((mode (DI)));
578: typedef unsigned int UDItype __attribute__ ((mode (DI)));
579: typedef UCell UWtype;
580: #if (SIZEOF_CHAR_P == 4)
581: typedef unsigned int UHWtype __attribute__ ((mode (HI)));
582: #endif
583: #if (SIZEOF_CHAR_P == 8)
584: typedef USItype UHWtype;
585: #endif
586: #ifndef BUGGY_LONG_LONG
587: typedef UDCell UDWtype;
588: #endif
589: #define W_TYPE_SIZE (SIZEOF_CHAR_P * 8)
590:
591: #include "longlong.h"
592:
593:
594: #if defined(udiv_qrnnd) && !defined(__alpha) && UDIV_NEEDS_NORMALIZATION
595:
596: #if defined(count_leading_zeros)
597: const UQItype __clz_tab[256] =
598: {
599: 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,
600: 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,
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: 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,
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: 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
607: };
608: #endif
609:
610: static Cell MAYBE_UNUSED nlz(UCell x)
611: /* number of leading zeros, adapted from "Hacker's Delight" */
612: {
613: Cell n;
614:
615: #if !defined(COUNT_LEADING_ZEROS_0)
616: if (x == 0) return(CELL_BITS);
617: #endif
618: #if defined(count_leading_zeros)
619: count_leading_zeros(n,x);
620: #else
621: n = 0;
622: #if (SIZEOF_CHAR_P > 4)
623: if (x <= 0xffffffff)
624: n+=32;
625: else
626: x >>= 32;
627: #endif
628: if (x <= 0x0000FFFF) {n = n +16; x = x <<16;}
629: if (x <= 0x00FFFFFF) {n = n + 8; x = x << 8;}
630: if (x <= 0x0FFFFFFF) {n = n + 4; x = x << 4;}
631: if (x <= 0x3FFFFFFF) {n = n + 2; x = x << 2;}
632: if (x <= 0x7FFFFFFF) {n = n + 1;}
633: #endif
634: return n;
635: }
636: #endif /*defined(udiv_qrnnd) && !defined(__alpha) && UDIV_NEEDS_NORMALIZATION*/
637:
638: #if !defined(ASM_UM_SLASH_MOD)
639: UDCell umdiv (UDCell u, UCell v)
640: /* Divide unsigned double by single precision using shifts and subtracts.
641: Return quotient in lo, remainder in hi. */
642: {
643: UDCell res;
644: #if defined(udiv_qrnnd) && !defined(__alpha)
645: #if 0
646: This code is slower on an Alpha (timings with gcc-3.3.5):
647: other this
648: */ 5205 ms 5741 ms
649: */mod 5167 ms 5717 ms
650: fm/mod 5467 ms 5312 ms
651: sm/rem 4734 ms 5278 ms
652: um/mod 4490 ms 5020 ms
653: m*/ 15557 ms 17151 ms
654: #endif /* 0 */
655: UCell q,r,u0,u1;
656: UCell MAYBE_UNUSED lz;
657:
658: vm_ud2twoCell(u,u0,u1);
659: if (v==0)
660: throw(BALL_DIVZERO);
661: if (u1>=v)
662: throw(BALL_RESULTRANGE);
663: #if UDIV_NEEDS_NORMALIZATION
664: lz = nlz(v);
665: v <<= lz;
666: u = UDLSHIFT(u,lz);
667: vm_ud2twoCell(u,u0,u1);
668: #endif
669: udiv_qrnnd(q,r,u1,u0,v);
670: #if UDIV_NEEDS_NORMALIZATION
671: r >>= lz;
672: #endif
673: vm_twoCell2ud(q,r,res);
674: #else /* !(defined(udiv_qrnnd) && !defined(__alpha)) */
675: /* simple restoring subtract-and-shift algorithm, might be faster on Alpha */
676: int i = CELL_BITS, c = 0;
677: UCell q = 0;
678: UCell h, l;
679:
680: vm_ud2twoCell(u,l,h);
681: if (v==0)
682: throw(BALL_DIVZERO);
683: if (h>=v)
684: throw(BALL_RESULTRANGE);
685: for (;;)
686: {
687: if (c || h >= v)
688: {
689: q++;
690: h -= v;
691: }
692: if (--i < 0)
693: break;
694: c = HIGHBIT (h);
695: h <<= 1;
696: h += HIGHBIT (l);
697: l <<= 1;
698: q <<= 1;
699: }
700: vm_twoCell2ud(q,h,res);
701: #endif /* !(defined(udiv_qrnnd) && !defined(__alpha)) */
702: return res;
703: }
704: #endif
705:
706: #if !defined(ASM_SM_SLASH_REM)
707: #if defined(ASM_UM_SLASH_MOD)
708: /* define it if it is not defined above */
709: static UDCell MAYBE_UNUSED umdiv (UDCell u, UCell v)
710: {
711: UDCell res;
712: UCell u0,u1;
713: vm_ud2twoCell(u,u0,u1);
714: ASM_UM_SLASH_MOD(u0,u1,v,r,q);
715: vm_twoCell2ud(q,r,res);
716: return res;
717: }
718: #endif /* defined(ASM_UM_SLASH_MOD) */
719:
720: #ifndef BUGGY_LONG_LONG
721: #define dnegate(x) (-(x))
722: #endif
723:
724: DCell smdiv (DCell num, Cell denom)
725: /* symmetric divide procedure, mixed prec */
726: {
727: DCell res;
728: #if defined(sdiv_qrnnd)
729: /* #warning "using sdiv_qrnnd" */
730: Cell u1,q,r
731: UCell u0;
732: UCell MAYBE_UNUSED lz;
733:
734: vm_d2twoCell(u,u0,u1);
735: if (v==0)
736: throw(BALL_DIVZERO);
737: if (u1>=v)
738: throw(BALL_RESULTRANGE);
739: sdiv_qrnnd(q,r,u1,u0,v);
740: vm_twoCell2d(q,r,res);
741: #else
742: UDCell ures;
743: UCell l, q, r;
744: Cell h;
745: Cell denomsign=denom;
746:
747: vm_d2twoCell(num,l,h);
748: if (h < 0)
749: num = dnegate (num);
750: if (denomsign < 0)
751: denom = -denom;
752: ures = umdiv(D2UD(num), denom);
753: vm_ud2twoCell(ures,q,r);
754: if ((h^denomsign)<0) {
755: q = -q;
756: if (((Cell)q) > 0) /* note: == 0 is possible */
757: throw(BALL_RESULTRANGE);
758: } else {
759: if (((Cell)q) < 0)
760: throw(BALL_RESULTRANGE);
761: }
762: if (h<0)
763: r = -r;
764: vm_twoCell2d(q,r,res);
765: #endif
766: return res;
767: }
768:
769: DCell fmdiv (DCell num, Cell denom)
770: /* floored divide procedure, mixed prec */
771: {
772: /* I have this technique from Andrew Haley */
773: DCell res;
774: UDCell ures;
775: Cell denomsign=denom;
776: Cell numsign;
777: UCell q,r;
778:
779: if (denom < 0) {
780: denom = -denom;
781: num = dnegate(num);
782: }
783: numsign = DHI(num);
784: if (numsign < 0)
785: DHI_IS(num,DHI(num)+denom);
786: ures = umdiv(D2UD(num),denom);
787: vm_ud2twoCell(ures,q,r);
788: if ((numsign^((Cell)q)) < 0)
789: throw(BALL_RESULTRANGE);
790: if (denomsign<0)
791: r = -r;
792: vm_twoCell2d(q,r,res);
793: return res;
794: }
795: #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