git.gag.com Git - debian/yforth/blob - core.c

   1 /* yForth? - Written by Luca Padovani (C) 1996/97
   2  * ------------------------------------------------------------------------
   3  * This software is FreeWare as long as it comes with this header in each
   4  * source file, anyway you can use it or any part of it whatever
   5  * you want. It comes without any warranty, so use it at your own risk.
   6  * ------------------------------------------------------------------------
   7  * Module name:     core.c
   8  * Abstract:        Core word set
   9  */
  10
  11 #include <string.h>
  12 #include <setjmp.h>
  13 #include <ctype.h>
  14 #include <stdio.h>
  15 #include <stdlib.h>
  16 #include "yforth.h"
  17 #include "udio.h"
  18 #include "core.h"
  19 #include "coree.h"
  20 #include "float.h"
  21 #include "double.h"
  22 #include "toolse.h"
  23 #include "locals.h"
  24 #include "block.h"
  25 #include "exceptio.h"
  26
  27 /**************************************************************************/
  28 /* VARIABLES **************************************************************/
  29 /**************************************************************************/
  30
  31 Char s_tmp_buffer[TMP_BUFFER_SIZE];     /* used by s" */
  32
  33 Cell _to_in;                            /* ptr to parse area */
  34 Cell _source_id;                        /* input source device */
  35 Char * _tib;                            /* ptr to terminal input buffer */
  36 Char * _input_buffer;                   /* current input buffer */
  37 Cell _in_input_buffer;                  /* # of chars in input buffer */
  38 Cell _base;                             /* base is base */
  39 Char * _dp;                             /* dictionary pointer */
  40 Cell _error;                            /* error code */
  41 struct word_def * _last;                /* ptr to last defined word */
  42 Cell _state;                            /* state of the interpreter */
  43 Cell _check_system = 1;                 /* 1 => check stacks overflow & underflow */
  44                                         /* Some variables used by environment? follows... */
  45 Cell _env_slash_counted_string;
  46 Cell _env_slash_hold;
  47 Cell _env_slash_pad;
  48 Cell _env_address_unit_bits;
  49 Cell _env_core;
  50 Cell _env_core_ext;
  51 Cell _env_floored;
  52 Cell _env_max_char;
  53 Cell _env_max_d;
  54 Cell _env_max_n;
  55 Cell _env_max_u;
  56 Cell _env_max_ud;
  57 Cell _env_return_stack_cells;
  58 Cell _env_stack_cells;
  59 Cell _env_double;
  60 Cell _env_double_ext;
  61 Cell _env_floating;
  62 Cell _env_floating_stack;
  63 Cell _env_max_float;
  64 Cell _env_floating_ext;
  65 Cell _env_memory_alloc;
  66 Cell _env_memory_alloc_ext;
  67 Cell _env_search_order;
  68 Cell _env_search_order_ext;
  69 Cell _env_wordlists;
  70 Cell _env_tools;
  71 Cell _env_tools_ext;
  72 Cell _env_number_locals;
  73 Cell _env_locals;
  74 Cell _env_locals_ext;
  75 Cell _env_facility;
  76 Cell _env_facility_ext;
  77 Cell _env_block;
  78 Cell _env_block_ext;
  79 Cell _env_exception;
  80 Cell _env_exception_ext;
  81 Cell _env_file;
  82 Cell _env_file_ext;
  83 Cell _env_string;
  84 Cell _env_string_ext;
  85
  86 /**************************************************************************/
  87 /* WORDS ******************************************************************/
  88 /**************************************************************************/
  89
  90 void _dot_quote() {
  91         compile_cell((Cell) _paren_dot_quote_paren);
  92         *--sp = '"';
  93         _word();
  94         _dp = (Char *) WORD_PTR(_dp);
  95     sp++;
  96 }
  97
  98 void _paren_dot_quote_paren() {
  99     register Char *addr = (Char *) ip;
 100     *--sp = (Cell) (addr + 1);
 101     *--sp = (Cell) *addr;
 102         _type();
 103         ip = (pfp *) WORD_PTR((Char *) ip);
 104 }
 105
 106 void _type() {
 107     register Cell u = *sp++;
 108     register Char *addr = (Char *) *sp++;
 109     while (u--) putchar(*addr++);
 110 }
 111
 112 void _u_dot() {
 113         *--sp = 0;
 114     _less_number_sign();
 115     _number_sign_s();
 116     _number_sign_greater();
 117         _type();
 118     putchar(' ');
 119 }
 120
 121 void _c_r() {
 122         putchar('\n');
 123 }
 124
 125 void _emit() {
 126         putchar(*sp++);
 127 }
 128
 129 #ifdef DOUBLE_DEF
 130 void _dot() {
 131         _s_to_d();
 132         _d_dot();
 133 }
 134 #else
 135 void _dot() {
 136         register DCell u = *sp;
 137         register int usign = u < 0;
 138         if (usign) u = -u;
 139         sp--;
 140         PUT_DCELL(sp, u);
 141         _less_number_sign();
 142         _number_sign_s();
 143         if (usign) {
 144                 *--sp = '-';
 145                 _hold();
 146         }
 147         _number_sign_greater();
 148         _type();
 149         putchar(' ');
 150 }
 151 #endif
 152
 153 void _space() {
 154     putchar(' ');
 155 }
 156
 157 void _spaces() {
 158     register UCell u = *sp++;
 159     while (u--) putchar(' ');
 160 }
 161
 162 void _less_number_sign() {
 163         in_pnos = 0;
 164         p_pnos = pnos + pnos_size;
 165 }
 166
 167 void _number_sign() {
 168         register UDCell ud1 = GET_DCELL(sp);
 169         register int rem = ud1 % _base;
 170         ud1 /= _base;
 171         PUT_DCELL(sp, ud1);
 172         if (rem < 10) *--p_pnos = rem + '0';
 173         else *--p_pnos = rem - 10 + 'a';
 174         in_pnos++;
 175 }
 176
 177 void _hold() {
 178         register Char ch = (Char) *sp++;
 179         *--p_pnos = ch;
 180         in_pnos++;
 181 }
 182
 183 void _number_sign_s() {
 184         do _number_sign();
 185         while (sp[0] || sp[1]);
 186 }
 187
 188 void _number_sign_greater() {
 189         sp[1] = (Cell) p_pnos;
 190         sp[0] = in_pnos;
 191 }
 192
 193 void _store() {
 194         register Cell *addr = (Cell *) *sp++;
 195         *addr = *sp++;
 196 }
 197
 198 void _star() {
 199     sp[1] *= *sp;
 200     sp++;
 201 }
 202
 203 void _star_slash() {
 204     register DCell d = (DCell) sp[1] * (DCell) sp[2];
 205     sp[2] = d / (DCell) sp[0];
 206     sp += 2;
 207 }
 208
 209 void _star_slash_mod() {
 210         register DCell d = (DCell) sp[1] * (DCell) sp[2];
 211     sp[2] = d % (DCell) sp[0];
 212         sp[1] = d / (DCell) sp[0];
 213         sp++;
 214 }
 215
 216 void _plus() {
 217         sp[1] += sp[0];
 218         sp++;
 219 }
 220
 221 void _plus_store() {
 222     register Cell *addr = (Cell *) *sp++;
 223     *addr += *sp++;
 224 }
 225
 226 void _minus() {
 227     sp[1] -= sp[0];
 228     sp++;
 229 }
 230
 231 void _slash() {
 232         sp[1] /= sp[0];
 233         sp++;
 234 }
 235
 236 void _slash_mod() {
 237         register Cell n1 = sp[1];
 238         register Cell n2 = sp[0];
 239     sp[1] = n1 % n2;
 240     sp[0] = n1 / n2;
 241 }
 242
 243 void _zero_less() {
 244     sp[0] = FFLAG(sp[0] < 0);
 245 }
 246
 247 void _zero_equals() {
 248     sp[0] = FFLAG(sp[0] == 0);
 249 }
 250
 251 void _one_plus() {
 252         sp[0]++;
 253 }
 254
 255 void _one_minus() {
 256     sp[0]--;
 257 }
 258
 259 void _two_store() {
 260     register Cell *addr = (Cell *) *sp++;
 261     *addr++ = *sp++;
 262     *addr = *sp++;
 263 }
 264
 265 void _two_star() {
 266     sp[0] <<= 1;
 267 }
 268
 269 void _two_slash() {
 270         sp[0] >>= 1;
 271 }
 272
 273 void _two_fetch() {
 274     register Cell *addr = (Cell *) *sp;
 275     *sp-- = *(addr + 1);
 276     *sp = *addr;
 277 }
 278
 279 void _two_drop() {
 280     sp += 2;
 281 }
 282
 283 void _two_dupe() {
 284     sp -= 2;
 285     sp[0] = sp[2];
 286     sp[1] = sp[3];
 287 }
 288
 289 void _two_over() {
 290         sp -= 2;
 291     sp[0] = sp[4];
 292     sp[1] = sp[5];
 293 }
 294
 295 void _two_swap() {
 296     register Cell x4 = sp[0];
 297         register Cell x3 = sp[1];
 298         sp[0] = sp[2];
 299     sp[1] = sp[3];
 300     sp[2] = x4;
 301     sp[3] = x3;
 302 }
 303
 304 void _less_than() {
 305     sp[1] = FFLAG(sp[1] < sp[0]);
 306     sp++;
 307 }
 308
 309 void _equals() {
 310         sp[1] = FFLAG(sp[1] == sp[0]);
 311     sp++;
 312 }
 313
 314 void _greater_than() {
 315     sp[1] = FFLAG(sp[1] > sp[0]);
 316     sp++;
 317 }
 318
 319 void _to_r() {
 320     *--rp = *sp++;
 321 }
 322
 323 void _question_dupe() {
 324     if (sp[0]) sp--, sp[0] = sp[1];
 325 }
 326
 327 void _fetch() {
 328     sp[0] = *((Cell *) sp[0]);
 329 }
 330
 331 void _abs() {
 332     register Cell n = sp[0];
 333     sp[0] = n >= 0 ? n : -n;
 334 }
 335
 336 void _align() {
 337         _dp = (Char *) ALIGN_PTR(_dp);
 338 }
 339
 340 void _aligned() {
 341     sp[0] = ALIGN_PTR((Cell *) sp[0]);
 342 }
 343
 344 void _and() {
 345         sp[1] &= sp[0];
 346     sp++;
 347 }
 348
 349 void _b_l() {
 350         *--sp = ' ';
 351 }
 352
 353 void _c_store() {
 354     register Char *addr = (Char *) *sp++;
 355     *addr = (Char) *sp++;
 356 }
 357
 358 void _c_fetch() {
 359     register Char *addr = (Char *) *sp;
 360     *sp = (Cell) *addr;
 361 }
 362
 363 void _cell_plus() {
 364         sp[0] += sizeof(Cell);
 365 }
 366
 367 void _cells() {
 368     sp[0] *= sizeof(Cell);
 369 }
 370
 371 void _char_plus() {
 372     sp[0] += sizeof(Char);
 373 }
 374
 375 void _chars() {
 376     sp[0] *= sizeof(Char);
 377 }
 378
 379 void _depth() {
 380         register Cell dep = sp_top - sp;
 381         *--sp = dep;
 382 }
 383
 384 void _drop() {
 385         sp++;
 386 }
 387
 388 void _dupe() {
 389     sp--;
 390     sp[0] = sp[1];
 391 }
 392
 393 void _f_m_slash_mod() {
 394     register Cell n1 = *sp++;
 395         register DCell d1 = GET_DCELL(sp);
 396     sp[0] = d1 / n1;
 397     sp[1] = d1 % n1;
 398 #if !FLOORED_DIVISION
 399         if (*sp < 0) {
 400                 sp[0]--;
 401                 if (sp[1] > 0) sp[1]++;
 402                 else sp[1]--;
 403                 sp[1] = -sp[1];
 404         }
 405 #endif
 406 }
 407
 408 void _invert() {
 409     sp[0] = ~sp[0];
 410 }
 411
 412 void _l_shift() {
 413         register UCell u = (UCell) *sp++;
 414     sp[0] <<= u;
 415 }
 416
 417 void _m_star() {
 418     register DCell d = (DCell) sp[1] * (DCell) sp[0];
 419         PUT_DCELL(sp, d);
 420 }
 421
 422 void _max() {
 423     register Cell n2 = *sp++;
 424     sp[0] = sp[0] > n2 ? sp[0] : n2;
 425 }
 426
 427 void _min() {
 428     register Cell n2 = *sp++;
 429     sp[0] = sp[0] < n2 ? sp[0] : n2;
 430 }
 431
 432 void _mod() {
 433     sp[1] %= sp[0];
 434     sp++;
 435 }
 436
 437 void _negate() {
 438     sp[0] = -sp[0];
 439 }
 440
 441 void _or() {
 442         sp[1] |= sp[0];
 443     sp++;
 444 }
 445
 446 void _over() {
 447     sp--;
 448     sp[0] = sp[2];
 449 }
 450
 451 void _r_from() {
 452         *--sp = *rp++;
 453 }
 454
 455 void _r_fetch() {
 456     *--sp = *rp;
 457 }
 458
 459 void _rote() {
 460     register Cell x3 = sp[0];
 461     register Cell x2 = sp[1];
 462     register Cell x1 = sp[2];
 463     sp[0] = x1;
 464     sp[1] = x3;
 465     sp[2] = x2;
 466 }
 467
 468 void _r_shift() {
 469     register UCell u = (UCell) *sp++;
 470         ((UCell *) sp)[0] >>= u;
 471 }
 472
 473 void _s_to_d() {
 474     register DCell d = (DCell) (*sp--);
 475         PUT_DCELL(sp, d);
 476 }
 477
 478 void _s_m_slash_rem() {
 479     register Cell n1 = *sp++;
 480         register DCell d1 = GET_DCELL(sp);
 481     sp[0] = d1 / n1;
 482     sp[1] = d1 % n1;
 483 #if FLOORED_DIVISION
 484         if (*sp < 0) {
 485                 sp[0]++;
 486                 if (sp[1] > 0) sp[1]--;
 487                 else sp[1]++;
 488                 sp[1] = -sp[1];
 489         }
 490 #endif
 491 }
 492
 493 void _swap() {
 494     register Cell temp = sp[0];
 495     sp[0] = sp[1];
 496     sp[1] = temp;
 497 }
 498
 499 void _u_less_than() {
 500     sp[1] = FFLAG((UCell) sp[1] < (UCell) sp[0]);
 501         sp++;
 502 }
 503
 504 void _u_m_star() {
 505         register UDCell ud = (UDCell) sp[1] * (UDCell) sp[0];
 506         PUT_DCELL(sp, ud);
 507 }
 508
 509 void _u_m_slash_mod() {
 510         register UCell u1 = *sp++;
 511         register UDCell ud = GET_DCELL(sp);
 512         sp[1] = ud % u1;
 513         sp[0] = ud / u1;
 514 }
 515
 516 void _xor() {
 517         sp[1] ^= sp[0];
 518         sp++;
 519 }
 520
 521 void _do_literal() {
 522     *--sp = (Cell) *ip++;
 523 }
 524
 525 void _do_fliteral() {
 526         *--fp = (Real) *((Real *) ip);
 527         ip += sizeof(Real) / sizeof(Cell);
 528 }
 529
 530 void _word() {
 531         register Char *addr;
 532         register Char delim = (Char) *sp;
 533         register int i, j;
 534         while (_to_in < _in_input_buffer && _input_buffer[_to_in] == delim) _to_in++;
 535         _parse();
 536         i = *_dp = *sp++;
 537         addr = (Char *) *sp;
 538         for (j = 0; j < i; j++) *(_dp + j + 1) = *addr++;
 539         *(_dp + i + 1) = ' ';
 540         *sp = (Cell) _dp;
 541 }
 542
 543 void _to_number() {
 544         register UCell u1 = (UCell) *sp;
 545     register Char *addr = (Char *) *(sp + 1);
 546         register UDCell ud1 = GET_DCELL(sp + 2);
 547         while (is_base_digit(*addr) && u1) {
 548                 ud1 *= _base;
 549                 if (*addr <= '9') ud1 += *addr - '0';
 550                 else ud1 += toupper(*addr) - 'A' + 10;
 551                 addr++;
 552                 u1--;
 553         }
 554         PUT_DCELL(sp + 2, ud1);
 555         *(sp + 1) = (Cell) addr;
 556         *sp = u1;
 557 }
 558
 559 void _read_const() {
 560         register Cell n;
 561         register Cell usign = 1;
 562         register UDCell num;
 563         register const_type = 1;
 564         register Char *orig = (Char *) sp[1];
 565         register Cell orig_len = sp[0];
 566         if (sp[0] && *((Char *) sp[1]) == '-') {
 567                 usign = -1;
 568                 sp[1] += sizeof(Char);
 569                 sp[0]--;
 570         }
 571         while (sp[0]) {
 572                 _to_number();
 573                 if (sp[0] && *((Char *) sp[1]) == '.') {
 574                         const_type = 2;
 575                         sp[0]--;
 576                         sp[1] += sizeof(Char);
 577                 } else break;
 578         }
 579         n = *sp++;
 580         num = GET_DCELL(sp + 1);
 581         if (usign < 0) {
 582                 num = -num;
 583                 PUT_DCELL(sp + 1, num);
 584         }
 585         if (!n) *sp = const_type;
 586 #ifdef FLOAT_DEF
 587         else {
 588                 if (_base == 10) {
 589                         sp++;
 590                         sp[1] = (Cell) orig;
 591                         sp[0] = orig_len;
 592                         _to_float();
 593                         if (*sp) sp[0] = 3;
 594                 } else *sp = 0;
 595         }
 596 #else
 597         else *sp = 0;
 598 #endif
 599 }
 600
 601 void _interpret() {
 602         register struct word_def *xt;
 603         while (!_error && _to_in < _in_input_buffer) {
 604                 *--sp = ' ';
 605                 _word();
 606                 sp++;
 607                 if (!(*_dp)) continue;                          /* Please forget this! */
 608                 xt = search_word(_dp + 1, *_dp);
 609                 if (xt) {
 610                         if (_state == INTERPRET) {
 611                                 if (xt->class & COMP_ONLY) _error = E_NOCOMP;
 612                                 else exec_word(xt);
 613                         } else /* _state == COMPILE */ {
 614                                 if (xt->class & IMMEDIATE) exec_word(xt);
 615                                 else compile_word(xt);
 616                         }
 617                 } else /* xt == 0 */ {
 618                         register UDCell num;
 619                         *--sp = 0;
 620                         *--sp = 0;
 621                         *--sp = (Cell) (_dp + sizeof(Char));
 622                         *--sp = (Cell) *_dp;
 623                         _read_const();
 624                         if (!(*sp)) {
 625                                 sp++;
 626                                 _error = E_NOWORD;
 627                         } else {
 628                                 switch (*sp++) {
 629                                         case 1:
 630                                                 num = GET_DCELL(sp);
 631                                                 if (_state == INTERPRET) sp++;
 632                                                 else {
 633                                                         sp += 2;
 634                                                         compile_cell((Cell) _do_literal);
 635                                                         compile_cell((Cell) num);
 636                                                 }
 637                                                 break;
 638                                         case 2:
 639                                                 num = GET_DCELL(sp);
 640                                                 if (_state == COMPILE) {
 641                                                         sp += 2;
 642                                                         compile_cell((Cell) _do_literal);
 643                                                         compile_cell((Cell) num);
 644                                                         compile_cell((Cell) _do_literal);
 645                                                         compile_cell((Cell) (num >> CellBits));
 646                                                 }
 647                                                 break;
 648                                         case 3:
 649                                                 if (_state == COMPILE) {
 650                                                         compile_cell((Cell) _do_fliteral);
 651                                                         compile_real(*fp);
 652                                                         fp++;
 653                                                 }
 654                                                 break;
 655                                 }
 656                         }
 657                 }
 658         }
 659 }
 660
 661 void _accept() {
 662     register Cell n1 = *sp++;
 663     register Char *addr = (Char *) *sp;
 664         register int i = 0;
 665     register char ch;
 666     do {
 667                 ch = getchar();
 668         i = process_char(addr, n1, i, ch);
 669     } while (ch != '\n');
 670     *sp = i;
 671 }
 672
 673 void _source() {
 674     *--sp = (Cell) _input_buffer;
 675     *--sp = _in_input_buffer;
 676 }
 677
 678 void _paren() {
 679         register Cell eof = 1;
 680         do {
 681                 while (_to_in < _in_input_buffer && _input_buffer[_to_in] != ')') _to_in++;
 682                 if (_source_id != 0 && _source_id != -1 && _to_in == _in_input_buffer) {
 683                         _refill();
 684                         eof = !(*sp++);
 685                 }
 686         } while (_to_in == _in_input_buffer && !eof);
 687         if (_to_in < _in_input_buffer) _to_in++;
 688 }
 689
 690 void _evaluate() {
 691     register Cell u = *sp++;
 692         register Char *addr = (Char *) *sp++;
 693         save_input_specification();
 694         _source_id = -1;
 695         _in_input_buffer = u;
 696         _input_buffer = addr;
 697         _to_in = 0;
 698         _b_l_k = 0;
 699         _interpret();
 700         restore_input_specification();
 701 }
 702
 703 void _view_error_msg() {
 704         static struct an_error {
 705                 char *msg;
 706                 char please_abort;
 707                 char print_word;
 708         } err_msg[] = {
 709                 { "everything allright",                                0, 0 },
 710                 { "no input avaliable",                                 0, 0 },
 711                 { "unknown word",                                               0, 1 },
 712                 { "word must be compiled",                              0, 1 },
 713                 { "corrupted dictionary",                               1, 0 },
 714                 { "not enough memory",                                  0, 0 },
 715                 { "data-stack underflow",                               1, 0 },
 716                 { "data-stack overflow",                                1, 0 },
 717                 { "return-stack underflow",                             1, 0 },
 718                 { "return-stack overflow",                              1, 0 },
 719                 { "floating-stack underflow",                   1, 0 },
 720                 { "floating-stack overflow",                    1, 0 },
 721                 { "data-space corrupted",                               1, 0 },
 722                 { "data-space exhausted",                               1, 0 },
 723                 { "unable to access image file",                0, 0 },
 724                 { "primitive not implemented",          0, 1 },
 725                 { "floating-point/math exception",              0, 0 },
 726                 { "segmentation fault",                                 0, 0 },
 727                 { "file not found",                                             0, 0 },
 728         };
 729         if (err_msg[-_error].print_word) {
 730                 putchar('[');
 731                 *--sp = (Cell) _dp;
 732                 _count();
 733                 _type();
 734                 printf("] ");
 735         }
 736         printf("error(%d): %s.\n", -_error, err_msg[-_error].msg);
 737         if (err_msg[-_error].please_abort) {
 738                 printf("Aborting...\n");
 739                 _abort();
 740         }
 741 }
 742
 743 void _quit() {
 744         while (1) {
 745                 rp = rp_top;
 746                 _source_id = 0;
 747                 _input_buffer = _tib;
 748                 _state = INTERPRET;
 749                 _error = E_OK;
 750                 while (_error == E_OK) {
 751                         _refill();
 752                         if (*sp++) {
 753                                 _to_in = 0;
 754                                 _interpret();
 755                                 if (_state == INTERPRET && !_error) printf("ok\n");
 756                                 else if (_state == COMPILE) printf("ko ");
 757                         } else _error = E_NOINPUT;
 758                         if (_error == E_OK && _check_system) check_system();
 759                 }
 760                 _view_error_msg();
 761         }
 762 }
 763
 764 void _comma() {
 765         *((Cell *) _dp) = *sp++;
 766         _dp += sizeof(Cell);
 767 }
 768
 769 void _allot() {
 770         _dp += *sp++;
 771 }
 772
 773 void _c_comma() {
 774         *_dp++ = (Char) *sp++;
 775 }
 776
 777 void _here() {
 778     *--sp = (Cell) _dp;
 779 }
 780
 781 void _do_exit() {
 782         ip = 0;
 783 }
 784
 785 void _exit_imm() {
 786         clear_locals();
 787         compile_cell((Cell) _do_exit);
 788 }
 789
 790 void _paren_do_colon_paren() {
 791         *--rp = (Cell) (ip + 1);
 792         ip = (pfp *) *ip;
 793         while (ip) (*ip++)();
 794         ip = (pfp *) *rp++;
 795 }
 796
 797 void _colon() {
 798         create_definition(A_COLON);
 799         _state = COMPILE;
 800         init_locals();
 801 }
 802
 803 void _variable() {
 804         create_definition(A_VARIABLE);
 805         compile_cell(0);
 806         mark_word(_last);
 807 }
 808
 809 void _constant() {
 810         register Cell x = *sp++;
 811         create_definition(A_CONSTANT);
 812         compile_cell(x);
 813         mark_word(_last);
 814 }
 815
 816 void _create() {
 817         create_definition(A_CREATE);
 818         compile_cell(0);
 819         mark_word(_last);
 820 }
 821
 822 void _does() {
 823         compile_cell((Cell) _paren_does_paren);
 824         _exit_imm();
 825         mark_word(_last);
 826         init_locals();
 827 }
 828
 829 void _paren_does_paren() {
 830         _last->func[0] = (pfp) (ip + 1);
 831 }
 832
 833 void _semi_colon() {
 834         _exit_imm();
 835         _state = INTERPRET;
 836         mark_word(_last);
 837 }
 838
 839 void _zero_branch() {
 840         if (*sp++) ip++;
 841         else ip += 1 + (Cell) *ip;
 842 }
 843
 844 void _branch() {
 845         ip += 1 + (Cell) *ip;
 846 }
 847
 848 void _if() {
 849         compile_cell((Cell) _zero_branch);
 850         *--sp = (Cell) _dp;
 851         compile_cell(0);
 852 }
 853
 854 void _then() {
 855     register Cell *patch = (Cell *) *sp++;
 856     *patch = ((Cell *) _dp) - patch - 1;
 857 }
 858
 859 void _else() {
 860         _ahead();
 861         *--sp = 1;
 862         _roll();
 863         _then();
 864 }
 865
 866 void _begin() {
 867     *--sp = (Cell) _dp;
 868 }
 869
 870 void _do() {
 871     compile_cell((Cell) _paren_do_paren);
 872     *--sp = (Cell) _dp;
 873     *--sp = 0;  /* Non e' un ?do */
 874 }
 875
 876 void _paren_do_paren() {
 877     *--rp = *sp++;
 878     *--rp = *sp++;
 879     /* R: index limit --- */
 880 }
 881
 882 void _loop() {
 883     register Cell q_do = *sp++;
 884     register Cell *dest = (Cell *) *sp++;
 885     compile_cell((Cell) _paren_loop_paren);
 886     compile_cell(dest - ((Cell *) _dp) - 1);
 887     if (q_do) {
 888         register Cell *patch = (Cell *) *sp++;
 889         *patch = ((Cell *) _dp) - patch - 1;
 890     }
 891 }
 892
 893 void _paren_loop_paren() {
 894     if (rp[0] == ++rp[1]) {
 895         ip++;
 896         rp += 2;
 897     } else ip += 1 + (Cell) *ip;
 898 }
 899
 900 void _i() {
 901     *--sp = rp[1];
 902 }
 903
 904 void _j() {
 905     *--sp = rp[3];
 906 }
 907
 908 void _plus_loop() {
 909     register Cell q_do = *sp++;
 910     register Cell *dest = (Cell *) *sp++;
 911     compile_cell((Cell) _paren_plus_loop_paren);
 912     compile_cell(dest - ((Cell *) _dp) - 1);
 913     if (q_do) {
 914         register Cell *patch = (Cell *) *sp++;
 915         *patch = ((Cell *) _dp) - patch - 1;
 916     }
 917 }
 918
 919 void _paren_plus_loop_paren() {
 920     register Cell old_index = *rp;
 921     rp[1] += *sp++;
 922     if (old_index < rp[1] && rp[0] >= rp[1]) {
 923         ip++;
 924         rp += 2;
 925     } else ip += 1 + (Cell) *ip;
 926 }
 927
 928 void _find() {
 929         register Char *addr = (Char *) *sp;
 930         register Cell len = (Cell) *addr++;
 931         register struct word_def *xt = search_word(addr, len);
 932         set_find_stack(addr, xt);
 933 }
 934
 935 void _recurse() {
 936     compile_cell((Cell) _paren_do_colon_paren);
 937     compile_cell((Cell) &_last->func[0]);
 938 }
 939
 940 void _tick() {
 941     register Char *addr;
 942     *--sp = ' ';
 943         _word();
 944         addr = (Char *) *sp;
 945         if (!(*sp = (Cell) search_word(addr + 1, *addr))) _error = E_NOWORD;
 946 }
 947
 948 void _to_body() {
 949         *sp = (Cell) &((struct word_def *) *sp)->func[0];
 950 }
 951
 952 void _abort() {
 953         *--sp = -1;
 954         _throw();
 955 }
 956
 957 void _abort_quote() {
 958         _if();
 959         _s_quote();
 960         compile_cell((Cell) _do_literal);
 961         compile_cell(-2);
 962         compile_cell((Cell) _throw);
 963         _then();
 964 }
 965
 966 void _count() {
 967         register Char *addr = (Char *) *sp;
 968     sp--;
 969     sp[0] = (Cell) *addr;
 970     sp[1]++;
 971 }
 972
 973 void _decimal() {
 974     _base = 10;
 975 }
 976
 977 void _environment_query() {
 978         register Cell len = *sp++;
 979         register Char *addr = (Char *) *sp++;
 980         static struct {
 981                 Char *name;
 982                 Cell *var;
 983         } kw[] = {
 984                 { "/COUNTED-STRING",            &_env_slash_counted_string },
 985                 { "/HOLD",                                      &_env_slash_hold },
 986                 { "/PAD",                                       &_env_slash_pad },
 987                 { "ADDRESS-UNIT-BITS",          &_env_address_unit_bits },
 988                 { "CORE",                                       &_env_core },
 989                 { "CORE-EXT",                           &_env_core_ext },
 990                 { "FLOORED",                            &_env_floored },
 991                 { "MAX-CHAR",                           &_env_max_char },
 992                 { "MAX-D",                                      &_env_max_d },
 993                 { "MAX-N",                                      &_env_max_n },
 994                 { "MAX-U",                                      &_env_max_u },
 995                 { "MAX-UD",                                     &_env_max_ud },
 996                 { "RETURN-STACK-CELLS",         &_env_return_stack_cells },
 997                 { "STACK-CELLS",                        &_env_stack_cells },
 998                 { "DOUBLE",                                     &_env_double },
 999                 { "DOUBLE-EXT",                         &_env_double_ext },
1000                 { "FLOATING",                           &_env_floating },
1001                 { "FLOATING-STACK",                     &_env_floating_stack },
1002                 { "MAX-FLOAT",                          &_env_max_float },
1003                 { "FLOATING-EXT",                       &_env_floating_ext },
1004                 { "MEMORY-ALLOC",                       &_env_memory_alloc },
1005                 { "MEMORY-ALLOC-EXT",           &_env_memory_alloc_ext },
1006                 { "SEARCH-ORDER",                       &_env_search_order },
1007                 { "WORDLISTS",                          &_env_wordlists },
1008                 { "SEARCH-ORDER-EXT",           &_env_search_order_ext },
1009                 { "TOOLS",                                      &_env_tools },
1010                 { "TOOLS-EXT",                          &_env_tools_ext },
1011                 { "#LOCALS",                            &_env_number_locals },
1012                 { "LOCALS",                                     &_env_locals },
1013                 { "LOCALS-EXT",                         &_env_locals_ext },
1014                 { "FACILITY",                           &_env_facility },
1015                 { "FACILITY-EXT",                       &_env_facility_ext },
1016                 { "BLOCK",                                      &_env_block },
1017                 { "BLOCK-EXT",                          &_env_block_ext },
1018                 { "EXCEPTION",                          &_env_exception },
1019                 { "EXCEPTION-EXT",                      &_env_exception_ext },
1020                 { "FILE",                                       &_env_file },
1021                 { "FILE-EXT",                           &_env_file_ext },
1022                 { "STRING",                                     &_env_string },
1023                 { "STRING-EXT",                         &_env_string_ext },
1024                 { NULL,                                         NULL },
1025         };
1026         register int i = 0;
1027         for (i = 0; i < len; i++) addr[i] = toupper(addr[i]);
1028         i = 0;
1029         while (kw[i].name && memcmp(addr, kw[i].name, len)) i++;
1030         if (kw[i].name) {
1031                 if (!strcmp(kw[i].name + 1, "MAX-UD")) {
1032                         sp -= 2;
1033                         PUT_DCELL(sp, MAX_UD);
1034                 } else if (!strcmp(kw[i].name + 1, "MAX-FLOAT"))
1035                         *--fp = MAX_F;
1036                 else *--sp = *kw[i].var;
1037                 *--sp = FFLAG(1);
1038         } else *--sp = FFLAG(0);
1039 }
1040
1041 void _execute() {
1042         exec_word((struct word_def *) *sp++);
1043 }
1044
1045 void _fill() {
1046         register int c = (int) *sp++;
1047         register UCell u = (UCell) *sp++;
1048         register Char *addr = (Char *) *sp++;
1049         if (u) memset(addr, c, u);
1050 }
1051
1052 void _immediate() {
1053     _last->class |= IMMEDIATE;
1054 }
1055
1056 void _key() {
1057         *--sp = d_getch();
1058 }
1059
1060 void _leave() {
1061     rp += 2;
1062         while (*ip != _paren_loop_paren && *ip != _paren_plus_loop_paren) ip++;
1063     ip += 2;
1064 }
1065
1066 void _literal() {
1067     compile_cell((Cell) _do_literal);
1068     compile_cell(sp[0]);
1069     sp++;
1070 }
1071
1072 void _move() {
1073     register UCell u = (UCell) *sp++;
1074     register Char *dest = (Char *) *sp++;
1075     register Char *source = (Char *) *sp++;
1076     if (u) memmove(dest, source, u);
1077 }
1078
1079 void _postpone() {
1080     *--sp = ' ';
1081     _word();
1082     _find();
1083     if (*sp++ > 0)  /* IMMEDIATE word */
1084         compile_word((struct word_def *) *sp++);
1085     else {
1086         compile_cell((Cell) _paren_compile_paren);
1087         compile_cell(sp[0]);
1088         sp++;
1089     }
1090 }
1091
1092 void _paren_compile_paren() {
1093     compile_word((struct word_def *) *sp++);
1094 }
1095
1096 void _s_quote() {
1097         if (_state == INTERPRET) {
1098                 *--sp = '"';
1099                 _word();
1100                 memcpy(s_tmp_buffer, _dp, *_dp + 1);
1101                 sp[0] = (Cell) s_tmp_buffer;
1102                 _count();
1103         } else {
1104                 _c_quote();
1105                 compile_cell((Cell) _count);
1106         }
1107 }
1108
1109 void _sign() {
1110     if (*sp++ < 0) {
1111                 *p_pnos-- = '-';
1112                 in_pnos++;
1113     }
1114 }
1115
1116 void _unloop() {
1117     rp += 2;
1118 }
1119
1120 void _left_bracket() {
1121     _state = INTERPRET;
1122 }
1123
1124 void _bracket_tick() {
1125     _tick();
1126     _literal();
1127 }
1128
1129 void _char() {
1130         *--sp = ' ';
1131         _word();
1132         sp[0] = _dp[1];
1133 }
1134
1135 void _bracket_char() {
1136         _char();
1137         _literal();
1138 }
1139
1140 void _right_bracket() {
1141     _state = COMPILE;
1142 }
1143
1144 void _while() {
1145         _if();
1146         *--sp = 1;
1147         _roll();
1148 }
1149
1150 void _repeat() {
1151         _again();
1152         _then();
1153 }
1154
1155 void _do_value() {
1156         *--sp = (Cell) *((Cell *) *ip++);
1157 }
1158
1159 /**************************************************************************/
1160 /* AUXILIARY FUNCTIONS ****************************************************/
1161 /**************************************************************************/
1162
1163 /* strmatch: compare two strings, the first is expressed as (s1, len), while
1164  * the second is a counted string pointed by "s2". If the two strings are
1165  * identical return 0, 1 otherwise. The comparison is case INsensitive
1166  */
1167 int strmatch(const Char *s1, const Char *s2, int len1) {
1168         if (len1 != *s2++) return (1);
1169         else {
1170                 while (len1--) if (toupper(*s1++) != toupper(*s2++)) return (1);
1171                 return (0);
1172         }
1173 }
1174
1175 /* search_wordlist: search a word (name, len) within the selected vocabulary.
1176  * Called by "search_word"
1177  */
1178 struct word_def *search_wordlist(Char *name, Cell len, struct vocabulary *wid) {
1179         register struct word_def *p = wid->voc[hash_func(name, len)];
1180         while (p && strmatch(name, p->name, len)) p = p->link;
1181         return (p);
1182 }
1183
1184 /* search_word: search the word (name, len) into the vocabularies, starting
1185  * with the vocabulary on the top of the vocabularies stack. If found,
1186  * return the word's execution token, which is a pointer to the structure
1187  * "word_def" of the word. If not found, return NULL.
1188  */
1189 struct word_def *search_word(Char *name, Cell len) {
1190         register struct word_def *p;
1191         register Cell ttop = top;
1192         if (locals_defined()) {
1193                 p = get_first_local();
1194                 while (p && strmatch(name, p->name, len)) p = p->link;
1195                 if (p) return (p);
1196         }
1197         while (ttop >= 0) {
1198                 p = search_wordlist(name, len, ttop >= 0 ? list[ttop] : forth_wid);
1199                 if (p) return (p);
1200                 ttop--;
1201         }
1202         return (0);
1203 }
1204
1205 /* ins_word: add the word with execution token "p" in the current
1206  * compilation vocabulary
1207  */
1208 void ins_word(struct word_def *p) {
1209         register int hash = hash_func(p->name + 1, *p->name);
1210         p->link = voc->voc[hash];
1211 }
1212
1213 /* mark_word: make the word with execution token "p" visible, by updating
1214  * the compilation vocabulary head pointer
1215  */
1216 void mark_word(struct word_def *p) {
1217         register int hash = hash_func(p->name + 1, *p->name);
1218         voc->voc[hash] = p;
1219 }
1220
1221 /* set_find_stack: setup the data stack after a search in the vocabularies
1222  * as reuired by the word "find"
1223  */
1224 void set_find_stack(Char *addr, struct word_def *xt) {
1225         if (xt) {
1226                 *sp = (Cell) xt;
1227                 if (xt->class & IMMEDIATE) *--sp = 1;
1228                 else *--sp = (Cell) -1;
1229         } else {
1230                 *sp = (Cell) addr;
1231                 *--sp = 0;
1232         }
1233 }
1234
1235 /* is_base_digit: return true if the digit "ch" is valid in the current base
1236  * stored in the variable "base".
1237  */
1238 int is_base_digit(Char ch) {
1239         ch = toupper(ch);
1240         if (ch >= '0' && ch <= '9') {
1241                 if (ch - '0' < _base) return (1);
1242                 else return (0);
1243         }
1244         if (ch >= 'A' && ch <= 'Z') {
1245                 if (ch - 'A' + 10 < _base) return (1);
1246                 else return (0);
1247         }
1248         return (0);
1249 }
1250
1251 /* process_char: do the work when a key is stroken on the keyboard.
1252  * "addr" is a base pointer to the buffer where the characters are to be
1253  * stored, "max_len" is the size of the buffer, "cur_pos" the current
1254  * position within the buffer, and "ch" the character to be processed.
1255  */
1256 int process_char(Char *addr, int max_len, int cur_pos, char ch) {
1257         switch (ch) {
1258                 case '\b':
1259                         if (cur_pos) cur_pos--;
1260                         else putchar('\a');
1261                         break;
1262                 case 0:
1263         case EOF:
1264         default:
1265             if (ch >= 32) {
1266                                 if (cur_pos < max_len) addr[cur_pos++] = ch;
1267                                 else putchar('\a');
1268             }
1269                         break;
1270         }
1271         return cur_pos;
1272 }
1273
1274 /* create_definition: create a new word in the dictionary allocating the
1275  * space for the name, which is stored yet by the call to "word", then
1276  * allocating a structure "word_def" and setting the "class" field to the
1277  * value passed to the function.
1278  */
1279 void create_definition(Cell class) {
1280         register struct word_def *def;
1281         register Char *name;
1282         *--sp = (Cell) ' ';
1283         name = _dp;
1284         _word();
1285         sp++;
1286         _dp = (Char *) WORD_PTR(_dp);
1287         _align();
1288         def = (struct word_def *) _dp;
1289         _last = def;
1290         def->name = name;
1291         def->class = class;
1292         ins_word(def);
1293         _dp += sizeof(struct word_def) - sizeof(Cell);
1294 }
1295
1296 /* exec_colon: execute a colon definition, with the first instruction pointed
1297  * by "ip0"
1298  */
1299 void exec_colon(pfp *ip0) {
1300         register pfp *old_ip = ip;
1301         ip = ip0;
1302         while (ip) (*ip++)();
1303         ip = old_ip;
1304 }
1305
1306 /* exec_word: execute the word with execution token "xt" when interpreting
1307  */
1308 void exec_word(struct word_def *xt) {
1309         switch (xt->class & A_WORD) {
1310                 case A_PRIMITIVE: xt->func[0](); break;
1311                 case A_FVARIABLE:
1312                 case A_2VARIABLE:
1313                 case A_VARIABLE: *--sp = (Cell) &xt->func[0]; break;
1314                 case A_COLON: exec_colon(&xt->func[0]); break;
1315                 case A_VALUE:
1316                 case A_USER:
1317                 case A_CONSTANT: *--sp = (Cell) xt->func[0]; break;
1318                 case A_2CONSTANT:
1319                         *--sp = (Cell) xt->func[0];
1320                         *--sp = (Cell) xt->func[1];
1321                         break;
1322                 case A_FCONSTANT: *--fp = *((Real *) &xt->func[0]); break;
1323                 case A_CREATE:
1324                         *--sp = (Cell) &xt->func[1];
1325                         if (xt->func[0]) exec_colon((pfp *) xt->func[0]);
1326                         break;
1327                 case A_MARKER:
1328                         exec_marker((struct voc_marker *) &xt->func[0]);
1329                         break;
1330                 case A_LOCAL:
1331                 default: _error = E_NOVOC; break;
1332         }
1333 }
1334
1335 /* compile_word: compile word with execution token "xt" within the dictionary
1336  */
1337 void compile_word(struct word_def *xt) {
1338         switch (xt->class & A_WORD) {
1339                 case A_PRIMITIVE:
1340                         compile_cell((Cell) xt->func[0]);
1341                         break;
1342                 case A_VARIABLE:
1343                 case A_2VARIABLE:
1344                 case A_FVARIABLE:
1345                         compile_cell((Cell) _do_literal);
1346                         compile_cell((Cell) &xt->func[0]);
1347                         break;
1348                 case A_VALUE:
1349                         compile_cell((Cell) _do_value);
1350                         compile_cell((Cell) &xt->func[0]);
1351                         break;
1352                 case A_USER:
1353                 case A_CONSTANT:
1354                         compile_cell((Cell) _do_literal);
1355                         compile_cell((Cell) xt->func[0]);
1356                         break;
1357                 case A_2CONSTANT:
1358                         compile_cell((Cell) _do_literal);
1359                         compile_cell((Cell) xt->func[0]);
1360                         compile_cell((Cell) _do_literal);
1361                         compile_cell((Cell) xt->func[1]);
1362                         break;
1363                 case A_FCONSTANT:
1364                         compile_cell((Cell) _do_fliteral);
1365                         compile_real(*((Real *) &xt->func[0]));
1366                         break;
1367                 case A_COLON:
1368                         compile_cell((Cell) _paren_do_colon_paren);
1369                         compile_cell((Cell) &xt->func[0]);
1370                         break;
1371                 case A_CREATE:
1372                         compile_cell((Cell) _do_literal);
1373                         compile_cell((Cell) &xt->func[1]);
1374                         if (xt->func[0]) {
1375                                 compile_cell((Cell) _paren_do_colon_paren);
1376                                 compile_cell((Cell) xt->func[0]);
1377                         }
1378                         break;
1379                 case A_LOCAL:
1380                         compile_cell((Cell) _paren_read_local_paren);
1381                         compile_cell((Cell) xt->func[0]);
1382                         break;
1383                 case A_MARKER:
1384                         compile_cell((Cell) _paren_marker_paren);
1385                         compile_cell((Cell) &xt->func[0]);
1386                         break;
1387                 default: _error = E_NOVOC; break;
1388         }
1389 }
1390
1391 /* save_input_specification: save all the information needed to restore the
1392  * state of current input later. First the word "save-input" is called, and
1393  * then each Cell on the stack is copied in the return stack
1394  */
1395 void save_input_specification() {
1396         register int dim, dim1;
1397         _save_input();
1398         dim1 = dim = *sp++;
1399         while (dim--) _to_r();
1400         *--sp = (Cell) dim1;
1401         _to_r();
1402 }
1403
1404 /* restore_input_specification: restore the input source by calling
1405  * "restore-input" after that the Cells on the return stack has been moved
1406  * on the data stack
1407  */
1408 void restore_input_specification() {
1409         register int dim = *rp++, dim1 = dim;
1410         while (dim--) _r_from();
1411         *--sp = (Cell) dim1;
1412         _restore_input();
1413         sp++;
1414 }
1415
1416 /* check_system: perform some tests to verify that's everything ok */
1417 void check_system() {
1418         if (sp > sp_top) _error = E_DSTK_UNDER;
1419         else if (sp < sp_base) _error = E_DSTK_OVER;
1420         else if (rp > rp_top) _error = E_RSTK_UNDER;
1421         else if (rp < rp_base) _error = E_RSTK_OVER;
1422         else if (fstack_size && fp > fp_top) _error = E_FSTK_UNDER;
1423         else if (fstack_size && fp < fp_base) _error = E_FSTK_OVER;
1424         else if (_dp < dp0) _error = E_DSPACE_UNDER;
1425         else if (_dp > dp0 + dspace_size) _error = E_DSPACE_OVER;
1426 }