Annotation of gforth/engine/support.c, revision 1.10
1.1 anton 1: /* Gforth support functions
2:
1.7 anton 3: Copyright (C) 1995,1996,1997,1998,2000,2003 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 = "";
87: s2 = from+1;
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;
104: s2 = from+i;
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);
114: return cstr(path,s1_len+s2_len,clear);
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:
193: struct Longname *listlfind(Char *c_addr, UCell u, struct Longname *longname1)
194: {
195: for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next))
196: if ((UCell)LONGNAME_COUNT(longname1)==u &&
197: memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)
198: break;
199: return longname1;
200: }
201:
202: struct Longname *hashlfind(Char *c_addr, UCell u, Cell *a_addr)
203: {
204: struct Longname *longname1;
205:
206: while(a_addr != NULL) {
207: longname1=(struct Longname *)(a_addr[1]);
208: a_addr=(Cell *)(a_addr[0]);
209: if ((UCell)LONGNAME_COUNT(longname1)==u &&
210: memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */) {
211: return longname1;
212: }
213: }
214: return NULL;
215: }
216:
217: struct Longname *tablelfind(Char *c_addr, UCell u, Cell *a_addr)
218: {
219: struct Longname *longname1;
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: memcmp(c_addr, longname1->name, u)== 0 /* or inline? */) {
225: return longname1;
226: }
227: }
228: return NULL;
229: }
230:
231: UCell hashkey1(Char *c_addr, UCell u, UCell ubits)
232: /* this hash function rotates the key at every step by rot bits within
233: ubits bits and xors it with the character. This function does ok in
234: the chi-sqare-test. Rot should be <=7 (preferably <=5) for
235: ASCII strings (larger if ubits is large), and should share no
236: divisors with ubits.
237: */
238: {
239: 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};
240: unsigned rot = rot_values[ubits];
241: Char *cp = c_addr;
242: UCell ukey;
243:
244: for (ukey=0; cp<c_addr+u; cp++)
245: ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))
246: ^ toupper(*cp))
247: & ((1<<ubits)-1));
248: return ukey;
249: }
250:
251: struct Cellpair parse_white(Char *c_addr1, UCell u1)
252: {
253: /* use !isgraph instead of isspace? */
254: struct Cellpair result;
255: Char *c_addr2;
256: Char *endp = c_addr1+u1;
257: while (c_addr1<endp && isspace(*c_addr1))
258: c_addr1++;
259: if (c_addr1<endp) {
260: for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++)
261: ;
1.6 anton 262: result.n1 = (Cell)c_addr2;
1.5 anton 263: result.n2 = c_addr1-c_addr2;
264: } else {
1.6 anton 265: result.n1 = (Cell)c_addr1;
1.5 anton 266: result.n2 = 0;
267: }
268: return result;
269: }
270:
271: Cell rename_file(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2)
272: {
273: char *s1=tilde_cstr(c_addr2, u2, 1);
274: return IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);
275: }
276:
277: struct Cellquad read_line(Char *c_addr, UCell u1, Cell wfileid)
278: {
279: UCell u2, u3;
280: Cell flag, wior;
281: Cell c;
282: struct Cellquad r;
283:
284: flag=-1;
285: u3=0;
286: for(u2=0; u2<u1; u2++) {
287: c = getc((FILE *)wfileid);
288: u3++;
289: if (c=='\n') break;
290: if (c=='\r') {
291: if ((c = getc((FILE *)wfileid))!='\n')
292: ungetc(c,(FILE *)wfileid);
293: else
294: u3++;
295: break;
296: }
297: if (c==EOF) {
298: flag=FLAG(u2!=0);
299: break;
300: }
301: c_addr[u2] = (Char)c;
302: }
303: wior=FILEIO(ferror((FILE *)wfileid));
304: r.n1 = u2;
305: r.n2 = flag;
306: r.n3 = u3;
307: r.n4 = wior;
308: return r;
309: }
310:
311: struct Cellpair file_status(Char *c_addr, UCell u)
312: {
313: struct Cellpair r;
314: Cell wfam;
315: Cell wior;
316: char *filename=tilde_cstr(c_addr, u, 1);
317:
318: if (access (filename, F_OK) != 0) {
319: wfam=0;
320: wior=IOR(1);
321: }
322: else if (access (filename, R_OK | W_OK) == 0) {
323: wfam=2; /* r/w */
324: wior=0;
325: }
326: else if (access (filename, R_OK) == 0) {
327: wfam=0; /* r/o */
328: wior=0;
329: }
330: else if (access (filename, W_OK) == 0) {
331: wfam=4; /* w/o */
332: wior=0;
333: }
334: else {
335: wfam=1; /* well, we cannot access the file, but better deliver a
336: legal access mode (r/o bin), so we get a decent error
337: later upon open. */
338: wior=0;
339: }
340: r.n1 = wfam;
341: r.n2 = wior;
1.6 anton 342: return r;
1.5 anton 343: }
344:
345: Cell to_float(Char *c_addr, UCell u, Float *rp)
346: {
347: Float r;
348: Cell flag;
349: char *number=cstr(c_addr, u, 1);
350: char *endconv;
351: int sign = 0;
352: if(number[0]=='-') {
353: sign = 1;
354: number++;
355: u--;
356: }
357: while(isspace((unsigned)(number[--u])) && u>0)
358: ;
359: switch(number[u]) {
360: case 'd':
361: case 'D':
362: case 'e':
363: case 'E': break;
364: default : u++; break;
365: }
366: number[u]='\0';
367: r=strtod(number,&endconv);
368: if((flag=FLAG(!(Cell)*endconv))) {
369: if (sign)
370: r = -r;
371: } else if(*endconv=='d' || *endconv=='D') {
372: *endconv='E';
373: r=strtod(number,&endconv);
374: if((flag=FLAG(!(Cell)*endconv))) {
375: if (sign)
376: r = -r;
377: }
378: }
379: *rp = r;
380: return flag;
381: }
382:
383: Float v_star(Float *f_addr1, Cell nstride1, Float *f_addr2, Cell nstride2, UCell ucount)
384: {
385: Float r;
386:
387: for (r=0.; ucount>0; ucount--) {
388: r += *f_addr1 * *f_addr2;
389: f_addr1 = (Float *)(((Address)f_addr1)+nstride1);
390: f_addr2 = (Float *)(((Address)f_addr2)+nstride2);
391: }
392: return r;
393: }
394:
395: void faxpy(Float ra, Float *f_x, Cell nstridex, Float *f_y, Cell nstridey, UCell ucount)
396: {
397: for (; ucount>0; ucount--) {
398: *f_y += ra * *f_x;
399: f_x = (Float *)(((Address)f_x)+nstridex);
400: f_y = (Float *)(((Address)f_y)+nstridey);
401: }
1.1 anton 402: }
1.9 pazsan 403:
404: UCell lshift(UCell u1, UCell n)
405: {
406: return u1 << n;
407: }
408:
409: UCell rshift(UCell u1, UCell n)
410: {
411: return u1 >> n;
1.10 ! anton 412: }
! 413:
! 414: int gforth_system(Char *c_addr, UCell u)
! 415: {
! 416: int retval;
! 417: char *prefix = getenv("GFORTHSYSTEMPREFIX") ? : DEFAULTSYSTEMPREFIX;
! 418: size_t prefixlen = strlen(prefix);
! 419: char buffer[prefixlen+u+1];
! 420: #ifndef MSDOS
! 421: int old_tp=terminal_prepped;
! 422: deprep_terminal();
! 423: #endif
! 424: memcpy(buffer,prefix,prefixlen);
! 425: memcpy(buffer+prefixlen,c_addr,u);
! 426: buffer[prefixlen+u]='\0';
! 427: retval=system(buffer); /* ~ expansion on first part of string? */
! 428: #ifndef MSDOS
! 429: if (old_tp)
! 430: prep_terminal();
! 431: #endif
! 432: return retval;
1.9 pazsan 433: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>