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