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
 172     if (_to_in < _in_input_buffer) _to_in++;
 173 }
 174
 175 void _pick() {
 176         sp[0] = sp[sp[0] + 1];
 177 }
 178
 179 void _refill() {
 180         if (_b_l_k != 0) {
 181                 current_block = _b_l_k++;
 182                 _to_in = 0;
 183                 *--sp = _b_l_k;
 184                 _block();
 185                 _input_buffer = (Char *) *sp++;
 186                 _in_input_buffer = BLOCK_SIZE;
 187                 *sp = FFLAG(_b_l_k && _input_buffer != NULL);
 188         } else if (_source_id == 0) {
 189         *--sp = (Cell) _tib;
 190                 *--sp = tib_size;
 191         _accept();
 192                 _input_buffer = _tib;
 193         _in_input_buffer = *sp;
 194         _to_in = 0;
 195         *sp = FFLAG(1);
 196     } else if (_source_id == -1) {
 197                 *--sp = FFLAG(0);
 198         } else if (_env_file) {
 199                 if (fgets(_input_buffer, FILE_BUFFER_SIZE, (FILE *) _source_id)) {
 200                         _in_input_buffer = strlen(_input_buffer);
 201                         if (_in_input_buffer && _input_buffer[_in_input_buffer - 1] == '\n')
 202                                 _in_input_buffer--;
 203                         _to_in = 0;
 204                         *--sp = FFLAG(1);
 205                 } else *--sp = FFLAG(0);
 206         } else *--sp = FFLAG(0);
 207 }
 208
 209 void _restore_input() {
 210         sp++;
 211         _b_l_k = *sp++;
 212         _to_in = *sp++;
 213         _in_input_buffer = *sp++;
 214         _input_buffer = (Char *) *sp++;
 215         _source_id = *sp++;
 216         if (_source_id == 0) {
 217         } else if (_source_id == -1) {
 218         } else {
 219         }
 220         *--sp = FFLAG(1);
 221 }
 222
 223 void _roll() {
 224         register Cell u = *sp++;
 225         register Cell xu = sp[u];
 226         register int i;
 227         for (i = u; i > 0; i--) sp[i] = sp[i - 1];
 228         sp[0] = xu;
 229 }
 230
 231 void _save_input() {
 232         if (_source_id == 0) {
 233         } else if (_source_id == -1) {
 234         } else {
 235         }
 236         *--sp = _source_id;
 237         *--sp = (Cell) _input_buffer;
 238         *--sp = _in_input_buffer;
 239         *--sp = _to_in;
 240         *--sp = _b_l_k;
 241         *--sp = 5;
 242 }
 243
 244 void _true() {
 245         *--sp = FFLAG(1);
 246 }
 247
 248 void _tuck() {
 249         sp--;
 250         sp[0] = sp[1];
 251         sp[1] = sp[2];
 252         sp[2] = sp[0];
 253 }
 254
 255 void _u_dot_r() {
 256     register Cell r = *sp++;
 257         *--sp = 0;
 258         _less_number_sign();
 259         _number_sign_s();
 260         _number_sign_greater();
 261         if (sp[0] < r) {
 262                 sp--;
 263                 sp[0] = r - sp[1];
 264                 _spaces();
 265         }
 266     _type();
 267     putchar(' ');
 268 }
 269
 270 void _u_greater_than() {
 271     sp[1] = FFLAG((UCell) sp[1] > (UCell) sp[0]);
 272         sp++;
 273 }
 274
 275 void _unused() {
 276         *--sp = (dspace_size - (_dp - dp0)) * sizeof(Cell);
 277 }
 278
 279 void _within() {
 280         register Cell n3 = *sp++;
 281     register Cell n2 = *sp++;
 282     register Cell n1 = *sp;
 283     sp[0] = FFLAG((n2 < n3 && (n2 <= n1 && n1 < n3)) ||
 284                   (n2 > n3 && (n2 <= n1 || n1 < n3)));
 285 }
 286
 287 void _backslash() {
 288     _to_in = _in_input_buffer;
 289 }
 290
 291 void _bracket_compile() {
 292         *--sp = ' ';
 293     _word();
 294     sp++;
 295     compile_word(search_word(_dp + 1, *_dp));
 296 }
 297
 298 void _value() {
 299         create_definition(A_VALUE);
 300         compile_cell((Cell) sp[0]);
 301         sp++;
 302         mark_word(_last);
 303 }
 304
 305 void _paren_write_value_paren() {
 306         register Cell *p = (Cell *) (*ip++);
 307         *p = *sp++;
 308 }
 309
 310 void _to() {
 311         _b_l();
 312         _word();
 313         _find();
 314         if (*sp++) {
 315                 register struct word_def *xt = (struct word_def *) *sp++;
 316                 if ((xt->class & A_WORD) == A_VALUE) {
 317                         if (_state == INTERPRET) xt->func[0] = (pfp) *sp++;
 318                         else {
 319                                 compile_cell((Cell) _paren_write_value_paren);
 320                                 compile_cell((Cell) &xt->func[0]);
 321                         }
 322                 } else if (xt->class & A_WORD == A_LOCAL && _state == COMPILE) {
 323                         compile_cell((Cell) _paren_write_local_paren);
 324                         compile_cell((Cell) xt->func[0]);
 325                 } else {
 326                         /* ... */
 327                 }
 328         } else sp++;
 329 }
 330
 331 void _paren_marker_paren() {
 332         exec_marker((struct voc_marker *) ip++);
 333 }
 334
 335 /**************************************************************************/
 336 /* AUXILIARY FUNCTIONS ****************************************************/
 337 /**************************************************************************/
 338
 339 void exec_marker(struct voc_marker *vm) {
 340         load_vocabulary(vm);
 341 }
 342