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