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

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