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 37void (*semi_ptr)(fcode_env_t *env) = do_semi; 38void (*does_ptr)(fcode_env_t *env) = install_does; 39void (*quote_ptr)(fcode_env_t *env) = do_quote; 40void (*blit_ptr)(fcode_env_t *env) = do_literal; 41void (*tlit_ptr)(fcode_env_t *env) = do_literal; 42void (*do_bdo_ptr)(fcode_env_t *env) = do_bdo; 43void (*do_bqdo_ptr)(fcode_env_t *env) = do_bqdo; 44void (*create_ptr)(fcode_env_t *env) = do_creator; 45void (*do_leave_ptr)(fcode_env_t *env) = do_bleave; 46void (*do_loop_ptr)(fcode_env_t *env) = do_bloop; 47void (*do_ploop_ptr)(fcode_env_t *env) = do_bploop; 48 49void unaligned_lstore(fcode_env_t *); 50void unaligned_wstore(fcode_env_t *); 51void unaligned_lfetch(fcode_env_t *); 52void unaligned_wfetch(fcode_env_t *); 53 54/* start with the simple maths functions */ 55 56 57void 58add(fcode_env_t *env) 59{ 60 fstack_t d; 61 62 CHECK_DEPTH(env, 2, "+"); 63 d = POP(DS); 64 TOS += d; 65} 66 67void 68subtract(fcode_env_t *env) 69{ 70 fstack_t d; 71 72 CHECK_DEPTH(env, 2, "-"); 73 d = POP(DS); 74 TOS -= d; 75} 76 77void 78multiply(fcode_env_t *env) 79{ 80 fstack_t d; 81 82 CHECK_DEPTH(env, 2, "*"); 83 d = POP(DS); 84 TOS *= d; 85} 86 87void 88slash_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 */ 129void 130uslash_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 144void 145divide(fcode_env_t *env) 146{ 147 CHECK_DEPTH(env, 2, "/"); 148 slash_mod(env); 149 nip(env); 150} 151 152void 153mod(fcode_env_t *env) 154{ 155 CHECK_DEPTH(env, 2, "mod"); 156 slash_mod(env); 157 drop(env); 158} 159 160void 161and(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 170void 171or(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 180void 181xor(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 190void 191invert(fcode_env_t *env) 192{ 193 CHECK_DEPTH(env, 1, "invert"); 194 TOS = ~TOS; 195} 196 197void 198lshift(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 207void 208rshift(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 217void 218rshifta(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 227void 228negate(fcode_env_t *env) 229{ 230 CHECK_DEPTH(env, 1, "negate"); 231 TOS = -TOS; 232} 233 234void 235f_abs(fcode_env_t *env) 236{ 237 CHECK_DEPTH(env, 1, "abs"); 238 if (TOS < 0) TOS = -TOS; 239} 240 241void 242f_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 251void 252f_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 261void 262to_r(fcode_env_t *env) 263{ 264 CHECK_DEPTH(env, 1, ">r"); 265 PUSH(RS, POP(DS)); 266} 267 268void 269from_r(fcode_env_t *env) 270{ 271 CHECK_RETURN_DEPTH(env, 1, "r>"); 272 PUSH(DS, POP(RS)); 273} 274 275void 276rfetch(fcode_env_t *env) 277{ 278 CHECK_RETURN_DEPTH(env, 1, "r@"); 279 PUSH(DS, *RS); 280} 281 282void 283f_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 300void 301zero_equals(fcode_env_t *env) 302{ 303 CHECK_DEPTH(env, 1, "0="); 304 TOS = COMPARE(EQUALS, 0); 305} 306 307void 308zero_not_equals(fcode_env_t *env) 309{ 310 CHECK_DEPTH(env, 1, "0<>"); 311 TOS = COMPARE(NOTEQUALS, 0); 312} 313 314void 315zero_less(fcode_env_t *env) 316{ 317 CHECK_DEPTH(env, 1, "0<"); 318 TOS = COMPARE(LESSTHAN, 0); 319} 320 321void 322zero_less_equals(fcode_env_t *env) 323{ 324 CHECK_DEPTH(env, 1, "0<="); 325 TOS = COMPARE(LESSEQUALS, 0); 326} 327 328void 329zero_greater(fcode_env_t *env) 330{ 331 CHECK_DEPTH(env, 1, "0>"); 332 TOS = COMPARE(GREATERTHAN, 0); 333} 334 335void 336zero_greater_equals(fcode_env_t *env) 337{ 338 CHECK_DEPTH(env, 1, "0>="); 339 TOS = COMPARE(GREATEREQUALS, 0); 340} 341 342void 343less(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 352void 353greater(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 362void 363equals(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 372void 373not_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 383void 384unsign_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 393void 394unsign_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 403void 404unsign_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 413void 414unsign_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 423void 424greater_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 433void 434less_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 443void 444between(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 454void 455within(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 465void 466do_literal(fcode_env_t *env) 467{ 468 PUSH(DS, *IP); 469 IP++; 470} 471 472void 473literal(fcode_env_t *env) 474{ 475 if (env->state) { 476 COMPILE_TOKEN(&blit_ptr); 477 compile_comma(env); 478 } 479} 480 481void 482do_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 495void 496do_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 506void 507do_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 518void 519noop(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 527void 528lwsplit(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 542void 543wljoin(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 557void 558lwflip(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 573void 574lbsplit(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 588void 589bljoin(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 603void 604lbflip(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 619void 620wbsplit(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 634void 635bwjoin(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 649void 650wbflip(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 665void 666upper_case(fcode_env_t *env) 667{ 668 CHECK_DEPTH(env, 1, "upc"); 669 TOS = toupper(TOS); 670} 671 672void 673lower_case(fcode_env_t *env) 674{ 675 CHECK_DEPTH(env, 1, "lcc"); 676 TOS = tolower(TOS); 677} 678 679void 680pack_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 695void 696count_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 706void 707to_body(fcode_env_t *env) 708{ 709 CHECK_DEPTH(env, 1, ">body"); 710 TOS = (fstack_t)(((acf_t)TOS)+1); 711} 712 713void 714to_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 */ 723static void 724unloop(fcode_env_t *env) 725{ 726 CHECK_RETURN_DEPTH(env, 3, "unloop"); 727 RS -= 3; 728} 729 730/* 731 * 'um*' Fcode implementation. 732 */ 733static void 734um_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 */ 749static void 750um_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 */ 767static void 768d_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 */ 782static void 783d_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 794void 795set_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 813static void 814unaligned_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 824static void 825unaligned_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 835void 836comma(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 845void 846lcomma(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 855void 856wcomma(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 865void 866ccomma(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 875void 876token_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 883void 884compile_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 894void 895unaligned_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 910void 911unaligned_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 925void 926unaligned_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 941void 942unaligned_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 */ 959static void 960lbflips(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 */ 981static void 982wbflips(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 */ 1003static void 1004lwflips(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 1022void 1023base(fcode_env_t *env) 1024{ 1025 PUSH(DS, (fstack_t)&env->num_base); 1026} 1027 1028void 1029dot_s(fcode_env_t *env) 1030{ 1031 output_data_stack(env, MSG_INFO); 1032} 1033 1034void 1035state(fcode_env_t *env) 1036{ 1037 PUSH(DS, (fstack_t)&env->state); 1038} 1039 1040int 1041is_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 1067void 1068dollar_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 1102void 1103digit(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 1118void 1119space(fcode_env_t *env) 1120{ 1121 PUSH(DS, ' '); 1122} 1123 1124void 1125backspace(fcode_env_t *env) 1126{ 1127 PUSH(DS, '\b'); 1128} 1129 1130void 1131bell(fcode_env_t *env) 1132{ 1133 PUSH(DS, '\a'); 1134} 1135 1136void 1137fc_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 1148void 1149here(fcode_env_t *env) 1150{ 1151 PUSH(DS, (fstack_t)HERE); 1152} 1153 1154void 1155aligned(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 1165void 1166instance(fcode_env_t *env) 1167{ 1168 env->instance_mode |= 1; 1169} 1170 1171void 1172semi(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 1192void 1193do_create(fcode_env_t *env) 1194{ 1195 PUSH(DS, (fstack_t)WA); 1196} 1197 1198void 1199drop(fcode_env_t *env) 1200{ 1201 CHECK_DEPTH(env, 1, "drop"); 1202 (void) POP(DS); 1203} 1204 1205void 1206f_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 1215void 1216over(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 1225void 1226swap(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 1237void 1238rot(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 1249void 1250minus_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 1261void 1262tuck(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 1272void 1273nip(fcode_env_t *env) 1274{ 1275 CHECK_DEPTH(env, 2, "nip"); 1276 swap(env); 1277 drop(env); 1278} 1279 1280void 1281qdup(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 1291void 1292depth(fcode_env_t *env) 1293{ 1294 fstack_t d; 1295 1296 d = DS - env->ds0; 1297 PUSH(DS, d); 1298} 1299 1300void 1301pick(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 1313void 1314roll(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 1331void 1332two_drop(fcode_env_t *env) 1333{ 1334 CHECK_DEPTH(env, 2, "2drop"); 1335 DS -= 2; 1336} 1337 1338void 1339two_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 1347void 1348two_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 1359void 1360two_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 1373void 1374two_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 1389void 1390two_slash(fcode_env_t *env) 1391{ 1392 CHECK_DEPTH(env, 1, "2/"); 1393 TOS = TOS >> 1; 1394} 1395 1396void 1397utwo_slash(fcode_env_t *env) 1398{ 1399 CHECK_DEPTH(env, 1, "u2/"); 1400 TOS = (ufstack_t)((ufstack_t)TOS) >> 1; 1401} 1402 1403void 1404two_times(fcode_env_t *env) 1405{ 1406 CHECK_DEPTH(env, 1, "2*"); 1407 TOS = (ufstack_t)((ufstack_t)TOS) << 1; 1408} 1409 1410void 1411slash_c(fcode_env_t *env) 1412{ 1413 PUSH(DS, sizeof (char)); 1414} 1415 1416void 1417slash_w(fcode_env_t *env) 1418{ 1419 PUSH(DS, sizeof (wforth_t)); 1420} 1421 1422void 1423slash_l(fcode_env_t *env) 1424{ 1425 PUSH(DS, sizeof (lforth_t)); 1426} 1427 1428void 1429slash_n(fcode_env_t *env) 1430{ 1431 PUSH(DS, sizeof (fstack_t)); 1432} 1433 1434void 1435ca_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 1444void 1445wa_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 1454void 1455la_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 1464void 1465na_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 1474void 1475char_plus(fcode_env_t *env) 1476{ 1477 CHECK_DEPTH(env, 1, "char+"); 1478 TOS += sizeof (char); 1479} 1480 1481void 1482wa1_plus(fcode_env_t *env) 1483{ 1484 CHECK_DEPTH(env, 1, "wa1+"); 1485 TOS += sizeof (wforth_t); 1486} 1487 1488void 1489la1_plus(fcode_env_t *env) 1490{ 1491 CHECK_DEPTH(env, 1, "la1+"); 1492 TOS += sizeof (lforth_t); 1493} 1494 1495void 1496cell_plus(fcode_env_t *env) 1497{ 1498 CHECK_DEPTH(env, 1, "cell+"); 1499 TOS += sizeof (fstack_t); 1500} 1501 1502void 1503do_chars(fcode_env_t *env) 1504{ 1505 CHECK_DEPTH(env, 1, "chars"); 1506} 1507 1508void 1509slash_w_times(fcode_env_t *env) 1510{ 1511 CHECK_DEPTH(env, 1, "/w*"); 1512 TOS *= sizeof (wforth_t); 1513} 1514 1515void 1516slash_l_times(fcode_env_t *env) 1517{ 1518 CHECK_DEPTH(env, 1, "/l*"); 1519 TOS *= sizeof (lforth_t); 1520} 1521 1522void 1523cells(fcode_env_t *env) 1524{ 1525 CHECK_DEPTH(env, 1, "cells"); 1526 TOS *= sizeof (fstack_t); 1527} 1528 1529void 1530do_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 1539void 1540do_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 1549void 1550fetch(fcode_env_t *env) 1551{ 1552 CHECK_DEPTH(env, 1, "@"); 1553 TOS = *((variable_t *)TOS); 1554} 1555 1556void 1557lfetch(fcode_env_t *env) 1558{ 1559 CHECK_DEPTH(env, 1, "l@"); 1560 TOS = *((lforth_t *)TOS); 1561} 1562 1563void 1564wfetch(fcode_env_t *env) 1565{ 1566 CHECK_DEPTH(env, 1, "w@"); 1567 TOS = *((wforth_t *)TOS); 1568} 1569 1570void 1571swfetch(fcode_env_t *env) 1572{ 1573 CHECK_DEPTH(env, 1, "<w@"); 1574 TOS = *((s_wforth_t *)TOS); 1575} 1576 1577void 1578cfetch(fcode_env_t *env) 1579{ 1580 CHECK_DEPTH(env, 1, "c@"); 1581 TOS = *((uchar_t *)TOS); 1582} 1583 1584void 1585store(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 1594void 1595addstore(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 1604void 1605lstore(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 1614void 1615wstore(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 1624void 1625cstore(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 1634void 1635two_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 1647void 1648two_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 */ 1663void 1664fc_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 1677void 1678fc_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 1691void 1692fc_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 1710void 1711set_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 1721void 1722bmark(fcode_env_t *env) 1723{ 1724 set_temporary_compile(env); 1725 env->level++; 1726 PUSH(DS, (fstack_t)HERE); 1727} 1728 1729void 1730temporary_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 1754void 1755bresolve(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 1766void 1767do_bbranch(fcode_env_t *env) 1768{ 1769 IP = BRANCH_IP(IP); 1770} 1771 1772void 1773do_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 1786void 1787do_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 1801void 1802do_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 1810void 1811loop_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 1829void 1830do_bloop(fcode_env_t *env) 1831{ 1832 loop_inc(env, 1); 1833} 1834 1835void 1836do_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 1845void 1846loop_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 1856void 1857bloop(fcode_env_t *env) 1858{ 1859 loop_common(env, (fstack_t)&do_loop_ptr); 1860} 1861 1862void 1863bplusloop(fcode_env_t *env) 1864{ 1865 loop_common(env, (fstack_t)&do_ploop_ptr); 1866} 1867 1868void 1869common_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 1884void 1885do_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 1898void 1899do_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 1916void 1917compile_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 1926void 1927bdo(fcode_env_t *env) 1928{ 1929 short offset = (short)get_short(env); 1930 compile_do_common(env, (fstack_t)&do_bdo_ptr); 1931} 1932 1933void 1934bqdo(fcode_env_t *env) 1935{ 1936 short offset = (short)get_short(env); 1937 compile_do_common(env, (fstack_t)&do_bqdo_ptr); 1938} 1939 1940void 1941loop_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 1950void 1951loop_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 1960void 1961bleave(fcode_env_t *env) 1962{ 1963 1964 if (env->state) { 1965 COMPILE_TOKEN(&do_leave_ptr); 1966 } 1967} 1968 1969void 1970push_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 1997void 1998parse_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 2019void 2020install_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 2031void 2032does(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 2050void 2051do_current(fcode_env_t *env) 2052{ 2053 debug_msg(DEBUG_CONTEXT, "CONTEXT:pushing &CURRENT\n"); 2054 PUSH(DS, (fstack_t)&env->current); 2055} 2056 2057void 2058do_context(fcode_env_t *env) 2059{ 2060 debug_msg(DEBUG_CONTEXT, "CONTEXT:pushing &CONTEXT\n"); 2061 PUSH(DS, (fstack_t)&CONTEXT); 2062} 2063 2064void 2065do_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 2072void 2073make_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 2082void 2083do_creator(fcode_env_t *env) 2084{ 2085 make_header(env, 0); 2086 COMPILE_TOKEN(&do_create); 2087 expose_acf(env, "<create>"); 2088} 2089 2090void 2091create(fcode_env_t *env) 2092{ 2093 if (env->state) { 2094 COMPILE_TOKEN(&create_ptr); 2095 } else 2096 do_creator(env); 2097} 2098 2099void 2100colon(fcode_env_t *env) 2101{ 2102 make_header(env, 0); 2103 env->state |= 1; 2104 COMPILE_TOKEN(&do_colon); 2105} 2106 2107void 2108recursive(fcode_env_t *env) 2109{ 2110 expose_acf(env, "<recursive>"); 2111} 2112 2113void 2114compile_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 2131void 2132run_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 2146void 2147does_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 2154void 2155do_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 2164void 2165do_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 2172acf_t 2173voc_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 2195void 2196dollar_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 2215void 2216interpret(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 2260void 2261evaluate(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 2277void 2278make_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 2319void 2320do_constant(fcode_env_t *env) 2321{ 2322 PUSH(DS, (variable_t)(*WA)); 2323} 2324 2325void 2326do_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 */ 2334static void 2335behavior(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 2352void 2353fc_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 2359void 2360f_abort(fcode_env_t *env) 2361{ 2362 fc_abort(env, "Abort"); 2363} 2364 2365/* 2366 * Fcodes chosen not to support. 2367 */ 2368void 2369fc_unimplemented(fcode_env_t *env) 2370{ 2371 fc_abort(env, "Unimplemented"); 2372} 2373 2374/* 2375 * Fcodes that are Obsolete per P1275-1994. 2376 */ 2377void 2378fc_obsolete(fcode_env_t *env) 2379{ 2380 fc_abort(env, "Obsolete"); 2381} 2382 2383/* 2384 * Fcodes that are Historical per P1275-1994 2385 */ 2386void 2387fc_historical(fcode_env_t *env) 2388{ 2389 fc_abort(env, "Historical"); 2390} 2391 2392void 2393catch(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 2411void 2412throw_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 2447void 2448throw(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 2464void 2465tick_literal(fcode_env_t *env) 2466{ 2467 if (env->state) { 2468 COMPILE_TOKEN(&tlit_ptr); 2469 compile_comma(env); 2470 } 2471} 2472 2473void 2474do_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 2483void 2484bracket_tick(fcode_env_t *env) 2485{ 2486 do_tick(env); 2487} 2488 2489#pragma init(_init) 2490 2491static 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