[gforth] / gforth / Attic / engine.c  

gforth: gforth/Attic/engine.c

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help