[gforth] / gforth / engine / engine.c  

gforth: gforth/engine/engine.c

1 : anton 1.1 /* Gforth virtual machine (aka inner interpreter)
2 :    
3 : anton 1.6 Copyright (C) 1995,1996,1997,1998 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., 675 Mass Ave, Cambridge, MA 02139, USA.
20 :     */
21 :    
22 :     #include "config.h"
23 :     #include <ctype.h>
24 :     #include <stdio.h>
25 :     #include <string.h>
26 :     #include <math.h>
27 : pazsan 1.4 #include <assert.h>
28 :     #include <stdlib.h>
29 :     #include <errno.h>
30 :     #include "forth.h"
31 :     #include "io.h"
32 :     #include "threaded.h"
33 :     #ifndef STANDALONE
34 : anton 1.1 #include <sys/types.h>
35 :     #include <sys/stat.h>
36 :     #include <fcntl.h>
37 :     #include <time.h>
38 :     #include <sys/time.h>
39 :     #include <unistd.h>
40 :     #include <pwd.h>
41 : pazsan 1.4 #else
42 :     #include "systypes.h"
43 :     #endif
44 : anton 1.1
45 :     #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */
46 :     #include <dlfcn.h>
47 :     #endif
48 : pazsan 1.8 #if defined(_WIN32)
49 :     #include <windows.h>
50 :     #endif
51 : anton 1.1 #ifdef hpux
52 :     #include <dl.h>
53 :     #endif
54 :    
55 :     #ifndef SEEK_SET
56 :     /* should be defined in stdio.h, but some systems don't have it */
57 :     #define SEEK_SET 0
58 :     #endif
59 :    
60 :     #define IOR(flag) ((flag)? -512-errno : 0)
61 :    
62 : pazsan 1.4 struct F83Name {
63 :     struct F83Name *next; /* the link field for old hands */
64 :     char countetc;
65 :     char name[0];
66 :     };
67 : anton 1.1
68 :     /* are macros for setting necessary? */
69 :     #define F83NAME_COUNT(np) ((np)->countetc & 0x1f)
70 :     #define F83NAME_SMUDGE(np) (((np)->countetc & 0x40) != 0)
71 :     #define F83NAME_IMMEDIATE(np) (((np)->countetc & 0x20) != 0)
72 :    
73 :     Cell *SP;
74 :     Float *FP;
75 :     Address UP=NULL;
76 :    
77 :     #if 0
78 :     /* not used currently */
79 :     int emitcounter;
80 :     #endif
81 :     #define NULLC '\0'
82 :    
83 : pazsan 1.14 #ifdef MEMCMP_AS_SUBROUTINE
84 :     extern int gforth_memcmp(const char * s1, const char * s2, size_t n);
85 : anton 1.15 #define memcmp(s1,s2,n) gforth_memcmp(s1,s2,n)
86 : pazsan 1.14 #endif
87 :    
88 : pazsan 1.9 #ifdef HAS_FILE
89 : anton 1.1 char *cstr(Char *from, UCell size, int clear)
90 :     /* return a C-string corresponding to the Forth string ( FROM SIZE ).
91 :     the C-string lives until the next call of cstr with CLEAR being true */
92 :     {
93 :     static struct cstr_buffer {
94 :     char *buffer;
95 :     size_t size;
96 :     } *buffers=NULL;
97 :     static int nbuffers=0;
98 :     static int used=0;
99 :     struct cstr_buffer *b;
100 :    
101 :     if (buffers==NULL)
102 :     buffers=malloc(0);
103 :     if (clear)
104 :     used=0;
105 :     if (used>=nbuffers) {
106 :     buffers=realloc(buffers,sizeof(struct cstr_buffer)*(used+1));
107 :     buffers[used]=(struct cstr_buffer){malloc(0),0};
108 :     nbuffers=used+1;
109 :     }
110 :     b=&buffers[used];
111 :     if (size+1 > b->size) {
112 :     b->buffer = realloc(b->buffer,size+1);
113 :     b->size = size+1;
114 :     }
115 :     memcpy(b->buffer,from,size);
116 :     b->buffer[size]='\0';
117 :     used++;
118 :     return b->buffer;
119 :     }
120 :    
121 :     char *tilde_cstr(Char *from, UCell size, int clear)
122 :     /* like cstr(), but perform tilde expansion on the string */
123 :     {
124 :     char *s1,*s2;
125 :     int s1_len, s2_len;
126 :     struct passwd *getpwnam (), *user_entry;
127 :    
128 :     if (size<1 || from[0]!='~')
129 :     return cstr(from, size, clear);
130 :     if (size<2 || from[1]=='/') {
131 :     s1 = (char *)getenv ("HOME");
132 :     if(s1 == NULL)
133 :     s1 = "";
134 :     s2 = from+1;
135 :     s2_len = size-1;
136 :     } else {
137 :     UCell i;
138 :     for (i=1; i<size && from[i]!='/'; i++)
139 :     ;
140 : anton 1.13 if (i==2 && from[1]=='+') /* deal with "~+", i.e., the wd */
141 :     return cstr(from+3, size<3?0:size-3,clear);
142 : anton 1.1 {
143 :     char user[i];
144 :     memcpy(user,from+1,i-1);
145 :     user[i-1]='\0';
146 :     user_entry=getpwnam(user);
147 :     }
148 :     if (user_entry==NULL)
149 :     return cstr(from, size, clear);
150 :     s1 = user_entry->pw_dir;
151 :     s2 = from+i;
152 :     s2_len = size-i;
153 :     }
154 :     s1_len = strlen(s1);
155 :     if (s1_len>1 && s1[s1_len-1]=='/')
156 :     s1_len--;
157 :     {
158 :     char path[s1_len+s2_len];
159 :     memcpy(path,s1,s1_len);
160 :     memcpy(path+s1_len,s2,s2_len);
161 :     return cstr(path,s1_len+s2_len,clear);
162 :     }
163 :     }
164 : pazsan 1.9 #endif
165 : anton 1.1
166 :     #define NEWLINE '\n'
167 :    
168 :     #ifndef HAVE_RINT
169 :     #define rint(x) floor((x)+0.5)
170 :     #endif
171 :    
172 : pazsan 1.9 #ifdef HAS_FILE
173 : anton 1.1 static char* fileattr[6]={"r","rb","r+","r+b","w","wb"};
174 :    
175 :     #ifndef O_BINARY
176 :     #define O_BINARY 0
177 :     #endif
178 :     #ifndef O_TEXT
179 :     #define O_TEXT 0
180 :     #endif
181 :    
182 :     static int ufileattr[6]= {
183 :     O_RDONLY|O_TEXT, O_RDONLY|O_BINARY,
184 :     O_RDWR |O_TEXT, O_RDWR |O_BINARY,
185 :     O_WRONLY|O_TEXT, O_WRONLY|O_BINARY };
186 : pazsan 1.9 #endif
187 : anton 1.1
188 :     /* if machine.h has not defined explicit registers, define them as implicit */
189 :     #ifndef IPREG
190 :     #define IPREG
191 :     #endif
192 :     #ifndef SPREG
193 :     #define SPREG
194 :     #endif
195 :     #ifndef RPREG
196 :     #define RPREG
197 :     #endif
198 :     #ifndef FPREG
199 :     #define FPREG
200 :     #endif
201 :     #ifndef LPREG
202 :     #define LPREG
203 :     #endif
204 :     #ifndef CFAREG
205 :     #define CFAREG
206 :     #endif
207 :     #ifndef UPREG
208 :     #define UPREG
209 :     #endif
210 :     #ifndef TOSREG
211 :     #define TOSREG
212 :     #endif
213 :     #ifndef FTOSREG
214 :     #define FTOSREG
215 :     #endif
216 :    
217 :     #ifndef CPU_DEP1
218 :     # define CPU_DEP1 0
219 :     #endif
220 :    
221 :     /* declare and compute cfa for certain threading variants */
222 :     /* warning: this is nonsyntactical; it will not work in place of a statement */
223 : anton 1.12 #ifndef GETCFA
224 : anton 1.1 #define DOCFA
225 :     #else
226 :     #define DOCFA Xt cfa; GETCFA(cfa)
227 :     #endif
228 :    
229 : anton 1.10 #ifdef GFORTH_DEBUGGING
230 :     /* define some VM registers as global variables, so they survive exceptions;
231 :     global register variables are not up to the task (according to the
232 :     GNU C manual) */
233 :     Xt *ip;
234 :     Cell *rp;
235 :     #endif
236 :    
237 : anton 1.1 Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
238 :     /* executes code at ip, if ip!=NULL
239 :     returns array of machine code labels (for use in a loader), if ip==NULL
240 :     */
241 :     {
242 : anton 1.10 #ifndef GFORTH_DEBUGGING
243 :     register Xt *ip IPREG;
244 :     register Cell *rp RPREG;
245 :     #endif
246 : anton 1.1 register Cell *sp SPREG = sp0;
247 :     register Float *fp FPREG = fp0;
248 :     register Address lp LPREG = lp0;
249 :     #ifdef CFA_NEXT
250 :     register Xt cfa CFAREG;
251 :     #endif
252 : anton 1.11 #ifdef MORE_VARS
253 :     MORE_VARS
254 :     #endif
255 : anton 1.1 register Address up UPREG = UP;
256 :     IF_TOS(register Cell TOS TOSREG;)
257 :     IF_FTOS(register Float FTOS FTOSREG;)
258 :     #if defined(DOUBLY_INDIRECT)
259 :     static Label *symbols;
260 :     static void *routines[]= {
261 :     #else /* !defined(DOUBLY_INDIRECT) */
262 :     static Label symbols[]= {
263 :     #endif /* !defined(DOUBLY_INDIRECT) */
264 : pazsan 1.4 (Label)&&docol,
265 :     (Label)&&docon,
266 :     (Label)&&dovar,
267 :     (Label)&&douser,
268 :     (Label)&&dodefer,
269 :     (Label)&&dofield,
270 :     (Label)&&dodoes,
271 : anton 1.1 /* the following entry is normally unused;
272 :     it's there because its index indicates a does-handler */
273 : pazsan 1.7 CPU_DEP1,
274 : anton 1.1 #include "prim_lab.i"
275 : pazsan 1.4 (Label)0
276 : anton 1.1 };
277 :     #ifdef CPU_DEP2
278 :     CPU_DEP2
279 :     #endif
280 :    
281 : anton 1.10 ip = ip0;
282 :     rp = rp0;
283 : anton 1.1 #ifdef DEBUG
284 :     fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
285 :     (unsigned)ip,(unsigned)sp,(unsigned)rp,
286 :     (unsigned)fp,(unsigned)lp,(unsigned)up);
287 :     #endif
288 :    
289 :     if (ip == NULL) {
290 :     #if defined(DOUBLY_INDIRECT)
291 : anton 1.3 #define MAX_SYMBOLS (sizeof(routines)/sizeof(routines[0]))
292 :     #define CODE_OFFSET (22*sizeof(Cell))
293 : anton 1.1 int i;
294 : anton 1.3 Cell code_offset = offset_image? CODE_OFFSET : 0;
295 : pazsan 1.7
296 : anton 1.3 symbols = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+CODE_OFFSET)+code_offset);
297 : anton 1.1 for (i=0; i<DOESJUMP+1; i++)
298 : pazsan 1.7 symbols[i] = (Label)routines[i];
299 : anton 1.1 for (; routines[i]!=0; i++) {
300 :     if (i>=MAX_SYMBOLS) {
301 :     fprintf(stderr,"gforth-ditc: more than %d primitives\n",MAX_SYMBOLS);
302 :     exit(1);
303 :     }
304 : pazsan 1.7 symbols[i] = &routines[i];
305 :     }
306 : pazsan 1.5 #endif /* defined(DOUBLY_INDIRECT) */
307 : pazsan 1.7 return symbols;
308 :     }
309 : anton 1.1
310 :     IF_TOS(TOS = sp[0]);
311 :     IF_FTOS(FTOS = fp[0]);
312 : pazsan 1.7 /* prep_terminal(); */
313 : anton 1.11 SET_IP(ip);
314 : anton 1.1 NEXT;
315 :    
316 : anton 1.11
317 : anton 1.1 #ifdef CPU_DEP3
318 :     CPU_DEP3
319 :     #endif
320 :    
321 :     docol:
322 :     {
323 :     DOCFA;
324 :     #ifdef DEBUG
325 :     fprintf(stderr,"%08lx: col: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
326 :     #endif
327 :     #ifdef CISC_NEXT
328 :     /* this is the simple version */
329 :     *--rp = (Cell)ip;
330 : anton 1.11 SET_IP((Xt *)PFA1(cfa));
331 : anton 1.1 NEXT;
332 :     #else
333 : anton 1.11 /* this one is important, so we help the compiler optimizing */
334 : anton 1.1 {
335 :     DEF_CA
336 : anton 1.11 rp[-1] = (Cell)ip;
337 :     SET_IP((Xt *)PFA1(cfa));
338 :     NEXT_P1;
339 :     rp--;
340 :     NEXT_P2;
341 : anton 1.1 }
342 :     #endif
343 :     }
344 :    
345 :     docon:
346 :     {
347 :     DOCFA;
348 :     #ifdef DEBUG
349 :     fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
350 :     #endif
351 :     #ifdef USE_TOS
352 :     *sp-- = TOS;
353 :     TOS = *(Cell *)PFA1(cfa);
354 :     #else
355 :     *--sp = *(Cell *)PFA1(cfa);
356 :     #endif
357 :     }
358 :     NEXT_P0;
359 :     NEXT;
360 :    
361 :     dovar:
362 :     {
363 :     DOCFA;
364 :     #ifdef DEBUG
365 :     fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
366 :     #endif
367 :     #ifdef USE_TOS
368 :     *sp-- = TOS;
369 :     TOS = (Cell)PFA1(cfa);
370 :     #else
371 :     *--sp = (Cell)PFA1(cfa);
372 :     #endif
373 :     }
374 :     NEXT_P0;
375 :     NEXT;
376 :    
377 :     douser:
378 :     {
379 :     DOCFA;
380 :     #ifdef DEBUG
381 :     fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
382 :     #endif
383 :     #ifdef USE_TOS
384 :     *sp-- = TOS;
385 :     TOS = (Cell)(up+*(Cell*)PFA1(cfa));
386 :     #else
387 :     *--sp = (Cell)(up+*(Cell*)PFA1(cfa));
388 :     #endif
389 :     }
390 :     NEXT_P0;
391 :     NEXT;
392 :    
393 :     dodefer:
394 :     {
395 :     DOCFA;
396 :     #ifdef DEBUG
397 :     fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa));
398 :     #endif
399 :     EXEC(*(Xt *)PFA1(cfa));
400 :     }
401 :    
402 :     dofield:
403 :     {
404 :     DOCFA;
405 :     #ifdef DEBUG
406 :     fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa));
407 :     #endif
408 : anton 1.11 TOS += *(Cell*)PFA1(cfa);
409 : anton 1.1 }
410 :     NEXT_P0;
411 :     NEXT;
412 :    
413 :     dodoes:
414 :     /* this assumes the following structure:
415 :     defining-word:
416 :    
417 :     ...
418 :     DOES>
419 :     (possible padding)
420 :     possibly handler: jmp dodoes
421 :     (possible branch delay slot(s))
422 :     Forth code after DOES>
423 :    
424 :     defined word:
425 :    
426 :     cfa: address of or jump to handler OR
427 :     address of or jump to dodoes, address of DOES-code
428 :     pfa:
429 :    
430 :     */
431 :     {
432 :     DOCFA;
433 :    
434 :     /* fprintf(stderr, "Got CFA %08lx at doescode %08lx/%08lx: does: %08lx\n",cfa,(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));*/
435 :     #ifdef DEBUG
436 :     fprintf(stderr,"%08lx/%08lx: does: %08lx\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));
437 :     fflush(stderr);
438 :     #endif
439 :     *--rp = (Cell)ip;
440 :     /* PFA1 might collide with DOES_CODE1 here, so we use PFA */
441 :     #ifdef USE_TOS
442 :     *sp-- = TOS;
443 :     TOS = (Cell)PFA(cfa);
444 :     #else
445 :     *--sp = (Cell)PFA(cfa);
446 :     #endif
447 : anton 1.11 SET_IP(DOES_CODE1(cfa));
448 : anton 1.1 /* fprintf(stderr,"TOS = %08lx, IP=%08lx\n", TOS, IP);*/
449 :     }
450 :     NEXT;
451 :    
452 :     #include "prim.i"
453 :     }
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help