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_FLOAT
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: #endif
467:
468: /* mixed division support; should usually be faster than gcc's
469: double-by-double division (and gcc typically does not generate
470: double-by-single division because of exception handling issues. If
471: the architecture has double-by-single division, you should define
472: ASM_SM_SLASH_REM and ASM_UM_SLASH_MOD appropriately. */
473:
474: /* Type definitions for longlong.h (according to the comments at the start):
475: declarations taken from libgcc2.h */
476:
477: typedef unsigned int UQItype __attribute__ ((mode (QI)));
478: typedef int SItype __attribute__ ((mode (SI)));
479: typedef unsigned int USItype __attribute__ ((mode (SI)));
480: typedef int DItype __attribute__ ((mode (DI)));
481: typedef unsigned int UDItype __attribute__ ((mode (DI)));
482: typedef UCell UWtype;
483: #if (SIZEOF_CHAR_P == 4)
484: typedef unsigned int UHWtype __attribute__ ((mode (HI)));
485: #endif
486: #if (SIZEOF_CHAR_P == 8)
487: typedef USItype UHWtype;
488: #endif
489: #ifndef BUGGY_LONG_LONG
490: typedef UDCell UDWtype;
491: #endif
492: #define W_TYPE_SIZE (SIZEOF_CHAR_P * 8)
493:
494: #include "longlong.h"
495:
496: static Cell MAYBE_UNUSED nlz(UCell x)
497: /* number of leading zeros, adapted from "Hacker's Delight" */
498: {
499: Cell n;
500:
501: #if !defined(COUNT_LEADING_ZEROS_0)
502: if (x == 0) return(CELL_BITS);
503: #endif
504: #if defined(count_leading_zeros)
505: count_leading_zeros(n,x);
506: #else
507: #warning "count_leading_zeros undefined (should not happen)"
508: n = 0;
509: #if (SIZEOF_CHAR_P > 4)
510: if (x <= 0xffffffff) {n+=32; x <<= 32;}
511: #error "this can't be correct"
512: #endif
513: if (x <= 0x0000FFFF) {n = n +16; x = x <<16;}
514: if (x <= 0x00FFFFFF) {n = n + 8; x = x << 8;}
515: if (x <= 0x0FFFFFFF) {n = n + 4; x = x << 4;}
516: if (x <= 0x3FFFFFFF) {n = n + 2; x = x << 2;}
517: if (x <= 0x7FFFFFFF) {n = n + 1;}
518: #endif
519: return n;
520: }
521:
522: #if !defined(ASM_UM_SLASH_MOD)
523: UDCell umdiv (UDCell u, UCell v)
524: /* Divide unsigned double by single precision using shifts and subtracts.
525: Return quotient in lo, remainder in hi. */
526: {
527: UDCell res;
528: #if defined(udiv_qrnnd)
529: UCell q,r,u0,u1;
530: UCell MAYBE_UNUSED lz;
531:
532: vm_ud2twoCell(u,u0,u1);
533: if (v==0)
534: throw(BALL_DIVZERO);
535: if (u1>=v)
536: throw(BALL_RESULTRANGE);
537: #if UDIV_NEEDS_NORMALIZATION
538: lz = nlz(v);
539: v <<= lz;
540: u = UDLSHIFT(u,lz);
541: vm_ud2twoCell(u,u0,u1);
542: #endif
543: udiv_qrnnd(q,r,u1,u0,v);
544: #if UDIV_NEEDS_NORMALIZATION
545: r >>= lz;
546: #endif
547: vm_twoCell2ud(q,r,res);
548: #else /* !(defined(udiv_qrnnd) */
549: #warning "udiv_qrnnd undefined (should not happen)"
550: /* simple restoring subtract-and-shift algorithm, might be faster on Alpha */
551: int i = CELL_BITS, c = 0;
552: UCell q = 0;
553: Ucell h, l;
554:
555: vm_ud2twoCell(u,l,h);
556: if (v==0)
557: throw(BALL_DIVZERO);
558: if (h>=v)
559: throw(BALL_RESULTRANGE);
560: for (;;)
561: {
562: if (c || h >= v)
563: {
564: q++;
565: h -= v;
566: }
567: if (--i < 0)
568: break;
569: c = HIGHBIT (h);
570: h <<= 1;
571: h += HIGHBIT (l);
572: l <<= 1;
573: q <<= 1;
574: }
575: vm_twoCell2ud(q,h,res);
576: #endif /* !(defined(udiv_qrnnd) && */
577: return res;
578: }
579: #endif
580:
581: #if !defined(ASM_SM_SLASH_REM)
582: #if defined(ASM_UM_SLASH_MOD)
583: /* define it if it is not defined above */
584: static UDCell MAYBE_UNUSED umdiv (UDCell u, UCell v)
585: {
586: UDCell res;
587: UCell u0,u1;
588: vm_ud2twoCell(u,u0,u1);
589: ASM_UM_SLASH_MOD(u0,u1,v,r,q);
590: vm_twoCell2ud(q,r,res);
591: return res;
592: }
593: #endif /* defined(ASM_UM_SLASH_MOD) */
594:
595: #ifndef BUGGY_LONG_LONG
596: #define dnegate(x) (-(x))
597: #endif
598:
599: DCell smdiv (DCell num, Cell denom)
600: /* symmetric divide procedure, mixed prec */
601: {
602: DCell res;
603: #if defined(sdiv_qrnnd)
604: #warning "using sdiv_qrnnd"
605: Cell u1,q,r
606: UCell u0;
607: UCell MAYBE_UNUSED lz;
608:
609: vm_d2twoCell(u,u0,u1);
610: if (v==0)
611: throw(BALL_DIVZERO);
612: if (u1>=v)
613: throw(BALL_RESULTRANGE);
614: sdiv_qrnnd(q,r,u1,u0,v);
615: vm_twoCell2d(q,r,res);
616: #else
617: UDCell ures;
618: UCell l, q, r;
619: Cell h;
620: Cell denomsign=denom;
621:
622: vm_d2twoCell(num,l,h);
623: if (h < 0)
624: num = dnegate (num);
625: if (denomsign < 0)
626: denom = -denom;
627: ures = umdiv(D2UD(num), denom);
628: vm_ud2twoCell(ures,q,r);
629: if ((h^denomsign)<0) {
630: q = -q;
631: if (((Cell)q) > 0) /* note: == 0 is possible */
632: throw(BALL_RESULTRANGE);
633: } else {
634: if (((Cell)q) < 0)
635: throw(BALL_RESULTRANGE);
636: }
637: if (h<0)
638: r = -r;
639: vm_twoCell2d(q,r,res);
640: #endif
641: return res;
642: }
643:
644: DCell fmdiv (DCell num, Cell denom)
645: /* floored divide procedure, mixed prec */
646: {
647: /* I have this technique from Andrew Haley */
648: DCell res;
649: UDCell ures;
650: Cell denomsign=denom;
651: Cell numsign;
652: UCell q,r;
653:
654: if (denom < 0) {
655: denom = -denom;
656: num = dnegate(num);
657: }
658: numsign = DHI(num);
659: if (numsign < 0)
660: DHI_IS(num,DHI(num)+denom);
661: ures = umdiv(D2UD(num),denom);
662: vm_ud2twoCell(ures,q,r);
663: if ((numsign^((Cell)q)) < 0)
664: throw(BALL_RESULTRANGE);
665: if (denomsign<0)
666: r = -r;
667: vm_twoCell2d(q,r,res);
668: return res;
669: }
670: #endif
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>