1: /* Gforth support functions
2:
3: Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2006,2007,2008,2009,2010 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, 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)
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
95: s1 = "";
96: s2 = (char *)from+1;
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;
113: s2 = (char *)from+i;
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);
123: return cstr((Char *)path,s1_len+s2_len,clear);
124: }
125: }
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) */
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:
156: DCell timespec2ns(struct timespec *tvp)
157: {
158: #ifndef BUGGY_LONG_LONG
159: return (tvp->tv_sec*(DCell)1000000000LL)+tvp->tn_nsec;
160: #else
161: DCell d2;
162: DCell d1=mmul(tvp->tv_sec,1000000000);
163: d2.lo = d1.lo+tvp->tv_nsec;
164: d2.hi = d1.hi + (d2.lo<d1.lo);
165: return d2;
166: #endif
167: }
168:
169: DCell double2ll(Float r)
170: {
171: #ifndef BUGGY_LONG_LONG
172: return (DCell)(r);
173: #else
174: double ldexp(double x, int exp);
175: DCell d;
176: if (r<0) {
177: d.hi = ldexp(-r,-(int)(CELL_BITS));
178: d.lo = (-r)-ldexp((Float)d.hi,CELL_BITS);
179: return dnegate(d);
180: }
181: d.hi = ldexp(r,-(int)(CELL_BITS));
182: d.lo = r-ldexp((Float)d.hi,CELL_BITS);
183: return d;
184: #endif
185: }
186:
187: void cmove(Char *c_from, Char *c_to, UCell u)
188: {
189: while (u-- > 0)
190: *c_to++ = *c_from++;
191: }
192:
193: void cmove_up(Char *c_from, Char *c_to, UCell u)
194: {
195: while (u-- > 0)
196: c_to[u] = c_from[u];
197: }
198:
199: Cell compare(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2)
200: {
201: Cell n;
202:
203: n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
204: if (n==0)
205: n = u1-u2;
206: if (n<0)
207: n = -1;
208: else if (n>0)
209: n = 1;
210: return n;
211: }
212:
213: Cell memcasecmp(const Char *s1, const Char *s2, Cell n)
214: {
215: Cell i;
216:
217: for (i=0; i<n; i++) {
218: Char c1=toupper(s1[i]);
219: Char c2=toupper(s2[i]);
220: if (c1 != c2) {
221: if (c1 < c2)
222: return -1;
223: else
224: return 1;
225: }
226: }
227: return 0;
228: }
229:
230: Cell capscompare(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2)
231: {
232: Cell n;
233:
234: n = memcasecmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
235: if (n==0)
236: n = u1-u2;
237: if (n<0)
238: n = -1;
239: else if (n>0)
240: n = 1;
241: return n;
242: }
243:
244: struct Longname *listlfind(Char *c_addr, UCell u, struct Longname *longname1)
245: {
246: for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next))
247: if ((UCell)LONGNAME_COUNT(longname1)==u &&
248: memcasecmp(c_addr, (Char *)(longname1->name), u)== 0 /* or inline? */)
249: break;
250: return longname1;
251: }
252:
253: struct Longname *hashlfind(Char *c_addr, UCell u, Cell *a_addr)
254: {
255: struct Longname *longname1;
256:
257: while(a_addr != NULL) {
258: longname1=(struct Longname *)(a_addr[1]);
259: a_addr=(Cell *)(a_addr[0]);
260: if ((UCell)LONGNAME_COUNT(longname1)==u &&
261: memcasecmp(c_addr, (Char *)(longname1->name), u)== 0 /* or inline? */) {
262: return longname1;
263: }
264: }
265: return NULL;
266: }
267:
268: struct Longname *tablelfind(Char *c_addr, UCell u, Cell *a_addr)
269: {
270: struct Longname *longname1;
271: while(a_addr != NULL) {
272: longname1=(struct Longname *)(a_addr[1]);
273: a_addr=(Cell *)(a_addr[0]);
274: if ((UCell)LONGNAME_COUNT(longname1)==u &&
275: memcmp(c_addr, longname1->name, u)== 0 /* or inline? */) {
276: return longname1;
277: }
278: }
279: return NULL;
280: }
281:
282: UCell hashkey1(Char *c_addr, UCell u, UCell ubits)
283: /* this hash function rotates the key at every step by rot bits within
284: ubits bits and xors it with the character. This function does ok in
285: the chi-sqare-test. Rot should be <=7 (preferably <=5) for
286: ASCII strings (larger if ubits is large), and should share no
287: divisors with ubits.
288: */
289: {
290: 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};
291: unsigned rot = rot_values[ubits];
292: Char *cp = c_addr;
293: UCell ukey;
294:
295: for (ukey=0; cp<c_addr+u; cp++)
296: ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))
297: ^ toupper(*cp))
298: & ((1<<ubits)-1));
299: return ukey;
300: }
301:
302: struct Cellpair parse_white(Char *c_addr1, UCell u1)
303: {
304: /* use !isgraph instead of isspace? */
305: struct Cellpair result;
306: Char *c_addr2;
307: Char *endp = c_addr1+u1;
308: while (c_addr1<endp && isspace(*c_addr1))
309: c_addr1++;
310: if (c_addr1<endp) {
311: for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++)
312: ;
313: result.n1 = (Cell)c_addr2;
314: result.n2 = c_addr1-c_addr2;
315: } else {
316: result.n1 = (Cell)c_addr1;
317: result.n2 = 0;
318: }
319: return result;
320: }
321:
322: #ifdef HAS_FILE
323: Cell rename_file(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2)
324: {
325: char *s1=tilde_cstr(c_addr2, u2, 1);
326: return IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);
327: }
328:
329: struct Cellquad read_line(Char *c_addr, UCell u1, FILE *wfileid)
330: {
331: UCell u2, u3;
332: Cell flag, wior;
333: Cell c;
334: struct Cellquad r;
335:
336: flag=-1;
337: u3=0;
338: if (u1>0)
339: gf_regetc(wfileid);
340: for(u2=0; u2<u1; u2++) {
341: c = getc(wfileid);
342: u3++;
343: if (c=='\n') break;
344: if (c=='\r') {
345: if ((c = getc(wfileid))!='\n')
346: gf_ungetc(c,wfileid);
347: else
348: u3++;
349: break;
350: }
351: if (c==EOF) {
352: flag=FLAG(u2!=0);
353: break;
354: }
355: c_addr[u2] = (Char)c;
356: }
357: wior=FILEIO(ferror(wfileid));
358: r.n1 = u2;
359: r.n2 = flag;
360: r.n3 = u3;
361: r.n4 = wior;
362: return r;
363: }
364:
365: struct Cellpair file_status(Char *c_addr, UCell u)
366: {
367: struct Cellpair r;
368: Cell wfam;
369: Cell wior;
370: char *filename=tilde_cstr(c_addr, u, 1);
371:
372: if (access (filename, F_OK) != 0) {
373: wfam=0;
374: wior=IOR(1);
375: }
376: else if (access (filename, R_OK | W_OK) == 0) {
377: wfam=2; /* r/w */
378: wior=0;
379: }
380: else if (access (filename, R_OK) == 0) {
381: wfam=0; /* r/o */
382: wior=0;
383: }
384: else if (access (filename, W_OK) == 0) {
385: wfam=4; /* w/o */
386: wior=0;
387: }
388: else {
389: wfam=1; /* well, we cannot access the file, but better deliver a
390: legal access mode (r/o bin), so we get a decent error
391: later upon open. */
392: wior=0;
393: }
394: r.n1 = wfam;
395: r.n2 = wior;
396: return r;
397: }
398:
399: Cell to_float(Char *c_addr, UCell u, Float *rp)
400: {
401: /* convertible string := <significand>[<exponent>]
402: <significand> := [<sign>]{<digits>[.<digits0>] | .<digits> }
403: <exponent> := <marker><digits0>
404: <marker> := {<e-form> | <sign-form>}
405: <e-form> := <e-char>[<sign-form>]
406: <sign-form> := { + | - }
407: <e-char> := { D | d | E | e }
408: */
409: Char *s = c_addr;
410: Char c;
411: Char *send = c_addr+u;
412: UCell ndigits = 0;
413: UCell ndots = 0;
414: UCell edigits = 0;
415: char cnum[u+3]; /* append at most "e0\0" */
416: char *t=cnum;
417: char *endconv;
418: Float r;
419:
420: if (s >= send) /* treat empty string as 0e */
421: goto return0;
422: switch ((c=*s)) {
423: case ' ':
424: /* "A string of blanks should be treated as a special case
425: representing zero."*/
426: for (s++; s<send; )
427: if (*s++ != ' ')
428: goto error;
429: goto return0;
430: case '-':
431: case '+': *t++ = c; s++; goto aftersign;
432: }
433: aftersign:
434: if (s >= send)
435: goto exponent;
436: switch (c=*s) {
437: case '0' ... '9': *t++ = c; ndigits++; s++; goto aftersign;
438: case '.': *t++ = c; ndots++; s++; goto aftersign;
439: default: goto exponent;
440: }
441: exponent:
442: if (ndigits < 1 || ndots > 1)
443: goto error;
444: *t++ = 'E';
445: if (s >= send)
446: goto done;
447: switch (c=*s) {
448: case 'D':
449: case 'd':
450: case 'E':
451: case 'e': s++; break;
452: }
453: if (s >= send)
454: goto done;
455: switch (c=*s) {
456: case '+':
457: case '-': *t++ = c; s++; break;
458: }
459: edigits0:
460: if (s >= send)
461: goto done;
462: switch (c=*s) {
463: case '0' ... '9': *t++ = c; s++; edigits++; goto edigits0;
464: default: goto error;
465: }
466: done:
467: if (edigits == 0)
468: *t++ = '0';
469: *t++ = '\0';
470: assert(t-cnum <= u+3);
471: r = strtod(cnum, &endconv);
472: assert(*endconv == '\0');
473: *rp = r;
474: return -1;
475: return0:
476: *rp = 0.0;
477: return -1;
478: error:
479: *rp = 0.0;
480: return 0;
481: }
482: #endif
483:
484: #ifdef HAS_FLOATING
485: Float v_star(Float *f_addr1, Cell nstride1, Float *f_addr2, Cell nstride2, UCell ucount)
486: {
487: Float r;
488:
489: for (r=0.; ucount>0; ucount--) {
490: r += *f_addr1 * *f_addr2;
491: f_addr1 = (Float *)(((Address)f_addr1)+nstride1);
492: f_addr2 = (Float *)(((Address)f_addr2)+nstride2);
493: }
494: return r;
495: }
496:
497: void faxpy(Float ra, Float *f_x, Cell nstridex, Float *f_y, Cell nstridey, UCell ucount)
498: {
499: for (; ucount>0; ucount--) {
500: *f_y += ra * *f_x;
501: f_x = (Float *)(((Address)f_x)+nstridex);
502: f_y = (Float *)(((Address)f_y)+nstridey);
503: }
504: }
505: #endif
506:
507: UCell lshift(UCell u1, UCell n)
508: {
509: return u1 << n;
510: }
511:
512: UCell rshift(UCell u1, UCell n)
513: {
514: return u1 >> n;
515: }
516:
517: #ifndef STANDALONE
518: int gforth_system(Char *c_addr, UCell u)
519: {
520: int retval;
521: char *prefix = getenv("GFORTHSYSTEMPREFIX") ? : DEFAULTSYSTEMPREFIX;
522: size_t prefixlen = strlen(prefix);
523: char buffer[prefixlen+u+1];
524: int MAYBE_UNUSED old_tp;
525: fflush(stdout);
526: #ifndef MSDOS
527: old_tp=terminal_prepped;
528: deprep_terminal();
529: #endif
530: memcpy(buffer,prefix,prefixlen);
531: memcpy(buffer+prefixlen,c_addr,u);
532: buffer[prefixlen+u]='\0';
533: retval=system(buffer); /* ~ expansion on first part of string? */
534: #ifndef MSDOS
535: if (old_tp)
536: prep_terminal();
537: #endif
538: return retval;
539: }
540:
541: void gforth_ms(UCell u)
542: {
543: #ifdef HAVE_NANOSLEEP
544: struct timespec time_req;
545: time_req.tv_sec=u/1000;
546: time_req.tv_nsec=1000000*(u%1000);
547: while(nanosleep(&time_req, &time_req));
548: #else /* !defined(HAVE_NANOSLEEP) */
549: struct timeval timeout;
550: timeout.tv_sec=u/1000;
551: timeout.tv_usec=1000*(u%1000);
552: (void)select(0,0,0,0,&timeout);
553: #endif /* !defined(HAVE_NANOSLEEP) */
554: }
555:
556: UCell gforth_dlopen(Char *c_addr, UCell u)
557: {
558: char * file=tilde_cstr(c_addr, u, 1);
559: UCell lib;
560: #if defined(HAVE_LIBLTDL)
561: lib = (UCell)lt_dlopen(file);
562: if(lib) return lib;
563: #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
564: #ifndef RTLD_GLOBAL
565: #define RTLD_GLOBAL 0
566: #endif
567: lib = (UCell)dlopen(file, RTLD_GLOBAL | RTLD_LAZY);
568: if(lib) return lib;
569: #elif defined(_WIN32)
570: lib = (UCell) GetModuleHandle(file);
571: if(lib) return lib;
572: #endif
573: return 0;
574: }
575:
576: #endif /* !defined(STANDALONE) */
577:
578:
579: /* mixed division support; should usually be faster than gcc's
580: double-by-double division (and gcc typically does not generate
581: double-by-single division because of exception handling issues. If
582: the architecture has double-by-single division, you should define
583: ASM_SM_SLASH_REM and ASM_UM_SLASH_MOD appropriately. */
584:
585: /* Type definitions for longlong.h (according to the comments at the start):
586: declarations taken from libgcc2.h */
587:
588: typedef unsigned int UQItype __attribute__ ((mode (QI)));
589: typedef int SItype __attribute__ ((mode (SI)));
590: typedef unsigned int USItype __attribute__ ((mode (SI)));
591: typedef int DItype __attribute__ ((mode (DI)));
592: typedef unsigned int UDItype __attribute__ ((mode (DI)));
593: typedef UCell UWtype;
594: #if (SIZEOF_CHAR_P == 4)
595: typedef unsigned int UHWtype __attribute__ ((mode (HI)));
596: #endif
597: #if (SIZEOF_CHAR_P == 8)
598: typedef USItype UHWtype;
599: #endif
600: #ifndef BUGGY_LONG_LONG
601: typedef UDCell UDWtype;
602: #endif
603: #define W_TYPE_SIZE (SIZEOF_CHAR_P * 8)
604:
605: #include "longlong.h"
606:
607:
608: #if defined(udiv_qrnnd) && !defined(__alpha) && UDIV_NEEDS_NORMALIZATION
609:
610: #if defined(count_leading_zeros)
611: const UQItype __clz_tab[256] =
612: {
613: 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,
614: 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,
615: 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,
616: 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,
617: 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,
618: 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,
619: 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,
620: 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
621: };
622: #endif
623:
624: static Cell MAYBE_UNUSED nlz(UCell x)
625: /* number of leading zeros, adapted from "Hacker's Delight" */
626: {
627: Cell n;
628:
629: #if !defined(COUNT_LEADING_ZEROS_0)
630: if (x == 0) return(CELL_BITS);
631: #endif
632: #if defined(count_leading_zeros)
633: count_leading_zeros(n,x);
634: #else
635: n = 0;
636: #if (SIZEOF_CHAR_P > 4)
637: if (x <= 0xffffffff)
638: n+=32;
639: else
640: x >>= 32;
641: #endif
642: if (x <= 0x0000FFFF) {n = n +16; x = x <<16;}
643: if (x <= 0x00FFFFFF) {n = n + 8; x = x << 8;}
644: if (x <= 0x0FFFFFFF) {n = n + 4; x = x << 4;}
645: if (x <= 0x3FFFFFFF) {n = n + 2; x = x << 2;}
646: if (x <= 0x7FFFFFFF) {n = n + 1;}
647: #endif
648: return n;
649: }
650: #endif /*defined(udiv_qrnnd) && !defined(__alpha) && UDIV_NEEDS_NORMALIZATION*/
651:
652: #if !defined(ASM_UM_SLASH_MOD)
653: UDCell umdiv (UDCell u, UCell v)
654: /* Divide unsigned double by single precision using shifts and subtracts.
655: Return quotient in lo, remainder in hi. */
656: {
657: UDCell res;
658: #if defined(udiv_qrnnd) && !defined(__alpha)
659: #if 0
660: This code is slower on an Alpha (timings with gcc-3.3.5):
661: other this
662: */ 5205 ms 5741 ms
663: */mod 5167 ms 5717 ms
664: fm/mod 5467 ms 5312 ms
665: sm/rem 4734 ms 5278 ms
666: um/mod 4490 ms 5020 ms
667: m*/ 15557 ms 17151 ms
668: #endif /* 0 */
669: UCell q,r,u0,u1;
670: UCell MAYBE_UNUSED lz;
671:
672: vm_ud2twoCell(u,u0,u1);
673: if (v==0)
674: throw(BALL_DIVZERO);
675: if (u1>=v)
676: throw(BALL_RESULTRANGE);
677: #if UDIV_NEEDS_NORMALIZATION
678: lz = nlz(v);
679: v <<= lz;
680: u = UDLSHIFT(u,lz);
681: vm_ud2twoCell(u,u0,u1);
682: #endif
683: udiv_qrnnd(q,r,u1,u0,v);
684: #if UDIV_NEEDS_NORMALIZATION
685: r >>= lz;
686: #endif
687: vm_twoCell2ud(q,r,res);
688: #else /* !(defined(udiv_qrnnd) && !defined(__alpha)) */
689: /* simple restoring subtract-and-shift algorithm, might be faster on Alpha */
690: int i = CELL_BITS, c = 0;
691: UCell q = 0;
692: UCell h, l;
693:
694: vm_ud2twoCell(u,l,h);
695: if (v==0)
696: throw(BALL_DIVZERO);
697: if (h>=v)
698: throw(BALL_RESULTRANGE);
699: for (;;)
700: {
701: if (c || h >= v)
702: {
703: q++;
704: h -= v;
705: }
706: if (--i < 0)
707: break;
708: c = HIGHBIT (h);
709: h <<= 1;
710: h += HIGHBIT (l);
711: l <<= 1;
712: q <<= 1;
713: }
714: vm_twoCell2ud(q,h,res);
715: #endif /* !(defined(udiv_qrnnd) && !defined(__alpha)) */
716: return res;
717: }
718: #endif
719:
720: #if !defined(ASM_SM_SLASH_REM)
721: #if defined(ASM_UM_SLASH_MOD)
722: /* define it if it is not defined above */
723: static UDCell MAYBE_UNUSED umdiv (UDCell u, UCell v)
724: {
725: UDCell res;
726: UCell u0,u1;
727: vm_ud2twoCell(u,u0,u1);
728: ASM_UM_SLASH_MOD(u0,u1,v,r,q);
729: vm_twoCell2ud(q,r,res);
730: return res;
731: }
732: #endif /* defined(ASM_UM_SLASH_MOD) */
733:
734: #ifndef BUGGY_LONG_LONG
735: #define dnegate(x) (-(x))
736: #endif
737:
738: DCell smdiv (DCell num, Cell denom)
739: /* symmetric divide procedure, mixed prec */
740: {
741: DCell res;
742: #if defined(sdiv_qrnnd)
743: /* #warning "using sdiv_qrnnd" */
744: Cell u1,q,r
745: UCell u0;
746: UCell MAYBE_UNUSED lz;
747:
748: vm_d2twoCell(u,u0,u1);
749: if (v==0)
750: throw(BALL_DIVZERO);
751: if (u1>=v)
752: throw(BALL_RESULTRANGE);
753: sdiv_qrnnd(q,r,u1,u0,v);
754: vm_twoCell2d(q,r,res);
755: #else
756: UDCell ures;
757: UCell l, q, r;
758: Cell h;
759: Cell denomsign=denom;
760:
761: vm_d2twoCell(num,l,h);
762: if (h < 0)
763: num = dnegate (num);
764: if (denomsign < 0)
765: denom = -denom;
766: ures = umdiv(D2UD(num), denom);
767: vm_ud2twoCell(ures,q,r);
768: if ((h^denomsign)<0) {
769: q = -q;
770: if (((Cell)q) > 0) /* note: == 0 is possible */
771: throw(BALL_RESULTRANGE);
772: } else {
773: if (((Cell)q) < 0)
774: throw(BALL_RESULTRANGE);
775: }
776: if (h<0)
777: r = -r;
778: vm_twoCell2d(q,r,res);
779: #endif
780: return res;
781: }
782:
783: DCell fmdiv (DCell num, Cell denom)
784: /* floored divide procedure, mixed prec */
785: {
786: /* I have this technique from Andrew Haley */
787: DCell res;
788: UDCell ures;
789: Cell denomsign=denom;
790: Cell numsign;
791: UCell q,r;
792:
793: if (denom < 0) {
794: denom = -denom;
795: num = dnegate(num);
796: }
797: numsign = DHI(num);
798: if (numsign < 0)
799: DHI_IS(num,DHI(num)+denom);
800: ures = umdiv(D2UD(num),denom);
801: vm_ud2twoCell(ures,q,r);
802: if ((numsign^((Cell)q)) < 0)
803: throw(BALL_RESULTRANGE);
804: if (denomsign<0)
805: r = -r;
806: vm_twoCell2d(q,r,res);
807: return res;
808: }
809: #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