1 /* 2 * CDDL HEADER START 3 * 4 * The contents of this file are subject to the terms of the 5 * Common Development and Distribution License (the "License"). 6 * You may not use this file except in compliance with the License. 7 * 8 * You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE 9 * or http://www.opensolaris.org/os/licensing. 10 * See the License for the specific language governing permissions 11 * and limitations under the License. 12 * 13 * When distributing Covered Code, include this CDDL HEADER in each 14 * file and include the License file at usr/src/OPENSOLARIS.LICENSE. 15 * If applicable, add the following below this CDDL HEADER, with the 16 * fields enclosed by brackets "[]" replaced with your own identifying 17 * information: Portions Copyright [yyyy] [name of copyright owner] 18 * 19 * CDDL HEADER END 20 */ 21 /* 22 * Copyright 2007 Sun Microsystems, Inc. All rights reserved. 23 * Use is subject to license terms. 24 */ 25 26 #pragma ident "%Z%%M% %I% %E% SMI" 27 28 #include <stdio.h> 29 #include <stdlib.h> 30 #include <string.h> 31 #include <stdarg.h> 32 #include <ctype.h> 33 34 #include <fcode/private.h> 35 #include <fcode/log.h> 36 37 void (*semi_ptr)(fcode_env_t *env) = do_semi; 38 void (*does_ptr)(fcode_env_t *env) = install_does; 39 void (*quote_ptr)(fcode_env_t *env) = do_quote; 40 void (*blit_ptr)(fcode_env_t *env) = do_literal; 41 void (*tlit_ptr)(fcode_env_t *env) = do_literal; 42 void (*do_bdo_ptr)(fcode_env_t *env) = do_bdo; 43 void (*do_bqdo_ptr)(fcode_env_t *env) = do_bqdo; 44 void (*create_ptr)(fcode_env_t *env) = do_creator; 45 void (*do_leave_ptr)(fcode_env_t *env) = do_bleave; 46 void (*do_loop_ptr)(fcode_env_t *env) = do_bloop; 47 void (*do_ploop_ptr)(fcode_env_t *env) = do_bploop; 48 49 void unaligned_lstore(fcode_env_t *); 50 void unaligned_wstore(fcode_env_t *); 51 void unaligned_lfetch(fcode_env_t *); 52 void unaligned_wfetch(fcode_env_t *); 53 54 /* start with the simple maths functions */ 55 56 57 void 58 add(fcode_env_t *env) 59 { 60 fstack_t d; 61 62 CHECK_DEPTH(env, 2, "+"); 63 d = POP(DS); 64 TOS += d; 65 } 66 67 void 68 subtract(fcode_env_t *env) 69 { 70 fstack_t d; 71 72 CHECK_DEPTH(env, 2, "-"); 73 d = POP(DS); 74 TOS -= d; 75 } 76 77 void 78 multiply(fcode_env_t *env) 79 { 80 fstack_t d; 81 82 CHECK_DEPTH(env, 2, "*"); 83 d = POP(DS); 84 TOS *= d; 85 } 86 87 void 88 slash_mod(fcode_env_t *env) 89 { 90 fstack_t d, o, t, rem; 91 int sign = 1; 92 93 CHECK_DEPTH(env, 2, "/mod"); 94 d = POP(DS); 95 o = t = POP(DS); 96 97 if (d == 0) { 98 throw_from_fclib(env, 1, "/mod divide by zero"); 99 } 100 sign = ((d ^ t) < 0); 101 if (d < 0) { 102 d = -d; 103 if (sign) { 104 t += (d-1); 105 } 106 } 107 if (t < 0) { 108 if (sign) { 109 t -= (d-1); 110 } 111 t = -t; 112 } 113 t = t / d; 114 if ((o ^ sign) < 0) { 115 rem = (t * d) + o; 116 } else { 117 rem = o - (t*d); 118 } 119 if (sign) { 120 t = -t; 121 } 122 PUSH(DS, rem); 123 PUSH(DS, t); 124 } 125 126 /* 127 * 'u/mod' Fcode implementation. 128 */ 129 void 130 uslash_mod(fcode_env_t *env) 131 { 132 u_lforth_t u1, u2; 133 134 CHECK_DEPTH(env, 2, "u/mod"); 135 u2 = POP(DS); 136 u1 = POP(DS); 137 138 if (u2 == 0) 139 forth_abort(env, "u/mod: divide by zero"); 140 PUSH(DS, u1 % u2); 141 PUSH(DS, u1 / u2); 142 } 143 144 void 145 divide(fcode_env_t *env) 146 { 147 CHECK_DEPTH(env, 2, "/"); 148 slash_mod(env); 149 nip(env); 150 } 151 152 void 153 mod(fcode_env_t *env) 154 { 155 CHECK_DEPTH(env, 2, "mod"); 156 slash_mod(env); 157 drop(env); 158 } 159 160 void 161 and(fcode_env_t *env) 162 { 163 fstack_t d; 164 165 CHECK_DEPTH(env, 2, "and"); 166 d = POP(DS); 167 TOS &= d; 168 } 169 170 void 171 or(fcode_env_t *env) 172 { 173 fstack_t d; 174 175 CHECK_DEPTH(env, 2, "or"); 176 d = POP(DS); 177 TOS |= d; 178 } 179 180 void 181 xor(fcode_env_t *env) 182 { 183 fstack_t d; 184 185 CHECK_DEPTH(env, 2, "xor"); 186 d = POP(DS); 187 TOS ^= d; 188 } 189 190 void 191 invert(fcode_env_t *env) 192 { 193 CHECK_DEPTH(env, 1, "invert"); 194 TOS = ~TOS; 195 } 196 197 void 198 lshift(fcode_env_t *env) 199 { 200 fstack_t d; 201 202 CHECK_DEPTH(env, 2, "lshift"); 203 d = POP(DS); 204 TOS = TOS << d; 205 } 206 207 void 208 rshift(fcode_env_t *env) 209 { 210 fstack_t d; 211 212 CHECK_DEPTH(env, 2, "rshift"); 213 d = POP(DS); 214 TOS = ((ufstack_t)TOS) >> d; 215 } 216 217 void 218 rshifta(fcode_env_t *env) 219 { 220 fstack_t d; 221 222 CHECK_DEPTH(env, 2, ">>a"); 223 d = POP(DS); 224 TOS = ((s_lforth_t)TOS) >> d; 225 } 226 227 void 228 negate(fcode_env_t *env) 229 { 230 CHECK_DEPTH(env, 1, "negate"); 231 TOS = -TOS; 232 } 233 234 void 235 f_abs(fcode_env_t *env) 236 { 237 CHECK_DEPTH(env, 1, "abs"); 238 if (TOS < 0) TOS = -TOS; 239 } 240 241 void 242 f_min(fcode_env_t *env) 243 { 244 fstack_t d; 245 246 CHECK_DEPTH(env, 2, "min"); 247 d = POP(DS); 248 if (d < TOS) TOS = d; 249 } 250 251 void 252 f_max(fcode_env_t *env) 253 { 254 fstack_t d; 255 256 CHECK_DEPTH(env, 2, "max"); 257 d = POP(DS); 258 if (d > TOS) TOS = d; 259 } 260 261 void 262 to_r(fcode_env_t *env) 263 { 264 CHECK_DEPTH(env, 1, ">r"); 265 PUSH(RS, POP(DS)); 266 } 267 268 void 269 from_r(fcode_env_t *env) 270 { 271 CHECK_RETURN_DEPTH(env, 1, "r>"); 272 PUSH(DS, POP(RS)); 273 } 274 275 void 276 rfetch(fcode_env_t *env) 277 { 278 CHECK_RETURN_DEPTH(env, 1, "r@"); 279 PUSH(DS, *RS); 280 } 281 282 void 283 f_exit(fcode_env_t *env) 284 { 285 CHECK_RETURN_DEPTH(env, 1, "exit"); 286 IP = (token_t *)POP(RS); 287 } 288 289 #define COMPARE(cmp, rhs) ((((s_lforth_t)TOS) cmp((s_lforth_t)(rhs))) ? \ 290 TRUE : FALSE) 291 #define UCOMPARE(cmp, rhs) ((((u_lforth_t)TOS) cmp((u_lforth_t)(rhs))) ? \ 292 TRUE : FALSE) 293 #define EQUALS == 294 #define NOTEQUALS != 295 #define LESSTHAN < 296 #define LESSEQUALS <= 297 #define GREATERTHAN > 298 #define GREATEREQUALS >= 299 300 void 301 zero_equals(fcode_env_t *env) 302 { 303 CHECK_DEPTH(env, 1, "0="); 304 TOS = COMPARE(EQUALS, 0); 305 } 306 307 void 308 zero_not_equals(fcode_env_t *env) 309 { 310 CHECK_DEPTH(env, 1, "0<>"); 311 TOS = COMPARE(NOTEQUALS, 0); 312 } 313 314 void 315 zero_less(fcode_env_t *env) 316 { 317 CHECK_DEPTH(env, 1, "0<"); 318 TOS = COMPARE(LESSTHAN, 0); 319 } 320 321 void 322 zero_less_equals(fcode_env_t *env) 323 { 324 CHECK_DEPTH(env, 1, "0<="); 325 TOS = COMPARE(LESSEQUALS, 0); 326 } 327 328 void 329 zero_greater(fcode_env_t *env) 330 { 331 CHECK_DEPTH(env, 1, "0>"); 332 TOS = COMPARE(GREATERTHAN, 0); 333 } 334 335 void 336 zero_greater_equals(fcode_env_t *env) 337 { 338 CHECK_DEPTH(env, 1, "0>="); 339 TOS = COMPARE(GREATEREQUALS, 0); 340 } 341 342 void 343 less(fcode_env_t *env) 344 { 345 fstack_t d; 346 347 CHECK_DEPTH(env, 2, "<"); 348 d = POP(DS); 349 TOS = COMPARE(LESSTHAN, d); 350 } 351 352 void 353 greater(fcode_env_t *env) 354 { 355 fstack_t d; 356 357 CHECK_DEPTH(env, 2, ">"); 358 d = POP(DS); 359 TOS = COMPARE(GREATERTHAN, d); 360 } 361 362 void 363 equals(fcode_env_t *env) 364 { 365 fstack_t d; 366 367 CHECK_DEPTH(env, 2, "="); 368 d = POP(DS); 369 TOS = COMPARE(EQUALS, d); 370 } 371 372 void 373 not_equals(fcode_env_t *env) 374 { 375 fstack_t d; 376 377 CHECK_DEPTH(env, 2, "<>"); 378 d = POP(DS); 379 TOS = COMPARE(NOTEQUALS, d); 380 } 381 382 383 void 384 unsign_greater(fcode_env_t *env) 385 { 386 ufstack_t d; 387 388 CHECK_DEPTH(env, 2, "u>"); 389 d = POP(DS); 390 TOS = UCOMPARE(GREATERTHAN, d); 391 } 392 393 void 394 unsign_less_equals(fcode_env_t *env) 395 { 396 ufstack_t d; 397 398 CHECK_DEPTH(env, 2, "u<="); 399 d = POP(DS); 400 TOS = UCOMPARE(LESSEQUALS, d); 401 } 402 403 void 404 unsign_less(fcode_env_t *env) 405 { 406 ufstack_t d; 407 408 CHECK_DEPTH(env, 2, "u<"); 409 d = POP(DS); 410 TOS = UCOMPARE(LESSTHAN, d); 411 } 412 413 void 414 unsign_greater_equals(fcode_env_t *env) 415 { 416 ufstack_t d; 417 418 CHECK_DEPTH(env, 2, "u>="); 419 d = POP(DS); 420 TOS = UCOMPARE(GREATEREQUALS, d); 421 } 422 423 void 424 greater_equals(fcode_env_t *env) 425 { 426 fstack_t d; 427 428 CHECK_DEPTH(env, 2, ">="); 429 d = POP(DS); 430 TOS = COMPARE(GREATEREQUALS, d); 431 } 432 433 void 434 less_equals(fcode_env_t *env) 435 { 436 fstack_t d; 437 438 CHECK_DEPTH(env, 2, "<="); 439 d = POP(DS); 440 TOS = COMPARE(LESSEQUALS, d); 441 } 442 443 void 444 between(fcode_env_t *env) 445 { 446 u_lforth_t hi, lo; 447 448 CHECK_DEPTH(env, 3, "between"); 449 hi = (u_lforth_t)POP(DS); 450 lo = (u_lforth_t)POP(DS); 451 TOS = (((u_lforth_t)TOS >= lo) && ((u_lforth_t)TOS <= hi) ? -1 : 0); 452 } 453 454 void 455 within(fcode_env_t *env) 456 { 457 u_lforth_t lo, hi; 458 459 CHECK_DEPTH(env, 3, "within"); 460 hi = (u_lforth_t)POP(DS); 461 lo = (u_lforth_t)POP(DS); 462 TOS = ((((u_lforth_t)TOS >= lo) && ((u_lforth_t)TOS < hi)) ? -1 : 0); 463 } 464 465 void 466 do_literal(fcode_env_t *env) 467 { 468 PUSH(DS, *IP); 469 IP++; 470 } 471 472 void 473 literal(fcode_env_t *env) 474 { 475 if (env->state) { 476 COMPILE_TOKEN(&blit_ptr); 477 compile_comma(env); 478 } 479 } 480 481 void 482 do_also(fcode_env_t *env) 483 { 484 token_t *d = *ORDER; 485 486 if (env->order_depth < (MAX_ORDER - 1)) { 487 env->order[++env->order_depth] = d; 488 debug_msg(DEBUG_CONTEXT, "CONTEXT:also: %d/%p/%p\n", 489 env->order_depth, CONTEXT, env->current); 490 } else 491 log_message(MSG_WARN, "Vocabulary search order exceeds: %d\n", 492 MAX_ORDER); 493 } 494 495 void 496 do_previous(fcode_env_t *env) 497 { 498 if (env->order_depth) { 499 env->order_depth--; 500 debug_msg(DEBUG_CONTEXT, "CONTEXT:previous: %d/%p/%p\n", 501 env->order_depth, CONTEXT, env->current); 502 } 503 } 504 505 #ifdef DEBUG 506 void 507 do_order(fcode_env_t *env) 508 { 509 int i; 510 511 log_message(MSG_INFO, "Order: Depth: %ld: ", env->order_depth); 512 for (i = env->order_depth; i >= 0 && env->order[i]; i--) 513 log_message(MSG_INFO, "%p ", (void *)env->order[i]); 514 log_message(MSG_INFO, "\n"); 515 } 516 #endif 517 518 void 519 noop(fcode_env_t *env) 520 { 521 /* what a waste of cycles */ 522 } 523 524 525 #define FW_PER_FL (sizeof (lforth_t)/sizeof (wforth_t)) 526 527 void 528 lwsplit(fcode_env_t *env) 529 { 530 union { 531 u_wforth_t l_wf[FW_PER_FL]; 532 u_lforth_t l_lf; 533 } d; 534 int i; 535 536 CHECK_DEPTH(env, 1, "lwsplit"); 537 d.l_lf = POP(DS); 538 for (i = 0; i < FW_PER_FL; i++) 539 PUSH(DS, d.l_wf[(FW_PER_FL - 1) - i]); 540 } 541 542 void 543 wljoin(fcode_env_t *env) 544 { 545 union { 546 u_wforth_t l_wf[FW_PER_FL]; 547 u_lforth_t l_lf; 548 } d; 549 int i; 550 551 CHECK_DEPTH(env, FW_PER_FL, "wljoin"); 552 for (i = 0; i < FW_PER_FL; i++) 553 d.l_wf[i] = POP(DS); 554 PUSH(DS, d.l_lf); 555 } 556 557 void 558 lwflip(fcode_env_t *env) 559 { 560 union { 561 u_wforth_t l_wf[FW_PER_FL]; 562 u_lforth_t l_lf; 563 } d, c; 564 int i; 565 566 CHECK_DEPTH(env, 1, "lwflip"); 567 d.l_lf = POP(DS); 568 for (i = 0; i < FW_PER_FL; i++) 569 c.l_wf[i] = d.l_wf[(FW_PER_FL - 1) - i]; 570 PUSH(DS, c.l_lf); 571 } 572 573 void 574 lbsplit(fcode_env_t *env) 575 { 576 union { 577 uchar_t l_bytes[sizeof (lforth_t)]; 578 u_lforth_t l_lf; 579 } d; 580 int i; 581 582 CHECK_DEPTH(env, 1, "lbsplit"); 583 d.l_lf = POP(DS); 584 for (i = 0; i < sizeof (lforth_t); i++) 585 PUSH(DS, d.l_bytes[(sizeof (lforth_t) - 1) - i]); 586 } 587 588 void 589 bljoin(fcode_env_t *env) 590 { 591 union { 592 uchar_t l_bytes[sizeof (lforth_t)]; 593 u_lforth_t l_lf; 594 } d; 595 int i; 596 597 CHECK_DEPTH(env, sizeof (lforth_t), "bljoin"); 598 for (i = 0; i < sizeof (lforth_t); i++) 599 d.l_bytes[i] = POP(DS); 600 PUSH(DS, (fstack_t)d.l_lf); 601 } 602 603 void 604 lbflip(fcode_env_t *env) 605 { 606 union { 607 uchar_t l_bytes[sizeof (lforth_t)]; 608 u_lforth_t l_lf; 609 } d, c; 610 int i; 611 612 CHECK_DEPTH(env, 1, "lbflip"); 613 d.l_lf = POP(DS); 614 for (i = 0; i < sizeof (lforth_t); i++) 615 c.l_bytes[i] = d.l_bytes[(sizeof (lforth_t) - 1) - i]; 616 PUSH(DS, c.l_lf); 617 } 618 619 void 620 wbsplit(fcode_env_t *env) 621 { 622 union { 623 uchar_t w_bytes[sizeof (wforth_t)]; 624 u_wforth_t w_wf; 625 } d; 626 int i; 627 628 CHECK_DEPTH(env, 1, "wbsplit"); 629 d.w_wf = POP(DS); 630 for (i = 0; i < sizeof (wforth_t); i++) 631 PUSH(DS, d.w_bytes[(sizeof (wforth_t) - 1) - i]); 632 } 633 634 void 635 bwjoin(fcode_env_t *env) 636 { 637 union { 638 uchar_t w_bytes[sizeof (wforth_t)]; 639 u_wforth_t w_wf; 640 } d; 641 int i; 642 643 CHECK_DEPTH(env, sizeof (wforth_t), "bwjoin"); 644 for (i = 0; i < sizeof (wforth_t); i++) 645 d.w_bytes[i] = POP(DS); 646 PUSH(DS, d.w_wf); 647 } 648 649 void 650 wbflip(fcode_env_t *env) 651 { 652 union { 653 uchar_t w_bytes[sizeof (wforth_t)]; 654 u_wforth_t w_wf; 655 } c, d; 656 int i; 657 658 CHECK_DEPTH(env, 1, "wbflip"); 659 d.w_wf = POP(DS); 660 for (i = 0; i < sizeof (wforth_t); i++) 661 c.w_bytes[i] = d.w_bytes[(sizeof (wforth_t) - 1) - i]; 662 PUSH(DS, c.w_wf); 663 } 664 665 void 666 upper_case(fcode_env_t *env) 667 { 668 CHECK_DEPTH(env, 1, "upc"); 669 TOS = toupper(TOS); 670 } 671 672 void 673 lower_case(fcode_env_t *env) 674 { 675 CHECK_DEPTH(env, 1, "lcc"); 676 TOS = tolower(TOS); 677 } 678 679 void 680 pack_str(fcode_env_t *env) 681 { 682 char *buf; 683 size_t len; 684 char *str; 685 686 CHECK_DEPTH(env, 3, "pack"); 687 buf = (char *)POP(DS); 688 len = (size_t)POP(DS); 689 str = (char *)TOS; 690 TOS = (fstack_t)buf; 691 *buf++ = (uchar_t)len; 692 strncpy(buf, str, (len&0xff)); 693 } 694 695 void 696 count_str(fcode_env_t *env) 697 { 698 uchar_t *len; 699 700 CHECK_DEPTH(env, 1, "count"); 701 len = (uchar_t *)TOS; 702 TOS += 1; 703 PUSH(DS, *len); 704 } 705 706 void 707 to_body(fcode_env_t *env) 708 { 709 CHECK_DEPTH(env, 1, ">body"); 710 TOS = (fstack_t)(((acf_t)TOS)+1); 711 } 712 713 void 714 to_acf(fcode_env_t *env) 715 { 716 CHECK_DEPTH(env, 1, "body>"); 717 TOS = (fstack_t)(((acf_t)TOS)-1); 718 } 719 720 /* 721 * 'unloop' Fcode implementation, drop 3 loop ctrl elements off return stack. 722 */ 723 static void 724 unloop(fcode_env_t *env) 725 { 726 CHECK_RETURN_DEPTH(env, 3, "unloop"); 727 RS -= 3; 728 } 729 730 /* 731 * 'um*' Fcode implementation. 732 */ 733 static void 734 um_multiply(fcode_env_t *env) 735 { 736 ufstack_t u1, u2; 737 dforth_t d; 738 739 CHECK_DEPTH(env, 2, "um*"); 740 u1 = POP(DS); 741 u2 = POP(DS); 742 d = u1 * u2; 743 push_double(env, d); 744 } 745 746 /* 747 * um/mod (d.lo d.hi u -- urem uquot) 748 */ 749 static void 750 um_slash_mod(fcode_env_t *env) 751 { 752 u_dforth_t d; 753 uint32_t u, urem, uquot; 754 755 CHECK_DEPTH(env, 3, "um/mod"); 756 u = (uint32_t)POP(DS); 757 d = pop_double(env); 758 urem = d % u; 759 uquot = d / u; 760 PUSH(DS, urem); 761 PUSH(DS, uquot); 762 } 763 764 /* 765 * d+ (d1.lo d1.hi d2.lo d2.hi -- dsum.lo dsum.hi) 766 */ 767 static void 768 d_plus(fcode_env_t *env) 769 { 770 dforth_t d1, d2; 771 772 CHECK_DEPTH(env, 4, "d+"); 773 d2 = pop_double(env); 774 d1 = pop_double(env); 775 d1 += d2; 776 push_double(env, d1); 777 } 778 779 /* 780 * d- (d1.lo d1.hi d2.lo d2.hi -- ddif.lo ddif.hi) 781 */ 782 static void 783 d_minus(fcode_env_t *env) 784 { 785 dforth_t d1, d2; 786 787 CHECK_DEPTH(env, 4, "d-"); 788 d2 = pop_double(env); 789 d1 = pop_double(env); 790 d1 -= d2; 791 push_double(env, d1); 792 } 793 794 void 795 set_here(fcode_env_t *env, uchar_t *new_here, char *where) 796 { 797 if (new_here < HERE) { 798 if (strcmp(where, "temporary_execute")) { 799 /* 800 * Other than temporary_execute, no one should set 801 * here backwards. 802 */ 803 log_message(MSG_WARN, "Warning: set_here(%s) back: old:" 804 " %p new: %p\n", where, HERE, new_here); 805 } 806 } 807 if (new_here >= env->base + dict_size) 808 forth_abort(env, "Here (%p) set past dictionary end (%p)", 809 new_here, env->base + dict_size); 810 HERE = new_here; 811 } 812 813 static void 814 unaligned_store(fcode_env_t *env) 815 { 816 extern void unaligned_xstore(fcode_env_t *); 817 818 if (sizeof (fstack_t) == sizeof (lforth_t)) 819 unaligned_lstore(env); 820 else 821 unaligned_xstore(env); 822 } 823 824 static void 825 unaligned_fetch(fcode_env_t *env) 826 { 827 extern void unaligned_xfetch(fcode_env_t *); 828 829 if (sizeof (fstack_t) == sizeof (lforth_t)) 830 unaligned_lfetch(env); 831 else 832 unaligned_xfetch(env); 833 } 834 835 void 836 comma(fcode_env_t *env) 837 { 838 CHECK_DEPTH(env, 1, ","); 839 DEBUGF(COMMA, dump_comma(env, ",")); 840 PUSH(DS, (fstack_t)HERE); 841 unaligned_store(env); 842 set_here(env, HERE + sizeof (fstack_t), "comma"); 843 } 844 845 void 846 lcomma(fcode_env_t *env) 847 { 848 CHECK_DEPTH(env, 1, "l,"); 849 DEBUGF(COMMA, dump_comma(env, "l,")); 850 PUSH(DS, (fstack_t)HERE); 851 unaligned_lstore(env); 852 set_here(env, HERE + sizeof (u_lforth_t), "lcomma"); 853 } 854 855 void 856 wcomma(fcode_env_t *env) 857 { 858 CHECK_DEPTH(env, 1, "w,"); 859 DEBUGF(COMMA, dump_comma(env, "w,")); 860 PUSH(DS, (fstack_t)HERE); 861 unaligned_wstore(env); 862 set_here(env, HERE + sizeof (u_wforth_t), "wcomma"); 863 } 864 865 void 866 ccomma(fcode_env_t *env) 867 { 868 CHECK_DEPTH(env, 1, "c,"); 869 DEBUGF(COMMA, dump_comma(env, "c,")); 870 PUSH(DS, (fstack_t)HERE); 871 cstore(env); 872 set_here(env, HERE + sizeof (uchar_t), "ccomma"); 873 } 874 875 void 876 token_roundup(fcode_env_t *env, char *where) 877 { 878 if ((((token_t)HERE) & (sizeof (token_t) - 1)) != 0) { 879 set_here(env, (uchar_t *)TOKEN_ROUNDUP(HERE), where); 880 } 881 } 882 883 void 884 compile_comma(fcode_env_t *env) 885 { 886 CHECK_DEPTH(env, 1, "compile,"); 887 DEBUGF(COMMA, dump_comma(env, "compile,")); 888 token_roundup(env, "compile,"); 889 PUSH(DS, (fstack_t)HERE); 890 unaligned_store(env); 891 set_here(env, HERE + sizeof (fstack_t), "compile,"); 892 } 893 894 void 895 unaligned_lfetch(fcode_env_t *env) 896 { 897 fstack_t addr; 898 int i; 899 900 CHECK_DEPTH(env, 1, "unaligned-l@"); 901 addr = POP(DS); 902 for (i = 0; i < sizeof (lforth_t); i++, addr++) { 903 PUSH(DS, addr); 904 cfetch(env); 905 } 906 bljoin(env); 907 lbflip(env); 908 } 909 910 void 911 unaligned_lstore(fcode_env_t *env) 912 { 913 fstack_t addr; 914 int i; 915 916 CHECK_DEPTH(env, 2, "unaligned-l!"); 917 addr = POP(DS); 918 lbsplit(env); 919 for (i = 0; i < sizeof (lforth_t); i++, addr++) { 920 PUSH(DS, addr); 921 cstore(env); 922 } 923 } 924 925 void 926 unaligned_wfetch(fcode_env_t *env) 927 { 928 fstack_t addr; 929 int i; 930 931 CHECK_DEPTH(env, 1, "unaligned-w@"); 932 addr = POP(DS); 933 for (i = 0; i < sizeof (wforth_t); i++, addr++) { 934 PUSH(DS, addr); 935 cfetch(env); 936 } 937 bwjoin(env); 938 wbflip(env); 939 } 940 941 void 942 unaligned_wstore(fcode_env_t *env) 943 { 944 fstack_t addr; 945 int i; 946 947 CHECK_DEPTH(env, 2, "unaligned-w!"); 948 addr = POP(DS); 949 wbsplit(env); 950 for (i = 0; i < sizeof (wforth_t); i++, addr++) { 951 PUSH(DS, addr); 952 cstore(env); 953 } 954 } 955 956 /* 957 * 'lbflips' Fcode implementation. 958 */ 959 static void 960 lbflips(fcode_env_t *env) 961 { 962 fstack_t len, addr; 963 int i; 964 965 CHECK_DEPTH(env, 2, "lbflips"); 966 len = POP(DS); 967 addr = POP(DS); 968 for (i = 0; i < len; i += sizeof (lforth_t), 969 addr += sizeof (lforth_t)) { 970 PUSH(DS, addr); 971 unaligned_lfetch(env); 972 lbflip(env); 973 PUSH(DS, addr); 974 unaligned_lstore(env); 975 } 976 } 977 978 /* 979 * 'wbflips' Fcode implementation. 980 */ 981 static void 982 wbflips(fcode_env_t *env) 983 { 984 fstack_t len, addr; 985 int i; 986 987 CHECK_DEPTH(env, 2, "wbflips"); 988 len = POP(DS); 989 addr = POP(DS); 990 for (i = 0; i < len; i += sizeof (wforth_t), 991 addr += sizeof (wforth_t)) { 992 PUSH(DS, addr); 993 unaligned_wfetch(env); 994 wbflip(env); 995 PUSH(DS, addr); 996 unaligned_wstore(env); 997 } 998 } 999 1000 /* 1001 * 'lwflips' Fcode implementation. 1002 */ 1003 static void 1004 lwflips(fcode_env_t *env) 1005 { 1006 fstack_t len, addr; 1007 int i; 1008 1009 CHECK_DEPTH(env, 2, "lwflips"); 1010 len = POP(DS); 1011 addr = POP(DS); 1012 for (i = 0; i < len; i += sizeof (lforth_t), 1013 addr += sizeof (lforth_t)) { 1014 PUSH(DS, addr); 1015 unaligned_lfetch(env); 1016 lwflip(env); 1017 PUSH(DS, addr); 1018 unaligned_lstore(env); 1019 } 1020 } 1021 1022 void 1023 base(fcode_env_t *env) 1024 { 1025 PUSH(DS, (fstack_t)&env->num_base); 1026 } 1027 1028 void 1029 dot_s(fcode_env_t *env) 1030 { 1031 output_data_stack(env, MSG_INFO); 1032 } 1033 1034 void 1035 state(fcode_env_t *env) 1036 { 1037 PUSH(DS, (fstack_t)&env->state); 1038 } 1039 1040 int 1041 is_digit(char digit, int num_base, fstack_t *dptr) 1042 { 1043 int error = 0; 1044 char base; 1045 1046 if (num_base < 10) { 1047 base = '0' + (num_base-1); 1048 } else { 1049 base = 'a' + (num_base - 10); 1050 } 1051 1052 *dptr = 0; 1053 if (digit > '9') digit |= 0x20; 1054 if (((digit < '0') || (digit > base)) || 1055 ((digit > '9') && (digit < 'a') && (num_base > 10))) 1056 error = 1; 1057 else { 1058 if (digit <= '9') 1059 digit -= '0'; 1060 else 1061 digit = digit - 'a' + 10; 1062 *dptr = digit; 1063 } 1064 return (error); 1065 } 1066 1067 void 1068 dollar_number(fcode_env_t *env) 1069 { 1070 char *buf; 1071 fstack_t value; 1072 int len, sign = 1, error = 0; 1073 1074 CHECK_DEPTH(env, 2, "$number"); 1075 buf = pop_a_string(env, &len); 1076 if (*buf == '-') { 1077 sign = -1; 1078 buf++; 1079 len--; 1080 } 1081 value = 0; 1082 while (len-- && !error) { 1083 fstack_t digit; 1084 1085 if (*buf == '.') { 1086 buf++; 1087 continue; 1088 } 1089 value *= env->num_base; 1090 error = is_digit(*buf++, env->num_base, &digit); 1091 value += digit; 1092 } 1093 if (error) { 1094 PUSH(DS, -1); 1095 } else { 1096 value *= sign; 1097 PUSH(DS, value); 1098 PUSH(DS, 0); 1099 } 1100 } 1101 1102 void 1103 digit(fcode_env_t *env) 1104 { 1105 fstack_t base; 1106 fstack_t value; 1107 1108 CHECK_DEPTH(env, 2, "digit"); 1109 base = POP(DS); 1110 if (is_digit(TOS, base, &value)) 1111 PUSH(DS, 0); 1112 else { 1113 TOS = value; 1114 PUSH(DS, -1); 1115 } 1116 } 1117 1118 void 1119 space(fcode_env_t *env) 1120 { 1121 PUSH(DS, ' '); 1122 } 1123 1124 void 1125 backspace(fcode_env_t *env) 1126 { 1127 PUSH(DS, '\b'); 1128 } 1129 1130 void 1131 bell(fcode_env_t *env) 1132 { 1133 PUSH(DS, '\a'); 1134 } 1135 1136 void 1137 fc_bounds(fcode_env_t *env) 1138 { 1139 fstack_t lo, hi; 1140 1141 CHECK_DEPTH(env, 2, "bounds"); 1142 lo = DS[-1]; 1143 hi = TOS; 1144 DS[-1] = lo+hi; 1145 TOS = lo; 1146 } 1147 1148 void 1149 here(fcode_env_t *env) 1150 { 1151 PUSH(DS, (fstack_t)HERE); 1152 } 1153 1154 void 1155 aligned(fcode_env_t *env) 1156 { 1157 ufstack_t a; 1158 1159 CHECK_DEPTH(env, 1, "aligned"); 1160 a = (TOS & (sizeof (lforth_t) - 1)); 1161 if (a) 1162 TOS += (sizeof (lforth_t) - a); 1163 } 1164 1165 void 1166 instance(fcode_env_t *env) 1167 { 1168 env->instance_mode |= 1; 1169 } 1170 1171 void 1172 semi(fcode_env_t *env) 1173 { 1174 1175 env->state &= ~1; 1176 COMPILE_TOKEN(&semi_ptr); 1177 1178 /* 1179 * check if we need to supress expose action; 1180 * If so this is an internal word and has no link field 1181 * or it is a temporary compile 1182 */ 1183 1184 if (env->state == 0) { 1185 expose_acf(env, "<semi>"); 1186 } 1187 if (env->state & 8) { 1188 env->state ^= 8; 1189 } 1190 } 1191 1192 void 1193 do_create(fcode_env_t *env) 1194 { 1195 PUSH(DS, (fstack_t)WA); 1196 } 1197 1198 void 1199 drop(fcode_env_t *env) 1200 { 1201 CHECK_DEPTH(env, 1, "drop"); 1202 (void) POP(DS); 1203 } 1204 1205 void 1206 f_dup(fcode_env_t *env) 1207 { 1208 fstack_t d; 1209 1210 CHECK_DEPTH(env, 1, "dup"); 1211 d = TOS; 1212 PUSH(DS, d); 1213 } 1214 1215 void 1216 over(fcode_env_t *env) 1217 { 1218 fstack_t d; 1219 1220 CHECK_DEPTH(env, 2, "over"); 1221 d = DS[-1]; 1222 PUSH(DS, d); 1223 } 1224 1225 void 1226 swap(fcode_env_t *env) 1227 { 1228 fstack_t d; 1229 1230 CHECK_DEPTH(env, 2, "swap"); 1231 d = DS[-1]; 1232 DS[-1] = DS[0]; 1233 DS[0] = d; 1234 } 1235 1236 1237 void 1238 rot(fcode_env_t *env) 1239 { 1240 fstack_t d; 1241 1242 CHECK_DEPTH(env, 3, "rot"); 1243 d = DS[-2]; 1244 DS[-2] = DS[-1]; 1245 DS[-1] = TOS; 1246 TOS = d; 1247 } 1248 1249 void 1250 minus_rot(fcode_env_t *env) 1251 { 1252 fstack_t d; 1253 1254 CHECK_DEPTH(env, 3, "-rot"); 1255 d = TOS; 1256 TOS = DS[-1]; 1257 DS[-1] = DS[-2]; 1258 DS[-2] = d; 1259 } 1260 1261 void 1262 tuck(fcode_env_t *env) 1263 { 1264 fstack_t d; 1265 1266 CHECK_DEPTH(env, 2, "tuck"); 1267 d = TOS; 1268 swap(env); 1269 PUSH(DS, d); 1270 } 1271 1272 void 1273 nip(fcode_env_t *env) 1274 { 1275 CHECK_DEPTH(env, 2, "nip"); 1276 swap(env); 1277 drop(env); 1278 } 1279 1280 void 1281 qdup(fcode_env_t *env) 1282 { 1283 fstack_t d; 1284 1285 CHECK_DEPTH(env, 1, "?dup"); 1286 d = TOS; 1287 if (d) 1288 PUSH(DS, d); 1289 } 1290 1291 void 1292 depth(fcode_env_t *env) 1293 { 1294 fstack_t d; 1295 1296 d = DS - env->ds0; 1297 PUSH(DS, d); 1298 } 1299 1300 void 1301 pick(fcode_env_t *env) 1302 { 1303 fstack_t p; 1304 1305 CHECK_DEPTH(env, 1, "pick"); 1306 p = POP(DS); 1307 if (p < 0 || p >= (env->ds - env->ds0)) 1308 forth_abort(env, "pick: invalid pick value: %d\n", (int)p); 1309 p = DS[-p]; 1310 PUSH(DS, p); 1311 } 1312 1313 void 1314 roll(fcode_env_t *env) 1315 { 1316 fstack_t d, r; 1317 1318 CHECK_DEPTH(env, 1, "roll"); 1319 r = POP(DS); 1320 if (r <= 0 || r >= (env->ds - env->ds0)) 1321 forth_abort(env, "roll: invalid roll value: %d\n", (int)r); 1322 1323 d = DS[-r]; 1324 while (r) { 1325 DS[-r] = DS[ -(r-1) ]; 1326 r--; 1327 } 1328 TOS = d; 1329 } 1330 1331 void 1332 two_drop(fcode_env_t *env) 1333 { 1334 CHECK_DEPTH(env, 2, "2drop"); 1335 DS -= 2; 1336 } 1337 1338 void 1339 two_dup(fcode_env_t *env) 1340 { 1341 CHECK_DEPTH(env, 2, "2dup"); 1342 DS[1] = DS[-1]; 1343 DS[2] = TOS; 1344 DS += 2; 1345 } 1346 1347 void 1348 two_over(fcode_env_t *env) 1349 { 1350 fstack_t a, b; 1351 1352 CHECK_DEPTH(env, 4, "2over"); 1353 a = DS[-3]; 1354 b = DS[-2]; 1355 PUSH(DS, a); 1356 PUSH(DS, b); 1357 } 1358 1359 void 1360 two_swap(fcode_env_t *env) 1361 { 1362 fstack_t a, b; 1363 1364 CHECK_DEPTH(env, 4, "2swap"); 1365 a = DS[-3]; 1366 b = DS[-2]; 1367 DS[-3] = DS[-1]; 1368 DS[-2] = TOS; 1369 DS[-1] = a; 1370 TOS = b; 1371 } 1372 1373 void 1374 two_rot(fcode_env_t *env) 1375 { 1376 fstack_t a, b; 1377 1378 CHECK_DEPTH(env, 6, "2rot"); 1379 a = DS[-5]; 1380 b = DS[-4]; 1381 DS[-5] = DS[-3]; 1382 DS[-4] = DS[-2]; 1383 DS[-3] = DS[-1]; 1384 DS[-2] = TOS; 1385 DS[-1] = a; 1386 TOS = b; 1387 } 1388 1389 void 1390 two_slash(fcode_env_t *env) 1391 { 1392 CHECK_DEPTH(env, 1, "2/"); 1393 TOS = TOS >> 1; 1394 } 1395 1396 void 1397 utwo_slash(fcode_env_t *env) 1398 { 1399 CHECK_DEPTH(env, 1, "u2/"); 1400 TOS = (ufstack_t)((ufstack_t)TOS) >> 1; 1401 } 1402 1403 void 1404 two_times(fcode_env_t *env) 1405 { 1406 CHECK_DEPTH(env, 1, "2*"); 1407 TOS = (ufstack_t)((ufstack_t)TOS) << 1; 1408 } 1409 1410 void 1411 slash_c(fcode_env_t *env) 1412 { 1413 PUSH(DS, sizeof (char)); 1414 } 1415 1416 void 1417 slash_w(fcode_env_t *env) 1418 { 1419 PUSH(DS, sizeof (wforth_t)); 1420 } 1421 1422 void 1423 slash_l(fcode_env_t *env) 1424 { 1425 PUSH(DS, sizeof (lforth_t)); 1426 } 1427 1428 void 1429 slash_n(fcode_env_t *env) 1430 { 1431 PUSH(DS, sizeof (fstack_t)); 1432 } 1433 1434 void 1435 ca_plus(fcode_env_t *env) 1436 { 1437 fstack_t d; 1438 1439 CHECK_DEPTH(env, 2, "ca+"); 1440 d = POP(DS); 1441 TOS += d * sizeof (char); 1442 } 1443 1444 void 1445 wa_plus(fcode_env_t *env) 1446 { 1447 fstack_t d; 1448 1449 CHECK_DEPTH(env, 2, "wa+"); 1450 d = POP(DS); 1451 TOS += d * sizeof (wforth_t); 1452 } 1453 1454 void 1455 la_plus(fcode_env_t *env) 1456 { 1457 fstack_t d; 1458 1459 CHECK_DEPTH(env, 2, "la+"); 1460 d = POP(DS); 1461 TOS += d * sizeof (lforth_t); 1462 } 1463 1464 void 1465 na_plus(fcode_env_t *env) 1466 { 1467 fstack_t d; 1468 1469 CHECK_DEPTH(env, 2, "na+"); 1470 d = POP(DS); 1471 TOS += d * sizeof (fstack_t); 1472 } 1473 1474 void 1475 char_plus(fcode_env_t *env) 1476 { 1477 CHECK_DEPTH(env, 1, "char+"); 1478 TOS += sizeof (char); 1479 } 1480 1481 void 1482 wa1_plus(fcode_env_t *env) 1483 { 1484 CHECK_DEPTH(env, 1, "wa1+"); 1485 TOS += sizeof (wforth_t); 1486 } 1487 1488 void 1489 la1_plus(fcode_env_t *env) 1490 { 1491 CHECK_DEPTH(env, 1, "la1+"); 1492 TOS += sizeof (lforth_t); 1493 } 1494 1495 void 1496 cell_plus(fcode_env_t *env) 1497 { 1498 CHECK_DEPTH(env, 1, "cell+"); 1499 TOS += sizeof (fstack_t); 1500 } 1501 1502 void 1503 do_chars(fcode_env_t *env) 1504 { 1505 CHECK_DEPTH(env, 1, "chars"); 1506 } 1507 1508 void 1509 slash_w_times(fcode_env_t *env) 1510 { 1511 CHECK_DEPTH(env, 1, "/w*"); 1512 TOS *= sizeof (wforth_t); 1513 } 1514 1515 void 1516 slash_l_times(fcode_env_t *env) 1517 { 1518 CHECK_DEPTH(env, 1, "/l*"); 1519 TOS *= sizeof (lforth_t); 1520 } 1521 1522 void 1523 cells(fcode_env_t *env) 1524 { 1525 CHECK_DEPTH(env, 1, "cells"); 1526 TOS *= sizeof (fstack_t); 1527 } 1528 1529 void 1530 do_on(fcode_env_t *env) 1531 { 1532 variable_t *d; 1533 1534 CHECK_DEPTH(env, 1, "on"); 1535 d = (variable_t *)POP(DS); 1536 *d = -1; 1537 } 1538 1539 void 1540 do_off(fcode_env_t *env) 1541 { 1542 variable_t *d; 1543 1544 CHECK_DEPTH(env, 1, "off"); 1545 d = (variable_t *)POP(DS); 1546 *d = 0; 1547 } 1548 1549 void 1550 fetch(fcode_env_t *env) 1551 { 1552 CHECK_DEPTH(env, 1, "@"); 1553 TOS = *((variable_t *)TOS); 1554 } 1555 1556 void 1557 lfetch(fcode_env_t *env) 1558 { 1559 CHECK_DEPTH(env, 1, "l@"); 1560 TOS = *((lforth_t *)TOS); 1561 } 1562 1563 void 1564 wfetch(fcode_env_t *env) 1565 { 1566 CHECK_DEPTH(env, 1, "w@"); 1567 TOS = *((wforth_t *)TOS); 1568 } 1569 1570 void 1571 swfetch(fcode_env_t *env) 1572 { 1573 CHECK_DEPTH(env, 1, "<w@"); 1574 TOS = *((s_wforth_t *)TOS); 1575 } 1576 1577 void 1578 cfetch(fcode_env_t *env) 1579 { 1580 CHECK_DEPTH(env, 1, "c@"); 1581 TOS = *((uchar_t *)TOS); 1582 } 1583 1584 void 1585 store(fcode_env_t *env) 1586 { 1587 variable_t *dptr; 1588 1589 CHECK_DEPTH(env, 2, "!"); 1590 dptr = (variable_t *)POP(DS); 1591 *dptr = POP(DS); 1592 } 1593 1594 void 1595 addstore(fcode_env_t *env) 1596 { 1597 variable_t *dptr; 1598 1599 CHECK_DEPTH(env, 2, "+!"); 1600 dptr = (variable_t *)POP(DS); 1601 *dptr = POP(DS) + *dptr; 1602 } 1603 1604 void 1605 lstore(fcode_env_t *env) 1606 { 1607 lforth_t *dptr; 1608 1609 CHECK_DEPTH(env, 2, "l!"); 1610 dptr = (lforth_t *)POP(DS); 1611 *dptr = (lforth_t)POP(DS); 1612 } 1613 1614 void 1615 wstore(fcode_env_t *env) 1616 { 1617 wforth_t *dptr; 1618 1619 CHECK_DEPTH(env, 2, "w!"); 1620 dptr = (wforth_t *)POP(DS); 1621 *dptr = (wforth_t)POP(DS); 1622 } 1623 1624 void 1625 cstore(fcode_env_t *env) 1626 { 1627 uchar_t *dptr; 1628 1629 CHECK_DEPTH(env, 2, "c!"); 1630 dptr = (uchar_t *)POP(DS); 1631 *dptr = (uchar_t)POP(DS); 1632 } 1633 1634 void 1635 two_fetch(fcode_env_t *env) 1636 { 1637 variable_t *d; 1638 1639 CHECK_DEPTH(env, 1, "2@"); 1640 d = (variable_t *)POP(DS); 1641 PUSH(DS, (fstack_t)(d + 1)); 1642 unaligned_fetch(env); 1643 PUSH(DS, (fstack_t)d); 1644 unaligned_fetch(env); 1645 } 1646 1647 void 1648 two_store(fcode_env_t *env) 1649 { 1650 variable_t *d; 1651 1652 CHECK_DEPTH(env, 3, "2!"); 1653 d = (variable_t *)POP(DS); 1654 PUSH(DS, (fstack_t)d); 1655 unaligned_store(env); 1656 PUSH(DS, (fstack_t)(d + 1)); 1657 unaligned_store(env); 1658 } 1659 1660 /* 1661 * 'move' Fcode reimplemented in fcdriver to check for mapped addresses. 1662 */ 1663 void 1664 fc_move(fcode_env_t *env) 1665 { 1666 void *dest, *src; 1667 size_t len; 1668 1669 CHECK_DEPTH(env, 3, "move"); 1670 len = (size_t)POP(DS); 1671 dest = (void *)POP(DS); 1672 src = (void *)POP(DS); 1673 1674 memmove(dest, src, len); 1675 } 1676 1677 void 1678 fc_fill(fcode_env_t *env) 1679 { 1680 void *dest; 1681 uchar_t val; 1682 size_t len; 1683 1684 CHECK_DEPTH(env, 3, "fill"); 1685 val = (uchar_t)POP(DS); 1686 len = (size_t)POP(DS); 1687 dest = (void *)POP(DS); 1688 memset(dest, val, len); 1689 } 1690 1691 void 1692 fc_comp(fcode_env_t *env) 1693 { 1694 char *str1, *str2; 1695 size_t len; 1696 int res; 1697 1698 CHECK_DEPTH(env, 3, "comp"); 1699 len = (size_t)POP(DS); 1700 str1 = (char *)POP(DS); 1701 str2 = (char *)POP(DS); 1702 res = memcmp(str2, str1, len); 1703 if (res > 0) 1704 res = 1; 1705 else if (res < 0) 1706 res = -1; 1707 PUSH(DS, res); 1708 } 1709 1710 void 1711 set_temporary_compile(fcode_env_t *env) 1712 { 1713 if (!env->state) { 1714 token_roundup(env, "set_temporary_compile"); 1715 PUSH(RS, (fstack_t)HERE); 1716 env->state = 3; 1717 COMPILE_TOKEN(&do_colon); 1718 } 1719 } 1720 1721 void 1722 bmark(fcode_env_t *env) 1723 { 1724 set_temporary_compile(env); 1725 env->level++; 1726 PUSH(DS, (fstack_t)HERE); 1727 } 1728 1729 void 1730 temporary_execute(fcode_env_t *env) 1731 { 1732 uchar_t *saved_here; 1733 1734 if ((env->level == 0) && (env->state & 2)) { 1735 fstack_t d = POP(RS); 1736 1737 semi(env); 1738 1739 saved_here = HERE; 1740 /* execute the temporary definition */ 1741 env->state &= ~2; 1742 PUSH(DS, d); 1743 execute(env); 1744 1745 /* now wind the dictionary back! */ 1746 if (saved_here != HERE) { 1747 debug_msg(DEBUG_COMMA, "Ignoring set_here in" 1748 " temporary_execute\n"); 1749 } else 1750 set_here(env, (uchar_t *)d, "temporary_execute"); 1751 } 1752 } 1753 1754 void 1755 bresolve(fcode_env_t *env) 1756 { 1757 token_t *prev = (token_t *)POP(DS); 1758 1759 env->level--; 1760 *prev = (token_t)HERE; 1761 temporary_execute(env); 1762 } 1763 1764 #define BRANCH_IP(ipp) ((token_t *)(*((token_t *)(ipp)))) 1765 1766 void 1767 do_bbranch(fcode_env_t *env) 1768 { 1769 IP = BRANCH_IP(IP); 1770 } 1771 1772 void 1773 do_bqbranch(fcode_env_t *env) 1774 { 1775 fstack_t flag; 1776 1777 CHECK_DEPTH(env, 1, "b?branch"); 1778 flag = POP(DS); 1779 if (flag) { 1780 IP++; 1781 } else { 1782 IP = BRANCH_IP(IP); 1783 } 1784 } 1785 1786 void 1787 do_bofbranch(fcode_env_t *env) 1788 { 1789 fstack_t d; 1790 1791 CHECK_DEPTH(env, 2, "bofbranch"); 1792 d = POP(DS); 1793 if (d == TOS) { 1794 (void) POP(DS); 1795 IP++; 1796 } else { 1797 IP = BRANCH_IP(IP); 1798 } 1799 } 1800 1801 void 1802 do_bleave(fcode_env_t *env) 1803 { 1804 CHECK_RETURN_DEPTH(env, 3, "do_bleave"); 1805 (void) POP(RS); 1806 (void) POP(RS); 1807 IP = (token_t *)POP(RS); 1808 } 1809 1810 void 1811 loop_inc(fcode_env_t *env, fstack_t inc) 1812 { 1813 ufstack_t a; 1814 1815 CHECK_RETURN_DEPTH(env, 2, "loop_inc"); 1816 1817 /* 1818 * Note: end condition is when the sign bit of R[0] changes. 1819 */ 1820 a = RS[0]; 1821 RS[0] += inc; 1822 if (((a ^ RS[0]) & SIGN_BIT) == 0) { 1823 IP = BRANCH_IP(IP); 1824 } else { 1825 do_bleave(env); 1826 } 1827 } 1828 1829 void 1830 do_bloop(fcode_env_t *env) 1831 { 1832 loop_inc(env, 1); 1833 } 1834 1835 void 1836 do_bploop(fcode_env_t *env) 1837 { 1838 fstack_t d; 1839 1840 CHECK_DEPTH(env, 1, "+loop"); 1841 d = POP(DS); 1842 loop_inc(env, d); 1843 } 1844 1845 void 1846 loop_common(fcode_env_t *env, fstack_t ptr) 1847 { 1848 short offset = get_short(env); 1849 1850 COMPILE_TOKEN(ptr); 1851 env->level--; 1852 compile_comma(env); 1853 bresolve(env); 1854 } 1855 1856 void 1857 bloop(fcode_env_t *env) 1858 { 1859 loop_common(env, (fstack_t)&do_loop_ptr); 1860 } 1861 1862 void 1863 bplusloop(fcode_env_t *env) 1864 { 1865 loop_common(env, (fstack_t)&do_ploop_ptr); 1866 } 1867 1868 void 1869 common_do(fcode_env_t *env, fstack_t endpt, fstack_t start, fstack_t limit) 1870 { 1871 ufstack_t i, l; 1872 1873 /* 1874 * Same computation as OBP, sets up so that loop_inc will terminate 1875 * when the sign bit of RS[0] changes. 1876 */ 1877 i = (start - limit) - SIGN_BIT; 1878 l = limit + SIGN_BIT; 1879 PUSH(RS, endpt); 1880 PUSH(RS, l); 1881 PUSH(RS, i); 1882 } 1883 1884 void 1885 do_bdo(fcode_env_t *env) 1886 { 1887 fstack_t lo, hi; 1888 fstack_t endpt; 1889 1890 CHECK_DEPTH(env, 2, "bdo"); 1891 endpt = (fstack_t)BRANCH_IP(IP); 1892 IP++; 1893 lo = POP(DS); 1894 hi = POP(DS); 1895 common_do(env, endpt, lo, hi); 1896 } 1897 1898 void 1899 do_bqdo(fcode_env_t *env) 1900 { 1901 fstack_t lo, hi; 1902 fstack_t endpt; 1903 1904 CHECK_DEPTH(env, 2, "b?do"); 1905 endpt = (fstack_t)BRANCH_IP(IP); 1906 IP++; 1907 lo = POP(DS); 1908 hi = POP(DS); 1909 if (lo == hi) { 1910 IP = (token_t *)endpt; 1911 } else { 1912 common_do(env, endpt, lo, hi); 1913 } 1914 } 1915 1916 void 1917 compile_do_common(fcode_env_t *env, fstack_t ptr) 1918 { 1919 set_temporary_compile(env); 1920 COMPILE_TOKEN(ptr); 1921 bmark(env); 1922 COMPILE_TOKEN(0); 1923 bmark(env); 1924 } 1925 1926 void 1927 bdo(fcode_env_t *env) 1928 { 1929 short offset = (short)get_short(env); 1930 compile_do_common(env, (fstack_t)&do_bdo_ptr); 1931 } 1932 1933 void 1934 bqdo(fcode_env_t *env) 1935 { 1936 short offset = (short)get_short(env); 1937 compile_do_common(env, (fstack_t)&do_bqdo_ptr); 1938 } 1939 1940 void 1941 loop_i(fcode_env_t *env) 1942 { 1943 fstack_t i; 1944 1945 CHECK_RETURN_DEPTH(env, 2, "i"); 1946 i = RS[0] + RS[-1]; 1947 PUSH(DS, i); 1948 } 1949 1950 void 1951 loop_j(fcode_env_t *env) 1952 { 1953 fstack_t j; 1954 1955 CHECK_RETURN_DEPTH(env, 5, "j"); 1956 j = RS[-3] + RS[-4]; 1957 PUSH(DS, j); 1958 } 1959 1960 void 1961 bleave(fcode_env_t *env) 1962 { 1963 1964 if (env->state) { 1965 COMPILE_TOKEN(&do_leave_ptr); 1966 } 1967 } 1968 1969 void 1970 push_string(fcode_env_t *env, char *str, int len) 1971 { 1972 #define NSTRINGS 16 1973 static int string_count = 0; 1974 static int buflen[NSTRINGS]; 1975 static char *buffer[NSTRINGS]; 1976 char *dest; 1977 1978 if (!len) { 1979 PUSH(DS, 0); 1980 PUSH(DS, 0); 1981 return; 1982 } 1983 if (len != buflen[string_count]) { 1984 if (buffer[string_count]) FREE(buffer[string_count]); 1985 buffer[ string_count ] = (char *)MALLOC(len+1); 1986 buflen[ string_count ] = len; 1987 } 1988 dest = buffer[ string_count++ ]; 1989 string_count = string_count%NSTRINGS; 1990 memcpy(dest, str, len); 1991 *(dest+len) = 0; 1992 PUSH(DS, (fstack_t)dest); 1993 PUSH(DS, len); 1994 #undef NSTRINGS 1995 } 1996 1997 void 1998 parse_word(fcode_env_t *env) 1999 { 2000 int len = 0; 2001 char *next, *dest, *here = ""; 2002 2003 if (env->input) { 2004 here = env->input->scanptr; 2005 while (*here == env->input->separator) here++; 2006 next = strchr(here, env->input->separator); 2007 if (next) { 2008 len = next - here; 2009 while (*next == env->input->separator) next++; 2010 } else { 2011 len = strlen(here); 2012 next = here + len; 2013 } 2014 env->input->scanptr = next; 2015 } 2016 push_string(env, here, len); 2017 } 2018 2019 void 2020 install_does(fcode_env_t *env) 2021 { 2022 token_t *dptr; 2023 2024 dptr = (token_t *)LINK_TO_ACF(env->lastlink); 2025 2026 log_message(MSG_WARN, "install_does: Last acf at: %p\n", (void *)dptr); 2027 2028 *dptr = ((token_t)(IP+1)) | 1; 2029 } 2030 2031 void 2032 does(fcode_env_t *env) 2033 { 2034 token_t *dptr; 2035 2036 token_roundup(env, "does"); 2037 2038 if (env->state) { 2039 COMPILE_TOKEN(&does_ptr); 2040 COMPILE_TOKEN(&semi_ptr); 2041 } else { 2042 dptr = (token_t *)LINK_TO_ACF(env->lastlink); 2043 log_message(MSG_WARN, "does: Last acf at: %p\n", (void *)dptr); 2044 *dptr = ((token_t)(HERE)) | 1; 2045 env->state |= 1; 2046 } 2047 COMPILE_TOKEN(&do_colon); 2048 } 2049 2050 void 2051 do_current(fcode_env_t *env) 2052 { 2053 debug_msg(DEBUG_CONTEXT, "CONTEXT:pushing &CURRENT\n"); 2054 PUSH(DS, (fstack_t)&env->current); 2055 } 2056 2057 void 2058 do_context(fcode_env_t *env) 2059 { 2060 debug_msg(DEBUG_CONTEXT, "CONTEXT:pushing &CONTEXT\n"); 2061 PUSH(DS, (fstack_t)&CONTEXT); 2062 } 2063 2064 void 2065 do_definitions(fcode_env_t *env) 2066 { 2067 env->current = CONTEXT; 2068 debug_msg(DEBUG_CONTEXT, "CONTEXT:definitions: %d/%p/%p\n", 2069 env->order_depth, CONTEXT, env->current); 2070 } 2071 2072 void 2073 make_header(fcode_env_t *env, int flags) 2074 { 2075 int len; 2076 char *name; 2077 2078 name = parse_a_string(env, &len); 2079 header(env, name, len, flags); 2080 } 2081 2082 void 2083 do_creator(fcode_env_t *env) 2084 { 2085 make_header(env, 0); 2086 COMPILE_TOKEN(&do_create); 2087 expose_acf(env, "<create>"); 2088 } 2089 2090 void 2091 create(fcode_env_t *env) 2092 { 2093 if (env->state) { 2094 COMPILE_TOKEN(&create_ptr); 2095 } else 2096 do_creator(env); 2097 } 2098 2099 void 2100 colon(fcode_env_t *env) 2101 { 2102 make_header(env, 0); 2103 env->state |= 1; 2104 COMPILE_TOKEN(&do_colon); 2105 } 2106 2107 void 2108 recursive(fcode_env_t *env) 2109 { 2110 expose_acf(env, "<recursive>"); 2111 } 2112 2113 void 2114 compile_string(fcode_env_t *env) 2115 { 2116 int len; 2117 uchar_t *str, *tostr; 2118 2119 COMPILE_TOKEN("e_ptr); 2120 len = POP(DS); 2121 str = (uchar_t *)POP(DS); 2122 tostr = HERE; 2123 *tostr++ = len; 2124 while (len--) 2125 *tostr++ = *str++; 2126 *tostr++ = '\0'; 2127 set_here(env, tostr, "compile_string"); 2128 token_roundup(env, "compile_string"); 2129 } 2130 2131 void 2132 run_quote(fcode_env_t *env) 2133 { 2134 char osep; 2135 2136 osep = env->input->separator; 2137 env->input->separator = '"'; 2138 parse_word(env); 2139 env->input->separator = osep; 2140 2141 if (env->state) { 2142 compile_string(env); 2143 } 2144 } 2145 2146 void 2147 does_vocabulary(fcode_env_t *env) 2148 { 2149 CONTEXT = WA; 2150 debug_msg(DEBUG_CONTEXT, "CONTEXT:vocabulary: %d/%p/%p\n", 2151 env->order_depth, CONTEXT, env->current); 2152 } 2153 2154 void 2155 do_vocab(fcode_env_t *env) 2156 { 2157 make_header(env, 0); 2158 COMPILE_TOKEN(does_vocabulary); 2159 PUSH(DS, 0); 2160 compile_comma(env); 2161 expose_acf(env, "<vocabulary>"); 2162 } 2163 2164 void 2165 do_forth(fcode_env_t *env) 2166 { 2167 CONTEXT = (token_t *)(&env->forth_voc_link); 2168 debug_msg(DEBUG_CONTEXT, "CONTEXT:forth: %d/%p/%p\n", 2169 env->order_depth, CONTEXT, env->current); 2170 } 2171 2172 acf_t 2173 voc_find(fcode_env_t *env) 2174 { 2175 token_t *voc; 2176 token_t *dptr; 2177 char *find_name, *name; 2178 2179 voc = (token_t *)POP(DS); 2180 find_name = pop_a_string(env, NULL); 2181 2182 for (dptr = (token_t *)(*voc); dptr; dptr = (token_t *)(*dptr)) { 2183 if ((name = get_name(dptr)) == NULL) 2184 continue; 2185 if (strcmp(find_name, name) == 0) { 2186 debug_msg(DEBUG_VOC_FIND, "%s -> %p\n", find_name, 2187 LINK_TO_ACF(dptr)); 2188 return (LINK_TO_ACF(dptr)); 2189 } 2190 } 2191 debug_msg(DEBUG_VOC_FIND, "%s not found\n", find_name); 2192 return (NULL); 2193 } 2194 2195 void 2196 dollar_find(fcode_env_t *env) 2197 { 2198 acf_t acf = NULL; 2199 int i; 2200 2201 CHECK_DEPTH(env, 2, "$find"); 2202 for (i = env->order_depth; i >= 0 && env->order[i] && !acf; i--) { 2203 two_dup(env); 2204 PUSH(DS, (fstack_t)env->order[i]); 2205 acf = voc_find(env); 2206 } 2207 if (acf) { 2208 two_drop(env); 2209 PUSH(DS, (fstack_t)acf); 2210 PUSH(DS, TRUE); 2211 } else 2212 PUSH(DS, FALSE); 2213 } 2214 2215 void 2216 interpret(fcode_env_t *env) 2217 { 2218 char *name; 2219 2220 parse_word(env); 2221 while (TOS) { 2222 two_dup(env); 2223 dollar_find(env); 2224 if (TOS) { 2225 flag_t *flags; 2226 2227 drop(env); 2228 nip(env); 2229 nip(env); 2230 flags = LINK_TO_FLAGS(ACF_TO_LINK(TOS)); 2231 2232 if ((env->state) && 2233 ((*flags & IMMEDIATE) == 0)) { 2234 /* Compile in references */ 2235 compile_comma(env); 2236 } else { 2237 execute(env); 2238 } 2239 } else { 2240 int bad; 2241 drop(env); 2242 dollar_number(env); 2243 bad = POP(DS); 2244 if (bad) { 2245 two_dup(env); 2246 name = pop_a_string(env, NULL); 2247 log_message(MSG_INFO, "%s?\n", name); 2248 break; 2249 } else { 2250 nip(env); 2251 nip(env); 2252 literal(env); 2253 } 2254 } 2255 parse_word(env); 2256 } 2257 two_drop(env); 2258 } 2259 2260 void 2261 evaluate(fcode_env_t *env) 2262 { 2263 input_typ *old_input = env->input; 2264 input_typ *eval_bufp = MALLOC(sizeof (input_typ)); 2265 2266 CHECK_DEPTH(env, 2, "evaluate"); 2267 eval_bufp->separator = ' '; 2268 eval_bufp->maxlen = POP(DS); 2269 eval_bufp->buffer = (char *)POP(DS); 2270 eval_bufp->scanptr = eval_bufp->buffer; 2271 env->input = eval_bufp; 2272 interpret(env); 2273 FREE(eval_bufp); 2274 env->input = old_input; 2275 } 2276 2277 void 2278 make_common_access(fcode_env_t *env, 2279 char *name, int len, 2280 int ncells, 2281 int instance_mode, 2282 void (*acf_instance)(fcode_env_t *env), 2283 void (*acf_static)(fcode_env_t *env), 2284 void (*set_action)(fcode_env_t *env, int)) 2285 { 2286 if (instance_mode && !MYSELF) { 2287 system_message(env, "No instance context"); 2288 } 2289 2290 debug_msg(DEBUG_ACTIONS, "make_common_access:%s '%s', %d\n", 2291 (instance_mode ? "instance" : ""), 2292 (name ? name : ""), ncells); 2293 2294 if (len) 2295 header(env, name, len, 0); 2296 if (instance_mode) { 2297 token_t *dptr; 2298 int offset; 2299 2300 COMPILE_TOKEN(acf_instance); 2301 dptr = alloc_instance_data(env, INIT_DATA, ncells, &offset); 2302 debug_msg(DEBUG_ACTIONS, "Data: %p, offset %d\n", (char *)dptr, 2303 offset); 2304 PUSH(DS, offset); 2305 compile_comma(env); 2306 while (ncells--) 2307 *dptr++ = MYSELF->data[INIT_DATA][offset++] = POP(DS); 2308 env->instance_mode = 0; 2309 } else { 2310 COMPILE_TOKEN(acf_static); 2311 while (ncells--) 2312 compile_comma(env); 2313 } 2314 expose_acf(env, name); 2315 if (set_action) 2316 set_action(env, instance_mode); 2317 } 2318 2319 void 2320 do_constant(fcode_env_t *env) 2321 { 2322 PUSH(DS, (variable_t)(*WA)); 2323 } 2324 2325 void 2326 do_crash(fcode_env_t *env) 2327 { 2328 forth_abort(env, "Unitialized defer"); 2329 } 2330 2331 /* 2332 * 'behavior' Fcode retrieve execution behavior for a defer word. 2333 */ 2334 static void 2335 behavior(fcode_env_t *env) 2336 { 2337 acf_t defer_xt; 2338 token_t token; 2339 acf_t contents_xt; 2340 2341 CHECK_DEPTH(env, 1, "behavior"); 2342 defer_xt = (acf_t)POP(DS); 2343 token = *defer_xt; 2344 contents_xt = (token_t *)(token & ~1); 2345 if ((token & 1) == 0 || *contents_xt != (token_t)&do_default_action) 2346 forth_abort(env, "behavior: bad xt: %p indir: %x/%p\n", 2347 defer_xt, token & 1, *contents_xt); 2348 defer_xt++; 2349 PUSH(DS, *((variable_t *)defer_xt)); 2350 } 2351 2352 void 2353 fc_abort(fcode_env_t *env, char *type) 2354 { 2355 forth_abort(env, "%s Fcode '%s' Executed", type, 2356 acf_to_name(env, WA - 1)); 2357 } 2358 2359 void 2360 f_abort(fcode_env_t *env) 2361 { 2362 fc_abort(env, "Abort"); 2363 } 2364 2365 /* 2366 * Fcodes chosen not to support. 2367 */ 2368 void 2369 fc_unimplemented(fcode_env_t *env) 2370 { 2371 fc_abort(env, "Unimplemented"); 2372 } 2373 2374 /* 2375 * Fcodes that are Obsolete per P1275-1994. 2376 */ 2377 void 2378 fc_obsolete(fcode_env_t *env) 2379 { 2380 fc_abort(env, "Obsolete"); 2381 } 2382 2383 /* 2384 * Fcodes that are Historical per P1275-1994 2385 */ 2386 void 2387 fc_historical(fcode_env_t *env) 2388 { 2389 fc_abort(env, "Historical"); 2390 } 2391 2392 void 2393 catch(fcode_env_t *env) 2394 { 2395 error_frame *new; 2396 2397 CHECK_DEPTH(env, 1, "catch"); 2398 new = MALLOC(sizeof (error_frame)); 2399 new->ds = DS-1; 2400 new->rs = RS; 2401 new->myself = MYSELF; 2402 new->next = env->catch_frame; 2403 new->code = 0; 2404 env->catch_frame = new; 2405 execute(env); 2406 PUSH(DS, new->code); 2407 env->catch_frame = new->next; 2408 FREE(new); 2409 } 2410 2411 void 2412 throw_from_fclib(fcode_env_t *env, fstack_t errcode, char *fmt, ...) 2413 { 2414 error_frame *efp; 2415 va_list ap; 2416 char msg[256]; 2417 2418 va_start(ap, fmt); 2419 vsprintf(msg, fmt, ap); 2420 2421 if (errcode) { 2422 2423 env->last_error = errcode; 2424 2425 /* 2426 * No catch frame set => fatal error 2427 */ 2428 efp = env->catch_frame; 2429 if (!efp) 2430 forth_abort(env, "%s: No catch frame", msg); 2431 2432 debug_msg(DEBUG_TRACING, "throw_from_fclib: throw: %s\n", msg); 2433 2434 /* 2435 * Setting IP=0 will force the unwinding of the calls 2436 * (see execute) which is how we will return (eventually) 2437 * to the test in catch that follows 'execute'. 2438 */ 2439 DS = efp->ds; 2440 RS = efp->rs; 2441 MYSELF = efp->myself; 2442 IP = 0; 2443 efp->code = errcode; 2444 } 2445 } 2446 2447 void 2448 throw(fcode_env_t *env) 2449 { 2450 fstack_t t; 2451 2452 CHECK_DEPTH(env, 1, "throw"); 2453 t = POP(DS); 2454 if (t >= -20 && t <= 20) 2455 throw_from_fclib(env, t, "throw Fcode errcode: 0x%x", (int)t); 2456 else { 2457 if (t) 2458 log_message(MSG_ERROR, "throw: errcode: 0x%x\n", 2459 (int)t); 2460 throw_from_fclib(env, t, "throw Fcode err: %s", (char *)t); 2461 } 2462 } 2463 2464 void 2465 tick_literal(fcode_env_t *env) 2466 { 2467 if (env->state) { 2468 COMPILE_TOKEN(&tlit_ptr); 2469 compile_comma(env); 2470 } 2471 } 2472 2473 void 2474 do_tick(fcode_env_t *env) 2475 { 2476 parse_word(env); 2477 dollar_find(env); 2478 invert(env); 2479 throw(env); 2480 tick_literal(env); 2481 } 2482 2483 void 2484 bracket_tick(fcode_env_t *env) 2485 { 2486 do_tick(env); 2487 } 2488 2489 #pragma init(_init) 2490 2491 static void 2492 _init(void) 2493 { 2494 fcode_env_t *env = initial_env; 2495 2496 NOTICE; 2497 ASSERT(env); 2498 2499 ANSI(0x019, 0, "i", loop_i); 2500 ANSI(0x01a, 0, "j", loop_j); 2501 ANSI(0x01d, 0, "execute", execute); 2502 ANSI(0x01e, 0, "+", add); 2503 ANSI(0x01f, 0, "-", subtract); 2504 ANSI(0x020, 0, "*", multiply); 2505 ANSI(0x021, 0, "/", divide); 2506 ANSI(0x022, 0, "mod", mod); 2507 FORTH(0, "/mod", slash_mod); 2508 ANSI(0x023, 0, "and", and); 2509 ANSI(0x024, 0, "or", or); 2510 ANSI(0x025, 0, "xor", xor); 2511 ANSI(0x026, 0, "invert", invert); 2512 ANSI(0x027, 0, "lshift", lshift); 2513 ANSI(0x028, 0, "rshift", rshift); 2514 ANSI(0x029, 0, ">>a", rshifta); 2515 ANSI(0x02a, 0, "/mod", slash_mod); 2516 ANSI(0x02b, 0, "u/mod", uslash_mod); 2517 ANSI(0x02c, 0, "negate", negate); 2518 ANSI(0x02d, 0, "abs", f_abs); 2519 ANSI(0x02e, 0, "min", f_min); 2520 ANSI(0x02f, 0, "max", f_max); 2521 ANSI(0x030, 0, ">r", to_r); 2522 ANSI(0x031, 0, "r>", from_r); 2523 ANSI(0x032, 0, "r@", rfetch); 2524 ANSI(0x033, 0, "exit", f_exit); 2525 ANSI(0x034, 0, "0=", zero_equals); 2526 ANSI(0x035, 0, "0<>", zero_not_equals); 2527 ANSI(0x036, 0, "0<", zero_less); 2528 ANSI(0x037, 0, "0<=", zero_less_equals); 2529 ANSI(0x038, 0, "0>", zero_greater); 2530 ANSI(0x039, 0, "0>=", zero_greater_equals); 2531 ANSI(0x03a, 0, "<", less); 2532 ANSI(0x03b, 0, ">", greater); 2533 ANSI(0x03c, 0, "=", equals); 2534 ANSI(0x03d, 0, "<>", not_equals); 2535 ANSI(0x03e, 0, "u>", unsign_greater); 2536 ANSI(0x03f, 0, "u<=", unsign_less_equals); 2537 ANSI(0x040, 0, "u<", unsign_less); 2538 ANSI(0x041, 0, "u>=", unsign_greater_equals); 2539 ANSI(0x042, 0, ">=", greater_equals); 2540 ANSI(0x043, 0, "<=", less_equals); 2541 ANSI(0x044, 0, "between", between); 2542 ANSI(0x045, 0, "within", within); 2543 ANSI(0x046, 0, "drop", drop); 2544 ANSI(0x047, 0, "dup", f_dup); 2545 ANSI(0x048, 0, "over", over); 2546 ANSI(0x049, 0, "swap", swap); 2547 ANSI(0x04a, 0, "rot", rot); 2548 ANSI(0x04b, 0, "-rot", minus_rot); 2549 ANSI(0x04c, 0, "tuck", tuck); 2550 ANSI(0x04d, 0, "nip", nip); 2551 ANSI(0x04e, 0, "pick", pick); 2552 ANSI(0x04f, 0, "roll", roll); 2553 ANSI(0x050, 0, "?dup", qdup); 2554 ANSI(0x051, 0, "depth", depth); 2555 ANSI(0x052, 0, "2drop", two_drop); 2556 ANSI(0x053, 0, "2dup", two_dup); 2557 ANSI(0x054, 0, "2over", two_over); 2558 ANSI(0x055, 0, "2swap", two_swap); 2559 ANSI(0x056, 0, "2rot", two_rot); 2560 ANSI(0x057, 0, "2/", two_slash); 2561 ANSI(0x058, 0, "u2/", utwo_slash); 2562 ANSI(0x059, 0, "2*", two_times); 2563 ANSI(0x05a, 0, "/c", slash_c); 2564 ANSI(0x05b, 0, "/w", slash_w); 2565 ANSI(0x05c, 0, "/l", slash_l); 2566 ANSI(0x05d, 0, "/n", slash_n); 2567 ANSI(0x05e, 0, "ca+", ca_plus); 2568 ANSI(0x05f, 0, "wa+", wa_plus); 2569 ANSI(0x060, 0, "la+", la_plus); 2570 ANSI(0x061, 0, "na+", na_plus); 2571 ANSI(0x062, 0, "char+", char_plus); 2572 ANSI(0x063, 0, "wa1+", wa1_plus); 2573 ANSI(0x064, 0, "la1+", la1_plus); 2574 ANSI(0x065, 0, "cell+", cell_plus); 2575 ANSI(0x066, 0, "chars", do_chars); 2576 ANSI(0x067, 0, "/w*", slash_w_times); 2577 ANSI(0x068, 0, "/l*", slash_l_times); 2578 ANSI(0x069, 0, "cells", cells); 2579 ANSI(0x06a, 0, "on", do_on); 2580 ANSI(0x06b, 0, "off", do_off); 2581 ANSI(0x06c, 0, "+!", addstore); 2582 ANSI(0x06d, 0, "@", fetch); 2583 ANSI(0x06e, 0, "l@", lfetch); 2584 ANSI(0x06f, 0, "w@", wfetch); 2585 ANSI(0x070, 0, "<w@", swfetch); 2586 ANSI(0x071, 0, "c@", cfetch); 2587 ANSI(0x072, 0, "!", store); 2588 ANSI(0x073, 0, "l!", lstore); 2589 ANSI(0x074, 0, "w!", wstore); 2590 ANSI(0x075, 0, "c!", cstore); 2591 ANSI(0x076, 0, "2@", two_fetch); 2592 ANSI(0x077, 0, "2!", two_store); 2593 ANSI(0x078, 0, "move", fc_move); 2594 ANSI(0x079, 0, "fill", fc_fill); 2595 ANSI(0x07a, 0, "comp", fc_comp); 2596 ANSI(0x07b, 0, "noop", noop); 2597 ANSI(0x07c, 0, "lwsplit", lwsplit); 2598 ANSI(0x07d, 0, "wljoin", wljoin); 2599 ANSI(0x07e, 0, "lbsplit", lbsplit); 2600 ANSI(0x07f, 0, "bljoin", bljoin); 2601 ANSI(0x080, 0, "wbflip", wbflip); 2602 ANSI(0x081, 0, "upc", upper_case); 2603 ANSI(0x082, 0, "lcc", lower_case); 2604 ANSI(0x083, 0, "pack", pack_str); 2605 ANSI(0x084, 0, "count", count_str); 2606 ANSI(0x085, 0, "body>", to_acf); 2607 ANSI(0x086, 0, ">body", to_body); 2608 2609 ANSI(0x089, 0, "unloop", unloop); 2610 2611 ANSI(0x09f, 0, ".s", dot_s); 2612 ANSI(0x0a0, 0, "base", base); 2613 FCODE(0x0a1, 0, "convert", fc_historical); 2614 ANSI(0x0a2, 0, "$number", dollar_number); 2615 ANSI(0x0a3, 0, "digit", digit); 2616 2617 ANSI(0x0a9, 0, "bl", space); 2618 ANSI(0x0aa, 0, "bs", backspace); 2619 ANSI(0x0ab, 0, "bell", bell); 2620 ANSI(0x0ac, 0, "bounds", fc_bounds); 2621 ANSI(0x0ad, 0, "here", here); 2622 2623 ANSI(0x0af, 0, "wbsplit", wbsplit); 2624 ANSI(0x0b0, 0, "bwjoin", bwjoin); 2625 2626 P1275(0x0cb, 0, "$find", dollar_find); 2627 2628 ANSI(0x0d0, 0, "c,", ccomma); 2629 ANSI(0x0d1, 0, "w,", wcomma); 2630 ANSI(0x0d2, 0, "l,", lcomma); 2631 ANSI(0x0d3, 0, ",", comma); 2632 ANSI(0x0d4, 0, "um*", um_multiply); 2633 ANSI(0x0d5, 0, "um/mod", um_slash_mod); 2634 2635 ANSI(0x0d8, 0, "d+", d_plus); 2636 ANSI(0x0d9, 0, "d-", d_minus); 2637 2638 ANSI(0x0dc, 0, "state", state); 2639 ANSI(0x0de, 0, "behavior", behavior); 2640 ANSI(0x0dd, 0, "compile,", compile_comma); 2641 2642 ANSI(0x216, 0, "abort", f_abort); 2643 ANSI(0x217, 0, "catch", catch); 2644 ANSI(0x218, 0, "throw", throw); 2645 2646 ANSI(0x226, 0, "lwflip", lwflip); 2647 ANSI(0x227, 0, "lbflip", lbflip); 2648 ANSI(0x228, 0, "lbflips", lbflips); 2649 2650 ANSI(0x236, 0, "wbflips", wbflips); 2651 ANSI(0x237, 0, "lwflips", lwflips); 2652 2653 FORTH(0, "forth", do_forth); 2654 FORTH(0, "current", do_current); 2655 FORTH(0, "context", do_context); 2656 FORTH(0, "definitions", do_definitions); 2657 FORTH(0, "vocabulary", do_vocab); 2658 FORTH(IMMEDIATE, ":", colon); 2659 FORTH(IMMEDIATE, ";", semi); 2660 FORTH(IMMEDIATE, "create", create); 2661 FORTH(IMMEDIATE, "does>", does); 2662 FORTH(IMMEDIATE, "recursive", recursive); 2663 FORTH(0, "parse-word", parse_word); 2664 FORTH(IMMEDIATE, "\"", run_quote); 2665 FORTH(IMMEDIATE, "order", do_order); 2666 FORTH(IMMEDIATE, "also", do_also); 2667 FORTH(IMMEDIATE, "previous", do_previous); 2668 FORTH(IMMEDIATE, "'", do_tick); 2669 FORTH(IMMEDIATE, "[']", bracket_tick); 2670 FORTH(0, "unaligned-l@", unaligned_lfetch); 2671 FORTH(0, "unaligned-l!", unaligned_lstore); 2672 FORTH(0, "unaligned-w@", unaligned_wfetch); 2673 FORTH(0, "unaligned-w!", unaligned_wstore); 2674 } 2675