git.gag.com Git - debian/yforth/blob - coree.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:     coree.c
  18  * Abstract:        Core extension word set
  19  */
  20
  21 #include "yforth.h"
  22
  23 #include <string.h>
  24 #include <stdio.h>
  25 #include "core.h"
  26 #include "coree.h"
  27 #include "double.h"
  28 #include "locals.h"
  29 #include "block.h"
  30 #include "search.h"
  31
  32 /**************************************************************************/
  33 /* VARIABLES **************************************************************/
  34 /**************************************************************************/
  35
  36 Char * _pad;
  37
  38 /**************************************************************************/
  39 /* WORDS ******************************************************************/
  40 /**************************************************************************/
  41
  42 void _dot_paren() {
  43     *--sp = ')';
  44     _word();
  45     _count();
  46     _type();
  47 }
  48
  49 void _dot_r() {
  50         register Cell u = *sp++;
  51         _s_to_d();
  52         *--sp = u;
  53         _d_dot_r();
  54 }
  55
  56 void _zero_not_equals() {
  57         sp[0] = FFLAG(sp[0] != 0);
  58 }
  59
  60 void _zero_greater() {
  61     sp[0] = FFLAG(sp[0] > 0);
  62 }
  63
  64 void _two_to_r() {
  65     rp -= 2;
  66     rp[0] = *sp++;
  67         rp[1] = *sp++;
  68 }
  69
  70 void _two_r_from() {
  71     sp -= 2;
  72     sp[0] = *rp++;
  73     sp[1] = *rp++;
  74 }
  75
  76 void _two_r_fetch() {
  77     sp -= 2;
  78     sp[0] = rp[0];
  79     sp[1] = rp[1];
  80 }
  81
  82 void _colon_no_name() {
  83     register struct word_def *def;
  84     _align();
  85     def = (struct word_def *) _dp;
  86         def->name = 0;
  87         def->link = 0;
  88         def->class = A_COLON;
  89         _dp += sizeof(struct word_def) - sizeof(Cell);
  90         _state = COMPILE;
  91         *--sp = (Cell) def;
  92         init_locals();
  93 }
  94
  95 void _not_equals() {
  96         sp[1] = FFLAG(sp[0] != sp[1]);
  97     sp++;
  98 }
  99
 100 void _question_do() {
 101     compile_cell((Cell) _paren_question_do_paren);
 102     *--sp = (Cell) _dp;
 103     compile_cell(0);
 104     *--sp = (Cell) _dp;
 105     *--sp = 1;  /* e' un ?do */
 106 }
 107
 108 void _paren_question_do_paren() {
 109     if (sp[0] == sp[1]) ip += 1 + (Cell) *ip;
 110     else {
 111                 *--rp = *sp++;
 112                 *--rp = *sp++;
 113                 ip++;
 114         }
 115 }
 116
 117 void _again() {
 118         register Cell *dest = (Cell *) *sp++;
 119         compile_cell((Cell) _branch);
 120         compile_cell(dest - ((Cell *) _dp) - 1);
 121 }
 122
 123 void _c_quote() {
 124         register Char *cur;
 125         register Cell *patch;
 126         compile_cell((Cell) _branch);
 127         patch = (Cell *) _dp;
 128         compile_cell(0);
 129         cur = _dp;
 130         *--sp = '"';
 131         _word();
 132         sp++;
 133         _dp = (Char *) WORD_PTR(_dp);
 134     *patch = ((Cell *) _dp) - patch - 1;
 135     compile_cell((Cell) _do_literal);
 136     compile_cell((Cell) cur);
 137 }
 138
 139 void _compile_comma() {
 140     compile_word((struct word_def *) *sp++);
 141 }
 142
 143 void _erase() {
 144     register UCell u = (UCell) *sp++;
 145     register Char *addr = (Char *) *sp++;
 146     if (u) memset(addr, 0, u);
 147 }
 148
 149 void _false() {
 150     *--sp = FFLAG(0);
 151 }
 152
 153 void _hex() {
 154         _base = 16;
 155 }
 156
 157 void _marker() {
 158         struct voc_marker vm;
 159         save_vocabulary(&vm);
 160         create_definition(A_MARKER);
 161         memcpy(_dp, &vm, sizeof(struct voc_marker));
 162         _dp += ALIGN_PTR(sizeof(struct voc_marker));
 163         mark_word(_last);
 164 }
 165
 166 void _nip() {
 167     sp[1] = sp[0];
 168     sp++;
 169 }
 170
 171 void _parse() {
 172     register Char delim = (Char) *sp;
 173     register Char *orig = &_input_buffer[_to_in];
 174     register int i = 0;
 175     while (_to_in < _in_input_buffer && _input_buffer[_to_in] != delim) {
 176         _to_in++;
 177         i++;
 178     }
 179     *sp = (Cell)orig;
 180     *--sp = i;
 181
 182     if (_to_in < _in_input_buffer) _to_in++;
 183 }
 184
 185 void _pick() {
 186         sp[0] = sp[sp[0] + 1];
 187 }
 188
 189 void _refill() {
 190         if (_b_l_k != 0) {
 191                 current_block = _b_l_k++;
 192                 _to_in = 0;
 193                 *--sp = _b_l_k;
 194                 _block();
 195                 _input_buffer = (Char *) *sp++;
 196                 _in_input_buffer = BLOCK_SIZE;
 197                 *sp = FFLAG(_b_l_k && _input_buffer != NULL);
 198         } else if (_source_id == 0) {
 199         *--sp = (Cell) _tib;
 200                 *--sp = tib_size;
 201         _accept();
 202                 _input_buffer = _tib;
 203         _in_input_buffer = *sp;
 204         _to_in = 0;
 205         *sp = FFLAG(1);
 206     } else if (_source_id == -1) {
 207                 *--sp = FFLAG(0);
 208         } else if (_env_file) {
 209                 if (fgets(_input_buffer, FILE_BUFFER_SIZE, (FILE *) _source_id)) {
 210                         _in_input_buffer = strlen(_input_buffer);
 211                         if (_in_input_buffer && _input_buffer[_in_input_buffer - 1] == '\n')
 212                                 _in_input_buffer--;
 213                         _to_in = 0;
 214                         *--sp = FFLAG(1);
 215                 } else *--sp = FFLAG(0);
 216         } else *--sp = FFLAG(0);
 217 }
 218
 219 void _restore_input() {
 220         sp++;
 221         _b_l_k = *sp++;
 222         _to_in = *sp++;
 223         _in_input_buffer = *sp++;
 224         _input_buffer = (Char *) *sp++;
 225         _source_id = *sp++;
 226         if (_source_id == 0) {
 227         } else if (_source_id == -1) {
 228         } else {
 229         }
 230         *--sp = FFLAG(1);
 231 }
 232
 233 void _roll() {
 234         register Cell u = *sp++;
 235         register Cell xu = sp[u];
 236         register int i;
 237         for (i = u; i > 0; i--) sp[i] = sp[i - 1];
 238         sp[0] = xu;
 239 }
 240
 241 void _save_input() {
 242         if (_source_id == 0) {
 243         } else if (_source_id == -1) {
 244         } else {
 245         }
 246         *--sp = _source_id;
 247         *--sp = (Cell) _input_buffer;
 248         *--sp = _in_input_buffer;
 249         *--sp = _to_in;
 250         *--sp = _b_l_k;
 251         *--sp = 5;
 252 }
 253
 254 void _true() {
 255         *--sp = FFLAG(1);
 256 }
 257
 258 void _tuck() {
 259         sp--;
 260         sp[0] = sp[1];
 261         sp[1] = sp[2];
 262         sp[2] = sp[0];
 263 }
 264
 265 void _u_dot_r() {
 266     register Cell r = *sp++;
 267         *--sp = 0;
 268         _less_number_sign();
 269         _number_sign_s();
 270         _number_sign_greater();
 271         if (sp[0] < r) {
 272                 sp--;
 273                 sp[0] = r - sp[1];
 274                 _spaces();
 275         }
 276     _type();
 277     putchar(' ');
 278 }
 279
 280 void _u_greater_than() {
 281     sp[1] = FFLAG((UCell) sp[1] > (UCell) sp[0]);
 282         sp++;
 283 }
 284
 285 void _unused() {
 286         *--sp = (dspace_size - (_dp - dp0)) * sizeof(Cell);
 287 }
 288
 289 void _within() {
 290         register Cell n3 = *sp++;
 291     register Cell n2 = *sp++;
 292     register Cell n1 = *sp;
 293     sp[0] = FFLAG((n2 < n3 && (n2 <= n1 && n1 < n3)) ||
 294                   (n2 > n3 && (n2 <= n1 || n1 < n3)));
 295 }
 296
 297 void _backslash() {
 298     _to_in = _in_input_buffer;
 299 }
 300
 301 void _bracket_compile() {
 302         *--sp = ' ';
 303     _word();
 304     sp++;
 305     compile_word(search_word(_dp + 1, *_dp));
 306 }
 307
 308 void _value() {
 309         create_definition(A_VALUE);
 310         compile_cell((Cell) sp[0]);
 311         sp++;
 312         mark_word(_last);
 313 }
 314
 315 void _paren_write_value_paren() {
 316         register Cell *p = (Cell *) (*ip++);
 317         *p = *sp++;
 318 }
 319
 320 void _to() {
 321         _b_l();
 322         _word();
 323         _find();
 324         if (*sp++) {
 325                 register struct word_def *xt = (struct word_def *) *sp++;
 326                 if ((xt->class & A_WORD) == A_VALUE) {
 327                         if (_state == INTERPRET) xt->func[0] = (pfp) *sp++;
 328                         else {
 329                                 compile_cell((Cell) _paren_write_value_paren);
 330                                 compile_cell((Cell) &xt->func[0]);
 331                         }
 332                 } else if (xt->class & A_WORD == A_LOCAL && _state == COMPILE) {
 333                         compile_cell((Cell) _paren_write_local_paren);
 334                         compile_cell((Cell) xt->func[0]);
 335                 } else {
 336                         /* ... */
 337                 }
 338         } else sp++;
 339 }
 340
 341 void _paren_marker_paren() {
 342         exec_marker((struct voc_marker *) ip++);
 343 }
 344
 345 /**************************************************************************/
 346 /* AUXILIARY FUNCTIONS ****************************************************/
 347 /**************************************************************************/
 348
 349 void exec_marker(struct voc_marker *vm) {
 350         load_vocabulary(vm);
 351 }
 352