1 /* yForth? - A Forth interpreter written in ANSI C
2 * Copyright (C) 2012 Luca Padovani
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.
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.
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
32 /**************************************************************************/
33 /* VARIABLES **************************************************************/
34 /**************************************************************************/
38 /**************************************************************************/
39 /* WORDS ******************************************************************/
40 /**************************************************************************/
50 register Cell u = *sp++;
56 void _zero_not_equals() {
57 sp[0] = FFLAG(sp[0] != 0);
60 void _zero_greater() {
61 sp[0] = FFLAG(sp[0] > 0);
82 void _colon_no_name() {
83 register struct word_def *def;
85 def = (struct word_def *) _dp;
89 _dp += sizeof(struct word_def) - sizeof(Cell);
96 sp[1] = FFLAG(sp[0] != sp[1]);
100 void _question_do() {
101 compile_cell((Cell) _paren_question_do_paren);
105 *--sp = 1; /* e' un ?do */
108 void _paren_question_do_paren() {
109 if (sp[0] == sp[1]) ip += 1 + (Cell) *ip;
118 register Cell *dest = (Cell *) *sp++;
119 compile_cell((Cell) _branch);
120 compile_cell(dest - ((Cell *) _dp) - 1);
125 register Cell *patch;
126 compile_cell((Cell) _branch);
127 patch = (Cell *) _dp;
133 _dp = (Char *) WORD_PTR(_dp);
134 *patch = ((Cell *) _dp) - patch - 1;
135 compile_cell((Cell) _do_literal);
136 compile_cell((Cell) cur);
139 void _compile_comma() {
140 compile_word((struct word_def *) *sp++);
144 register UCell u = (UCell) *sp++;
145 register Char *addr = (Char *) *sp++;
146 if (u) memset(addr, 0, u);
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));
172 register Char delim = (Char) *sp;
173 register Char *orig = &_input_buffer[_to_in];
175 while (_to_in < _in_input_buffer && _input_buffer[_to_in] != delim) {
182 if (_to_in < _in_input_buffer) _to_in++;
186 sp[0] = sp[sp[0] + 1];
191 current_block = _b_l_k++;
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) {
202 _input_buffer = _tib;
203 _in_input_buffer = *sp;
206 } else if (_source_id == -1) {
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')
215 } else *--sp = FFLAG(0);
216 } else *--sp = FFLAG(0);
219 void _restore_input() {
223 _in_input_buffer = *sp++;
224 _input_buffer = (Char *) *sp++;
226 if (_source_id == 0) {
227 } else if (_source_id == -1) {
234 register Cell u = *sp++;
235 register Cell xu = sp[u];
237 for (i = u; i > 0; i--) sp[i] = sp[i - 1];
242 if (_source_id == 0) {
243 } else if (_source_id == -1) {
247 *--sp = (Cell) _input_buffer;
248 *--sp = _in_input_buffer;
266 register Cell r = *sp++;
270 _number_sign_greater();
280 void _u_greater_than() {
281 sp[1] = FFLAG((UCell) sp[1] > (UCell) sp[0]);
286 *--sp = (dspace_size - (_dp - dp0)) * sizeof(Cell);
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)));
298 _to_in = _in_input_buffer;
301 void _bracket_compile() {
305 compile_word(search_word(_dp + 1, *_dp));
309 create_definition(A_VALUE);
310 compile_cell((Cell) sp[0]);
315 void _paren_write_value_paren() {
316 register Cell *p = (Cell *) (*ip++);
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++;
329 compile_cell((Cell) _paren_write_value_paren);
330 compile_cell((Cell) &xt->func[0]);
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]);
341 void _paren_marker_paren() {
342 exec_marker((struct voc_marker *) ip++);
345 /**************************************************************************/
346 /* AUXILIARY FUNCTIONS ****************************************************/
347 /**************************************************************************/
349 void exec_marker(struct voc_marker *vm) {