Annotation of gforth/engine/support.c, revision 1.16
1.1 anton 1: /* Gforth support functions
2:
1.11 anton 3: Copyright (C) 1995,1996,1997,1998,2000,2003,2004 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
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"
1.10 anton 24: #include "io.h"
1.1 anton 25: #include <stdlib.h>
26: #include <string.h>
27: #include <sys/time.h>
28: #include <unistd.h>
29: #include <pwd.h>
30: #include <dirent.h>
1.2 anton 31: #include <math.h>
1.5 anton 32: #include <ctype.h>
33: #include <errno.h>
1.1 anton 34:
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)
1.8 pazsan 80: #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
1.1 anton 86: s1 = "";
1.15 pazsan 87: s2 = (char *)from+1;
1.1 anton 88: 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;
1.15 pazsan 104: s2 = (char *)from+i;
1.1 anton 105: 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);
1.15 pazsan 114: return cstr((Char *)path,s1_len+s2_len,clear);
1.1 anton 115: }
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:
1.2 anton 132: 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
1.5 anton 148: }
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:
1.14 pazsan 193: 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:
1.5 anton 207: 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 &&
1.15 pazsan 211: memcasecmp(c_addr, (Char *)(longname1->name), u)== 0 /* or inline? */)
1.5 anton 212: 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 &&
1.15 pazsan 224: memcasecmp(c_addr, (Char *)(longname1->name), u)== 0 /* or inline? */) {
1.5 anton 225: 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: ;
1.6 anton 276: result.n1 = (Cell)c_addr2;
1.5 anton 277: result.n2 = c_addr1-c_addr2;
278: } else {
1.6 anton 279: result.n1 = (Cell)c_addr1;
1.5 anton 280: 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;
1.6 anton 356: return r;
1.5 anton 357: }
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;
1.12 anton 366: if(number[0]==' ') {
367: UCell i;
368: for (i=1; i<u; i++)
369: if (number[i] != ' ')
370: return 0;
1.13 anton 371: *rp = 0.0;
1.12 anton 372: return -1;
373: }
1.5 anton 374: if(number[0]=='-') {
375: sign = 1;
376: number++;
377: u--;
1.12 anton 378: if (u==0)
379: return 0;
1.5 anton 380: }
1.12 anton 381: switch(number[u-1]) {
1.5 anton 382: case 'd':
383: case 'D':
384: case 'e':
1.12 anton 385: case 'E':
386: u--;
387: break;
1.5 anton 388: }
389: number[u]='\0';
390: r=strtod(number,&endconv);
1.12 anton 391: flag=FLAG((*endconv)=='\0');
392: if(flag) {
1.5 anton 393: if (sign)
394: r = -r;
395: } else if(*endconv=='d' || *endconv=='D') {
396: *endconv='E';
397: r=strtod(number,&endconv);
1.12 anton 398: flag=FLAG((*endconv)=='\0');
399: if (flag) {
1.5 anton 400: 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: }
1.1 anton 427: }
1.9 pazsan 428:
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;
1.10 anton 437: }
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;
1.9 pazsan 458: }
1.16 ! anton 459:
! 460: /* mixed division; should usually be faster than gcc's
! 461: 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: ASM_SM_SLASH_REM[4] and ASM_UM_SLASH_MOD[4] appropriately. */
! 465:
! 466: #if !defined(ASM_UM_SLASH_MOD)
! 467: static Cell nlz(UCell x)
! 468: /* number of leading zeros, adapted from "Hacker's Delight" */
! 469: {
! 470: Cell n;
! 471:
! 472: if (x == 0) return(CELL_BITS);
! 473: n = 0;
! 474: #if (SIZEOF_CHAR_P > 4)
! 475: if (x <= 0xffffffff) {n+=32; x <<= 32;}
! 476: #endif
! 477: if (x <= 0x0000FFFF) {n = n +16; x = x <<16;}
! 478: if (x <= 0x00FFFFFF) {n = n + 8; x = x << 8;}
! 479: if (x <= 0x0FFFFFFF) {n = n + 4; x = x << 4;}
! 480: if (x <= 0x3FFFFFFF) {n = n + 2; x = x << 2;}
! 481: if (x <= 0x7FFFFFFF) {n = n + 1;}
! 482: return n;
! 483: }
! 484:
! 485: UDCell umdiv (UDCell u, UCell v)
! 486: /* Divide unsigned double by single precision using shifts and subtracts.
! 487: Return quotient in lo, remainder in hi. */
! 488: {
! 489: #if 0
! 490: /* simple restoring subtract-and-shift algorithm, might be faster on Alpha */
! 491: int i = CELL_BITS, c = 0;
! 492: UCell q = 0;
! 493: Ucell h, l;
! 494: UDCell res;
! 495:
! 496: vm_ud2twoCell(u,l,h);
! 497: if (v==0)
! 498: throw(BALL_DIVZERO);
! 499: if (h>=v)
! 500: throw(BALL_RESULTRANGE);
! 501: for (;;)
! 502: {
! 503: if (c || h >= v)
! 504: {
! 505: q++;
! 506: h -= v;
! 507: }
! 508: if (--i < 0)
! 509: break;
! 510: c = HIGHBIT (h);
! 511: h <<= 1;
! 512: h += HIGHBIT (l);
! 513: l <<= 1;
! 514: q <<= 1;
! 515: }
! 516: vm_twoCell2ud(q,h,res);
! 517: #else
! 518: /* adapted from "Hacker's Delight", Figure 9-3,
! 519: http://www.hackersdelight.org/HDcode/divlu.cc, which in turn is
! 520: adapted from Knuth's TAoCP Vol 2., Sect 4.3.1, Algorithm D */
! 521: UCell u1, u0;
! 522: UDCell res;
! 523: UCell b = ((UCell)1)<<HALFCELL_BITS; /* Number base. */
! 524: UCell un1, un0, /* Norm. dividend LSD's. */
! 525: vn1, vn0, /* Norm. divisor digits. */
! 526: q1, q0, /* Quotient digits. */
! 527: un32, un21, un10,/* Dividend digit pairs. */
! 528: rhat; /* A remainder. */
! 529: Cell s; /* Shift amount for norm. */
! 530:
! 531: vm_ud2twoCell(u,u0,u1);
! 532: if (v==0)
! 533: throw(BALL_DIVZERO);
! 534: if (u1 >= v) /* overflow */
! 535: throw(BALL_RESULTRANGE);
! 536: s = nlz(v); /* 0 <= s <= CELL_BITS-1. */
! 537: v = v << s; /* Normalize divisor. */
! 538: vn1 = v >> HALFCELL_BITS; /* Break divisor up into */
! 539: vn0 = v & HALFCELL_MASK; /* two half-cell digits. */
! 540:
! 541: un32 = (u1 << s) | ((u0 >> (CELL_BITS-s)) & ((-s) >> (CELL_BITS-1)));
! 542: un10 = u0 << s; /* Shift dividend left. */
! 543:
! 544: un1 = un10 >> HALFCELL_BITS; /* Break right half of */
! 545: un0 = un10 & HALFCELL_MASK; /* dividend into two digits. */
! 546:
! 547: q1 = un32/vn1; /* Compute the first */
! 548: rhat = un32 - q1*vn1; /* quotient digit, q1. */
! 549: again1:
! 550: if (q1 >= b || q1*vn0 > b*rhat + un1) {
! 551: q1 = q1 - 1;
! 552: rhat = rhat + vn1;
! 553: if (rhat < b) goto again1;}
! 554:
! 555: un21 = un32*b + un1 - q1*v; /* Multiply and subtract. */
! 556:
! 557: q0 = un21/vn1; /* Compute the second */
! 558: rhat = un21 - q0*vn1; /* quotient digit, q0. */
! 559: again2:
! 560: if (q0 >= b || q0*vn0 > b*rhat + un0) {
! 561: q0 = q0 - 1;
! 562: rhat = rhat + vn1;
! 563: if (rhat < b) goto again2;}
! 564:
! 565: vm_twoCell2ud(q1*b + q0 /* quotient */,
! 566: (un21*b + un0 - q0*v) >> s /* remainder */,
! 567: res);
! 568: #endif
! 569: return res;
! 570: }
! 571: #endif
! 572:
! 573: #if !defined(ASM_SM_SLASH_REM)
! 574: #if defined(ASM_UM_SLASH_MOD)
! 575: /* define it if it is not defined above */
! 576: UDCell umdiv (UDCell u, UCell v)
! 577: {
! 578: UDCell res;
! 579: UCell u0,u1;
! 580: vm_ud2twoCell(u,u0,u1);
! 581: ASM_UM_SLASH_MOD(u0,u1,v,r,q);
! 582: vm_twoCell2ud(q,r,res);
! 583: return res;
! 584: }
! 585: #endif /* defined(ASM_UM_SLASH_MOD) */
! 586:
! 587: #ifndef BUGGY_LONG_LONG
! 588: #define dnegate(x) (-(x))
! 589: #endif
! 590:
! 591: DCell smdiv (DCell num, Cell denom) /* symmetric divide procedure, mixed prec */
! 592: {
! 593: DCell res;
! 594: UDCell ures;
! 595: UCell l, q, r;
! 596: Cell h;
! 597: Cell denomsign=denom;
! 598:
! 599: vm_d2twoCell(num,l,h);
! 600: if (h < 0)
! 601: num = dnegate (num);
! 602: if (denomsign < 0)
! 603: denom = -denom;
! 604: ures = umdiv(D2UD(num), denom);
! 605: vm_ud2twoCell(ures,q,r);
! 606: if ((h^denomsign)<0) {
! 607: q = -q;
! 608: if (((Cell)q) > 0) /* note: == 0 is possible */
! 609: throw(BALL_RESULTRANGE);
! 610: } else {
! 611: if (((Cell)q) < 0)
! 612: throw(BALL_RESULTRANGE);
! 613: }
! 614: if (h<0)
! 615: r = -r;
! 616: vm_twoCell2d(q,r,res);
! 617: return res;
! 618: }
! 619:
! 620: DCell fmdiv (DCell num, Cell denom) /* floored divide procedure, mixed prec */
! 621: {
! 622: /* I have this technique from Andrew Haley */
! 623: DCell res;
! 624: UDCell ures;
! 625: Cell denomsign=denom;
! 626: Cell numsign;
! 627: UCell q,r;
! 628:
! 629: if (denom < 0) {
! 630: denom = -denom;
! 631: num = dnegate(num);
! 632: }
! 633: numsign = DHI(num);
! 634: if (numsign < 0)
! 635: DHI_IS(num,DHI(num)+denom);
! 636: ures = umdiv(D2UD(num),denom);
! 637: vm_ud2twoCell(ures,q,r);
! 638: if ((numsign^((Cell)q)) < 0)
! 639: throw(BALL_RESULTRANGE);
! 640: if (denomsign<0)
! 641: r = -r;
! 642: vm_twoCell2d(q,r,res);
! 643: return res;
! 644: }
! 645: #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