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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help