Print this page
11506 smatch resync
| Split |
Close |
| Expand all |
| Collapse all |
--- old/usr/src/common/ficl/vm.c
+++ new/usr/src/common/ficl/vm.c
1 1 /*
2 2 * v m . c
3 3 * Forth Inspired Command Language - virtual machine methods
4 4 * Author: John Sadler (john_sadler@alum.mit.edu)
5 5 * Created: 19 July 1997
6 6 * $Id: vm.c,v 1.17 2010/09/13 18:43:04 asau Exp $
7 7 */
8 8 /*
9 9 * This file implements the virtual machine of Ficl. Each virtual
10 10 * machine retains the state of an interpreter. A virtual machine
11 11 * owns a pair of stacks for parameters and return addresses, as
12 12 * well as a pile of state variables and the two dedicated registers
13 13 * of the interpreter.
14 14 */
15 15 /*
16 16 * Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
17 17 * All rights reserved.
18 18 *
19 19 * Get the latest Ficl release at http://ficl.sourceforge.net
20 20 *
21 21 * I am interested in hearing from anyone who uses Ficl. If you have
22 22 * a problem, a success story, a defect, an enhancement request, or
23 23 * if you would like to contribute to the Ficl release, please
24 24 * contact me by email at the address above.
25 25 *
26 26 * L I C E N S E and D I S C L A I M E R
27 27 *
28 28 * Redistribution and use in source and binary forms, with or without
29 29 * modification, are permitted provided that the following conditions
30 30 * are met:
31 31 * 1. Redistributions of source code must retain the above copyright
32 32 * notice, this list of conditions and the following disclaimer.
33 33 * 2. Redistributions in binary form must reproduce the above copyright
34 34 * notice, this list of conditions and the following disclaimer in the
35 35 * documentation and/or other materials provided with the distribution.
36 36 *
37 37 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
38 38 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
39 39 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
↓ open down ↓ |
39 lines elided |
↑ open up ↑ |
40 40 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
41 41 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
42 42 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
43 43 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
44 44 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
45 45 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
46 46 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
47 47 * SUCH DAMAGE.
48 48 */
49 49
50 +/*
51 + * Copyright 2019 Joyent, Inc.
52 + */
53 +
50 54 #include "ficl.h"
51 55
52 56 #if FICL_ROBUST >= 2
53 57 #define FICL_VM_CHECK(vm) \
54 58 FICL_VM_ASSERT(vm, (*(vm->ip - 1)) == vm->runningWord)
55 59 #else
56 60 #define FICL_VM_CHECK(vm)
57 61 #endif
58 62
59 63 /*
60 64 * v m B r a n c h R e l a t i v e
61 65 */
62 66 void
63 67 ficlVmBranchRelative(ficlVm *vm, int offset)
64 68 {
65 69 vm->ip += offset;
66 70 }
67 71
68 72 /*
69 73 * v m C r e a t e
70 74 * Creates a virtual machine either from scratch (if vm is NULL on entry)
71 75 * or by resizing and reinitializing an existing VM to the specified stack
72 76 * sizes.
73 77 */
74 78 ficlVm *
75 79 ficlVmCreate(ficlVm *vm, unsigned nPStack, unsigned nRStack)
76 80 {
77 81 if (vm == NULL) {
78 82 vm = (ficlVm *)ficlMalloc(sizeof (ficlVm));
79 83 FICL_ASSERT(NULL, vm);
80 84 memset(vm, 0, sizeof (ficlVm));
81 85 }
82 86
83 87 if (vm->dataStack)
84 88 ficlStackDestroy(vm->dataStack);
85 89 vm->dataStack = ficlStackCreate(vm, "data", nPStack);
86 90
87 91 if (vm->returnStack)
88 92 ficlStackDestroy(vm->returnStack);
89 93 vm->returnStack = ficlStackCreate(vm, "return", nRStack);
90 94
91 95 #if FICL_WANT_FLOAT
92 96 if (vm->floatStack)
93 97 ficlStackDestroy(vm->floatStack);
94 98 vm->floatStack = ficlStackCreate(vm, "float", nPStack);
95 99 #endif
96 100
97 101 ficlVmReset(vm);
98 102 return (vm);
99 103 }
100 104
101 105 /*
102 106 * v m D e l e t e
103 107 * Free all memory allocated to the specified VM and its subordinate
104 108 * structures.
105 109 */
106 110 void
107 111 ficlVmDestroy(ficlVm *vm)
108 112 {
109 113 if (vm) {
110 114 ficlFree(vm->dataStack);
111 115 ficlFree(vm->returnStack);
112 116 #if FICL_WANT_FLOAT
113 117 ficlFree(vm->floatStack);
114 118 #endif
115 119 ficlFree(vm);
116 120 }
117 121 }
118 122
119 123 /*
120 124 * v m E x e c u t e
121 125 * Sets up the specified word to be run by the inner interpreter.
122 126 * Executes the word's code part immediately, but in the case of
123 127 * colon definition, the definition itself needs the inner interpreter
124 128 * to complete. This does not happen until control reaches ficlExec
125 129 */
126 130 void
127 131 ficlVmExecuteWord(ficlVm *vm, ficlWord *pWord)
128 132 {
129 133 ficlVmInnerLoop(vm, pWord);
130 134 }
131 135
132 136 static void
133 137 ficlVmOptimizeJumpToJump(ficlVm *vm, ficlIp ip)
134 138 {
135 139 ficlIp destination;
136 140 switch ((ficlInstruction)(*ip)) {
137 141 case ficlInstructionBranchParenWithCheck:
138 142 *ip = (ficlWord *)ficlInstructionBranchParen;
139 143 goto RUNTIME_FIXUP;
140 144
141 145 case ficlInstructionBranch0ParenWithCheck:
142 146 *ip = (ficlWord *)ficlInstructionBranch0Paren;
143 147 RUNTIME_FIXUP:
144 148 ip++;
145 149 destination = ip + *(ficlInteger *)ip;
146 150 switch ((ficlInstruction)*destination) {
147 151 case ficlInstructionBranchParenWithCheck:
148 152 /* preoptimize where we're jumping to */
149 153 ficlVmOptimizeJumpToJump(vm, destination);
150 154 /* FALLTHROUGH */
151 155 case ficlInstructionBranchParen:
152 156 destination++;
153 157 destination += *(ficlInteger *)destination;
154 158 *ip = (ficlWord *)(destination - ip);
155 159 break;
156 160 }
157 161 }
158 162 }
159 163
160 164 /*
161 165 * v m I n n e r L o o p
162 166 * the mysterious inner interpreter...
163 167 * This loop is the address interpreter that makes colon definitions
164 168 * work. Upon entry, it assumes that the IP points to an entry in
165 169 * a definition (the body of a colon word). It runs one word at a time
166 170 * until something does vmThrow. The catcher for this is expected to exist
167 171 * in the calling code.
168 172 * vmThrow gets you out of this loop with a longjmp()
169 173 */
170 174
171 175 #if FICL_ROBUST <= 1
172 176 /* turn off stack checking for primitives */
173 177 #define _CHECK_STACK(stack, top, pop, push)
174 178 #else
175 179
176 180 #define _CHECK_STACK(stack, top, pop, push) \
177 181 ficlStackCheckNospill(stack, top, pop, push)
178 182
179 183 static FICL_PLATFORM_INLINE void
180 184 ficlStackCheckNospill(ficlStack *stack, ficlCell *top, int popCells,
181 185 int pushCells)
182 186 {
183 187 /*
184 188 * Why save and restore stack->top?
185 189 * So the simple act of stack checking doesn't force a "register" spill,
186 190 * which might mask bugs (places where we needed to spill but didn't).
187 191 * --lch
188 192 */
189 193 ficlCell *oldTop = stack->top;
190 194 stack->top = top;
191 195 ficlStackCheck(stack, popCells, pushCells);
192 196 stack->top = oldTop;
193 197 }
194 198
195 199 #endif /* FICL_ROBUST <= 1 */
196 200
197 201 #define CHECK_STACK(pop, push) \
198 202 _CHECK_STACK(vm->dataStack, dataTop, pop, push)
199 203 #define CHECK_FLOAT_STACK(pop, push) \
200 204 _CHECK_STACK(vm->floatStack, floatTop, pop, push)
201 205 #define CHECK_RETURN_STACK(pop, push) \
202 206 _CHECK_STACK(vm->returnStack, returnTop, pop, push)
203 207
204 208 #if FICL_WANT_FLOAT
205 209 #define FLOAT_LOCAL_VARIABLE_SPILL \
206 210 vm->floatStack->top = floatTop;
207 211 #define FLOAT_LOCAL_VARIABLE_REFILL \
208 212 floatTop = vm->floatStack->top;
209 213 #else
210 214 #define FLOAT_LOCAL_VARIABLE_SPILL
211 215 #define FLOAT_LOCAL_VARIABLE_REFILL
212 216 #endif /* FICL_WANT_FLOAT */
213 217
214 218 #if FICL_WANT_LOCALS
215 219 #define LOCALS_LOCAL_VARIABLE_SPILL \
216 220 vm->returnStack->frame = frame;
217 221 #define LOCALS_LOCAL_VARIABLE_REFILL \
218 222 frame = vm->returnStack->frame;
219 223 #else
220 224 #define LOCALS_LOCAL_VARIABLE_SPILL
221 225 #define LOCALS_LOCAL_VARIABLE_REFILL
222 226 #endif /* FICL_WANT_FLOAT */
223 227
224 228 #define LOCAL_VARIABLE_SPILL \
225 229 vm->ip = (ficlIp)ip; \
226 230 vm->dataStack->top = dataTop; \
227 231 vm->returnStack->top = returnTop; \
228 232 FLOAT_LOCAL_VARIABLE_SPILL \
229 233 LOCALS_LOCAL_VARIABLE_SPILL
230 234
231 235 #define LOCAL_VARIABLE_REFILL \
232 236 ip = (ficlInstruction *)vm->ip; \
233 237 dataTop = vm->dataStack->top; \
234 238 returnTop = vm->returnStack->top; \
235 239 FLOAT_LOCAL_VARIABLE_REFILL \
236 240 LOCALS_LOCAL_VARIABLE_REFILL
237 241
238 242 void
239 243 ficlVmInnerLoop(ficlVm *vm, ficlWord *fw)
240 244 {
241 245 register ficlInstruction *ip;
242 246 register ficlCell *dataTop;
243 247 register ficlCell *returnTop;
244 248 #if FICL_WANT_FLOAT
245 249 register ficlCell *floatTop;
246 250 ficlFloat f;
247 251 #endif /* FICL_WANT_FLOAT */
248 252 #if FICL_WANT_LOCALS
249 253 register ficlCell *frame;
250 254 #endif /* FICL_WANT_LOCALS */
251 255 jmp_buf *oldExceptionHandler;
252 256 jmp_buf exceptionHandler;
253 257 int except;
254 258 int once;
255 259 volatile int count; /* volatile because of longjmp */
256 260 ficlInstruction instruction;
257 261 ficlInteger i;
258 262 ficlUnsigned u;
259 263 ficlCell c;
260 264 ficlCountedString *s;
261 265 ficlCell *cell;
262 266 char *cp;
263 267
264 268 once = (fw != NULL);
265 269 if (once)
266 270 count = 1;
267 271
268 272 oldExceptionHandler = vm->exceptionHandler;
269 273 /* This has to come before the setjmp! */
270 274 vm->exceptionHandler = &exceptionHandler;
271 275 except = setjmp(exceptionHandler);
272 276
273 277 LOCAL_VARIABLE_REFILL;
274 278
275 279 if (except) {
276 280 LOCAL_VARIABLE_SPILL;
277 281 vm->exceptionHandler = oldExceptionHandler;
278 282 ficlVmThrow(vm, except);
279 283 }
280 284
281 285 for (;;) {
282 286 if (once) {
283 287 if (!count--)
284 288 break;
285 289 instruction = (ficlInstruction)((void *)fw);
286 290 } else {
287 291 instruction = *ip++;
288 292 fw = (ficlWord *)instruction;
289 293 }
290 294
291 295 AGAIN:
292 296 switch (instruction) {
293 297 case ficlInstructionInvalid:
294 298 ficlVmThrowError(vm,
295 299 "Error: NULL instruction executed!");
296 300 break;
297 301
298 302 case ficlInstruction1:
299 303 case ficlInstruction2:
300 304 case ficlInstruction3:
301 305 case ficlInstruction4:
302 306 case ficlInstruction5:
303 307 case ficlInstruction6:
304 308 case ficlInstruction7:
305 309 case ficlInstruction8:
306 310 case ficlInstruction9:
307 311 case ficlInstruction10:
308 312 case ficlInstruction11:
309 313 case ficlInstruction12:
310 314 case ficlInstruction13:
311 315 case ficlInstruction14:
312 316 case ficlInstruction15:
313 317 case ficlInstruction16:
314 318 CHECK_STACK(0, 1);
315 319 (++dataTop)->i = instruction;
316 320 continue;
317 321
318 322 case ficlInstruction0:
319 323 case ficlInstructionNeg1:
320 324 case ficlInstructionNeg2:
321 325 case ficlInstructionNeg3:
322 326 case ficlInstructionNeg4:
323 327 case ficlInstructionNeg5:
324 328 case ficlInstructionNeg6:
325 329 case ficlInstructionNeg7:
326 330 case ficlInstructionNeg8:
327 331 case ficlInstructionNeg9:
328 332 case ficlInstructionNeg10:
329 333 case ficlInstructionNeg11:
330 334 case ficlInstructionNeg12:
331 335 case ficlInstructionNeg13:
332 336 case ficlInstructionNeg14:
333 337 case ficlInstructionNeg15:
334 338 case ficlInstructionNeg16:
335 339 CHECK_STACK(0, 1);
336 340 (++dataTop)->i = ficlInstruction0 - instruction;
337 341 continue;
338 342
339 343 /*
340 344 * stringlit: Fetch the count from the dictionary, then push
341 345 * the address and count on the stack. Finally, update ip to
342 346 * point to the first aligned address after the string text.
343 347 */
344 348 case ficlInstructionStringLiteralParen: {
345 349 ficlUnsigned8 length;
346 350 CHECK_STACK(0, 2);
347 351
348 352 s = (ficlCountedString *)(ip);
349 353 length = s->length;
350 354 cp = s->text;
351 355 (++dataTop)->p = cp;
352 356 (++dataTop)->i = length;
353 357
354 358 cp += length + 1;
355 359 cp = ficlAlignPointer(cp);
356 360 ip = (void *)cp;
357 361 continue;
358 362 }
359 363
360 364 case ficlInstructionCStringLiteralParen:
361 365 CHECK_STACK(0, 1);
362 366
363 367 s = (ficlCountedString *)(ip);
364 368 cp = s->text + s->length + 1;
365 369 cp = ficlAlignPointer(cp);
366 370 ip = (void *)cp;
367 371 (++dataTop)->p = s;
368 372 continue;
369 373
370 374 #if FICL_WANT_OPTIMIZE == FICL_OPTIMIZE_FOR_SIZE
371 375 #if FICL_WANT_FLOAT
372 376 FLOAT_PUSH_CELL_POINTER_DOUBLE_MINIPROC:
373 377 *++floatTop = cell[1];
374 378 /* intentional fall-through */
375 379 FLOAT_PUSH_CELL_POINTER_MINIPROC:
376 380 *++floatTop = cell[0];
377 381 continue;
378 382
379 383 FLOAT_POP_CELL_POINTER_MINIPROC:
380 384 cell[0] = *floatTop--;
381 385 continue;
382 386
383 387 FLOAT_POP_CELL_POINTER_DOUBLE_MINIPROC:
384 388 cell[0] = *floatTop--;
385 389 cell[1] = *floatTop--;
386 390 continue;
387 391
388 392 #define FLOAT_PUSH_CELL_POINTER_DOUBLE(cp) \
389 393 cell = (cp); goto FLOAT_PUSH_CELL_POINTER_DOUBLE_MINIPROC
390 394 #define FLOAT_PUSH_CELL_POINTER(cp) \
391 395 cell = (cp); goto FLOAT_PUSH_CELL_POINTER_MINIPROC
392 396 #define FLOAT_POP_CELL_POINTER_DOUBLE(cp) \
393 397 cell = (cp); goto FLOAT_POP_CELL_POINTER_DOUBLE_MINIPROC
394 398 #define FLOAT_POP_CELL_POINTER(cp) \
395 399 cell = (cp); goto FLOAT_POP_CELL_POINTER_MINIPROC
396 400 #endif /* FICL_WANT_FLOAT */
397 401
398 402 /*
399 403 * Think of these as little mini-procedures.
400 404 * --lch
401 405 */
402 406 PUSH_CELL_POINTER_DOUBLE_MINIPROC:
403 407 *++dataTop = cell[1];
404 408 /* intentional fall-through */
405 409 PUSH_CELL_POINTER_MINIPROC:
406 410 *++dataTop = cell[0];
407 411 continue;
408 412
409 413 POP_CELL_POINTER_MINIPROC:
410 414 cell[0] = *dataTop--;
411 415 continue;
412 416 POP_CELL_POINTER_DOUBLE_MINIPROC:
413 417 cell[0] = *dataTop--;
414 418 cell[1] = *dataTop--;
415 419 continue;
416 420
417 421 #define PUSH_CELL_POINTER_DOUBLE(cp) \
418 422 cell = (cp); goto PUSH_CELL_POINTER_DOUBLE_MINIPROC
419 423 #define PUSH_CELL_POINTER(cp) \
420 424 cell = (cp); goto PUSH_CELL_POINTER_MINIPROC
421 425 #define POP_CELL_POINTER_DOUBLE(cp) \
422 426 cell = (cp); goto POP_CELL_POINTER_DOUBLE_MINIPROC
423 427 #define POP_CELL_POINTER(cp) \
424 428 cell = (cp); goto POP_CELL_POINTER_MINIPROC
425 429
426 430 BRANCH_MINIPROC:
427 431 ip += *(ficlInteger *)ip;
428 432 continue;
429 433
430 434 #define BRANCH() goto BRANCH_MINIPROC
431 435
432 436 EXIT_FUNCTION_MINIPROC:
433 437 ip = (ficlInstruction *)((returnTop--)->p);
434 438 continue;
435 439
436 440 #define EXIT_FUNCTION goto EXIT_FUNCTION_MINIPROC
437 441
438 442 #else /* FICL_WANT_SIZE */
439 443
440 444 #if FICL_WANT_FLOAT
441 445 #define FLOAT_PUSH_CELL_POINTER_DOUBLE(cp) \
442 446 cell = (cp); *++floatTop = cell[1]; *++floatTop = *cell; continue
443 447 #define FLOAT_PUSH_CELL_POINTER(cp) \
444 448 cell = (cp); *++floatTop = *cell; continue
445 449 #define FLOAT_POP_CELL_POINTER_DOUBLE(cp) \
446 450 cell = (cp); *cell = *floatTop--; cell[1] = *floatTop--; continue
447 451 #define FLOAT_POP_CELL_POINTER(cp) \
448 452 cell = (cp); *cell = *floatTop--; continue
449 453 #endif /* FICL_WANT_FLOAT */
450 454
451 455 #define PUSH_CELL_POINTER_DOUBLE(cp) \
452 456 cell = (cp); *++dataTop = cell[1]; *++dataTop = *cell; continue
453 457 #define PUSH_CELL_POINTER(cp) \
454 458 cell = (cp); *++dataTop = *cell; continue
455 459 #define POP_CELL_POINTER_DOUBLE(cp) \
456 460 cell = (cp); *cell = *dataTop--; cell[1] = *dataTop--; continue
457 461 #define POP_CELL_POINTER(cp) \
458 462 cell = (cp); *cell = *dataTop--; continue
459 463
460 464 #define BRANCH() ip += *(ficlInteger *)ip; continue
461 465 #define EXIT_FUNCTION() ip = (ficlInstruction *)((returnTop--)->p); continue
462 466
463 467 #endif /* FICL_WANT_SIZE */
464 468
465 469
466 470 /*
467 471 * This is the runtime for (literal). It assumes that it is
468 472 * part of a colon definition, and that the next ficlCell
469 473 * contains a value to be pushed on the parameter stack at
470 474 * runtime. This code is compiled by "literal".
471 475 */
472 476
473 477 case ficlInstructionLiteralParen:
474 478 CHECK_STACK(0, 1);
475 479 (++dataTop)->i = *ip++;
476 480 continue;
477 481
478 482 case ficlInstruction2LiteralParen:
479 483 CHECK_STACK(0, 2);
480 484 (++dataTop)->i = ip[1];
481 485 (++dataTop)->i = ip[0];
482 486 ip += 2;
483 487 continue;
484 488
485 489 #if FICL_WANT_LOCALS
486 490 /*
487 491 * Link a frame on the return stack, reserving nCells of space
488 492 * for locals - the value of nCells is the next ficlCell in
489 493 * the instruction stream.
490 494 * 1) Push frame onto returnTop
491 495 * 2) frame = returnTop
492 496 * 3) returnTop += nCells
493 497 */
494 498 case ficlInstructionLinkParen: {
495 499 ficlInteger nCells = *ip++;
496 500 (++returnTop)->p = frame;
497 501 frame = returnTop + 1;
498 502 returnTop += nCells;
499 503 continue;
500 504 }
501 505
502 506 /*
503 507 * Unink a stack frame previously created by stackLink
504 508 * 1) dataTop = frame
505 509 * 2) frame = pop()
506 510 */
507 511 case ficlInstructionUnlinkParen:
508 512 returnTop = frame - 1;
509 513 frame = (returnTop--)->p;
510 514 continue;
511 515
512 516 /*
513 517 * Immediate - cfa of a local while compiling - when executed,
514 518 * compiles code to fetch the value of a local given the
515 519 * local's index in the word's pfa
516 520 */
517 521 #if FICL_WANT_FLOAT
518 522 case ficlInstructionGetF2LocalParen:
519 523 FLOAT_PUSH_CELL_POINTER_DOUBLE(frame + *ip++);
520 524
521 525 case ficlInstructionGetFLocalParen:
522 526 FLOAT_PUSH_CELL_POINTER(frame + *ip++);
523 527
524 528 case ficlInstructionToF2LocalParen:
525 529 FLOAT_POP_CELL_POINTER_DOUBLE(frame + *ip++);
526 530
527 531 case ficlInstructionToFLocalParen:
528 532 FLOAT_POP_CELL_POINTER(frame + *ip++);
529 533 #endif /* FICL_WANT_FLOAT */
530 534
531 535 case ficlInstructionGet2LocalParen:
532 536 PUSH_CELL_POINTER_DOUBLE(frame + *ip++);
533 537
534 538 case ficlInstructionGetLocalParen:
535 539 PUSH_CELL_POINTER(frame + *ip++);
536 540
537 541 /*
538 542 * Immediate - cfa of a local while compiling - when executed,
539 543 * compiles code to store the value of a local given the
540 544 * local's index in the word's pfa
541 545 */
542 546
543 547 case ficlInstructionTo2LocalParen:
544 548 POP_CELL_POINTER_DOUBLE(frame + *ip++);
545 549
546 550 case ficlInstructionToLocalParen:
547 551 POP_CELL_POINTER(frame + *ip++);
548 552
549 553 /*
550 554 * Silly little minor optimizations.
551 555 * --lch
552 556 */
553 557 case ficlInstructionGetLocal0:
554 558 PUSH_CELL_POINTER(frame);
555 559
556 560 case ficlInstructionGetLocal1:
557 561 PUSH_CELL_POINTER(frame + 1);
558 562
559 563 case ficlInstructionGet2Local0:
560 564 PUSH_CELL_POINTER_DOUBLE(frame);
561 565
562 566 case ficlInstructionToLocal0:
563 567 POP_CELL_POINTER(frame);
564 568
565 569 case ficlInstructionToLocal1:
566 570 POP_CELL_POINTER(frame + 1);
567 571
568 572 case ficlInstructionTo2Local0:
569 573 POP_CELL_POINTER_DOUBLE(frame);
570 574
571 575 #endif /* FICL_WANT_LOCALS */
572 576
573 577 case ficlInstructionPlus:
574 578 CHECK_STACK(2, 1);
575 579 i = (dataTop--)->i;
576 580 dataTop->i += i;
577 581 continue;
578 582
579 583 case ficlInstructionMinus:
580 584 CHECK_STACK(2, 1);
581 585 i = (dataTop--)->i;
582 586 dataTop->i -= i;
583 587 continue;
584 588
585 589 case ficlInstruction1Plus:
586 590 CHECK_STACK(1, 1);
587 591 dataTop->i++;
588 592 continue;
589 593
590 594 case ficlInstruction1Minus:
591 595 CHECK_STACK(1, 1);
592 596 dataTop->i--;
593 597 continue;
594 598
595 599 case ficlInstruction2Plus:
596 600 CHECK_STACK(1, 1);
597 601 dataTop->i += 2;
598 602 continue;
599 603
600 604 case ficlInstruction2Minus:
601 605 CHECK_STACK(1, 1);
602 606 dataTop->i -= 2;
603 607 continue;
604 608
605 609 case ficlInstructionDup: {
606 610 ficlInteger i = dataTop->i;
607 611 CHECK_STACK(0, 1);
608 612 (++dataTop)->i = i;
609 613 continue;
610 614 }
611 615
612 616 case ficlInstructionQuestionDup:
613 617 CHECK_STACK(1, 2);
614 618
615 619 if (dataTop->i != 0) {
616 620 dataTop[1] = dataTop[0];
617 621 dataTop++;
618 622 }
619 623
620 624 continue;
621 625
622 626 case ficlInstructionSwap: {
623 627 ficlCell swap;
624 628 CHECK_STACK(2, 2);
625 629 swap = dataTop[0];
626 630 dataTop[0] = dataTop[-1];
627 631 dataTop[-1] = swap;
628 632 continue;
629 633 }
630 634
631 635 case ficlInstructionDrop:
632 636 CHECK_STACK(1, 0);
633 637 dataTop--;
634 638 continue;
635 639
636 640 case ficlInstruction2Drop:
637 641 CHECK_STACK(2, 0);
638 642 dataTop -= 2;
639 643 continue;
640 644
641 645 case ficlInstruction2Dup:
642 646 CHECK_STACK(2, 4);
643 647 dataTop[1] = dataTop[-1];
644 648 dataTop[2] = *dataTop;
645 649 dataTop += 2;
646 650 continue;
647 651
648 652 case ficlInstructionOver:
649 653 CHECK_STACK(2, 3);
650 654 dataTop[1] = dataTop[-1];
651 655 dataTop++;
652 656 continue;
653 657
654 658 case ficlInstruction2Over:
655 659 CHECK_STACK(4, 6);
656 660 dataTop[1] = dataTop[-3];
657 661 dataTop[2] = dataTop[-2];
658 662 dataTop += 2;
659 663 continue;
660 664
661 665 case ficlInstructionPick:
662 666 CHECK_STACK(1, 0);
663 667 i = dataTop->i;
664 668 if (i < 0)
665 669 continue;
666 670 CHECK_STACK(i + 2, i + 3);
667 671 *dataTop = dataTop[-i - 1];
668 672 continue;
669 673
670 674 /*
671 675 * Do stack rot.
672 676 * rot ( 1 2 3 -- 2 3 1 )
673 677 */
674 678 case ficlInstructionRot:
675 679 i = 2;
676 680 goto ROLL;
677 681
678 682 /*
679 683 * Do stack roll.
680 684 * roll ( n -- )
681 685 */
682 686 case ficlInstructionRoll:
683 687 CHECK_STACK(1, 0);
684 688 i = (dataTop--)->i;
685 689
686 690 if (i < 1)
687 691 continue;
688 692
689 693 ROLL:
690 694 CHECK_STACK(i+1, i+2);
691 695 c = dataTop[-i];
692 696 memmove(dataTop - i, dataTop - (i - 1),
693 697 i * sizeof (ficlCell));
694 698 *dataTop = c;
695 699 continue;
696 700
697 701 /*
698 702 * Do stack -rot.
699 703 * -rot ( 1 2 3 -- 3 1 2 )
700 704 */
701 705 case ficlInstructionMinusRot:
702 706 i = 2;
703 707 goto MINUSROLL;
704 708
705 709 /*
706 710 * Do stack -roll.
707 711 * -roll ( n -- )
708 712 */
709 713 case ficlInstructionMinusRoll:
710 714 CHECK_STACK(1, 0);
711 715 i = (dataTop--)->i;
712 716
713 717 if (i < 1)
714 718 continue;
715 719
716 720 MINUSROLL:
717 721 CHECK_STACK(i+1, i+2);
718 722 c = *dataTop;
719 723 memmove(dataTop - (i - 1), dataTop - i,
720 724 i * sizeof (ficlCell));
721 725 dataTop[-i] = c;
722 726
723 727 continue;
724 728
725 729 /*
726 730 * Do stack 2swap
727 731 * 2swap ( 1 2 3 4 -- 3 4 1 2 )
728 732 */
729 733 case ficlInstruction2Swap: {
730 734 ficlCell c2;
731 735 CHECK_STACK(4, 4);
732 736
733 737 c = *dataTop;
734 738 c2 = dataTop[-1];
735 739
736 740 *dataTop = dataTop[-2];
737 741 dataTop[-1] = dataTop[-3];
738 742
739 743 dataTop[-2] = c;
740 744 dataTop[-3] = c2;
741 745 continue;
742 746 }
743 747
744 748 case ficlInstructionPlusStore: {
745 749 ficlCell *cell;
746 750 CHECK_STACK(2, 0);
747 751 cell = (ficlCell *)(dataTop--)->p;
748 752 cell->i += (dataTop--)->i;
749 753 continue;
750 754 }
751 755
752 756 case ficlInstructionQuadFetch: {
753 757 ficlUnsigned32 *integer32;
754 758 CHECK_STACK(1, 1);
755 759 integer32 = (ficlUnsigned32 *)dataTop->i;
756 760 dataTop->u = (ficlUnsigned)*integer32;
757 761 continue;
758 762 }
759 763
760 764 case ficlInstructionQuadStore: {
761 765 ficlUnsigned32 *integer32;
762 766 CHECK_STACK(2, 0);
763 767 integer32 = (ficlUnsigned32 *)(dataTop--)->p;
764 768 *integer32 = (ficlUnsigned32)((dataTop--)->u);
765 769 continue;
766 770 }
767 771
768 772 case ficlInstructionWFetch: {
769 773 ficlUnsigned16 *integer16;
770 774 CHECK_STACK(1, 1);
771 775 integer16 = (ficlUnsigned16 *)dataTop->p;
772 776 dataTop->u = ((ficlUnsigned)*integer16);
773 777 continue;
774 778 }
775 779
776 780 case ficlInstructionWStore: {
777 781 ficlUnsigned16 *integer16;
778 782 CHECK_STACK(2, 0);
779 783 integer16 = (ficlUnsigned16 *)(dataTop--)->p;
780 784 *integer16 = (ficlUnsigned16)((dataTop--)->u);
781 785 continue;
782 786 }
783 787
784 788 case ficlInstructionCFetch: {
785 789 ficlUnsigned8 *integer8;
786 790 CHECK_STACK(1, 1);
787 791 integer8 = (ficlUnsigned8 *)dataTop->p;
788 792 dataTop->u = ((ficlUnsigned)*integer8);
789 793 continue;
790 794 }
791 795
792 796 case ficlInstructionCStore: {
793 797 ficlUnsigned8 *integer8;
794 798 CHECK_STACK(2, 0);
795 799 integer8 = (ficlUnsigned8 *)(dataTop--)->p;
796 800 *integer8 = (ficlUnsigned8)((dataTop--)->u);
797 801 continue;
798 802 }
799 803
800 804
801 805 /*
802 806 * l o g i c a n d c o m p a r i s o n s
803 807 */
804 808
805 809 case ficlInstruction0Equals:
806 810 CHECK_STACK(1, 1);
807 811 dataTop->i = FICL_BOOL(dataTop->i == 0);
808 812 continue;
809 813
810 814 case ficlInstruction0Less:
811 815 CHECK_STACK(1, 1);
812 816 dataTop->i = FICL_BOOL(dataTop->i < 0);
813 817 continue;
814 818
815 819 case ficlInstruction0Greater:
816 820 CHECK_STACK(1, 1);
817 821 dataTop->i = FICL_BOOL(dataTop->i > 0);
818 822 continue;
819 823
820 824 case ficlInstructionEquals:
821 825 CHECK_STACK(2, 1);
822 826 i = (dataTop--)->i;
823 827 dataTop->i = FICL_BOOL(dataTop->i == i);
824 828 continue;
825 829
826 830 case ficlInstructionLess:
827 831 CHECK_STACK(2, 1);
828 832 i = (dataTop--)->i;
829 833 dataTop->i = FICL_BOOL(dataTop->i < i);
830 834 continue;
831 835
832 836 case ficlInstructionULess:
833 837 CHECK_STACK(2, 1);
834 838 u = (dataTop--)->u;
835 839 dataTop->i = FICL_BOOL(dataTop->u < u);
836 840 continue;
837 841
838 842 case ficlInstructionAnd:
839 843 CHECK_STACK(2, 1);
840 844 i = (dataTop--)->i;
841 845 dataTop->i = dataTop->i & i;
842 846 continue;
843 847
844 848 case ficlInstructionOr:
845 849 CHECK_STACK(2, 1);
846 850 i = (dataTop--)->i;
847 851 dataTop->i = dataTop->i | i;
848 852 continue;
849 853
850 854 case ficlInstructionXor:
851 855 CHECK_STACK(2, 1);
852 856 i = (dataTop--)->i;
853 857 dataTop->i = dataTop->i ^ i;
854 858 continue;
855 859
856 860 case ficlInstructionInvert:
857 861 CHECK_STACK(1, 1);
858 862 dataTop->i = ~dataTop->i;
859 863 continue;
860 864
861 865 /*
862 866 * r e t u r n s t a c k
863 867 */
864 868 case ficlInstructionToRStack:
865 869 CHECK_STACK(1, 0);
866 870 CHECK_RETURN_STACK(0, 1);
867 871 *++returnTop = *dataTop--;
868 872 continue;
869 873
870 874 case ficlInstructionFromRStack:
871 875 CHECK_STACK(0, 1);
872 876 CHECK_RETURN_STACK(1, 0);
873 877 *++dataTop = *returnTop--;
874 878 continue;
875 879
876 880 case ficlInstructionFetchRStack:
877 881 CHECK_STACK(0, 1);
878 882 CHECK_RETURN_STACK(1, 1);
879 883 *++dataTop = *returnTop;
880 884 continue;
881 885
882 886 case ficlInstruction2ToR:
883 887 CHECK_STACK(2, 0);
884 888 CHECK_RETURN_STACK(0, 2);
885 889 *++returnTop = dataTop[-1];
886 890 *++returnTop = dataTop[0];
887 891 dataTop -= 2;
888 892 continue;
889 893
890 894 case ficlInstruction2RFrom:
891 895 CHECK_STACK(0, 2);
892 896 CHECK_RETURN_STACK(2, 0);
893 897 *++dataTop = returnTop[-1];
894 898 *++dataTop = returnTop[0];
895 899 returnTop -= 2;
896 900 continue;
897 901
898 902 case ficlInstruction2RFetch:
899 903 CHECK_STACK(0, 2);
900 904 CHECK_RETURN_STACK(2, 2);
901 905 *++dataTop = returnTop[-1];
902 906 *++dataTop = returnTop[0];
903 907 continue;
904 908
905 909 /*
906 910 * f i l l
907 911 * CORE ( c-addr u char -- )
908 912 * If u is greater than zero, store char in each of u
909 913 * consecutive characters of memory beginning at c-addr.
910 914 */
911 915 case ficlInstructionFill: {
912 916 char c;
913 917 char *memory;
914 918 CHECK_STACK(3, 0);
915 919 c = (char)(dataTop--)->i;
916 920 u = (dataTop--)->u;
917 921 memory = (char *)(dataTop--)->p;
918 922
919 923 /*
920 924 * memset() is faster than the previous hand-rolled
921 925 * solution. --lch
922 926 */
923 927 memset(memory, c, u);
924 928 continue;
925 929 }
926 930
927 931 /*
928 932 * l s h i f t
929 933 * l-shift CORE ( x1 u -- x2 )
930 934 * Perform a logical left shift of u bit-places on x1,
931 935 * giving x2. Put zeroes into the least significant bits
932 936 * vacated by the shift. An ambiguous condition exists if
933 937 * u is greater than or equal to the number of bits in a
934 938 * ficlCell.
935 939 *
936 940 * r-shift CORE ( x1 u -- x2 )
937 941 * Perform a logical right shift of u bit-places on x1,
938 942 * giving x2. Put zeroes into the most significant bits
939 943 * vacated by the shift. An ambiguous condition exists
940 944 * if u is greater than or equal to the number of bits
941 945 * in a ficlCell.
942 946 */
943 947 case ficlInstructionLShift: {
944 948 ficlUnsigned nBits;
945 949 ficlUnsigned x1;
946 950 CHECK_STACK(2, 1);
947 951
948 952 nBits = (dataTop--)->u;
949 953 x1 = dataTop->u;
950 954 dataTop->u = x1 << nBits;
951 955 continue;
952 956 }
953 957
954 958 case ficlInstructionRShift: {
955 959 ficlUnsigned nBits;
956 960 ficlUnsigned x1;
957 961 CHECK_STACK(2, 1);
958 962
959 963 nBits = (dataTop--)->u;
960 964 x1 = dataTop->u;
961 965 dataTop->u = x1 >> nBits;
962 966 continue;
963 967 }
964 968
965 969 /*
966 970 * m a x & m i n
967 971 */
968 972 case ficlInstructionMax: {
969 973 ficlInteger n2;
970 974 ficlInteger n1;
971 975 CHECK_STACK(2, 1);
972 976
973 977 n2 = (dataTop--)->i;
974 978 n1 = dataTop->i;
975 979
976 980 dataTop->i = ((n1 > n2) ? n1 : n2);
977 981 continue;
978 982 }
979 983
980 984 case ficlInstructionMin: {
981 985 ficlInteger n2;
982 986 ficlInteger n1;
983 987 CHECK_STACK(2, 1);
984 988
985 989 n2 = (dataTop--)->i;
986 990 n1 = dataTop->i;
987 991
988 992 dataTop->i = ((n1 < n2) ? n1 : n2);
989 993 continue;
990 994 }
991 995
992 996 /*
993 997 * m o v e
994 998 * CORE ( addr1 addr2 u -- )
995 999 * If u is greater than zero, copy the contents of u
996 1000 * consecutive address units at addr1 to the u consecutive
997 1001 * address units at addr2. After MOVE completes, the u
998 1002 * consecutive address units at addr2 contain exactly
999 1003 * what the u consecutive address units at addr1 contained
1000 1004 * before the move.
1001 1005 * NOTE! This implementation assumes that a char is the same
1002 1006 * size as an address unit.
1003 1007 */
1004 1008 case ficlInstructionMove: {
1005 1009 ficlUnsigned u;
1006 1010 char *addr2;
1007 1011 char *addr1;
1008 1012 CHECK_STACK(3, 0);
1009 1013
1010 1014 u = (dataTop--)->u;
1011 1015 addr2 = (dataTop--)->p;
1012 1016 addr1 = (dataTop--)->p;
1013 1017
1014 1018 if (u == 0)
1015 1019 continue;
1016 1020 /*
1017 1021 * Do the copy carefully, so as to be
1018 1022 * correct even if the two ranges overlap
1019 1023 */
1020 1024 /* Which ANSI C's memmove() does for you! Yay! --lch */
1021 1025 memmove(addr2, addr1, u);
1022 1026 continue;
1023 1027 }
1024 1028
1025 1029 /*
1026 1030 * s t o d
1027 1031 * s-to-d CORE ( n -- d )
1028 1032 * Convert the number n to the double-ficlCell number d with
1029 1033 * the same numerical value.
1030 1034 */
1031 1035 case ficlInstructionSToD: {
1032 1036 ficlInteger s;
1033 1037 CHECK_STACK(1, 2);
1034 1038
1035 1039 s = dataTop->i;
1036 1040
1037 1041 /* sign extend to 64 bits.. */
1038 1042 (++dataTop)->i = (s < 0) ? -1 : 0;
1039 1043 continue;
1040 1044 }
1041 1045
1042 1046 /*
1043 1047 * c o m p a r e
1044 1048 * STRING ( c-addr1 u1 c-addr2 u2 -- n )
1045 1049 * Compare the string specified by c-addr1 u1 to the string
1046 1050 * specified by c-addr2 u2. The strings are compared, beginning
1047 1051 * at the given addresses, character by character, up to the
1048 1052 * length of the shorter string or until a difference is found.
1049 1053 * If the two strings are identical, n is zero. If the two
1050 1054 * strings are identical up to the length of the shorter string,
1051 1055 * n is minus-one (-1) if u1 is less than u2 and one (1)
1052 1056 * otherwise. If the two strings are not identical up to the
1053 1057 * length of the shorter string, n is minus-one (-1) if the
1054 1058 * first non-matching character in the string specified by
1055 1059 * c-addr1 u1 has a lesser numeric value than the corresponding
1056 1060 * character in the string specified by c-addr2 u2 and
1057 1061 * one (1) otherwise.
1058 1062 */
1059 1063 case ficlInstructionCompare:
1060 1064 i = FICL_FALSE;
1061 1065 goto COMPARE;
1062 1066
1063 1067
1064 1068 case ficlInstructionCompareInsensitive:
1065 1069 i = FICL_TRUE;
1066 1070 goto COMPARE;
1067 1071
1068 1072 COMPARE:
1069 1073 {
1070 1074 char *cp1, *cp2;
1071 1075 ficlUnsigned u1, u2, uMin;
1072 1076 int n = 0;
1073 1077
1074 1078 CHECK_STACK(4, 1);
1075 1079 u2 = (dataTop--)->u;
1076 1080 cp2 = (char *)(dataTop--)->p;
1077 1081 u1 = (dataTop--)->u;
1078 1082 cp1 = (char *)(dataTop--)->p;
1079 1083
1080 1084 uMin = (u1 < u2)? u1 : u2;
1081 1085 for (; (uMin > 0) && (n == 0); uMin--) {
1082 1086 int c1 = (unsigned char)*cp1++;
1083 1087 int c2 = (unsigned char)*cp2++;
1084 1088
1085 1089 if (i) {
1086 1090 c1 = tolower(c1);
1087 1091 c2 = tolower(c2);
1088 1092 }
1089 1093 n = (c1 - c2);
1090 1094 }
1091 1095
1092 1096 if (n == 0)
1093 1097 n = (int)(u1 - u2);
1094 1098
1095 1099 if (n < 0)
1096 1100 n = -1;
1097 1101 else if (n > 0)
1098 1102 n = 1;
1099 1103
1100 1104 (++dataTop)->i = n;
1101 1105 continue;
1102 1106 }
1103 1107
1104 1108 /*
1105 1109 * r a n d o m
1106 1110 * Ficl-specific
1107 1111 */
1108 1112 case ficlInstructionRandom:
1109 1113 (++dataTop)->i = random();
1110 1114 continue;
1111 1115
1112 1116 /*
1113 1117 * s e e d - r a n d o m
1114 1118 * Ficl-specific
1115 1119 */
1116 1120 case ficlInstructionSeedRandom:
1117 1121 srandom((dataTop--)->i);
1118 1122 continue;
1119 1123
1120 1124 case ficlInstructionGreaterThan: {
1121 1125 ficlInteger x, y;
1122 1126 CHECK_STACK(2, 1);
1123 1127 y = (dataTop--)->i;
1124 1128 x = dataTop->i;
1125 1129 dataTop->i = FICL_BOOL(x > y);
1126 1130 continue;
1127 1131 }
1128 1132
1129 1133 case ficlInstructionUGreaterThan:
1130 1134 CHECK_STACK(2, 1);
1131 1135 u = (dataTop--)->u;
1132 1136 dataTop->i = FICL_BOOL(dataTop->u > u);
1133 1137 continue;
1134 1138
1135 1139 /*
1136 1140 * This function simply pops the previous instruction
1137 1141 * pointer and returns to the "next" loop. Used for exiting
1138 1142 * from within a definition. Note that exitParen is identical
1139 1143 * to semiParen - they are in two different functions so that
1140 1144 * "see" can correctly identify the end of a colon definition,
1141 1145 * even if it uses "exit".
1142 1146 */
1143 1147 case ficlInstructionExitParen:
1144 1148 case ficlInstructionSemiParen:
1145 1149 EXIT_FUNCTION();
1146 1150
1147 1151 /*
1148 1152 * The first time we run "(branch)", perform a "peephole
1149 1153 * optimization" to see if we're jumping to another
1150 1154 * unconditional jump. If so, just jump directly there.
1151 1155 */
1152 1156 case ficlInstructionBranchParenWithCheck:
1153 1157 LOCAL_VARIABLE_SPILL;
1154 1158 ficlVmOptimizeJumpToJump(vm, vm->ip - 1);
1155 1159 LOCAL_VARIABLE_REFILL;
1156 1160 goto BRANCH_PAREN;
1157 1161
1158 1162 /*
1159 1163 * Same deal with branch0.
1160 1164 */
1161 1165 case ficlInstructionBranch0ParenWithCheck:
1162 1166 LOCAL_VARIABLE_SPILL;
1163 1167 ficlVmOptimizeJumpToJump(vm, vm->ip - 1);
1164 1168 LOCAL_VARIABLE_REFILL;
1165 1169 /* intentional fall-through */
1166 1170
1167 1171 /*
1168 1172 * Runtime code for "(branch0)"; pop a flag from the stack,
1169 1173 * branch if 0. fall through otherwise.
1170 1174 * The heart of "if" and "until".
1171 1175 */
1172 1176 case ficlInstructionBranch0Paren:
1173 1177 CHECK_STACK(1, 0);
1174 1178
1175 1179 if ((dataTop--)->i) {
1176 1180 /*
1177 1181 * don't branch, but skip over branch
1178 1182 * relative address
1179 1183 */
1180 1184 ip += 1;
1181 1185 continue;
1182 1186 }
1183 1187 /* otherwise, take branch (to else/endif/begin) */
1184 1188 /* intentional fall-through! */
1185 1189
1186 1190 /*
1187 1191 * Runtime for "(branch)" -- expects a literal offset in the
1188 1192 * next compilation address, and branches to that location.
1189 1193 */
1190 1194 case ficlInstructionBranchParen:
1191 1195 BRANCH_PAREN:
1192 1196 BRANCH();
1193 1197
1194 1198 case ficlInstructionOfParen: {
1195 1199 ficlUnsigned a, b;
1196 1200
1197 1201 CHECK_STACK(2, 1);
1198 1202
1199 1203 a = (dataTop--)->u;
1200 1204 b = dataTop->u;
1201 1205
1202 1206 if (a == b) {
1203 1207 /* fall through */
1204 1208 ip++;
1205 1209 /* remove CASE argument */
1206 1210 dataTop--;
1207 1211 } else {
1208 1212 /* take branch to next of or endcase */
1209 1213 BRANCH();
1210 1214 }
1211 1215
1212 1216 continue;
1213 1217 }
1214 1218
1215 1219 case ficlInstructionDoParen: {
1216 1220 ficlCell index, limit;
1217 1221
1218 1222 CHECK_STACK(2, 0);
1219 1223
1220 1224 index = *dataTop--;
1221 1225 limit = *dataTop--;
1222 1226
1223 1227 /* copy "leave" target addr to stack */
1224 1228 (++returnTop)->i = *(ip++);
1225 1229 *++returnTop = limit;
1226 1230 *++returnTop = index;
1227 1231
1228 1232 continue;
1229 1233 }
1230 1234
1231 1235 case ficlInstructionQDoParen: {
1232 1236 ficlCell index, limit, leave;
1233 1237
1234 1238 CHECK_STACK(2, 0);
1235 1239
1236 1240 index = *dataTop--;
1237 1241 limit = *dataTop--;
1238 1242
1239 1243 leave.i = *ip;
1240 1244
1241 1245 if (limit.u == index.u) {
1242 1246 ip = leave.p;
1243 1247 } else {
1244 1248 ip++;
1245 1249 *++returnTop = leave;
1246 1250 *++returnTop = limit;
1247 1251 *++returnTop = index;
1248 1252 }
1249 1253
1250 1254 continue;
1251 1255 }
1252 1256
1253 1257 case ficlInstructionLoopParen:
1254 1258 case ficlInstructionPlusLoopParen: {
1255 1259 ficlInteger index;
1256 1260 ficlInteger limit;
1257 1261 int direction = 0;
1258 1262
1259 1263 index = returnTop->i;
1260 1264 limit = returnTop[-1].i;
1261 1265
1262 1266 if (instruction == ficlInstructionLoopParen)
1263 1267 index++;
1264 1268 else {
1265 1269 ficlInteger increment;
1266 1270 CHECK_STACK(1, 0);
1267 1271 increment = (dataTop--)->i;
1268 1272 index += increment;
1269 1273 direction = (increment < 0);
1270 1274 }
1271 1275
1272 1276 if (direction ^ (index >= limit)) {
1273 1277 /* nuke the loop indices & "leave" addr */
1274 1278 returnTop -= 3;
1275 1279 ip++; /* fall through the loop */
1276 1280 } else { /* update index, branch to loop head */
1277 1281 returnTop->i = index;
1278 1282 BRANCH();
1279 1283 }
1280 1284
1281 1285 continue;
1282 1286 }
1283 1287
1284 1288
1285 1289 /*
1286 1290 * Runtime code to break out of a do..loop construct
1287 1291 * Drop the loop control variables; the branch address
1288 1292 * past "loop" is next on the return stack.
1289 1293 */
1290 1294 case ficlInstructionLeave:
1291 1295 /* almost unloop */
1292 1296 returnTop -= 2;
1293 1297 /* exit */
1294 1298 EXIT_FUNCTION();
1295 1299
1296 1300 case ficlInstructionUnloop:
1297 1301 returnTop -= 3;
1298 1302 continue;
1299 1303
1300 1304 case ficlInstructionI:
1301 1305 *++dataTop = *returnTop;
1302 1306 continue;
1303 1307
1304 1308 case ficlInstructionJ:
1305 1309 *++dataTop = returnTop[-3];
1306 1310 continue;
1307 1311
1308 1312 case ficlInstructionK:
1309 1313 *++dataTop = returnTop[-6];
1310 1314 continue;
1311 1315
1312 1316 case ficlInstructionDoesParen: {
1313 1317 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
1314 1318 dictionary->smudge->code =
1315 1319 (ficlPrimitive)ficlInstructionDoDoes;
1316 1320 dictionary->smudge->param[0].p = ip;
1317 1321 ip = (ficlInstruction *)((returnTop--)->p);
1318 1322 continue;
1319 1323 }
1320 1324
1321 1325 case ficlInstructionDoDoes: {
1322 1326 ficlCell *cell;
1323 1327 ficlIp tempIP;
1324 1328
1325 1329 CHECK_STACK(0, 1);
1326 1330
1327 1331 cell = fw->param;
1328 1332 tempIP = (ficlIp)((*cell).p);
1329 1333 (++dataTop)->p = (cell + 1);
1330 1334 (++returnTop)->p = (void *)ip;
1331 1335 ip = (ficlInstruction *)tempIP;
1332 1336 continue;
1333 1337 }
1334 1338
1335 1339 #if FICL_WANT_FLOAT
1336 1340 case ficlInstructionF2Fetch:
1337 1341 CHECK_FLOAT_STACK(0, 2);
1338 1342 CHECK_STACK(1, 0);
1339 1343 FLOAT_PUSH_CELL_POINTER_DOUBLE((dataTop--)->p);
1340 1344
1341 1345 case ficlInstructionFFetch:
1342 1346 CHECK_FLOAT_STACK(0, 1);
1343 1347 CHECK_STACK(1, 0);
1344 1348 FLOAT_PUSH_CELL_POINTER((dataTop--)->p);
1345 1349
1346 1350 case ficlInstructionF2Store:
1347 1351 CHECK_FLOAT_STACK(2, 0);
1348 1352 CHECK_STACK(1, 0);
1349 1353 FLOAT_POP_CELL_POINTER_DOUBLE((dataTop--)->p);
1350 1354
1351 1355 case ficlInstructionFStore:
1352 1356 CHECK_FLOAT_STACK(1, 0);
1353 1357 CHECK_STACK(1, 0);
1354 1358 FLOAT_POP_CELL_POINTER((dataTop--)->p);
1355 1359 #endif /* FICL_WANT_FLOAT */
1356 1360
1357 1361 /*
1358 1362 * two-fetch CORE ( a-addr -- x1 x2 )
1359 1363 *
1360 1364 * Fetch the ficlCell pair x1 x2 stored at a-addr.
1361 1365 * x2 is stored at a-addr and x1 at the next consecutive
1362 1366 * ficlCell. It is equivalent to the sequence
1363 1367 * DUP ficlCell+ @ SWAP @ .
1364 1368 */
1365 1369 case ficlInstruction2Fetch:
1366 1370 CHECK_STACK(1, 2);
1367 1371 PUSH_CELL_POINTER_DOUBLE((dataTop--)->p);
1368 1372
1369 1373 /*
1370 1374 * fetch CORE ( a-addr -- x )
1371 1375 *
1372 1376 * x is the value stored at a-addr.
1373 1377 */
1374 1378 case ficlInstructionFetch:
1375 1379 CHECK_STACK(1, 1);
1376 1380 PUSH_CELL_POINTER((dataTop--)->p);
1377 1381
1378 1382 /*
1379 1383 * two-store CORE ( x1 x2 a-addr -- )
1380 1384 * Store the ficlCell pair x1 x2 at a-addr, with x2 at a-addr
1381 1385 * and x1 at the next consecutive ficlCell. It is equivalent
1382 1386 * to the sequence SWAP OVER ! ficlCell+ !
1383 1387 */
1384 1388 case ficlInstruction2Store:
1385 1389 CHECK_STACK(3, 0);
1386 1390 POP_CELL_POINTER_DOUBLE((dataTop--)->p);
1387 1391
1388 1392 /*
1389 1393 * store CORE ( x a-addr -- )
1390 1394 * Store x at a-addr.
1391 1395 */
1392 1396 case ficlInstructionStore:
1393 1397 CHECK_STACK(2, 0);
1394 1398 POP_CELL_POINTER((dataTop--)->p);
1395 1399
1396 1400 case ficlInstructionComma: {
1397 1401 ficlDictionary *dictionary;
1398 1402 CHECK_STACK(1, 0);
1399 1403
1400 1404 dictionary = ficlVmGetDictionary(vm);
1401 1405 ficlDictionaryAppendCell(dictionary, *dataTop--);
1402 1406 continue;
1403 1407 }
1404 1408
1405 1409 case ficlInstructionCComma: {
1406 1410 ficlDictionary *dictionary;
1407 1411 char c;
1408 1412 CHECK_STACK(1, 0);
1409 1413
1410 1414 dictionary = ficlVmGetDictionary(vm);
1411 1415 c = (char)(dataTop--)->i;
1412 1416 ficlDictionaryAppendCharacter(dictionary, c);
1413 1417 continue;
1414 1418 }
1415 1419
1416 1420 case ficlInstructionCells:
1417 1421 CHECK_STACK(1, 1);
1418 1422 dataTop->i *= sizeof (ficlCell);
1419 1423 continue;
1420 1424
1421 1425 case ficlInstructionCellPlus:
1422 1426 CHECK_STACK(1, 1);
1423 1427 dataTop->i += sizeof (ficlCell);
1424 1428 continue;
1425 1429
1426 1430 case ficlInstructionStar:
1427 1431 CHECK_STACK(2, 1);
1428 1432 i = (dataTop--)->i;
1429 1433 dataTop->i *= i;
1430 1434 continue;
1431 1435
1432 1436 case ficlInstructionNegate:
1433 1437 CHECK_STACK(1, 1);
1434 1438 dataTop->i = - dataTop->i;
1435 1439 continue;
1436 1440
1437 1441 case ficlInstructionSlash:
1438 1442 CHECK_STACK(2, 1);
1439 1443 i = (dataTop--)->i;
1440 1444 dataTop->i /= i;
1441 1445 continue;
1442 1446
1443 1447 /*
1444 1448 * slash-mod CORE ( n1 n2 -- n3 n4 )
1445 1449 * Divide n1 by n2, giving the single-ficlCell remainder n3
1446 1450 * and the single-ficlCell quotient n4. An ambiguous condition
1447 1451 * exists if n2 is zero. If n1 and n2 differ in sign, the
1448 1452 * implementation-defined result returned will be the
1449 1453 * same as that returned by either the phrase
1450 1454 * >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM.
1451 1455 * NOTE: Ficl complies with the second phrase
1452 1456 * (symmetric division)
1453 1457 */
1454 1458 case ficlInstructionSlashMod: {
1455 1459 ficl2Integer n1;
1456 1460 ficlInteger n2;
1457 1461 ficl2IntegerQR qr;
1458 1462
1459 1463 CHECK_STACK(2, 2);
1460 1464 n2 = dataTop[0].i;
1461 1465 FICL_INTEGER_TO_2INTEGER(dataTop[-1].i, n1);
1462 1466
1463 1467 qr = ficl2IntegerDivideSymmetric(n1, n2);
1464 1468 dataTop[-1].i = qr.remainder;
1465 1469 dataTop[0].i = FICL_2UNSIGNED_GET_LOW(qr.quotient);
1466 1470 continue;
1467 1471 }
1468 1472
1469 1473 case ficlInstruction2Star:
1470 1474 CHECK_STACK(1, 1);
1471 1475 dataTop->i <<= 1;
1472 1476 continue;
1473 1477
1474 1478 case ficlInstruction2Slash:
1475 1479 CHECK_STACK(1, 1);
1476 1480 dataTop->i >>= 1;
1477 1481 continue;
1478 1482
1479 1483 case ficlInstructionStarSlash: {
1480 1484 ficlInteger x, y, z;
1481 1485 ficl2Integer prod;
1482 1486 CHECK_STACK(3, 1);
1483 1487
1484 1488 z = (dataTop--)->i;
1485 1489 y = (dataTop--)->i;
1486 1490 x = dataTop->i;
1487 1491
1488 1492 prod = ficl2IntegerMultiply(x, y);
1489 1493 dataTop->i = FICL_2UNSIGNED_GET_LOW(
1490 1494 ficl2IntegerDivideSymmetric(prod, z).quotient);
1491 1495 continue;
1492 1496 }
1493 1497
1494 1498 case ficlInstructionStarSlashMod: {
1495 1499 ficlInteger x, y, z;
1496 1500 ficl2Integer prod;
1497 1501 ficl2IntegerQR qr;
1498 1502
1499 1503 CHECK_STACK(3, 2);
1500 1504
1501 1505 z = (dataTop--)->i;
1502 1506 y = dataTop[0].i;
1503 1507 x = dataTop[-1].i;
1504 1508
1505 1509 prod = ficl2IntegerMultiply(x, y);
1506 1510 qr = ficl2IntegerDivideSymmetric(prod, z);
1507 1511
1508 1512 dataTop[-1].i = qr.remainder;
1509 1513 dataTop[0].i = FICL_2UNSIGNED_GET_LOW(qr.quotient);
1510 1514 continue;
1511 1515 }
1512 1516
1513 1517 #if FICL_WANT_FLOAT
1514 1518 case ficlInstructionF0:
1515 1519 CHECK_FLOAT_STACK(0, 1);
1516 1520 (++floatTop)->f = 0.0f;
1517 1521 continue;
1518 1522
1519 1523 case ficlInstructionF1:
1520 1524 CHECK_FLOAT_STACK(0, 1);
1521 1525 (++floatTop)->f = 1.0f;
1522 1526 continue;
1523 1527
1524 1528 case ficlInstructionFNeg1:
1525 1529 CHECK_FLOAT_STACK(0, 1);
1526 1530 (++floatTop)->f = -1.0f;
1527 1531 continue;
1528 1532
1529 1533 /*
1530 1534 * Floating point literal execution word.
1531 1535 */
1532 1536 case ficlInstructionFLiteralParen:
1533 1537 CHECK_FLOAT_STACK(0, 1);
1534 1538
1535 1539 /*
1536 1540 * Yes, I'm using ->i here,
1537 1541 * but it's really a float. --lch
1538 1542 */
1539 1543 (++floatTop)->i = *ip++;
1540 1544 continue;
1541 1545
1542 1546 /*
1543 1547 * Do float addition r1 + r2.
1544 1548 * f+ ( r1 r2 -- r )
1545 1549 */
1546 1550 case ficlInstructionFPlus:
1547 1551 CHECK_FLOAT_STACK(2, 1);
1548 1552
1549 1553 f = (floatTop--)->f;
1550 1554 floatTop->f += f;
1551 1555 continue;
1552 1556
1553 1557 /*
1554 1558 * Do float subtraction r1 - r2.
1555 1559 * f- ( r1 r2 -- r )
1556 1560 */
1557 1561 case ficlInstructionFMinus:
1558 1562 CHECK_FLOAT_STACK(2, 1);
1559 1563
1560 1564 f = (floatTop--)->f;
1561 1565 floatTop->f -= f;
1562 1566 continue;
1563 1567
1564 1568 /*
1565 1569 * Do float multiplication r1 * r2.
1566 1570 * f* ( r1 r2 -- r )
1567 1571 */
1568 1572 case ficlInstructionFStar:
1569 1573 CHECK_FLOAT_STACK(2, 1);
1570 1574
1571 1575 f = (floatTop--)->f;
1572 1576 floatTop->f *= f;
1573 1577 continue;
1574 1578
1575 1579 /*
1576 1580 * Do float negation.
1577 1581 * fnegate ( r -- r )
1578 1582 */
1579 1583 case ficlInstructionFNegate:
1580 1584 CHECK_FLOAT_STACK(1, 1);
1581 1585
1582 1586 floatTop->f = -(floatTop->f);
1583 1587 continue;
1584 1588
1585 1589 /*
1586 1590 * Do float division r1 / r2.
1587 1591 * f/ ( r1 r2 -- r )
1588 1592 */
1589 1593 case ficlInstructionFSlash:
1590 1594 CHECK_FLOAT_STACK(2, 1);
1591 1595
1592 1596 f = (floatTop--)->f;
1593 1597 floatTop->f /= f;
1594 1598 continue;
1595 1599
1596 1600 /*
1597 1601 * Do float + integer r + n.
1598 1602 * f+i ( r n -- r )
1599 1603 */
1600 1604 case ficlInstructionFPlusI:
1601 1605 CHECK_FLOAT_STACK(1, 1);
1602 1606 CHECK_STACK(1, 0);
1603 1607
1604 1608 f = (ficlFloat)(dataTop--)->f;
1605 1609 floatTop->f += f;
1606 1610 continue;
1607 1611
1608 1612 /*
1609 1613 * Do float - integer r - n.
1610 1614 * f-i ( r n -- r )
1611 1615 */
1612 1616 case ficlInstructionFMinusI:
1613 1617 CHECK_FLOAT_STACK(1, 1);
1614 1618 CHECK_STACK(1, 0);
1615 1619
1616 1620 f = (ficlFloat)(dataTop--)->f;
1617 1621 floatTop->f -= f;
1618 1622 continue;
1619 1623
1620 1624 /*
1621 1625 * Do float * integer r * n.
1622 1626 * f*i ( r n -- r )
1623 1627 */
1624 1628 case ficlInstructionFStarI:
1625 1629 CHECK_FLOAT_STACK(1, 1);
1626 1630 CHECK_STACK(1, 0);
1627 1631
1628 1632 f = (ficlFloat)(dataTop--)->f;
1629 1633 floatTop->f *= f;
1630 1634 continue;
1631 1635
1632 1636 /*
1633 1637 * Do float / integer r / n.
1634 1638 * f/i ( r n -- r )
1635 1639 */
1636 1640 case ficlInstructionFSlashI:
1637 1641 CHECK_FLOAT_STACK(1, 1);
1638 1642 CHECK_STACK(1, 0);
1639 1643
1640 1644 f = (ficlFloat)(dataTop--)->f;
1641 1645 floatTop->f /= f;
1642 1646 continue;
1643 1647
1644 1648 /*
1645 1649 * Do integer - float n - r.
1646 1650 * i-f ( n r -- r )
1647 1651 */
1648 1652 case ficlInstructionIMinusF:
1649 1653 CHECK_FLOAT_STACK(1, 1);
1650 1654 CHECK_STACK(1, 0);
1651 1655
1652 1656 f = (ficlFloat)(dataTop--)->f;
1653 1657 floatTop->f = f - floatTop->f;
1654 1658 continue;
1655 1659
1656 1660 /*
1657 1661 * Do integer / float n / r.
1658 1662 * i/f ( n r -- r )
1659 1663 */
1660 1664 case ficlInstructionISlashF:
1661 1665 CHECK_FLOAT_STACK(1, 1);
1662 1666 CHECK_STACK(1, 0);
1663 1667
1664 1668 f = (ficlFloat)(dataTop--)->f;
1665 1669 floatTop->f = f / floatTop->f;
1666 1670 continue;
1667 1671
1668 1672 /*
1669 1673 * Do integer to float conversion.
1670 1674 * int>float ( n -- r )
1671 1675 */
1672 1676 case ficlInstructionIntToFloat:
1673 1677 CHECK_STACK(1, 0);
1674 1678 CHECK_FLOAT_STACK(0, 1);
1675 1679
1676 1680 (++floatTop)->f = ((dataTop--)->f);
1677 1681 continue;
1678 1682
1679 1683 /*
1680 1684 * Do float to integer conversion.
1681 1685 * float>int ( r -- n )
1682 1686 */
1683 1687 case ficlInstructionFloatToInt:
1684 1688 CHECK_STACK(0, 1);
1685 1689 CHECK_FLOAT_STACK(1, 0);
1686 1690
1687 1691 (++dataTop)->i = ((floatTop--)->i);
1688 1692 continue;
1689 1693
1690 1694 /*
1691 1695 * Add a floating point number to contents of a variable.
1692 1696 * f+! ( r n -- )
1693 1697 */
1694 1698 case ficlInstructionFPlusStore: {
1695 1699 ficlCell *cell;
1696 1700
1697 1701 CHECK_STACK(1, 0);
1698 1702 CHECK_FLOAT_STACK(1, 0);
1699 1703
1700 1704 cell = (ficlCell *)(dataTop--)->p;
1701 1705 cell->f += (floatTop--)->f;
1702 1706 continue;
1703 1707 }
1704 1708
1705 1709 /*
1706 1710 * Do float stack drop.
1707 1711 * fdrop ( r -- )
1708 1712 */
1709 1713 case ficlInstructionFDrop:
1710 1714 CHECK_FLOAT_STACK(1, 0);
1711 1715 floatTop--;
1712 1716 continue;
1713 1717
1714 1718 /*
1715 1719 * Do float stack ?dup.
1716 1720 * f?dup ( r -- r )
1717 1721 */
1718 1722 case ficlInstructionFQuestionDup:
1719 1723 CHECK_FLOAT_STACK(1, 2);
1720 1724
1721 1725 if (floatTop->f != 0)
1722 1726 goto FDUP;
1723 1727
1724 1728 continue;
1725 1729
1726 1730 /*
1727 1731 * Do float stack dup.
1728 1732 * fdup ( r -- r r )
1729 1733 */
1730 1734 case ficlInstructionFDup:
1731 1735 CHECK_FLOAT_STACK(1, 2);
1732 1736
1733 1737 FDUP:
1734 1738 floatTop[1] = floatTop[0];
1735 1739 floatTop++;
1736 1740 continue;
1737 1741
1738 1742 /*
1739 1743 * Do float stack swap.
1740 1744 * fswap ( r1 r2 -- r2 r1 )
1741 1745 */
1742 1746 case ficlInstructionFSwap:
1743 1747 CHECK_FLOAT_STACK(2, 2);
1744 1748
1745 1749 c = floatTop[0];
1746 1750 floatTop[0] = floatTop[-1];
1747 1751 floatTop[-1] = c;
1748 1752 continue;
1749 1753
1750 1754 /*
1751 1755 * Do float stack 2drop.
1752 1756 * f2drop ( r r -- )
1753 1757 */
1754 1758 case ficlInstructionF2Drop:
1755 1759 CHECK_FLOAT_STACK(2, 0);
1756 1760
1757 1761 floatTop -= 2;
1758 1762 continue;
1759 1763
1760 1764 /*
1761 1765 * Do float stack 2dup.
1762 1766 * f2dup ( r1 r2 -- r1 r2 r1 r2 )
1763 1767 */
1764 1768 case ficlInstructionF2Dup:
1765 1769 CHECK_FLOAT_STACK(2, 4);
1766 1770
1767 1771 floatTop[1] = floatTop[-1];
1768 1772 floatTop[2] = *floatTop;
1769 1773 floatTop += 2;
1770 1774 continue;
1771 1775
1772 1776 /*
1773 1777 * Do float stack over.
1774 1778 * fover ( r1 r2 -- r1 r2 r1 )
1775 1779 */
1776 1780 case ficlInstructionFOver:
1777 1781 CHECK_FLOAT_STACK(2, 3);
1778 1782
1779 1783 floatTop[1] = floatTop[-1];
1780 1784 floatTop++;
1781 1785 continue;
1782 1786
1783 1787 /*
1784 1788 * Do float stack 2over.
1785 1789 * f2over ( r1 r2 r3 -- r1 r2 r3 r1 r2 )
1786 1790 */
1787 1791 case ficlInstructionF2Over:
1788 1792 CHECK_FLOAT_STACK(4, 6);
1789 1793
1790 1794 floatTop[1] = floatTop[-2];
1791 1795 floatTop[2] = floatTop[-1];
1792 1796 floatTop += 2;
1793 1797 continue;
1794 1798
1795 1799 /*
1796 1800 * Do float stack pick.
1797 1801 * fpick ( n -- r )
1798 1802 */
1799 1803 case ficlInstructionFPick:
1800 1804 CHECK_STACK(1, 0);
1801 1805 c = *dataTop--;
1802 1806 CHECK_FLOAT_STACK(c.i+2, c.i+3);
1803 1807
1804 1808 floatTop[1] = floatTop[- c.i - 1];
1805 1809 continue;
1806 1810
1807 1811 /*
1808 1812 * Do float stack rot.
1809 1813 * frot ( r1 r2 r3 -- r2 r3 r1 )
1810 1814 */
1811 1815 case ficlInstructionFRot:
1812 1816 i = 2;
1813 1817 goto FROLL;
1814 1818
1815 1819 /*
1816 1820 * Do float stack roll.
1817 1821 * froll ( n -- )
1818 1822 */
1819 1823 case ficlInstructionFRoll:
1820 1824 CHECK_STACK(1, 0);
1821 1825 i = (dataTop--)->i;
1822 1826
1823 1827 if (i < 1)
1824 1828 continue;
1825 1829
1826 1830 FROLL:
1827 1831 CHECK_FLOAT_STACK(i+1, i+2);
1828 1832 c = floatTop[-i];
1829 1833 memmove(floatTop - i, floatTop - (i - 1),
1830 1834 i * sizeof (ficlCell));
1831 1835 *floatTop = c;
1832 1836
1833 1837 continue;
1834 1838
1835 1839 /*
1836 1840 * Do float stack -rot.
1837 1841 * f-rot ( r1 r2 r3 -- r3 r1 r2 )
1838 1842 */
1839 1843 case ficlInstructionFMinusRot:
1840 1844 i = 2;
1841 1845 goto FMINUSROLL;
1842 1846
1843 1847
1844 1848 /*
1845 1849 * Do float stack -roll.
1846 1850 * f-roll ( n -- )
1847 1851 */
1848 1852 case ficlInstructionFMinusRoll:
1849 1853 CHECK_STACK(1, 0);
1850 1854 i = (dataTop--)->i;
1851 1855
1852 1856 if (i < 1)
1853 1857 continue;
1854 1858
1855 1859 FMINUSROLL:
1856 1860 CHECK_FLOAT_STACK(i+1, i+2);
1857 1861 c = *floatTop;
1858 1862 memmove(floatTop - (i - 1), floatTop - i,
1859 1863 i * sizeof (ficlCell));
1860 1864 floatTop[-i] = c;
1861 1865
1862 1866 continue;
1863 1867
1864 1868 /*
1865 1869 * Do float stack 2swap
1866 1870 * f2swap ( r1 r2 r3 r4 -- r3 r4 r1 r2 )
1867 1871 */
1868 1872 case ficlInstructionF2Swap: {
1869 1873 ficlCell c2;
1870 1874 CHECK_FLOAT_STACK(4, 4);
1871 1875
1872 1876 c = *floatTop;
1873 1877 c2 = floatTop[-1];
1874 1878
1875 1879 *floatTop = floatTop[-2];
1876 1880 floatTop[-1] = floatTop[-3];
1877 1881
1878 1882 floatTop[-2] = c;
1879 1883 floatTop[-3] = c2;
1880 1884 continue;
1881 1885 }
1882 1886
1883 1887 /*
1884 1888 * Do float 0= comparison r = 0.0.
1885 1889 * f0= ( r -- T/F )
1886 1890 */
1887 1891 case ficlInstructionF0Equals:
1888 1892 CHECK_FLOAT_STACK(1, 0);
1889 1893 CHECK_STACK(0, 1);
1890 1894
1891 1895 (++dataTop)->i = FICL_BOOL((floatTop--)->f != 0.0f);
1892 1896 continue;
1893 1897
1894 1898 /*
1895 1899 * Do float 0< comparison r < 0.0.
1896 1900 * f0< ( r -- T/F )
1897 1901 */
1898 1902 case ficlInstructionF0Less:
1899 1903 CHECK_FLOAT_STACK(1, 0);
1900 1904 CHECK_STACK(0, 1);
1901 1905
1902 1906 (++dataTop)->i = FICL_BOOL((floatTop--)->f < 0.0f);
1903 1907 continue;
1904 1908
1905 1909 /*
1906 1910 * Do float 0> comparison r > 0.0.
1907 1911 * f0> ( r -- T/F )
1908 1912 */
1909 1913 case ficlInstructionF0Greater:
1910 1914 CHECK_FLOAT_STACK(1, 0);
1911 1915 CHECK_STACK(0, 1);
1912 1916
1913 1917 (++dataTop)->i = FICL_BOOL((floatTop--)->f > 0.0f);
1914 1918 continue;
1915 1919
1916 1920 /*
1917 1921 * Do float = comparison r1 = r2.
1918 1922 * f= ( r1 r2 -- T/F )
1919 1923 */
1920 1924 case ficlInstructionFEquals:
1921 1925 CHECK_FLOAT_STACK(2, 0);
1922 1926 CHECK_STACK(0, 1);
1923 1927
1924 1928 f = (floatTop--)->f;
1925 1929 (++dataTop)->i = FICL_BOOL((floatTop--)->f == f);
1926 1930 continue;
1927 1931
1928 1932 /*
1929 1933 * Do float < comparison r1 < r2.
1930 1934 * f< ( r1 r2 -- T/F )
1931 1935 */
1932 1936 case ficlInstructionFLess:
1933 1937 CHECK_FLOAT_STACK(2, 0);
1934 1938 CHECK_STACK(0, 1);
1935 1939
1936 1940 f = (floatTop--)->f;
1937 1941 (++dataTop)->i = FICL_BOOL((floatTop--)->f < f);
1938 1942 continue;
1939 1943
1940 1944 /*
1941 1945 * Do float > comparison r1 > r2.
1942 1946 * f> ( r1 r2 -- T/F )
1943 1947 */
1944 1948 case ficlInstructionFGreater:
1945 1949 CHECK_FLOAT_STACK(2, 0);
1946 1950 CHECK_STACK(0, 1);
1947 1951
1948 1952 f = (floatTop--)->f;
1949 1953 (++dataTop)->i = FICL_BOOL((floatTop--)->f > f);
1950 1954 continue;
1951 1955
1952 1956
1953 1957 /*
1954 1958 * Move float to param stack (assumes they both fit in a
1955 1959 * single ficlCell) f>s
1956 1960 */
1957 1961 case ficlInstructionFFrom:
1958 1962 CHECK_FLOAT_STACK(1, 0);
1959 1963 CHECK_STACK(0, 1);
1960 1964
1961 1965 *++dataTop = *floatTop--;
1962 1966 continue;
1963 1967
1964 1968 case ficlInstructionToF:
1965 1969 CHECK_FLOAT_STACK(0, 1);
1966 1970 CHECK_STACK(1, 0);
1967 1971
1968 1972 *++floatTop = *dataTop--;
1969 1973 continue;
1970 1974
1971 1975 #endif /* FICL_WANT_FLOAT */
1972 1976
1973 1977 /*
1974 1978 * c o l o n P a r e n
1975 1979 * This is the code that executes a colon definition. It
1976 1980 * assumes that the virtual machine is running a "next" loop
1977 1981 * (See the vm.c for its implementation of member function
1978 1982 * vmExecute()). The colon code simply copies the address of
1979 1983 * the first word in the list of words to interpret into IP
1980 1984 * after saving its old value. When we return to the "next"
1981 1985 * loop, the virtual machine will call the code for each
1982 1986 * word in turn.
1983 1987 */
1984 1988 case ficlInstructionColonParen:
1985 1989 (++returnTop)->p = (void *)ip;
1986 1990 ip = (ficlInstruction *)(fw->param);
1987 1991 continue;
1988 1992
1989 1993 case ficlInstructionCreateParen:
1990 1994 CHECK_STACK(0, 1);
1991 1995 (++dataTop)->p = (fw->param + 1);
1992 1996 continue;
1993 1997
1994 1998 case ficlInstructionVariableParen:
1995 1999 CHECK_STACK(0, 1);
1996 2000 (++dataTop)->p = fw->param;
1997 2001 continue;
1998 2002
1999 2003 /*
2000 2004 * c o n s t a n t P a r e n
2001 2005 * This is the run-time code for "constant". It simply returns
2002 2006 * the contents of its word's first data ficlCell.
2003 2007 */
2004 2008
2005 2009 #if FICL_WANT_FLOAT
2006 2010 case ficlInstructionF2ConstantParen:
2007 2011 CHECK_FLOAT_STACK(0, 2);
2008 2012 FLOAT_PUSH_CELL_POINTER_DOUBLE(fw->param);
2009 2013
2010 2014 case ficlInstructionFConstantParen:
2011 2015 CHECK_FLOAT_STACK(0, 1);
2012 2016 FLOAT_PUSH_CELL_POINTER(fw->param);
2013 2017 #endif /* FICL_WANT_FLOAT */
2014 2018
2015 2019 case ficlInstruction2ConstantParen:
2016 2020 CHECK_STACK(0, 2);
2017 2021 PUSH_CELL_POINTER_DOUBLE(fw->param);
2018 2022
2019 2023 case ficlInstructionConstantParen:
2020 2024 CHECK_STACK(0, 1);
2021 2025 PUSH_CELL_POINTER(fw->param);
2022 2026
2023 2027 #if FICL_WANT_USER
2024 2028 case ficlInstructionUserParen: {
2025 2029 ficlInteger i = fw->param[0].i;
2026 2030 (++dataTop)->p = &vm->user[i];
2027 2031 continue;
2028 2032 }
2029 2033 #endif
2030 2034
2031 2035 default:
2032 2036 /*
2033 2037 * Clever hack, or evil coding? You be the judge.
2034 2038 *
2035 2039 * If the word we've been asked to execute is in fact
2036 2040 * an *instruction*, we grab the instruction, stow it
2037 2041 * in "i" (our local cache of *ip), and *jump* to the
2038 2042 * top of the switch statement. --lch
2039 2043 */
2040 2044 if (((ficlInstruction)fw->code >
2041 2045 ficlInstructionInvalid) &&
2042 2046 ((ficlInstruction)fw->code < ficlInstructionLast)) {
2043 2047 instruction = (ficlInstruction)fw->code;
2044 2048 goto AGAIN;
2045 2049 }
2046 2050
2047 2051 LOCAL_VARIABLE_SPILL;
2048 2052 (vm)->runningWord = fw;
2049 2053 fw->code(vm);
2050 2054 LOCAL_VARIABLE_REFILL;
2051 2055 continue;
2052 2056 }
2053 2057 }
2054 2058
2055 2059 LOCAL_VARIABLE_SPILL;
2056 2060 vm->exceptionHandler = oldExceptionHandler;
2057 2061 }
2058 2062
2059 2063 /*
2060 2064 * v m G e t D i c t
2061 2065 * Returns the address dictionary for this VM's system
2062 2066 */
2063 2067 ficlDictionary *
2064 2068 ficlVmGetDictionary(ficlVm *vm)
2065 2069 {
2066 2070 FICL_VM_ASSERT(vm, vm);
2067 2071 return (vm->callback.system->dictionary);
2068 2072 }
2069 2073
2070 2074 /*
2071 2075 * v m G e t S t r i n g
2072 2076 * Parses a string out of the VM input buffer and copies up to the first
2073 2077 * FICL_COUNTED_STRING_MAX characters to the supplied destination buffer, a
2074 2078 * ficlCountedString. The destination string is NULL terminated.
2075 2079 *
2076 2080 * Returns the address of the first unused character in the dest buffer.
2077 2081 */
2078 2082 char *
2079 2083 ficlVmGetString(ficlVm *vm, ficlCountedString *counted, char delimiter)
2080 2084 {
2081 2085 ficlString s = ficlVmParseStringEx(vm, delimiter, 0);
2082 2086
2083 2087 if (FICL_STRING_GET_LENGTH(s) > FICL_COUNTED_STRING_MAX) {
2084 2088 FICL_STRING_SET_LENGTH(s, FICL_COUNTED_STRING_MAX);
2085 2089 }
2086 2090
2087 2091 (void) strncpy(counted->text, FICL_STRING_GET_POINTER(s),
2088 2092 FICL_STRING_GET_LENGTH(s));
2089 2093 counted->text[FICL_STRING_GET_LENGTH(s)] = '\0';
2090 2094 counted->length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(s);
2091 2095
2092 2096 return (counted->text + FICL_STRING_GET_LENGTH(s) + 1);
2093 2097 }
2094 2098
2095 2099 /*
2096 2100 * v m G e t W o r d
2097 2101 * vmGetWord calls vmGetWord0 repeatedly until it gets a string with
2098 2102 * non-zero length.
2099 2103 */
2100 2104 ficlString
2101 2105 ficlVmGetWord(ficlVm *vm)
2102 2106 {
2103 2107 ficlString s = ficlVmGetWord0(vm);
2104 2108
2105 2109 if (FICL_STRING_GET_LENGTH(s) == 0) {
2106 2110 ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
2107 2111 }
2108 2112
2109 2113 return (s);
2110 2114 }
2111 2115
2112 2116 /*
2113 2117 * v m G e t W o r d 0
2114 2118 * Skip leading whitespace and parse a space delimited word from the tib.
2115 2119 * Returns the start address and length of the word. Updates the tib
2116 2120 * to reflect characters consumed, including the trailing delimiter.
2117 2121 * If there's nothing of interest in the tib, returns zero. This function
2118 2122 * does not use vmParseString because it uses isspace() rather than a
2119 2123 * single delimiter character.
2120 2124 */
2121 2125 ficlString
2122 2126 ficlVmGetWord0(ficlVm *vm)
2123 2127 {
2124 2128 char *trace = ficlVmGetInBuf(vm);
2125 2129 char *stop = ficlVmGetInBufEnd(vm);
2126 2130 ficlString s;
2127 2131 ficlUnsigned length = 0;
2128 2132 char c = 0;
2129 2133
2130 2134 trace = ficlStringSkipSpace(trace, stop);
2131 2135 FICL_STRING_SET_POINTER(s, trace);
2132 2136
2133 2137 /* Please leave this loop this way; it makes Purify happier. --lch */
2134 2138 for (;;) {
2135 2139 if (trace == stop)
2136 2140 break;
2137 2141 c = *trace;
2138 2142 if (isspace((unsigned char)c))
2139 2143 break;
2140 2144 length++;
2141 2145 trace++;
2142 2146 }
2143 2147
2144 2148 FICL_STRING_SET_LENGTH(s, length);
2145 2149
2146 2150 /* skip one trailing delimiter */
2147 2151 if ((trace != stop) && isspace((unsigned char)c))
2148 2152 trace++;
2149 2153
2150 2154 ficlVmUpdateTib(vm, trace);
2151 2155
2152 2156 return (s);
2153 2157 }
2154 2158
2155 2159 /*
2156 2160 * v m G e t W o r d T o P a d
2157 2161 * Does vmGetWord and copies the result to the pad as a NULL terminated
|
↓ open down ↓ |
2098 lines elided |
↑ open up ↑ |
2158 2162 * string. Returns the length of the string. If the string is too long
2159 2163 * to fit in the pad, it is truncated.
2160 2164 */
2161 2165 int
2162 2166 ficlVmGetWordToPad(ficlVm *vm)
2163 2167 {
2164 2168 ficlString s;
2165 2169 char *pad = (char *)vm->pad;
2166 2170 s = ficlVmGetWord(vm);
2167 2171
2168 - if (FICL_STRING_GET_LENGTH(s) > FICL_PAD_SIZE)
2169 - FICL_STRING_SET_LENGTH(s, FICL_PAD_SIZE);
2172 + if (FICL_STRING_GET_LENGTH(s) >= FICL_PAD_SIZE)
2173 + FICL_STRING_SET_LENGTH(s, FICL_PAD_SIZE - 1);
2170 2174
2171 2175 (void) strncpy(pad, FICL_STRING_GET_POINTER(s),
2172 2176 FICL_STRING_GET_LENGTH(s));
2173 2177 pad[FICL_STRING_GET_LENGTH(s)] = '\0';
2174 2178 return ((int)(FICL_STRING_GET_LENGTH(s)));
2175 2179 }
2176 2180
2177 2181 /*
2178 2182 * v m P a r s e S t r i n g
2179 2183 * Parses a string out of the input buffer using the delimiter
2180 2184 * specified. Skips leading delimiters, marks the start of the string,
2181 2185 * and counts characters to the next delimiter it encounters. It then
2182 2186 * updates the vm input buffer to consume all these chars, including the
2183 2187 * trailing delimiter.
2184 2188 * Returns the address and length of the parsed string, not including the
2185 2189 * trailing delimiter.
2186 2190 */
2187 2191 ficlString
2188 2192 ficlVmParseString(ficlVm *vm, char delimiter)
2189 2193 {
2190 2194 return (ficlVmParseStringEx(vm, delimiter, 1));
2191 2195 }
2192 2196
2193 2197 ficlString
2194 2198 ficlVmParseStringEx(ficlVm *vm, char delimiter, char skipLeadingDelimiters)
2195 2199 {
2196 2200 ficlString s;
2197 2201 char *trace = ficlVmGetInBuf(vm);
2198 2202 char *stop = ficlVmGetInBufEnd(vm);
2199 2203 char c;
2200 2204
2201 2205 if (skipLeadingDelimiters) {
2202 2206 while ((trace != stop) && (*trace == delimiter))
2203 2207 trace++;
2204 2208 }
2205 2209
2206 2210 FICL_STRING_SET_POINTER(s, trace); /* mark start of text */
2207 2211
2208 2212 /* find next delimiter or end of line */
2209 2213 for (c = *trace;
2210 2214 (trace != stop) && (c != delimiter) && (c != '\r') && (c != '\n');
2211 2215 c = *++trace) {
2212 2216 ;
2213 2217 }
2214 2218
2215 2219 /* set length of result */
2216 2220 FICL_STRING_SET_LENGTH(s, trace - FICL_STRING_GET_POINTER(s));
2217 2221
2218 2222 /* gobble trailing delimiter */
2219 2223 if ((trace != stop) && (*trace == delimiter))
2220 2224 trace++;
2221 2225
2222 2226 ficlVmUpdateTib(vm, trace);
2223 2227 return (s);
2224 2228 }
2225 2229
2226 2230
2227 2231 /*
2228 2232 * v m P o p
2229 2233 */
2230 2234 ficlCell
2231 2235 ficlVmPop(ficlVm *vm)
2232 2236 {
2233 2237 return (ficlStackPop(vm->dataStack));
2234 2238 }
2235 2239
2236 2240 /*
2237 2241 * v m P u s h
2238 2242 */
2239 2243 void
2240 2244 ficlVmPush(ficlVm *vm, ficlCell c)
2241 2245 {
2242 2246 ficlStackPush(vm->dataStack, c);
2243 2247 }
2244 2248
2245 2249 /*
2246 2250 * v m P o p I P
2247 2251 */
2248 2252 void
2249 2253 ficlVmPopIP(ficlVm *vm)
2250 2254 {
2251 2255 vm->ip = (ficlIp)(ficlStackPopPointer(vm->returnStack));
2252 2256 }
2253 2257
2254 2258 /*
2255 2259 * v m P u s h I P
2256 2260 */
2257 2261 void
2258 2262 ficlVmPushIP(ficlVm *vm, ficlIp newIP)
2259 2263 {
2260 2264 ficlStackPushPointer(vm->returnStack, (void *)vm->ip);
2261 2265 vm->ip = newIP;
2262 2266 }
2263 2267
2264 2268 /*
2265 2269 * v m P u s h T i b
2266 2270 * Binds the specified input string to the VM and clears >IN (the index)
2267 2271 */
2268 2272 void
2269 2273 ficlVmPushTib(ficlVm *vm, char *text, ficlInteger nChars, ficlTIB *pSaveTib)
2270 2274 {
2271 2275 if (pSaveTib) {
2272 2276 *pSaveTib = vm->tib;
2273 2277 }
2274 2278 vm->tib.text = text;
2275 2279 vm->tib.end = text + nChars;
2276 2280 vm->tib.index = 0;
2277 2281 }
2278 2282
2279 2283 void
2280 2284 ficlVmPopTib(ficlVm *vm, ficlTIB *pTib)
2281 2285 {
2282 2286 if (pTib) {
2283 2287 vm->tib = *pTib;
2284 2288 }
2285 2289 }
2286 2290
2287 2291 /*
2288 2292 * v m Q u i t
2289 2293 */
2290 2294 void
2291 2295 ficlVmQuit(ficlVm *vm)
2292 2296 {
2293 2297 ficlStackReset(vm->returnStack);
2294 2298 vm->restart = 0;
2295 2299 vm->ip = NULL;
2296 2300 vm->runningWord = NULL;
2297 2301 vm->state = FICL_VM_STATE_INTERPRET;
2298 2302 vm->tib.text = NULL;
2299 2303 vm->tib.end = NULL;
2300 2304 vm->tib.index = 0;
2301 2305 vm->pad[0] = '\0';
2302 2306 vm->sourceId.i = 0;
2303 2307 }
2304 2308
2305 2309 /*
2306 2310 * v m R e s e t
2307 2311 */
2308 2312 void
2309 2313 ficlVmReset(ficlVm *vm)
2310 2314 {
2311 2315 ficlVmQuit(vm);
2312 2316 ficlStackReset(vm->dataStack);
2313 2317 #if FICL_WANT_FLOAT
2314 2318 ficlStackReset(vm->floatStack);
2315 2319 #endif
2316 2320 vm->base = 10;
2317 2321 }
2318 2322
2319 2323 /*
2320 2324 * v m S e t T e x t O u t
2321 2325 * Binds the specified output callback to the vm. If you pass NULL,
2322 2326 * binds the default output function (ficlTextOut)
2323 2327 */
2324 2328 void
2325 2329 ficlVmSetTextOut(ficlVm *vm, ficlOutputFunction textOut)
2326 2330 {
2327 2331 vm->callback.textOut = textOut;
2328 2332 }
2329 2333
2330 2334 void
2331 2335 ficlVmTextOut(ficlVm *vm, char *text)
2332 2336 {
2333 2337 ficlCallbackTextOut((ficlCallback *)vm, text);
2334 2338 }
2335 2339
2336 2340
2337 2341 void
2338 2342 ficlVmErrorOut(ficlVm *vm, char *text)
2339 2343 {
2340 2344 ficlCallbackErrorOut((ficlCallback *)vm, text);
2341 2345 }
2342 2346
2343 2347
2344 2348 /*
2345 2349 * v m T h r o w
2346 2350 */
2347 2351 void
2348 2352 ficlVmThrow(ficlVm *vm, int except)
2349 2353 {
2350 2354 if (vm->exceptionHandler)
2351 2355 longjmp(*(vm->exceptionHandler), except);
2352 2356 }
2353 2357
2354 2358 void
2355 2359 ficlVmThrowError(ficlVm *vm, char *fmt, ...)
2356 2360 {
2357 2361 va_list list;
2358 2362
2359 2363 va_start(list, fmt);
2360 2364 (void) vsprintf(vm->pad, fmt, list);
2361 2365 va_end(list);
2362 2366 (void) strcat(vm->pad, "\n");
2363 2367
2364 2368 ficlVmErrorOut(vm, vm->pad);
2365 2369 longjmp(*(vm->exceptionHandler), FICL_VM_STATUS_ERROR_EXIT);
2366 2370 }
2367 2371
2368 2372 void
2369 2373 ficlVmThrowErrorVararg(ficlVm *vm, char *fmt, va_list list)
2370 2374 {
2371 2375 (void) vsprintf(vm->pad, fmt, list);
2372 2376 /*
2373 2377 * well, we can try anyway, we're certainly not
2374 2378 * returning to our caller!
2375 2379 */
2376 2380 va_end(list);
2377 2381 (void) strcat(vm->pad, "\n");
2378 2382
2379 2383 ficlVmErrorOut(vm, vm->pad);
2380 2384 longjmp(*(vm->exceptionHandler), FICL_VM_STATUS_ERROR_EXIT);
2381 2385 }
2382 2386
2383 2387 /*
2384 2388 * f i c l E v a l u a t e
2385 2389 * Wrapper for ficlExec() which sets SOURCE-ID to -1.
2386 2390 */
2387 2391 int
2388 2392 ficlVmEvaluate(ficlVm *vm, char *s)
2389 2393 {
2390 2394 int returnValue;
2391 2395 ficlCell id = vm->sourceId;
2392 2396 ficlString string;
2393 2397 vm->sourceId.i = -1;
2394 2398 FICL_STRING_SET_FROM_CSTRING(string, s);
2395 2399 returnValue = ficlVmExecuteString(vm, string);
2396 2400 vm->sourceId = id;
2397 2401 return (returnValue);
2398 2402 }
2399 2403
2400 2404 /*
2401 2405 * f i c l E x e c
2402 2406 * Evaluates a block of input text in the context of the
2403 2407 * specified interpreter. Emits any requested output to the
2404 2408 * interpreter's output function.
2405 2409 *
2406 2410 * Contains the "inner interpreter" code in a tight loop
2407 2411 *
2408 2412 * Returns one of the VM_XXXX codes defined in ficl.h:
2409 2413 * VM_OUTOFTEXT is the normal exit condition
2410 2414 * VM_ERREXIT means that the interpreter encountered a syntax error
2411 2415 * and the vm has been reset to recover (some or all
2412 2416 * of the text block got ignored
2413 2417 * VM_USEREXIT means that the user executed the "bye" command
2414 2418 * to shut down the interpreter. This would be a good
2415 2419 * time to delete the vm, etc -- or you can ignore this
2416 2420 * signal.
2417 2421 */
2418 2422 int
2419 2423 ficlVmExecuteString(ficlVm *vm, ficlString s)
2420 2424 {
2421 2425 ficlSystem *system = vm->callback.system;
2422 2426 ficlDictionary *dictionary = system->dictionary;
2423 2427
2424 2428 int except;
2425 2429 jmp_buf vmState;
2426 2430 jmp_buf *oldState;
2427 2431 ficlTIB saveficlTIB;
2428 2432
2429 2433 FICL_VM_ASSERT(vm, vm);
2430 2434 FICL_VM_ASSERT(vm, system->interpreterLoop[0]);
2431 2435
2432 2436 ficlVmPushTib(vm, FICL_STRING_GET_POINTER(s),
2433 2437 FICL_STRING_GET_LENGTH(s), &saveficlTIB);
2434 2438
2435 2439 /*
2436 2440 * Save and restore VM's jmp_buf to enable nested calls to ficlExec
2437 2441 */
2438 2442 oldState = vm->exceptionHandler;
2439 2443
2440 2444 /* This has to come before the setjmp! */
2441 2445 vm->exceptionHandler = &vmState;
2442 2446 except = setjmp(vmState);
2443 2447
2444 2448 switch (except) {
2445 2449 case 0:
2446 2450 if (vm->restart) {
2447 2451 vm->runningWord->code(vm);
2448 2452 vm->restart = 0;
2449 2453 } else { /* set VM up to interpret text */
2450 2454 ficlVmPushIP(vm, &(system->interpreterLoop[0]));
2451 2455 }
2452 2456
2453 2457 ficlVmInnerLoop(vm, 0);
2454 2458 break;
2455 2459
2456 2460 case FICL_VM_STATUS_RESTART:
2457 2461 vm->restart = 1;
2458 2462 except = FICL_VM_STATUS_OUT_OF_TEXT;
2459 2463 break;
2460 2464
2461 2465 case FICL_VM_STATUS_OUT_OF_TEXT:
2462 2466 ficlVmPopIP(vm);
2463 2467 #if 0 /* we dont output prompt in loader */
2464 2468 if ((vm->state != FICL_VM_STATE_COMPILE) &&
2465 2469 (vm->sourceId.i == 0))
2466 2470 ficlVmTextOut(vm, FICL_PROMPT);
2467 2471 #endif
2468 2472 break;
2469 2473
2470 2474 case FICL_VM_STATUS_USER_EXIT:
2471 2475 case FICL_VM_STATUS_INNER_EXIT:
2472 2476 case FICL_VM_STATUS_BREAK:
2473 2477 break;
2474 2478
2475 2479 case FICL_VM_STATUS_QUIT:
2476 2480 if (vm->state == FICL_VM_STATE_COMPILE) {
2477 2481 ficlDictionaryAbortDefinition(dictionary);
2478 2482 #if FICL_WANT_LOCALS
2479 2483 ficlDictionaryEmpty(system->locals,
2480 2484 system->locals->forthWordlist->size);
2481 2485 #endif
2482 2486 }
2483 2487 ficlVmQuit(vm);
2484 2488 break;
2485 2489
2486 2490 case FICL_VM_STATUS_ERROR_EXIT:
2487 2491 case FICL_VM_STATUS_ABORT:
2488 2492 case FICL_VM_STATUS_ABORTQ:
2489 2493 default: /* user defined exit code?? */
2490 2494 if (vm->state == FICL_VM_STATE_COMPILE) {
2491 2495 ficlDictionaryAbortDefinition(dictionary);
2492 2496 #if FICL_WANT_LOCALS
2493 2497 ficlDictionaryEmpty(system->locals,
2494 2498 system->locals->forthWordlist->size);
2495 2499 #endif
2496 2500 }
2497 2501 ficlDictionaryResetSearchOrder(dictionary);
2498 2502 ficlVmReset(vm);
2499 2503 break;
2500 2504 }
2501 2505
2502 2506 vm->exceptionHandler = oldState;
2503 2507 ficlVmPopTib(vm, &saveficlTIB);
2504 2508 return (except);
2505 2509 }
2506 2510
2507 2511 /*
2508 2512 * f i c l E x e c X T
2509 2513 * Given a pointer to a ficlWord, push an inner interpreter and
2510 2514 * execute the word to completion. This is in contrast with vmExecute,
2511 2515 * which does not guarantee that the word will have completed when
2512 2516 * the function returns (ie in the case of colon definitions, which
2513 2517 * need an inner interpreter to finish)
2514 2518 *
2515 2519 * Returns one of the VM_XXXX exception codes listed in ficl.h. Normal
2516 2520 * exit condition is VM_INNEREXIT, Ficl's private signal to exit the
2517 2521 * inner loop under normal circumstances. If another code is thrown to
2518 2522 * exit the loop, this function will re-throw it if it's nested under
2519 2523 * itself or ficlExec.
2520 2524 *
2521 2525 * NOTE: this function is intended so that C code can execute ficlWords
2522 2526 * given their address in the dictionary (xt).
2523 2527 */
2524 2528 int
2525 2529 ficlVmExecuteXT(ficlVm *vm, ficlWord *pWord)
2526 2530 {
2527 2531 int except;
2528 2532 jmp_buf vmState;
2529 2533 jmp_buf *oldState;
2530 2534 ficlWord *oldRunningWord;
2531 2535
2532 2536 FICL_VM_ASSERT(vm, vm);
2533 2537 FICL_VM_ASSERT(vm, vm->callback.system->exitInnerWord);
2534 2538
2535 2539 /*
2536 2540 * Save the runningword so that RESTART behaves correctly
2537 2541 * over nested calls.
2538 2542 */
2539 2543 oldRunningWord = vm->runningWord;
2540 2544 /*
2541 2545 * Save and restore VM's jmp_buf to enable nested calls
2542 2546 */
2543 2547 oldState = vm->exceptionHandler;
2544 2548 /* This has to come before the setjmp! */
2545 2549 vm->exceptionHandler = &vmState;
2546 2550 except = setjmp(vmState);
2547 2551
2548 2552 if (except)
2549 2553 ficlVmPopIP(vm);
2550 2554 else
2551 2555 ficlVmPushIP(vm, &(vm->callback.system->exitInnerWord));
2552 2556
2553 2557 switch (except) {
2554 2558 case 0:
2555 2559 ficlVmExecuteWord(vm, pWord);
2556 2560 ficlVmInnerLoop(vm, 0);
2557 2561 break;
2558 2562
2559 2563 case FICL_VM_STATUS_INNER_EXIT:
2560 2564 case FICL_VM_STATUS_BREAK:
2561 2565 break;
2562 2566
2563 2567 case FICL_VM_STATUS_RESTART:
2564 2568 case FICL_VM_STATUS_OUT_OF_TEXT:
2565 2569 case FICL_VM_STATUS_USER_EXIT:
2566 2570 case FICL_VM_STATUS_QUIT:
2567 2571 case FICL_VM_STATUS_ERROR_EXIT:
2568 2572 case FICL_VM_STATUS_ABORT:
2569 2573 case FICL_VM_STATUS_ABORTQ:
2570 2574 default: /* user defined exit code?? */
2571 2575 if (oldState) {
2572 2576 vm->exceptionHandler = oldState;
2573 2577 ficlVmThrow(vm, except);
2574 2578 }
2575 2579 break;
2576 2580 }
2577 2581
2578 2582 vm->exceptionHandler = oldState;
2579 2583 vm->runningWord = oldRunningWord;
2580 2584 return (except);
2581 2585 }
2582 2586
2583 2587 /*
2584 2588 * f i c l P a r s e N u m b e r
2585 2589 * Attempts to convert the NULL terminated string in the VM's pad to
2586 2590 * a number using the VM's current base. If successful, pushes the number
2587 2591 * onto the param stack and returns FICL_TRUE. Otherwise, returns FICL_FALSE.
2588 2592 * (jws 8/01) Trailing decimal point causes a zero ficlCell to be pushed. (See
2589 2593 * the standard for DOUBLE wordset.
2590 2594 */
2591 2595 int
2592 2596 ficlVmParseNumber(ficlVm *vm, ficlString s)
2593 2597 {
2594 2598 ficlInteger accumulator = 0;
2595 2599 char isNegative = 0;
2596 2600 char isDouble = 0;
2597 2601 unsigned base = vm->base;
2598 2602 char *trace = FICL_STRING_GET_POINTER(s);
2599 2603 ficlUnsigned8 length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(s);
2600 2604 unsigned c;
2601 2605 unsigned digit;
2602 2606
2603 2607 if (length > 1) {
2604 2608 switch (*trace) {
2605 2609 case '-':
2606 2610 trace++;
2607 2611 length--;
2608 2612 isNegative = 1;
2609 2613 break;
2610 2614 case '+':
2611 2615 trace++;
2612 2616 length--;
2613 2617 isNegative = 0;
2614 2618 break;
2615 2619 default:
2616 2620 break;
2617 2621 }
2618 2622 }
2619 2623
2620 2624 /* detect & remove trailing decimal */
2621 2625 if ((length > 0) && (trace[length - 1] == '.')) {
2622 2626 isDouble = 1;
2623 2627 length--;
2624 2628 }
2625 2629
2626 2630 if (length == 0) /* detect "+", "-", ".", "+." etc */
2627 2631 return (0); /* false */
2628 2632
2629 2633 while ((length--) && ((c = *trace++) != '\0')) {
2630 2634 if (!isalnum(c))
2631 2635 return (0); /* false */
2632 2636
2633 2637 digit = c - '0';
2634 2638
2635 2639 if (digit > 9)
2636 2640 digit = tolower(c) - 'a' + 10;
2637 2641
2638 2642 if (digit >= base)
2639 2643 return (0); /* false */
2640 2644
2641 2645 accumulator = accumulator * base + digit;
2642 2646 }
2643 2647
2644 2648 if (isNegative)
2645 2649 accumulator = -accumulator;
2646 2650
2647 2651 ficlStackPushInteger(vm->dataStack, accumulator);
2648 2652 if (vm->state == FICL_VM_STATE_COMPILE)
2649 2653 ficlPrimitiveLiteralIm(vm);
2650 2654
2651 2655 if (isDouble) { /* simple (required) DOUBLE support */
2652 2656 if (isNegative)
2653 2657 ficlStackPushInteger(vm->dataStack, -1);
2654 2658 else
2655 2659 ficlStackPushInteger(vm->dataStack, 0);
2656 2660 if (vm->state == FICL_VM_STATE_COMPILE)
2657 2661 ficlPrimitiveLiteralIm(vm);
2658 2662 }
2659 2663
2660 2664 return (1); /* true */
2661 2665 }
2662 2666
2663 2667 /*
2664 2668 * d i c t C h e c k
2665 2669 * Checks the dictionary for corruption and throws appropriate
2666 2670 * errors.
2667 2671 * Input: +n number of ADDRESS UNITS (not ficlCells) proposed to allot
2668 2672 * -n number of ADDRESS UNITS proposed to de-allot
2669 2673 * 0 just do a consistency check
2670 2674 */
2671 2675 void
2672 2676 ficlVmDictionarySimpleCheck(ficlVm *vm, ficlDictionary *dictionary, int cells)
2673 2677 {
2674 2678 #if FICL_ROBUST >= 1
2675 2679 if ((cells >= 0) &&
2676 2680 (ficlDictionaryCellsAvailable(dictionary) *
2677 2681 (int)sizeof (ficlCell) < cells)) {
2678 2682 ficlVmThrowError(vm, "Error: dictionary full");
2679 2683 }
2680 2684
2681 2685 if ((cells <= 0) &&
2682 2686 (ficlDictionaryCellsUsed(dictionary) *
2683 2687 (int)sizeof (ficlCell) < -cells)) {
2684 2688 ficlVmThrowError(vm, "Error: dictionary underflow");
2685 2689 }
2686 2690 #else /* FICL_ROBUST >= 1 */
2687 2691 FICL_IGNORE(vm);
2688 2692 FICL_IGNORE(dictionary);
2689 2693 FICL_IGNORE(cells);
2690 2694 #endif /* FICL_ROBUST >= 1 */
2691 2695 }
2692 2696
2693 2697 void
2694 2698 ficlVmDictionaryCheck(ficlVm *vm, ficlDictionary *dictionary, int cells)
2695 2699 {
2696 2700 #if FICL_ROBUST >= 1
2697 2701 ficlVmDictionarySimpleCheck(vm, dictionary, cells);
2698 2702
2699 2703 if (dictionary->wordlistCount > FICL_MAX_WORDLISTS) {
2700 2704 ficlDictionaryResetSearchOrder(dictionary);
2701 2705 ficlVmThrowError(vm, "Error: search order overflow");
2702 2706 } else if (dictionary->wordlistCount < 0) {
2703 2707 ficlDictionaryResetSearchOrder(dictionary);
2704 2708 ficlVmThrowError(vm, "Error: search order underflow");
2705 2709 }
2706 2710 #else /* FICL_ROBUST >= 1 */
2707 2711 FICL_IGNORE(vm);
2708 2712 FICL_IGNORE(dictionary);
2709 2713 FICL_IGNORE(cells);
2710 2714 #endif /* FICL_ROBUST >= 1 */
2711 2715 }
2712 2716
2713 2717 void
2714 2718 ficlVmDictionaryAllot(ficlVm *vm, ficlDictionary *dictionary, int n)
2715 2719 {
2716 2720 FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, n);
2717 2721 FICL_IGNORE(vm);
2718 2722 ficlDictionaryAllot(dictionary, n);
2719 2723 }
2720 2724
2721 2725 void
2722 2726 ficlVmDictionaryAllotCells(ficlVm *vm, ficlDictionary *dictionary, int cells)
2723 2727 {
2724 2728 FICL_VM_DICTIONARY_SIMPLE_CHECK(vm, dictionary, cells);
2725 2729 FICL_IGNORE(vm);
2726 2730 ficlDictionaryAllotCells(dictionary, cells);
2727 2731 }
2728 2732
2729 2733 /*
2730 2734 * f i c l P a r s e W o r d
2731 2735 * From the standard, section 3.4
2732 2736 * b) Search the dictionary name space (see 3.4.2). If a definition name
2733 2737 * matching the string is found:
2734 2738 * 1.if interpreting, perform the interpretation semantics of the definition
2735 2739 * (see 3.4.3.2), and continue at a);
2736 2740 * 2.if compiling, perform the compilation semantics of the definition
2737 2741 * (see 3.4.3.3), and continue at a).
2738 2742 *
2739 2743 * c) If a definition name matching the string is not found, attempt to
2740 2744 * convert the string to a number (see 3.4.1.3). If successful:
2741 2745 * 1.if interpreting, place the number on the data stack, and continue at a);
2742 2746 * 2.if compiling, FICL_VM_STATE_COMPILE code that when executed will place
2743 2747 * the number on the stack (see 6.1.1780 LITERAL), and continue at a);
2744 2748 *
2745 2749 * d) If unsuccessful, an ambiguous condition exists (see 3.4.4).
2746 2750 *
2747 2751 * (jws 4/01) Modified to be a ficlParseStep
2748 2752 */
2749 2753 int
2750 2754 ficlVmParseWord(ficlVm *vm, ficlString name)
2751 2755 {
2752 2756 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
2753 2757 ficlWord *tempFW;
2754 2758
2755 2759 FICL_VM_DICTIONARY_CHECK(vm, dictionary, 0);
2756 2760 FICL_STACK_CHECK(vm->dataStack, 0, 0);
2757 2761
2758 2762 #if FICL_WANT_LOCALS
2759 2763 if (vm->callback.system->localsCount > 0) {
2760 2764 tempFW = ficlSystemLookupLocal(vm->callback.system, name);
2761 2765 } else
2762 2766 #endif
2763 2767 tempFW = ficlDictionaryLookup(dictionary, name);
2764 2768
2765 2769 if (vm->state == FICL_VM_STATE_INTERPRET) {
2766 2770 if (tempFW != NULL) {
2767 2771 if (ficlWordIsCompileOnly(tempFW)) {
2768 2772 ficlVmThrowError(vm,
2769 2773 "Error: FICL_VM_STATE_COMPILE only!");
2770 2774 }
2771 2775
2772 2776 ficlVmExecuteWord(vm, tempFW);
2773 2777 return (1); /* true */
2774 2778 }
2775 2779 } else { /* (vm->state == FICL_VM_STATE_COMPILE) */
2776 2780 if (tempFW != NULL) {
2777 2781 if (ficlWordIsImmediate(tempFW)) {
2778 2782 ficlVmExecuteWord(vm, tempFW);
2779 2783 } else {
2780 2784 ficlCell c;
2781 2785 c.p = tempFW;
2782 2786 if (tempFW->flags & FICL_WORD_INSTRUCTION)
2783 2787 ficlDictionaryAppendUnsigned(dictionary,
2784 2788 (ficlInteger)tempFW->code);
2785 2789 else
2786 2790 ficlDictionaryAppendCell(dictionary, c);
2787 2791 }
2788 2792 return (1); /* true */
2789 2793 }
2790 2794 }
2791 2795
2792 2796 return (0); /* false */
2793 2797 }
|
↓ open down ↓ |
614 lines elided |
↑ open up ↑ |
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX