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