[gforth] / gforth / engine / support.c  

gforth: gforth/engine/support.c

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help