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