Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | /* Gforth virtual machine (aka inner interpreter) |
| 2 : | |||
| 3 : | anton | 1.22 | Copyright (C) 1995,1996,1997,1998,2000 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 : | anton | 1.23 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
| 20 : | anton | 1.1 | */ |
| 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.17 | #include <dirent.h> |
| 42 : | anton | 1.21 | #include <sys/resource.h> |
| 43 : | anton | 1.19 | #ifdef HAVE_FNMATCH_H |
| 44 : | anton | 1.18 | #include <fnmatch.h> |
| 45 : | anton | 1.19 | #else |
| 46 : | #include "fnmatch.h" | ||
| 47 : | #endif | ||
| 48 : | pazsan | 1.4 | #else |
| 49 : | #include "systypes.h" | ||
| 50 : | #endif | ||
| 51 : | anton | 1.1 | |
| 52 : | #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */ | ||
| 53 : | #include <dlfcn.h> | ||
| 54 : | #endif | ||
| 55 : | pazsan | 1.8 | #if defined(_WIN32) |
| 56 : | #include <windows.h> | ||
| 57 : | #endif | ||
| 58 : | anton | 1.1 | #ifdef hpux |
| 59 : | #include <dl.h> | ||
| 60 : | #endif | ||
| 61 : | |||
| 62 : | #ifndef SEEK_SET | ||
| 63 : | /* should be defined in stdio.h, but some systems don't have it */ | ||
| 64 : | #define SEEK_SET 0 | ||
| 65 : | #endif | ||
| 66 : | |||
| 67 : | #define IOR(flag) ((flag)? -512-errno : 0) | ||
| 68 : | |||
| 69 : | pazsan | 1.4 | struct F83Name { |
| 70 : | struct F83Name *next; /* the link field for old hands */ | ||
| 71 : | char countetc; | ||
| 72 : | char name[0]; | ||
| 73 : | }; | ||
| 74 : | anton | 1.1 | |
| 75 : | #define F83NAME_COUNT(np) ((np)->countetc & 0x1f) | ||
| 76 : | anton | 1.25 | |
| 77 : | struct Longname { | ||
| 78 : | struct Longname *next; /* the link field for old hands */ | ||
| 79 : | Cell countetc; | ||
| 80 : | char name[0]; | ||
| 81 : | }; | ||
| 82 : | |||
| 83 : | #define LONGNAME_COUNT(np) ((np)->countetc & (((~((UCell)0))<<3)>>3)) | ||
| 84 : | anton | 1.1 | |
| 85 : | Cell *SP; | ||
| 86 : | Float *FP; | ||
| 87 : | Address UP=NULL; | ||
| 88 : | |||
| 89 : | #if 0 | ||
| 90 : | /* not used currently */ | ||
| 91 : | int emitcounter; | ||
| 92 : | #endif | ||
| 93 : | #define NULLC '\0' | ||
| 94 : | |||
| 95 : | pazsan | 1.14 | #ifdef MEMCMP_AS_SUBROUTINE |
| 96 : | extern int gforth_memcmp(const char * s1, const char * s2, size_t n); | ||
| 97 : | anton | 1.15 | #define memcmp(s1,s2,n) gforth_memcmp(s1,s2,n) |
| 98 : | pazsan | 1.14 | #endif |
| 99 : | |||
| 100 : | pazsan | 1.9 | #ifdef HAS_FILE |
| 101 : | anton | 1.1 | char *cstr(Char *from, UCell size, int clear) |
| 102 : | /* return a C-string corresponding to the Forth string ( FROM SIZE ). | ||
| 103 : | the C-string lives until the next call of cstr with CLEAR being true */ | ||
| 104 : | { | ||
| 105 : | static struct cstr_buffer { | ||
| 106 : | char *buffer; | ||
| 107 : | size_t size; | ||
| 108 : | } *buffers=NULL; | ||
| 109 : | static int nbuffers=0; | ||
| 110 : | static int used=0; | ||
| 111 : | struct cstr_buffer *b; | ||
| 112 : | |||
| 113 : | if (buffers==NULL) | ||
| 114 : | buffers=malloc(0); | ||
| 115 : | if (clear) | ||
| 116 : | used=0; | ||
| 117 : | if (used>=nbuffers) { | ||
| 118 : | buffers=realloc(buffers,sizeof(struct cstr_buffer)*(used+1)); | ||
| 119 : | buffers[used]=(struct cstr_buffer){malloc(0),0}; | ||
| 120 : | nbuffers=used+1; | ||
| 121 : | } | ||
| 122 : | b=&buffers[used]; | ||
| 123 : | if (size+1 > b->size) { | ||
| 124 : | b->buffer = realloc(b->buffer,size+1); | ||
| 125 : | b->size = size+1; | ||
| 126 : | } | ||
| 127 : | memcpy(b->buffer,from,size); | ||
| 128 : | b->buffer[size]='\0'; | ||
| 129 : | used++; | ||
| 130 : | return b->buffer; | ||
| 131 : | } | ||
| 132 : | |||
| 133 : | char *tilde_cstr(Char *from, UCell size, int clear) | ||
| 134 : | /* like cstr(), but perform tilde expansion on the string */ | ||
| 135 : | { | ||
| 136 : | char *s1,*s2; | ||
| 137 : | int s1_len, s2_len; | ||
| 138 : | struct passwd *getpwnam (), *user_entry; | ||
| 139 : | |||
| 140 : | if (size<1 || from[0]!='~') | ||
| 141 : | return cstr(from, size, clear); | ||
| 142 : | if (size<2 || from[1]=='/') { | ||
| 143 : | s1 = (char *)getenv ("HOME"); | ||
| 144 : | if(s1 == NULL) | ||
| 145 : | s1 = ""; | ||
| 146 : | s2 = from+1; | ||
| 147 : | s2_len = size-1; | ||
| 148 : | } else { | ||
| 149 : | UCell i; | ||
| 150 : | for (i=1; i<size && from[i]!='/'; i++) | ||
| 151 : | ; | ||
| 152 : | anton | 1.13 | if (i==2 && from[1]=='+') /* deal with "~+", i.e., the wd */ |
| 153 : | return cstr(from+3, size<3?0:size-3,clear); | ||
| 154 : | anton | 1.1 | { |
| 155 : | char user[i]; | ||
| 156 : | memcpy(user,from+1,i-1); | ||
| 157 : | user[i-1]='\0'; | ||
| 158 : | user_entry=getpwnam(user); | ||
| 159 : | } | ||
| 160 : | if (user_entry==NULL) | ||
| 161 : | return cstr(from, size, clear); | ||
| 162 : | s1 = user_entry->pw_dir; | ||
| 163 : | s2 = from+i; | ||
| 164 : | s2_len = size-i; | ||
| 165 : | } | ||
| 166 : | s1_len = strlen(s1); | ||
| 167 : | if (s1_len>1 && s1[s1_len-1]=='/') | ||
| 168 : | s1_len--; | ||
| 169 : | { | ||
| 170 : | char path[s1_len+s2_len]; | ||
| 171 : | memcpy(path,s1,s1_len); | ||
| 172 : | memcpy(path+s1_len,s2,s2_len); | ||
| 173 : | return cstr(path,s1_len+s2_len,clear); | ||
| 174 : | } | ||
| 175 : | } | ||
| 176 : | pazsan | 1.9 | #endif |
| 177 : | anton | 1.21 | |
| 178 : | DCell timeval2us(struct timeval *tvp) | ||
| 179 : | { | ||
| 180 : | #ifndef BUGGY_LONG_LONG | ||
| 181 : | return (tvp->tv_sec*(DCell)1000000)+tvp->tv_usec; | ||
| 182 : | #else | ||
| 183 : | DCell d2; | ||
| 184 : | DCell d1=mmul(tvp->tv_sec,1000000); | ||
| 185 : | d2.lo = d1.lo+tvp->tv_usec; | ||
| 186 : | d2.hi = d1.hi + (d2.lo<d1.lo); | ||
| 187 : | return d2; | ||
| 188 : | #endif | ||
| 189 : | } | ||
| 190 : | anton | 1.1 | |
| 191 : | #define NEWLINE '\n' | ||
| 192 : | |||
| 193 : | #ifndef HAVE_RINT | ||
| 194 : | #define rint(x) floor((x)+0.5) | ||
| 195 : | #endif | ||
| 196 : | |||
| 197 : | pazsan | 1.9 | #ifdef HAS_FILE |
| 198 : | anton | 1.16 | static char* fileattr[6]={"rb","rb","r+b","r+b","wb","wb"}; |
| 199 : | anton | 1.1 | |
| 200 : | #ifndef O_BINARY | ||
| 201 : | #define O_BINARY 0 | ||
| 202 : | #endif | ||
| 203 : | #ifndef O_TEXT | ||
| 204 : | #define O_TEXT 0 | ||
| 205 : | #endif | ||
| 206 : | |||
| 207 : | static int ufileattr[6]= { | ||
| 208 : | anton | 1.16 | O_RDONLY|O_BINARY, O_RDONLY|O_BINARY, |
| 209 : | O_RDWR |O_BINARY, O_RDWR |O_BINARY, | ||
| 210 : | O_WRONLY|O_BINARY, O_WRONLY|O_BINARY }; | ||
| 211 : | pazsan | 1.9 | #endif |
| 212 : | anton | 1.1 | |
| 213 : | anton | 1.26 | /* conversion on fetch */ |
| 214 : | |||
| 215 : | #define vm_Cell2f(x) ((Bool)(x)) | ||
| 216 : | #define vm_Cell2c(x) ((Char)(x)) | ||
| 217 : | #define vm_Cell2n(x) ((Cell)x) | ||
| 218 : | #define vm_Cell2w(x) ((Cell)x) | ||
| 219 : | #define vm_Cell2u(x) ((UCell)(x)) | ||
| 220 : | #define vm_Cell2a_(x) ((Cell *)(x)) | ||
| 221 : | #define vm_Cell2c_(x) ((Char *)(x)) | ||
| 222 : | #define vm_Cell2f_(x) ((Float *)(x)) | ||
| 223 : | #define vm_Cell2df_(x) ((DFloat *)(x)) | ||
| 224 : | #define vm_Cell2sf_(x) ((SFloat *)(x)) | ||
| 225 : | #define vm_Cell2xt(x) ((Xt)(x)) | ||
| 226 : | #define vm_Cell2f83name(x) ((struct F83Name *)(x)) | ||
| 227 : | #define vm_Cell2longname(x) ((struct Longname *)(x)) | ||
| 228 : | #define vm_Float2r(x) (x) | ||
| 229 : | |||
| 230 : | /* conversion on store */ | ||
| 231 : | |||
| 232 : | #define vm_f2Cell(x) ((Cell)(x)) | ||
| 233 : | #define vm_c2Cell(x) ((Cell)(x)) | ||
| 234 : | #define vm_n2Cell(x) ((Cell)(x)) | ||
| 235 : | #define vm_w2Cell(x) ((Cell)(x)) | ||
| 236 : | #define vm_u2Cell(x) ((Cell)(x)) | ||
| 237 : | #define vm_a_2Cell(x) ((Cell)(x)) | ||
| 238 : | #define vm_c_2Cell(x) ((Cell)(x)) | ||
| 239 : | #define vm_f_2Cell(x) ((Cell)(x)) | ||
| 240 : | #define vm_df_2Cell(x) ((Cell)(x)) | ||
| 241 : | #define vm_sf_2Cell(x) ((Cell)(x)) | ||
| 242 : | #define vm_xt2Cell(x) ((Cell)(x)) | ||
| 243 : | #define vm_f83name2Cell(x) ((Cell)(x)) | ||
| 244 : | #define vm_longname2Cell(x) ((Cell)(x)) | ||
| 245 : | #define vm_r2Float(x) (x) | ||
| 246 : | |||
| 247 : | anton | 1.29 | #define vm_Cell2Cell(x) (x) |
| 248 : | |||
| 249 : | anton | 1.1 | /* if machine.h has not defined explicit registers, define them as implicit */ |
| 250 : | #ifndef IPREG | ||
| 251 : | #define IPREG | ||
| 252 : | #endif | ||
| 253 : | #ifndef SPREG | ||
| 254 : | #define SPREG | ||
| 255 : | #endif | ||
| 256 : | #ifndef RPREG | ||
| 257 : | #define RPREG | ||
| 258 : | #endif | ||
| 259 : | #ifndef FPREG | ||
| 260 : | #define FPREG | ||
| 261 : | #endif | ||
| 262 : | #ifndef LPREG | ||
| 263 : | #define LPREG | ||
| 264 : | #endif | ||
| 265 : | #ifndef CFAREG | ||
| 266 : | #define CFAREG | ||
| 267 : | #endif | ||
| 268 : | #ifndef UPREG | ||
| 269 : | #define UPREG | ||
| 270 : | #endif | ||
| 271 : | #ifndef TOSREG | ||
| 272 : | #define TOSREG | ||
| 273 : | #endif | ||
| 274 : | #ifndef FTOSREG | ||
| 275 : | #define FTOSREG | ||
| 276 : | #endif | ||
| 277 : | |||
| 278 : | #ifndef CPU_DEP1 | ||
| 279 : | # define CPU_DEP1 0 | ||
| 280 : | #endif | ||
| 281 : | |||
| 282 : | /* declare and compute cfa for certain threading variants */ | ||
| 283 : | /* warning: this is nonsyntactical; it will not work in place of a statement */ | ||
| 284 : | anton | 1.12 | #ifndef GETCFA |
| 285 : | anton | 1.1 | #define DOCFA |
| 286 : | #else | ||
| 287 : | #define DOCFA Xt cfa; GETCFA(cfa) | ||
| 288 : | #endif | ||
| 289 : | |||
| 290 : | anton | 1.28 | /* instructions containing these must be the last instruction of a |
| 291 : | super-instruction (e.g., branches, EXECUTE, and other instructions | ||
| 292 : | ending the basic block). Instructions containing SET_IP get this | ||
| 293 : | automatically, so you usually don't have to write it. If you have | ||
| 294 : | to write it, write it after IP points to the next instruction. | ||
| 295 : | Used for profiling. Don't write it in a word containing SET_IP, or | ||
| 296 : | the following block will be counted twice. */ | ||
| 297 : | #ifdef VM_PROFILING | ||
| 298 : | #define SUPER_END vm_count_block(IP) | ||
| 299 : | #else | ||
| 300 : | #define SUPER_END | ||
| 301 : | #endif | ||
| 302 : | |||
| 303 : | anton | 1.10 | #ifdef GFORTH_DEBUGGING |
| 304 : | /* define some VM registers as global variables, so they survive exceptions; | ||
| 305 : | global register variables are not up to the task (according to the | ||
| 306 : | GNU C manual) */ | ||
| 307 : | Xt *ip; | ||
| 308 : | Cell *rp; | ||
| 309 : | #endif | ||
| 310 : | |||
| 311 : | anton | 1.1 | Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0) |
| 312 : | /* executes code at ip, if ip!=NULL | ||
| 313 : | returns array of machine code labels (for use in a loader), if ip==NULL | ||
| 314 : | */ | ||
| 315 : | { | ||
| 316 : | anton | 1.10 | #ifndef GFORTH_DEBUGGING |
| 317 : | register Xt *ip IPREG; | ||
| 318 : | register Cell *rp RPREG; | ||
| 319 : | #endif | ||
| 320 : | anton | 1.1 | register Cell *sp SPREG = sp0; |
| 321 : | register Float *fp FPREG = fp0; | ||
| 322 : | register Address lp LPREG = lp0; | ||
| 323 : | #ifdef CFA_NEXT | ||
| 324 : | register Xt cfa CFAREG; | ||
| 325 : | #endif | ||
| 326 : | anton | 1.11 | #ifdef MORE_VARS |
| 327 : | MORE_VARS | ||
| 328 : | #endif | ||
| 329 : | anton | 1.1 | register Address up UPREG = UP; |
| 330 : | anton | 1.24 | IF_spTOS(register Cell spTOS TOSREG;) |
| 331 : | IF_fpTOS(register Float fpTOS FTOSREG;) | ||
| 332 : | anton | 1.1 | #if defined(DOUBLY_INDIRECT) |
| 333 : | static Label *symbols; | ||
| 334 : | static void *routines[]= { | ||
| 335 : | anton | 1.27 | #define MAX_SYMBOLS (sizeof(routines)/sizeof(routines[0])) |
| 336 : | anton | 1.1 | #else /* !defined(DOUBLY_INDIRECT) */ |
| 337 : | static Label symbols[]= { | ||
| 338 : | anton | 1.27 | #define MAX_SYMBOLS (sizeof(symbols)/sizeof(symbols[0])) |
| 339 : | anton | 1.1 | #endif /* !defined(DOUBLY_INDIRECT) */ |
| 340 : | pazsan | 1.4 | (Label)&&docol, |
| 341 : | (Label)&&docon, | ||
| 342 : | (Label)&&dovar, | ||
| 343 : | (Label)&&douser, | ||
| 344 : | (Label)&&dodefer, | ||
| 345 : | (Label)&&dofield, | ||
| 346 : | (Label)&&dodoes, | ||
| 347 : | anton | 1.1 | /* the following entry is normally unused; |
| 348 : | it's there because its index indicates a does-handler */ | ||
| 349 : | pazsan | 1.7 | CPU_DEP1, |
| 350 : | anton | 1.1 | #include "prim_lab.i" |
| 351 : | pazsan | 1.4 | (Label)0 |
| 352 : | anton | 1.1 | }; |
| 353 : | #ifdef CPU_DEP2 | ||
| 354 : | CPU_DEP2 | ||
| 355 : | #endif | ||
| 356 : | |||
| 357 : | anton | 1.10 | ip = ip0; |
| 358 : | rp = rp0; | ||
| 359 : | anton | 1.1 | #ifdef DEBUG |
| 360 : | fprintf(stderr,"ip=%x, sp=%x, rp=%x, fp=%x, lp=%x, up=%x\n", | ||
| 361 : | (unsigned)ip,(unsigned)sp,(unsigned)rp, | ||
| 362 : | (unsigned)fp,(unsigned)lp,(unsigned)up); | ||
| 363 : | #endif | ||
| 364 : | |||
| 365 : | if (ip == NULL) { | ||
| 366 : | #if defined(DOUBLY_INDIRECT) | ||
| 367 : | anton | 1.3 | #define CODE_OFFSET (22*sizeof(Cell)) |
| 368 : | anton | 1.1 | int i; |
| 369 : | anton | 1.3 | Cell code_offset = offset_image? CODE_OFFSET : 0; |
| 370 : | pazsan | 1.7 | |
| 371 : | anton | 1.3 | symbols = (Label *)(malloc(MAX_SYMBOLS*sizeof(Cell)+CODE_OFFSET)+code_offset); |
| 372 : | anton | 1.1 | for (i=0; i<DOESJUMP+1; i++) |
| 373 : | pazsan | 1.7 | symbols[i] = (Label)routines[i]; |
| 374 : | anton | 1.1 | for (; routines[i]!=0; i++) { |
| 375 : | if (i>=MAX_SYMBOLS) { | ||
| 376 : | fprintf(stderr,"gforth-ditc: more than %d primitives\n",MAX_SYMBOLS); | ||
| 377 : | exit(1); | ||
| 378 : | anton | 1.20 | } |
| 379 : | symbols[i] = &routines[i]; | ||
| 380 : | anton | 1.1 | } |
| 381 : | anton | 1.20 | #endif /* defined(DOUBLY_INDIRECT) */ |
| 382 : | return symbols; | ||
| 383 : | pazsan | 1.7 | } |
| 384 : | anton | 1.1 | |
| 385 : | anton | 1.24 | IF_spTOS(spTOS = sp[0]); |
| 386 : | IF_fpTOS(fpTOS = fp[0]); | ||
| 387 : | pazsan | 1.7 | /* prep_terminal(); */ |
| 388 : | anton | 1.11 | SET_IP(ip); |
| 389 : | anton | 1.28 | SUPER_END; /* count the first block, too */ |
| 390 : | anton | 1.1 | NEXT; |
| 391 : | |||
| 392 : | anton | 1.11 | |
| 393 : | anton | 1.1 | #ifdef CPU_DEP3 |
| 394 : | CPU_DEP3 | ||
| 395 : | #endif | ||
| 396 : | |||
| 397 : | docol: | ||
| 398 : | { | ||
| 399 : | DOCFA; | ||
| 400 : | #ifdef DEBUG | ||
| 401 : | fprintf(stderr,"%08lx: col: %08lx\n",(Cell)ip,(Cell)PFA1(cfa)); | ||
| 402 : | #endif | ||
| 403 : | #ifdef CISC_NEXT | ||
| 404 : | /* this is the simple version */ | ||
| 405 : | *--rp = (Cell)ip; | ||
| 406 : | anton | 1.11 | SET_IP((Xt *)PFA1(cfa)); |
| 407 : | anton | 1.28 | SUPER_END; |
| 408 : | anton | 1.1 | NEXT; |
| 409 : | #else | ||
| 410 : | anton | 1.11 | /* this one is important, so we help the compiler optimizing */ |
| 411 : | anton | 1.1 | { |
| 412 : | DEF_CA | ||
| 413 : | anton | 1.11 | rp[-1] = (Cell)ip; |
| 414 : | SET_IP((Xt *)PFA1(cfa)); | ||
| 415 : | anton | 1.28 | SUPER_END; |
| 416 : | anton | 1.11 | NEXT_P1; |
| 417 : | rp--; | ||
| 418 : | NEXT_P2; | ||
| 419 : | anton | 1.1 | } |
| 420 : | #endif | ||
| 421 : | } | ||
| 422 : | |||
| 423 : | docon: | ||
| 424 : | { | ||
| 425 : | DOCFA; | ||
| 426 : | #ifdef DEBUG | ||
| 427 : | fprintf(stderr,"%08lx: con: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa)); | ||
| 428 : | #endif | ||
| 429 : | #ifdef USE_TOS | ||
| 430 : | anton | 1.24 | *sp-- = spTOS; |
| 431 : | spTOS = *(Cell *)PFA1(cfa); | ||
| 432 : | anton | 1.1 | #else |
| 433 : | *--sp = *(Cell *)PFA1(cfa); | ||
| 434 : | #endif | ||
| 435 : | } | ||
| 436 : | NEXT_P0; | ||
| 437 : | NEXT; | ||
| 438 : | |||
| 439 : | dovar: | ||
| 440 : | { | ||
| 441 : | DOCFA; | ||
| 442 : | #ifdef DEBUG | ||
| 443 : | fprintf(stderr,"%08lx: var: %08lx\n",(Cell)ip,(Cell)PFA1(cfa)); | ||
| 444 : | #endif | ||
| 445 : | #ifdef USE_TOS | ||
| 446 : | anton | 1.24 | *sp-- = spTOS; |
| 447 : | spTOS = (Cell)PFA1(cfa); | ||
| 448 : | anton | 1.1 | #else |
| 449 : | *--sp = (Cell)PFA1(cfa); | ||
| 450 : | #endif | ||
| 451 : | } | ||
| 452 : | NEXT_P0; | ||
| 453 : | NEXT; | ||
| 454 : | |||
| 455 : | douser: | ||
| 456 : | { | ||
| 457 : | DOCFA; | ||
| 458 : | #ifdef DEBUG | ||
| 459 : | fprintf(stderr,"%08lx: user: %08lx\n",(Cell)ip,(Cell)PFA1(cfa)); | ||
| 460 : | #endif | ||
| 461 : | #ifdef USE_TOS | ||
| 462 : | anton | 1.24 | *sp-- = spTOS; |
| 463 : | spTOS = (Cell)(up+*(Cell*)PFA1(cfa)); | ||
| 464 : | anton | 1.1 | #else |
| 465 : | *--sp = (Cell)(up+*(Cell*)PFA1(cfa)); | ||
| 466 : | #endif | ||
| 467 : | } | ||
| 468 : | NEXT_P0; | ||
| 469 : | NEXT; | ||
| 470 : | |||
| 471 : | dodefer: | ||
| 472 : | { | ||
| 473 : | DOCFA; | ||
| 474 : | #ifdef DEBUG | ||
| 475 : | fprintf(stderr,"%08lx: defer: %08lx\n",(Cell)ip,*(Cell*)PFA1(cfa)); | ||
| 476 : | #endif | ||
| 477 : | anton | 1.28 | SUPER_END; |
| 478 : | anton | 1.1 | EXEC(*(Xt *)PFA1(cfa)); |
| 479 : | } | ||
| 480 : | |||
| 481 : | dofield: | ||
| 482 : | { | ||
| 483 : | DOCFA; | ||
| 484 : | #ifdef DEBUG | ||
| 485 : | fprintf(stderr,"%08lx: field: %08lx\n",(Cell)ip,(Cell)PFA1(cfa)); | ||
| 486 : | #endif | ||
| 487 : | anton | 1.24 | spTOS += *(Cell*)PFA1(cfa); |
| 488 : | anton | 1.1 | } |
| 489 : | NEXT_P0; | ||
| 490 : | NEXT; | ||
| 491 : | |||
| 492 : | dodoes: | ||
| 493 : | /* this assumes the following structure: | ||
| 494 : | defining-word: | ||
| 495 : | |||
| 496 : | ... | ||
| 497 : | DOES> | ||
| 498 : | (possible padding) | ||
| 499 : | possibly handler: jmp dodoes | ||
| 500 : | (possible branch delay slot(s)) | ||
| 501 : | Forth code after DOES> | ||
| 502 : | |||
| 503 : | defined word: | ||
| 504 : | |||
| 505 : | cfa: address of or jump to handler OR | ||
| 506 : | address of or jump to dodoes, address of DOES-code | ||
| 507 : | pfa: | ||
| 508 : | |||
| 509 : | */ | ||
| 510 : | { | ||
| 511 : | DOCFA; | ||
| 512 : | |||
| 513 : | /* fprintf(stderr, "Got CFA %08lx at doescode %08lx/%08lx: does: %08lx\n",cfa,(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa));*/ | ||
| 514 : | #ifdef DEBUG | ||
| 515 : | fprintf(stderr,"%08lx/%08lx: does: %08lx\n",(Cell)ip,(Cell)PFA(cfa),(Cell)DOES_CODE1(cfa)); | ||
| 516 : | fflush(stderr); | ||
| 517 : | #endif | ||
| 518 : | *--rp = (Cell)ip; | ||
| 519 : | /* PFA1 might collide with DOES_CODE1 here, so we use PFA */ | ||
| 520 : | #ifdef USE_TOS | ||
| 521 : | anton | 1.24 | *sp-- = spTOS; |
| 522 : | spTOS = (Cell)PFA(cfa); | ||
| 523 : | anton | 1.1 | #else |
| 524 : | *--sp = (Cell)PFA(cfa); | ||
| 525 : | #endif | ||
| 526 : | anton | 1.11 | SET_IP(DOES_CODE1(cfa)); |
| 527 : | anton | 1.28 | SUPER_END; |
| 528 : | anton | 1.24 | /* fprintf(stderr,"TOS = %08lx, IP=%08lx\n", spTOS, IP);*/ |
| 529 : | anton | 1.1 | } |
| 530 : | NEXT; | ||
| 531 : | |||
| 532 : | #include "prim.i" | ||
| 533 : | } |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |