[gforth] / gforth / engine / support.c  

gforth: gforth/engine/support.c

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help