1: /* Gforth support functions
2:
3: Copyright (C) 1995,1996,1997,1998,2000,2003 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 <stdlib.h>
25: #include <string.h>
26: #include <sys/time.h>
27: #include <unistd.h>
28: #include <pwd.h>
29: #include <dirent.h>
30: #include <math.h>
31: #include <ctype.h>
32: #include <errno.h>
33:
34: #ifdef HAS_FILE
35: char *cstr(Char *from, UCell size, int clear)
36: /* return a C-string corresponding to the Forth string ( FROM SIZE ).
37: the C-string lives until the next call of cstr with CLEAR being true */
38: {
39: static struct cstr_buffer {
40: char *buffer;
41: size_t size;
42: } *buffers=NULL;
43: static int nbuffers=0;
44: static int used=0;
45: struct cstr_buffer *b;
46:
47: if (buffers==NULL)
48: buffers=malloc(0);
49: if (clear)
50: used=0;
51: if (used>=nbuffers) {
52: buffers=realloc(buffers,sizeof(struct cstr_buffer)*(used+1));
53: buffers[used]=(struct cstr_buffer){malloc(0),0};
54: nbuffers=used+1;
55: }
56: b=&buffers[used];
57: if (size+1 > b->size) {
58: b->buffer = realloc(b->buffer,size+1);
59: b->size = size+1;
60: }
61: memcpy(b->buffer,from,size);
62: b->buffer[size]='\0';
63: used++;
64: return b->buffer;
65: }
66:
67: char *tilde_cstr(Char *from, UCell size, int clear)
68: /* like cstr(), but perform tilde expansion on the string */
69: {
70: char *s1,*s2;
71: int s1_len, s2_len;
72: struct passwd *getpwnam (), *user_entry;
73:
74: if (size<1 || from[0]!='~')
75: return cstr(from, size, clear);
76: if (size<2 || from[1]=='/') {
77: s1 = (char *)getenv ("HOME");
78: if(s1 == NULL)
79: s1 = "";
80: s2 = from+1;
81: s2_len = size-1;
82: } else {
83: UCell i;
84: for (i=1; i<size && from[i]!='/'; i++)
85: ;
86: if (i==2 && from[1]=='+') /* deal with "~+", i.e., the wd */
87: return cstr(from+3, size<3?0:size-3,clear);
88: {
89: char user[i];
90: memcpy(user,from+1,i-1);
91: user[i-1]='\0';
92: user_entry=getpwnam(user);
93: }
94: if (user_entry==NULL)
95: return cstr(from, size, clear);
96: s1 = user_entry->pw_dir;
97: s2 = from+i;
98: s2_len = size-i;
99: }
100: s1_len = strlen(s1);
101: if (s1_len>1 && s1[s1_len-1]=='/')
102: s1_len--;
103: {
104: char path[s1_len+s2_len];
105: memcpy(path,s1,s1_len);
106: memcpy(path+s1_len,s2,s2_len);
107: return cstr(path,s1_len+s2_len,clear);
108: }
109: }
110: #endif
111:
112: DCell timeval2us(struct timeval *tvp)
113: {
114: #ifndef BUGGY_LONG_LONG
115: return (tvp->tv_sec*(DCell)1000000)+tvp->tv_usec;
116: #else
117: DCell d2;
118: DCell d1=mmul(tvp->tv_sec,1000000);
119: d2.lo = d1.lo+tvp->tv_usec;
120: d2.hi = d1.hi + (d2.lo<d1.lo);
121: return d2;
122: #endif
123: }
124:
125: DCell double2ll(Float r)
126: {
127: #ifndef BUGGY_LONG_LONG
128: return (DCell)(r);
129: #else
130: double ldexp(double x, int exp);
131: DCell d;
132: if (r<0) {
133: d.hi = ldexp(-r,-(int)(CELL_BITS));
134: d.lo = (-r)-ldexp((Float)d.hi,CELL_BITS);
135: return dnegate(d);
136: }
137: d.hi = ldexp(r,-(int)(CELL_BITS));
138: d.lo = r-ldexp((Float)d.hi,CELL_BITS);
139: return d;
140: #endif
141: }
142:
143: void cmove(Char *c_from, Char *c_to, UCell u)
144: {
145: while (u-- > 0)
146: *c_to++ = *c_from++;
147: }
148:
149: void cmove_up(Char *c_from, Char *c_to, UCell u)
150: {
151: while (u-- > 0)
152: c_to[u] = c_from[u];
153: }
154:
155: Cell compare(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2)
156: {
157: Cell n;
158:
159: n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
160: if (n==0)
161: n = u1-u2;
162: if (n<0)
163: n = -1;
164: else if (n>0)
165: n = 1;
166: return n;
167: }
168:
169: Cell memcasecmp(const Char *s1, const Char *s2, Cell n)
170: {
171: Cell i;
172:
173: for (i=0; i<n; i++) {
174: Char c1=toupper(s1[i]);
175: Char c2=toupper(s2[i]);
176: if (c1 != c2) {
177: if (c1 < c2)
178: return -1;
179: else
180: return 1;
181: }
182: }
183: return 0;
184: }
185:
186: struct Longname *listlfind(Char *c_addr, UCell u, struct Longname *longname1)
187: {
188: for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next))
189: if ((UCell)LONGNAME_COUNT(longname1)==u &&
190: memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)
191: break;
192: return longname1;
193: }
194:
195: struct Longname *hashlfind(Char *c_addr, UCell u, Cell *a_addr)
196: {
197: struct Longname *longname1;
198:
199: while(a_addr != NULL) {
200: longname1=(struct Longname *)(a_addr[1]);
201: a_addr=(Cell *)(a_addr[0]);
202: if ((UCell)LONGNAME_COUNT(longname1)==u &&
203: memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */) {
204: return longname1;
205: }
206: }
207: return NULL;
208: }
209:
210: struct Longname *tablelfind(Char *c_addr, UCell u, Cell *a_addr)
211: {
212: struct Longname *longname1;
213: while(a_addr != NULL) {
214: longname1=(struct Longname *)(a_addr[1]);
215: a_addr=(Cell *)(a_addr[0]);
216: if ((UCell)LONGNAME_COUNT(longname1)==u &&
217: memcmp(c_addr, longname1->name, u)== 0 /* or inline? */) {
218: return longname1;
219: }
220: }
221: return NULL;
222: }
223:
224: UCell hashkey1(Char *c_addr, UCell u, UCell ubits)
225: /* this hash function rotates the key at every step by rot bits within
226: ubits bits and xors it with the character. This function does ok in
227: the chi-sqare-test. Rot should be <=7 (preferably <=5) for
228: ASCII strings (larger if ubits is large), and should share no
229: divisors with ubits.
230: */
231: {
232: 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};
233: unsigned rot = rot_values[ubits];
234: Char *cp = c_addr;
235: UCell ukey;
236:
237: for (ukey=0; cp<c_addr+u; cp++)
238: ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))
239: ^ toupper(*cp))
240: & ((1<<ubits)-1));
241: return ukey;
242: }
243:
244: struct Cellpair parse_white(Char *c_addr1, UCell u1)
245: {
246: /* use !isgraph instead of isspace? */
247: struct Cellpair result;
248: Char *c_addr2;
249: Char *endp = c_addr1+u1;
250: while (c_addr1<endp && isspace(*c_addr1))
251: c_addr1++;
252: if (c_addr1<endp) {
253: for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++)
254: ;
255: result.n1 = (Cell)c_addr2;
256: result.n2 = c_addr1-c_addr2;
257: } else {
258: result.n1 = (Cell)c_addr1;
259: result.n2 = 0;
260: }
261: return result;
262: }
263:
264: Cell rename_file(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2)
265: {
266: char *s1=tilde_cstr(c_addr2, u2, 1);
267: return IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);
268: }
269:
270: struct Cellquad read_line(Char *c_addr, UCell u1, Cell wfileid)
271: {
272: UCell u2, u3;
273: Cell flag, wior;
274: Cell c;
275: struct Cellquad r;
276:
277: flag=-1;
278: u3=0;
279: for(u2=0; u2<u1; u2++) {
280: c = getc((FILE *)wfileid);
281: u3++;
282: if (c=='\n') break;
283: if (c=='\r') {
284: if ((c = getc((FILE *)wfileid))!='\n')
285: ungetc(c,(FILE *)wfileid);
286: else
287: u3++;
288: break;
289: }
290: if (c==EOF) {
291: flag=FLAG(u2!=0);
292: break;
293: }
294: c_addr[u2] = (Char)c;
295: }
296: wior=FILEIO(ferror((FILE *)wfileid));
297: r.n1 = u2;
298: r.n2 = flag;
299: r.n3 = u3;
300: r.n4 = wior;
301: return r;
302: }
303:
304: struct Cellpair file_status(Char *c_addr, UCell u)
305: {
306: struct Cellpair r;
307: Cell wfam;
308: Cell wior;
309: char *filename=tilde_cstr(c_addr, u, 1);
310:
311: if (access (filename, F_OK) != 0) {
312: wfam=0;
313: wior=IOR(1);
314: }
315: else if (access (filename, R_OK | W_OK) == 0) {
316: wfam=2; /* r/w */
317: wior=0;
318: }
319: else if (access (filename, R_OK) == 0) {
320: wfam=0; /* r/o */
321: wior=0;
322: }
323: else if (access (filename, W_OK) == 0) {
324: wfam=4; /* w/o */
325: wior=0;
326: }
327: else {
328: wfam=1; /* well, we cannot access the file, but better deliver a
329: legal access mode (r/o bin), so we get a decent error
330: later upon open. */
331: wior=0;
332: }
333: r.n1 = wfam;
334: r.n2 = wior;
335: return r;
336: }
337:
338: Cell to_float(Char *c_addr, UCell u, Float *rp)
339: {
340: Float r;
341: Cell flag;
342: char *number=cstr(c_addr, u, 1);
343: char *endconv;
344: int sign = 0;
345: if(number[0]=='-') {
346: sign = 1;
347: number++;
348: u--;
349: }
350: while(isspace((unsigned)(number[--u])) && u>0)
351: ;
352: switch(number[u]) {
353: case 'd':
354: case 'D':
355: case 'e':
356: case 'E': break;
357: default : u++; break;
358: }
359: number[u]='\0';
360: r=strtod(number,&endconv);
361: if((flag=FLAG(!(Cell)*endconv))) {
362: if (sign)
363: r = -r;
364: } else if(*endconv=='d' || *endconv=='D') {
365: *endconv='E';
366: r=strtod(number,&endconv);
367: if((flag=FLAG(!(Cell)*endconv))) {
368: if (sign)
369: r = -r;
370: }
371: }
372: *rp = r;
373: return flag;
374: }
375:
376: Float v_star(Float *f_addr1, Cell nstride1, Float *f_addr2, Cell nstride2, UCell ucount)
377: {
378: Float r;
379:
380: for (r=0.; ucount>0; ucount--) {
381: r += *f_addr1 * *f_addr2;
382: f_addr1 = (Float *)(((Address)f_addr1)+nstride1);
383: f_addr2 = (Float *)(((Address)f_addr2)+nstride2);
384: }
385: return r;
386: }
387:
388: void faxpy(Float ra, Float *f_x, Cell nstridex, Float *f_y, Cell nstridey, UCell ucount)
389: {
390: for (; ucount>0; ucount--) {
391: *f_y += ra * *f_x;
392: f_x = (Float *)(((Address)f_x)+nstridex);
393: f_y = (Float *)(((Address)f_y)+nstridey);
394: }
395: }
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