[gforth] / gforth / Attic / engine.c  

gforth: gforth/Attic/engine.c

1 : anton 1.1 /*
2 :     Copyright 1992 by the ANSI figForth Development Group
3 :     */
4 :    
5 :     #include <ctype.h>
6 :     #include <stdio.h>
7 :     #include <string.h>
8 :     #include <math.h>
9 :     #include <sys/types.h>
10 :     #include <sys/stat.h>
11 :     #include <fcntl.h>
12 :     #include <assert.h>
13 :     #include <stdlib.h>
14 : pazsan 1.2 #include <time.h>
15 : pazsan 1.6 #include <sys/time.h>
16 : anton 1.1 #include "forth.h"
17 :     #include "io.h"
18 :    
19 : anton 1.20 #ifndef SEEK_SET
20 :     /* should be defined in stdio.h, but some systems don't have it */
21 :     #define SEEK_SET 0
22 :     #endif
23 :    
24 : anton 1.1 typedef union {
25 :     struct {
26 : anton 1.20 #ifdef WORDS_BIGENDIAN
27 : anton 1.1 Cell high;
28 :     Cell low;
29 :     #else
30 :     Cell low;
31 :     Cell high;
32 :     #endif;
33 :     } cells;
34 :     DCell dcell;
35 :     } Double_Store;
36 :    
37 :     typedef struct F83Name {
38 :     struct F83Name *next; /* the link field for old hands */
39 :     char countetc;
40 :     Char name[0];
41 :     } F83Name;
42 :    
43 :     /* are macros for setting necessary? */
44 :     #define F83NAME_COUNT(np) ((np)->countetc & 0x1f)
45 :     #define F83NAME_SMUDGE(np) (((np)->countetc & 0x40) != 0)
46 :     #define F83NAME_IMMEDIATE(np) (((np)->countetc & 0x20) != 0)
47 :    
48 : anton 1.14 /* NEXT and NEXT1 are split into several parts to help scheduling,
49 :     unless CISC_NEXT is defined */
50 :     #ifdef CISC_NEXT
51 :     #define NEXT1_P1
52 :     #define NEXT_P1
53 :     #define DEF_CA
54 : anton 1.1 #ifdef DIRECT_THREADED
55 : anton 1.14 #define NEXT1_P2 ({goto *cfa;})
56 : anton 1.1 #else
57 : anton 1.14 #define NEXT1_P2 ({goto **cfa;})
58 :     #endif /* DIRECT_THREADED */
59 :     #define NEXT_P2 ({cfa = *ip++; NEXT1_P2;})
60 :     #else /* CISC_NEXT */
61 :     #ifdef DIRECT_THREADED
62 :     #define NEXT1_P1
63 :     #define NEXT1_P2 ({goto *cfa;})
64 :     #define DEF_CA
65 :     #else /* DIRECT_THREADED */
66 :     #define NEXT1_P1 ({ca = *cfa;})
67 :     #define NEXT1_P2 ({goto *ca;})
68 :     #define DEF_CA Label ca;
69 :     #endif /* DIRECT_THREADED */
70 :     #define NEXT_P1 ({cfa=*ip++; NEXT1_P1;})
71 :     #define NEXT_P2 NEXT1_P2
72 :     #endif /* CISC_NEXT */
73 : anton 1.1
74 : anton 1.14 #define NEXT1 ({DEF_CA NEXT1_P1; NEXT1_P2;})
75 :     #define NEXT ({DEF_CA NEXT_P1; NEXT_P2;})
76 : anton 1.1
77 :     #ifdef USE_TOS
78 :     #define IF_TOS(x) x
79 :     #else
80 :     #define IF_TOS(x)
81 :     #define TOS (sp[0])
82 :     #endif
83 :    
84 :     #ifdef USE_FTOS
85 :     #define IF_FTOS(x) x
86 :     #else
87 :     #define IF_FTOS(x)
88 :     #define FTOS (fp[0])
89 :     #endif
90 :    
91 :     int emitcounter;
92 :     #define NULLC '\0'
93 :    
94 : anton 1.14 char *cstr(Char *from, UCell size, int clear)
95 :     /* if clear is true, scratch can be reused, otherwise we want more of
96 :     the same */
97 :     {
98 :     static char *scratch=NULL;
99 :     static unsigned scratchsize=0;
100 :     static char *nextscratch;
101 :     char *oldnextscratch;
102 :    
103 :     if (clear)
104 :     nextscratch=scratch;
105 :     if (scratch==NULL) {
106 :     scratch=malloc(size+1);
107 :     nextscratch=scratch;
108 :     scratchsize=size;
109 :     }
110 :     else if (nextscratch+size>scratch+scratchsize) {
111 :     char *oldscratch=scratch;
112 :     scratch = realloc(scratch, (nextscratch-scratch)+size+1);
113 :     nextscratch=scratch+(nextscratch-oldscratch);
114 :     scratchsize=size;
115 :     }
116 :     memcpy(nextscratch,from,size);
117 :     nextscratch[size]='\0';
118 :     oldnextscratch = nextscratch;
119 :     nextscratch += size+1;
120 :     return oldnextscratch;
121 :     }
122 : pazsan 1.13
123 : anton 1.1 #define NEWLINE '\n'
124 :    
125 : pazsan 1.21 #ifndef HAVE_RINT
126 :     #define rint(x) floor((x)+0.5)
127 :     #endif
128 : pazsan 1.13
129 : anton 1.1 static char* fileattr[6]={"r","rb","r+","r+b","w+","w+b"};
130 : pazsan 1.6
131 : pazsan 1.11 static Address up0=NULL;
132 :    
133 : anton 1.15 /* if machine.h has not defined explicit registers, define them as implicit */
134 :     #ifndef IPREG
135 :     #define IPREG
136 :     #endif
137 :     #ifndef SPREG
138 :     #define SPREG
139 :     #endif
140 :     #ifndef RPREG
141 :     #define RPREG
142 :     #endif
143 :     #ifndef FPREG
144 :     #define FPREG
145 :     #endif
146 :     #ifndef LPREG
147 :     #define LPREG
148 :     #endif
149 :     #ifndef CFAREG
150 :     #define CFAREG
151 :     #endif
152 :     #ifndef UPREG
153 :     #define UPREG
154 :     #endif
155 :     #ifndef TOSREG
156 :     #define TOSREG
157 :     #endif
158 :     #ifndef FTOSREG
159 :     #define FTOSREG
160 :     #endif
161 : pazsan 1.13
162 : anton 1.15 Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
163 : anton 1.1 /* executes code at ip, if ip!=NULL
164 :     returns array of machine code labels (for use in a loader), if ip==NULL
165 :     */
166 : anton 1.15 {
167 :     register Xt *ip IPREG = ip0;
168 :     register Cell *sp SPREG = sp0;
169 :     register Cell *rp RPREG = rp0;
170 :     register Float *fp FPREG = fp0;
171 :     register Address lp LPREG = lp0;
172 :     register Xt cfa CFAREG;
173 :     register Address up UPREG = up0;
174 :     IF_TOS(register Cell TOS TOSREG;)
175 :     IF_FTOS(register Float FTOS FTOSREG;)
176 : anton 1.1 static Label symbols[]= {
177 :     &&docol,
178 :     &&docon,
179 :     &&dovar,
180 : pazsan 1.4 &&douser,
181 : anton 1.12 &&dodefer,
182 : anton 1.1 &&dodoes,
183 : pazsan 1.6 &&dodoes, /* dummy for does handler address */
184 : anton 1.1 #include "prim_labels.i"
185 :     };
186 :     #ifdef CPU_DEP
187 :     CPU_DEP;
188 :     #endif
189 :    
190 : pazsan 1.16 #ifdef DEBUG
191 :     fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n",
192 : anton 1.19 (unsigned)ip,(unsigned)sp,(unsigned)rp,
193 :     (unsigned)fp,(unsigned)lp,(unsigned)up);
194 : pazsan 1.16 #endif
195 :    
196 : anton 1.1 if (ip == NULL)
197 :     return symbols;
198 : anton 1.10
199 : anton 1.1 IF_TOS(TOS = sp[0]);
200 :     IF_FTOS(FTOS = fp[0]);
201 :     prep_terminal();
202 :     NEXT;
203 :    
204 :     docol:
205 :     #ifdef DEBUG
206 : pazsan 1.16 fprintf(stderr,"%08x: col: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
207 : anton 1.1 #endif
208 : anton 1.15 #ifdef CISC_NEXT
209 : anton 1.1 /* this is the simple version */
210 :     *--rp = (Cell)ip;
211 :     ip = (Xt *)PFA1(cfa);
212 :     NEXT;
213 : anton 1.15 #else
214 : anton 1.1 /* this one is important, so we help the compiler optimizing
215 :     The following version may be better (for scheduling), but probably has
216 :     problems with code fields employing calls and delay slots
217 :     */
218 :     {
219 : pazsan 1.4 DEF_CA
220 : anton 1.1 Xt *current_ip = (Xt *)PFA1(cfa);
221 :     cfa = *current_ip;
222 :     NEXT1_P1;
223 :     *--rp = (Cell)ip;
224 :     ip = current_ip+1;
225 : pazsan 1.3 NEXT1_P2;
226 : anton 1.1 }
227 : anton 1.15 #endif
228 : anton 1.1
229 :     docon:
230 :     #ifdef DEBUG
231 : pazsan 1.16 fprintf(stderr,"%08x: con: %08x\n",(Cell)ip,*(Cell*)PFA1(cfa));
232 : anton 1.1 #endif
233 :     #ifdef USE_TOS
234 :     *sp-- = TOS;
235 :     TOS = *(Cell *)PFA1(cfa);
236 :     #else
237 :     *--sp = *(Cell *)PFA1(cfa);
238 :     #endif
239 :     NEXT;
240 :    
241 :     dovar:
242 :     #ifdef DEBUG
243 : pazsan 1.16 fprintf(stderr,"%08x: var: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
244 : anton 1.1 #endif
245 :     #ifdef USE_TOS
246 :     *sp-- = TOS;
247 :     TOS = (Cell)PFA1(cfa);
248 :     #else
249 :     *--sp = (Cell)PFA1(cfa);
250 :     #endif
251 :     NEXT;
252 :    
253 :     /* !! user? */
254 :    
255 : pazsan 1.4 douser:
256 :     #ifdef DEBUG
257 : pazsan 1.16 fprintf(stderr,"%08x: user: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
258 : pazsan 1.4 #endif
259 :     #ifdef USE_TOS
260 :     *sp-- = TOS;
261 : anton 1.5 TOS = (Cell)(up+*(Cell*)PFA1(cfa));
262 : pazsan 1.4 #else
263 : anton 1.5 *--sp = (Cell)(up+*(Cell*)PFA1(cfa));
264 : pazsan 1.4 #endif
265 :     NEXT;
266 :    
267 : anton 1.12 dodefer:
268 :     #ifdef DEBUG
269 : pazsan 1.16 fprintf(stderr,"%08x: defer: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
270 : anton 1.12 #endif
271 :     cfa = *(Xt *)PFA1(cfa);
272 :     NEXT1;
273 :    
274 : anton 1.1 dodoes:
275 :     /* this assumes the following structure:
276 :     defining-word:
277 :    
278 :     ...
279 :     DOES>
280 :     (possible padding)
281 :     possibly handler: jmp dodoes
282 :     (possible branch delay slot(s))
283 :     Forth code after DOES>
284 :    
285 :     defined word:
286 :    
287 :     cfa: address of or jump to handler OR
288 :     address of or jump to dodoes, address of DOES-code
289 :     pfa:
290 :    
291 :     */
292 :     #ifdef DEBUG
293 : anton 1.17 fprintf(stderr,"%08x/%08x: does: %08x\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));
294 : pazsan 1.16 fflush(stderr);
295 : anton 1.1 #endif
296 :     *--rp = (Cell)ip;
297 :     /* PFA1 might collide with DOES_CODE1 here, so we use PFA */
298 : pazsan 1.13 ip = DOES_CODE1(cfa);
299 : anton 1.1 #ifdef USE_TOS
300 :     *sp-- = TOS;
301 :     TOS = (Cell)PFA(cfa);
302 :     #else
303 :     *--sp = (Cell)PFA(cfa);
304 :     #endif
305 :     NEXT;
306 : pazsan 1.16
307 : anton 1.1 #include "primitives.i"
308 :     }
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help