1// This file is part of SmallBASIC
2//
3// SmallBASIC RTL - STANDARD COMMANDS
4//
5// This program is distributed under the terms of the GPL v2.0 or later
6// Download the GNU Public License (GPL) from www.gnu.org
7//
8// Copyright(C) 2000 Nicholas Christopoulos
9
10#include "common/sys.h"
11#include "common/pproc.h"
12#include "common/fmt.h"
13#include "common/keymap.h"
14#include "common/messages.h"
15
16#define STR_INIT_SIZE 256
17#define PKG_INIT_SIZE 5
18
19/**
20 * LET v[(x)] = any
21 * CONST v[(x)] = any
22 */
23void cmd_let(int is_const) {
24 var_t *v_left = code_getvarptr();
25 if (!prog_error) {
26 if (v_left->const_flag) {
27 err_const();
28 } else {
29 if (prog_source[prog_ip] == kwTYPE_CMPOPR &&
30 prog_source[prog_ip + 1] == '=') {
31 code_skipopr();
32 }
33 var_t v_right;
34 v_init(&v_right);
35 eval(&v_right);
36 v_move(v_left, &v_right);
37 v_left->const_flag = is_const;
38 // no free after v_move
39 }
40 }
41}
42
43void cmd_let_opt() {
44 var_t *v_left = code_getvarptr();
45 if (!prog_error) {
46 // skip kwTYPE_CMPOPR + "="
47 code_skipopr();
48
49 // skip kwTYPE_VAR
50 code_skipnext();
51
52 v_set(v_left, tvar[code_getaddr()]);
53 v_left->const_flag = 0;
54 }
55}
56
57void cmd_packed_let() {
58 if (code_peek() != kwTYPE_LEVEL_BEGIN) {
59 err_missing_comma();
60 } else {
61 code_skipnext();
62
63 int size = PKG_INIT_SIZE;
64 int count = 0;
65 var_t **vars = (var_t **)malloc(sizeof(var_t *) * size);
66
67 while (code_peek() != kwTYPE_LEVEL_END && !prog_error) {
68 if (count + 1 > size) {
69 size += PKG_INIT_SIZE;
70 vars = (var_t **)realloc(vars, sizeof(var_t *) * size);
71 }
72 vars[count++] = code_getvarptr();
73
74 // skip separator
75 if (code_peek() == kwTYPE_SEP) {
76 code_skipnext();
77 if (code_getnext() != ',') {
78 err_missing_comma();
79 }
80 }
81 }
82 // skip end separator
83 code_skipnext();
84
85 var_t v_right_eval;
86 var_t *v_right;
87 v_init(&v_right_eval);
88 if (code_isvar()) {
89 // avoid memory allocation
90 v_right = code_getvarptr();
91 } else {
92 eval(&v_right_eval);
93 v_right = &v_right_eval;
94 }
95
96 if (!prog_error) {
97 int arrayCount = v_right->type == V_ARRAY ? v_asize(v_right) : 1;
98 if (arrayCount == count) {
99 if (count == 1) {
100 // right can be another data type
101 v_set(vars[0], v_right);
102 } else {
103 for (int i = 0; i < count; i++) {
104 v_set(vars[i], v_elem(v_right, i));
105 }
106 }
107 } else if (arrayCount > count) {
108 rt_raise(ERR_PACK_TOO_MANY);
109 } else {
110 rt_raise(ERR_PACK_TOO_FEW, arrayCount);
111 }
112 }
113 v_free(&v_right_eval);
114 free(vars);
115 }
116}
117
118uint8_t get_dimensions(int32_t **lbound, int32_t **ubound) {
119 uint8_t count = 0;
120 if (code_peek() == kwTYPE_LEVEL_BEGIN) {
121 code_skipnext();
122 while (code_peek() != kwTYPE_LEVEL_END && !prog_error) {
123 if (count == MAXDIM) {
124 err_matdim();
125 break;
126 }
127 var_t arg;
128 v_init(&arg);
129 eval(&arg);
130 if (prog_error) {
131 break;
132 }
133 int dim = v_getint(&arg);
134 v_free(&arg);
135
136 if (count) {
137 // allocate for extra dimension
138 *lbound = (int32_t *)realloc(*lbound, (sizeof(int32_t) * (count + 1)));
139 *ubound = (int32_t *)realloc(*ubound, (sizeof(int32_t) * (count + 1)));
140 } else {
141 // allocate for first dimension
142 *lbound = (int32_t *)malloc(sizeof(int32_t));
143 *ubound = (int32_t *)malloc(sizeof(int32_t));
144 }
145
146 if (code_peek() == kwTO) {
147 (*lbound)[count] = dim;
148 code_skipnext();
149 eval(&arg);
150 (*ubound)[count] = v_getint(&arg);
151 v_free(&arg);
152 } else {
153 (*lbound)[count] = opt_base;
154 (*ubound)[count] = dim;
155 }
156
157 count++;
158
159 // skip separator
160 if (code_peek() == kwTYPE_SEP) {
161 code_skipnext();
162 if (code_getnext() != ',') {
163 err_missing_comma();
164 break;
165 }
166 }
167 }
168 // skip end separator
169 code_skipnext();
170 }
171 return count;
172}
173
174/**
175 * DIM var([lower TO] uppper [, ...])
176 */
177void cmd_dim(int preserve) {
178 do {
179 byte code = code_peek();
180 if (code == kwTYPE_LINE || code == kwTYPE_EOC) {
181 break;
182 }
183 if (code_peek() == kwTYPE_SEP) {
184 code_skipnext();
185 if (code_getnext() != ',') {
186 err_missing_comma();
187 break;
188 }
189 }
190
191 var_t *var_p = code_getvarptr_parens(1);
192 if (prog_error) {
193 break;
194 }
195
196 int32_t *lbound = NULL;
197 int32_t *ubound = NULL;
198 uint8_t dimensions = get_dimensions(&lbound, &ubound);
199 if (!prog_error) {
200 if (!preserve || var_p->type != V_ARRAY) {
201 v_free(var_p);
202 }
203 if (!dimensions) {
204 v_toarray1(var_p, 0);
205 continue;
206 }
207 uint32_t size = 1;
208 for (int i = 0; i < dimensions; i++) {
209 size = size * (ABS(ubound[i] - lbound[i]) + 1);
210 }
211 if (!preserve || var_p->type != V_ARRAY) {
212 v_new_array(var_p, size);
213 } else if (v_maxdim(var_p) != dimensions) {
214 err_matdim();
215 } else {
216 // preserve previous array contents
217 v_resize_array(var_p, size);
218 }
219 v_maxdim(var_p) = dimensions;
220 for (int i = 0; i < dimensions; i++) {
221 v_lbound(var_p, i) = lbound[i];
222 v_ubound(var_p, i) = ubound[i];
223 }
224 }
225 free(lbound);
226 free(ubound);
227 } while (!prog_error);
228}
229
230/**
231 * REDIM x
232 */
233void cmd_redim() {
234 cmd_dim(1);
235}
236
237/**
238 * APPEND A, x1 [, x2, ...]
239 * or
240 * A << x1 [, x2, ...]
241 */
242void cmd_append() {
243 var_t *var_p = code_getvarptr();
244 if (prog_error) {
245 return;
246 }
247
248 if (code_peek() == kwTYPE_CMPOPR && prog_source[prog_ip + 1] == '=') {
249 // compatible with LET, operator format
250 code_skipopr();
251 } else if (code_peek() == kwTYPE_SEP && prog_source[prog_ip + 1] == ',') {
252 // command style
253 code_skipsep();
254 } else {
255 err_missing_comma();
256 return;
257 }
258
259 // for each argument to append
260 do {
261 // find the array element
262 var_t *elem_p;
263 if (var_p->type != V_ARRAY) {
264 v_toarray1(var_p, 1);
265 elem_p = v_elem(var_p, 0);
266 } else {
267 v_resize_array(var_p, v_asize(var_p) + 1);
268 elem_p = v_elem(var_p, v_asize(var_p) - 1);
269 }
270
271 // set the value onto the element
272 v_init(elem_p);
273 eval(elem_p);
274
275 // next parameter
276 if (code_peek() != kwTYPE_SEP) {
277 break;
278 } else {
279 par_getcomma();
280 if (prog_error) {
281 break;
282 }
283 }
284 } while (1);
285}
286
287/**
288 * INSERT A, index, v1 [, vN]
289 */
290void cmd_lins() {
291 var_t *var_p = code_getvarptr();
292 if (prog_error) {
293 return;
294 }
295 par_getcomma();
296 if (prog_error) {
297 return;
298 }
299
300 // convert to array
301 if (var_p->type != V_ARRAY) {
302 v_toarray1(var_p, 0);
303 }
304
305 // get 'index'
306 int idx = par_getint();
307 if (prog_error) {
308 return;
309 }
310 idx -= v_lbound(var_p, 0);
311
312 par_getcomma();
313 if (prog_error) {
314 return;
315 }
316
317 int ladd = 0;
318 if (idx >= v_asize(var_p)) {
319 // append
320 ladd = 1;
321 idx = v_asize(var_p);
322 } else if (idx <= 0) {
323 // insert at top
324 idx = 0;
325 }
326
327 // for each argument to insert
328 var_t *arg_p = v_new();
329 do {
330 // get the value to append
331 v_free(arg_p);
332 eval(arg_p);
333
334 // resize +1
335 v_resize_array(var_p, v_asize(var_p) + 1);
336
337 // find the array element
338 var_t *elem_p;
339 if (ladd) {
340 // append
341 elem_p = v_elem(var_p, v_asize(var_p) - 1);
342 } else {
343 // move all form idx one down
344 for (int i = v_asize(var_p) - 1; i > idx; i--) {
345 // A(i) = A(i-1)
346 v_set(v_elem(var_p, i), v_elem(var_p, i - 1));
347 }
348 elem_p = v_elem(var_p, idx);
349 }
350
351 // set the value onto the element
352 v_set(elem_p, arg_p);
353
354 // next parameter
355 if (code_peek() != kwTYPE_SEP) {
356 break;
357 } else {
358 par_getcomma();
359 if (prog_error) {
360 break;
361 }
362 }
363 } while (1);
364
365 // cleanup
366 v_free(arg_p);
367 v_detach(arg_p);
368}
369
370/**
371 * DELETE A, index[, count]
372 */
373void cmd_ldel() {
374 var_t *var_p = code_getvarptr();
375 if (prog_error) {
376 return;
377 }
378 par_getcomma();
379 if (prog_error) {
380 return;
381 }
382 // only arrays
383 if (var_p->type != V_ARRAY) {
384 err_argerr();
385 return;
386 }
387
388 // get 'index'
389 uint32_t size = v_asize(var_p);
390 int idx = par_getint();
391 if (prog_error) {
392 return;
393 }
394 idx -= v_lbound(var_p, 0);
395 if ((idx >= size) || (idx < 0)) {
396 err_out_of_range();
397 return;
398 }
399
400 // get 'count'
401 int count = 1;
402 if (code_peek() == kwTYPE_SEP) {
403 par_getcomma();
404 if (prog_error) {
405 return;
406 }
407 count = par_getint();
408 if (prog_error) {
409 return;
410 }
411 if (((count + idx) - 1 > size)) {
412 err_out_of_range();
413 } else if (count <= 0) {
414 err_argerr();
415 }
416 }
417 if (prog_error) {
418 return;
419 }
420
421 if (idx + count == size) {
422 // pop elements from a stack
423 v_resize_array(var_p, size - count);
424 } else if (idx == 0) {
425 // pop element from a queue
426 // for better performance create a queue in the language
427 for (int i = 0; i < size - count; i++) {
428 v_set(v_elem(var_p, i), v_elem(var_p, i + count));
429 }
430 v_resize_array(var_p, size - count);
431 } else {
432 var_t *arg_p = v_clone(var_p);
433 v_resize_array(var_p, size - count);
434
435 // first part
436 for (int i = 0; i < idx; i++) {
437 // A(i) = OLD(i)
438 v_set(v_elem(var_p, i), v_elem(arg_p, i));
439 }
440 // second part
441 for (int i = idx + count, j = idx; i < size; i++, j++) {
442 // A(j) = OLD(i)
443 v_set(v_elem(var_p, j), v_elem(arg_p, i));
444 }
445
446 // cleanup
447 v_free(arg_p);
448 v_detach(arg_p);
449 }
450}
451
452/**
453 * ERASE var1 [, var2[, ...]]
454 */
455void cmd_erase() {
456 var_t *var_p;
457
458 do {
459 if (prog_error) {
460 break;
461 }
462 if (code_isvar()) {
463 var_p = code_getvarptr();
464 } else {
465 err_typemismatch();
466 break;
467 }
468
469 if (var_p->type == V_ARRAY) {
470 v_toarray1(var_p, 0);
471 } else {
472 v_free(var_p);
473 v_init(var_p);
474 }
475
476 // next
477 byte code = code_peek();
478 if (code == kwTYPE_SEP) {
479 par_getcomma();
480 } else {
481 break;
482 }
483 } while (1);
484}
485
486/**
487 * PRINT ...
488 */
489void cmd_print(int output) {
490 byte last_op = 0;
491 byte use_format = 0;
492 intptr_t handle = 0;
493 var_t var;
494
495 // prefix - # (file)
496 if (output == PV_FILE) {
497 par_getsharp();
498 if (prog_error) {
499 return;
500 }
501 handle = par_getint();
502 if (prog_error) {
503 return;
504 }
505 if (code_peek() == kwTYPE_EOC || code_peek() == kwTYPE_LINE) {
506 // There are no parameters
507 if (dev_fstatus(handle)) {
508 dev_fwrite(handle, (byte *)OS_LINESEPARATOR, OS_LINESEPARATOR_LEN);
509 } else {
510 err_fopen();
511 }
512 return;
513 }
514
515 par_getsep();
516 if (prog_error) {
517 return;
518 }
519 if (!dev_fstatus(handle)) {
520 err_fopen();
521 return;
522 }
523 }
524
525 // prefix: memory variable
526 if (output == PV_STRING) {
527 if (!code_isvar()) {
528 err_argerr();
529 return;
530 }
531
532 var_t *vuser_p = code_getvarptr();
533 par_getsemicolon();
534 if (prog_error) {
535 return;
536 }
537 v_free(vuser_p);
538 vuser_p->type = V_STR;
539 vuser_p->v.p.ptr = NULL;
540 vuser_p->v.p.length = 0;
541 vuser_p->v.p.owner = 1;
542 handle = (intptr_t)vuser_p;
543 }
544
545 // prefix - USING
546 byte code = code_peek();
547 if (code == kwUSING) {
548 code_skipnext();
549 if (code_peek() != kwTYPE_SEP) {
550 v_init(&var);
551 eval(&var);
552 if (prog_error) {
553 return;
554 }
555 if (var.type != V_STR) {
556 rt_raise(ERR_FORMAT_INVALID_FORMAT);
557 v_free(&var);
558 return;
559 } else {
560 build_format(var.v.p.ptr);
561 v_free(&var);
562 }
563 }
564 if (code_peek() == kwTYPE_SEP) {
565 par_getsemicolon();
566 }
567 last_op = ';';
568 if (prog_error) {
569 return;
570 }
571 use_format = 1;
572 }
573
574 // PRINT
575 while (!prog_error) {
576 code = code_peek();
577 if (code == kwTYPE_SEP) {
578 code_skipnext();
579 last_op = code_getnext();
580 if (!use_format) {
581 if (last_op == ',') {
582 pv_write("\t", output, handle);
583 }
584 }
585 } else {
586 if (kw_check_evexit(code) || code == kwTYPE_LEVEL_END) {
587 break;
588 }
589
590 last_op = 0;
591 v_init(&var);
592 eval(&var);
593 if (!prog_error) {
594 if (use_format) {
595 switch (var.type) {
596 case V_STR:
597 fmt_printS(var.v.p.ptr, output, handle);
598 break;
599 case V_INT:
600 fmt_printN(var.v.i, output, handle);
601 break;
602 case V_NUM:
603 fmt_printN(var.v.n, output, handle);
604 break;
605 default:
606 err_typemismatch();
607 }
608 } else {
609 pv_writevar(&var, output, handle);
610 }
611 }
612 v_free(&var);
613 };
614 if (prog_error) {
615 return;
616 }
617 };
618
619 if (last_op == 0) {
620 pv_write(output == PV_FILE ? OS_LINESEPARATOR : "\n", output, handle);
621 }
622}
623
624/**
625 * INPUT ...
626 */
627void cmd_input(int input) {
628 byte print_crlf = 1;
629 var_t prompt;
630 var_t *vuser_p = NULL;
631 intptr_t handle = 0;
632 char *inps = NULL;
633
634 v_init(&prompt);
635 // prefix - # (file)
636 if (input == PV_FILE) {
637 par_getsharp();
638 if (prog_error) {
639 return;
640 }
641 handle = par_getint();
642 if (prog_error) {
643 return;
644 }
645 par_getsep();
646 if (prog_error) {
647 return;
648 }
649 if (!dev_fstatus(handle)) {
650 err_fopen();
651 return;
652 }
653 }
654
655 // prefix: memory variable
656 if (input == PV_STRING) {
657 if (!code_isvar()) {
658 err_argerr();
659 return;
660 }
661
662 vuser_p = code_getvarptr();
663 par_getsemicolon();
664 if (prog_error) {
665 return;
666 }
667 if (vuser_p->type == V_INT || vuser_p->type == V_NUM) {
668 v_tostr(vuser_p);
669 }
670 if (vuser_p->type != V_STR) {
671 err_argerr();
672 return;
673 }
674 handle = (intptr_t)vuser_p;
675 }
676
677 // prefix: prompt
678 if (input == PV_CONSOLE) {
679 v_setstr(&prompt, "");
680 byte code = code_peek();
681 if (code != kwTYPE_STR && code != kwTYPE_VAR) {
682 print_crlf = (code_peeksep() != ';');
683 if (!print_crlf) {
684 code_skipsep();
685 }
686 }
687 if (!code_isvar()) {
688 v_free(&prompt);
689 eval(&prompt);
690
691 byte code = code_getsep();
692 if (!prog_error) {
693 if (code == ';') {
694 v_strcat(&prompt, "? ");
695 }
696 }
697 } else {
698 // no prompt
699 v_setstr(&prompt, "? ");
700 }
701 } else {
702 print_crlf = 0;
703 }
704
705 // get list of parameters
706 par_t *ptable = NULL;
707 int pcount = par_getpartable(&ptable, ",;");
708 if (pcount == 0) {
709 rt_raise(ERR_INPUT_NO_VARS);
710 }
711 // the INPUT itself
712 if (!prog_error) {
713 int redo = 0;
714 do {
715 // "redo from start"
716 if (input == PV_CONSOLE) { // prompt
717 if (prompt.v.p.ptr) {
718 pv_write(prompt.v.p.ptr, input, handle);
719 }
720 }
721
722 // get user's input
723 switch (input) {
724 case PV_CONSOLE:
725 // console
726 inps = malloc(SB_TEXTLINE_SIZE + 1);
727 if (prompt.v.p.ptr) {
728 // prime output buffer with prompt text
729 int prompt_len = v_strlen(&prompt);
730 int len = prompt_len < SB_TEXTLINE_SIZE ? prompt_len : SB_TEXTLINE_SIZE;
731 strncpy(inps, prompt.v.p.ptr, len);
732 inps[len] = 0;
733 }
734 dev_gets(inps, SB_TEXTLINE_SIZE);
735 break;
736 case PV_STRING:
737 // string (SINPUT)
738 inps = strdup(vuser_p->v.p.ptr);
739 break;
740 case PV_FILE:
741 // file (INPUT#)
742 {
743 byte ch, quotes;
744 int size = STR_INIT_SIZE;
745 inps = malloc(size);
746 int index = 0;
747 quotes = 0;
748
749 while (!dev_feof(handle)) {
750 dev_fread(handle, &ch, 1);
751 if (prog_error) {
752 break;
753 } else if (ch == '\n' && !quotes) {
754 break;
755 } else if (ch != '\r') {
756 // store char
757 if (index == (size - 2)) {
758 size += STR_INIT_SIZE;
759 inps = realloc(inps, size);
760 }
761
762 inps[index] = ch;
763 index++;
764 if (ch == '\"') {
765 quotes = !quotes;
766 }
767 }
768 }
769
770 inps[index] = '\0';
771 }
772 break;
773 }
774
775 // for each variable
776 int cur_par_idx = 0;
777 char *inp_p = inps;
778 int input_is_finished = 0;
779 int unused_vars = 0;
780
781 while (cur_par_idx < pcount && !prog_error) {
782 par_t *par = &ptable[cur_par_idx];
783
784 if (input_is_finished) {
785 // setup all remaining variables to "null"
786 if (!(par->flags & PAR_BYVAL)) {
787 v_setstr(par->var, "");
788 unused_vars++;
789 }
790 } else { // we continue to read
791 if (par->flags & PAR_BYVAL) {
792 // no constants are allowed
793 err_typemismatch();
794 break;
795 } else {
796 // check if user had specify a delimiter (next parameter is NOT a
797 // variable)
798 byte next_is_const = 0;
799 if (cur_par_idx < (pcount - 1)) {
800 if (ptable[cur_par_idx + 1].flags & PAR_BYVAL) {
801 cur_par_idx++;
802 // par = previous parameter
803 // ptable[cur_par_idx] = the constant
804 next_is_const = 1;
805 }
806 }
807 // get next string
808 v_free(par->var);
809
810 // next_is_const = get the left string of the specified word
811 // NOT next_is_const = get the left string of the specified
812 // character
813 // (,)
814 char *p;
815 if (pcount == 1) {
816 p = (inp_p + strlen(inp_p));
817 } else {
818 p = q_strstr(inp_p, ((next_is_const) ? v_getstr(ptable[cur_par_idx].var) : ","), "\"\"");
819 }
820 if (p) {
821 char lc = *p;
822 *p = '\0';
823 v_input2var(inp_p, par->var);
824 *p = lc;
825
826 // next pos
827 inp_p = p + ((next_is_const) ? strlen(ptable[cur_par_idx].var->v.p.ptr) : 1);
828 if (*p == '\0') {
829 input_is_finished = 1;
830 }
831 } else {
832 v_input2var(inp_p, par->var);
833 inp_p = (inp_p + strlen(inp_p)); // go to '\0'
834 input_is_finished = 1;
835 }
836 }
837 }
838
839 // next
840 cur_par_idx++;
841 }
842
843 // REDO FROM START
844 if (cur_par_idx == pcount) {
845 input_is_finished = 1;
846 }
847
848 if (input_is_finished && (input == PV_CONSOLE) && (!prog_error)
849 && (((pcount > 1) && (*inp_p || unused_vars)))) {
850 redo = 1;
851 free(inps);
852 dev_printf("\n\a\033[7m * %s * \033[0m\n", WORD_INPUT_REDO);
853 } else {
854 redo = 0;
855 }
856
857 } while (redo && !prog_error);
858 }
859
860 // exit
861 if (input == PV_CONSOLE) {
862 if (print_crlf && (prog_error == 0)) {
863 pv_write("\n", input, handle);
864 }
865 }
866
867 if (inps) {
868 free(inps);
869 }
870 par_freepartable(&ptable, pcount);
871 v_free(&prompt);
872}
873
874/**
875 * ON x GOTO|GOSUB ...
876 */
877void cmd_on_go() {
878 bcip_t dest_ip;
879 var_t var;
880 stknode_t *node;
881
882 bcip_t next_ip = code_getaddr();
883 code_skipaddr();
884 code_t command = code_getnext();
885 byte count = code_getnext();
886 bcip_t table_ip = prog_ip;
887 bcip_t expr_ip = prog_ip + (count * ADDRSZ);
888
889 v_init(&var);
890 prog_ip = expr_ip;
891 eval(&var);
892
893 bcip_t index = (v_igetval(&var) - 1);
894 if (((int) index == -1) || ((int) index >= (int) count)) {
895 // index == -1 (0 on BASIC) || index >= count do nothing
896 command = kwNULL;
897 prog_ip = next_ip;
898 dest_ip = 0;
899 } else if ((int) index < 0) {
900 // QB: run-time-error on < 0 or > 255
901 rt_raise(ERR_ONGOTO_RANGE, (command == kwGOTO) ? WORD_GOTO : WORD_GOSUB);
902 dest_ip = 0;
903 } else {
904 // default
905 memcpy(&dest_ip, prog_source + table_ip + (index * ADDRSZ), ADDRSZ);
906 }
907
908 switch (command) {
909 case kwGOTO:
910 code_jump(dest_ip);
911 break;
912 case kwGOSUB:
913 code_jump(dest_ip);
914 node = code_push(kwGOSUB);
915 node->x.vgosub.ret_ip = next_ip;
916 break;
917 case kwNULL:
918 break;
919 default:
920 rt_raise("ON x: INTERNAL ERROR");
921 }
922}
923
924/**
925 * GOSUB label
926 */
927void cmd_gosub() {
928 bid_t goto_label = code_getaddr();
929 bcip_t ret_ip = prog_ip;
930
931 stknode_t *node = code_push(kwGOSUB);
932 node->x.vgosub.ret_ip = ret_ip;
933 code_jump_label(goto_label);
934}
935
936/**
937 * Call a user-defined procedure or function
938 *
939 * What will happend to the stack
940 * [param 1]
941 * ...
942 * [param N]
943 * [udp-call node]
944 *
945 * p1...pN nodes will be removed by cmd_param()
946 * cmd_param is the first UDP/F's command
947 *
948 * @param cmd is the type of the udp (function or procedure)
949 * @param target sub/func
950 * @param return-variable ID
951 */
952bcip_t cmd_push_args(int cmd, bcip_t goto_addr, bcip_t rvid) {
953 bcip_t ofs;
954 bcip_t pcount = 0;
955 var_t *arg = NULL;
956
957 if (code_peek() == kwTYPE_LEVEL_BEGIN) {
958 // kwTYPE_LEVEL_BEGIN (which means left-parenthesis)
959 code_skipnext();
960
961 if (code_peek() == kwTYPE_CALL_PTR) {
962 // replace call address with address in first arg
963 var_t var_ptr;
964 code_skipnext();
965 v_init(&var_ptr);
966 eval(&var_ptr);
967 if (var_ptr.type != V_PTR || var_ptr.v.ap.p == 0) {
968 rt_raise("Invalid %s pointer variable", cmd == kwPROC ? "SUB" : "FUNC");
969 return 0;
970 }
971 goto_addr = var_ptr.v.ap.p;
972 rvid = var_ptr.v.ap.v;
973 }
974
975 byte ready = 0;
976 do {
977 byte code = code_peek(); // get next BC
978 switch (code) {
979 case kwTYPE_LINE:
980 ready = 1; // finish flag
981 break;
982 case kwTYPE_EOC: // end of an expression (parameter)
983 code_skipnext(); // ignore it
984 break;
985 case kwTYPE_SEP: // separator (comma or semi-colon)
986 code_skipsep(); // ignore it
987 break;
988 case kwTYPE_LEVEL_END: // (right-parenthesis) which means: end of parameters
989 code_skipnext();
990 ready = 1; // finish flag
991 break;
992
993 case kwTYPE_VAR: // the parameter is a variable
994 ofs = prog_ip; // keep expression's IP
995 if (code_isvar()) { // this parameter is a single variable (it is not an expression)
996 stknode_t *param = code_push(kwTYPE_VAR); // push parameter
997 param->x.param.res = code_getvarptr(); // var_t pointer; the variable itself
998 param->x.param.vcheck = 0x3; // parameter can be used 'by value' or 'by reference'
999 pcount++;
1000 break; // we finished with this parameter
1001 }
1002
1003 prog_ip = ofs; // back to the start of the expression
1004 // now we are sure, this parameter is not a single variable
1005 // no 'break' here
1006
1007 default:
1008 // default: the parameter is an expression
1009 arg = v_new(); // create a new temporary variable; it is the
1010 // by-val value 'arg' will be freed at udp's return
1011 eval(arg); // execute the expression and store the result to 'arg'
1012
1013 if (!prog_error) {
1014 stknode_t *param = code_push(kwTYPE_VAR); // push parameter
1015 param->x.param.res = arg; // var_t pointer; the variable itself
1016 param->x.param.vcheck = 1; // parameter can be used only as 'by value'
1017 pcount++;
1018 } else { // error; clean up and return
1019 v_free(arg);
1020 v_detach(arg);
1021 return 0;
1022 }
1023 }
1024 } while (!ready);
1025 }
1026
1027 // store call-info
1028 stknode_t *vcall = code_push(cmd); // store it to stack
1029 vcall->x.vcall.pcount = pcount; // number parameter-nodes in the stack
1030 vcall->x.vcall.ret_ip = prog_ip; // where to go after exit (caller's next address)
1031 vcall->x.vcall.rvid = rvid; // return-variable ID
1032 vcall->x.vcall.task_id = -1;
1033
1034 if (rvid != INVALID_ADDR) {
1035 // if we call a function
1036 vcall->x.vcall.retvar = tvar[rvid]; // store previous data of RVID
1037 tvar[rvid] = v_new(); // create a temporary variable to store the function's result
1038 // value will be restored on udp-return
1039 }
1040 return goto_addr;
1041}
1042
1043void cmd_udp(int cmd) {
1044 bcip_t goto_addr = code_getaddr();
1045 bcip_t rvid = code_getaddr();
1046 prog_ip = cmd_push_args(cmd, goto_addr, rvid);
1047}
1048
1049/**
1050 * Call a user-defined procedure or function OF ANOTHER UNIT
1051 *
1052 * @param cmd is the type of the udp (function or procedure)
1053 * @param udp_tid is the UDP's task-id
1054 * @param goto_addr address of UDP
1055 * @param rvid return-var-id on callers task (this task)
1056 */
1057void cmd_call_unit_udp(int cmd, int udp_tid, bcip_t goto_addr, bcip_t rvid) {
1058 bcip_t ofs;
1059 var_t *arg = NULL;
1060 bcip_t pcount = 0;
1061 int my_tid = ctask->tid;
1062
1063 if (code_peek() == kwTYPE_LEVEL_BEGIN) {
1064 code_skipnext(); // kwTYPE_LEVEL_BEGIN (which means left-parenthesis)
1065
1066 byte ready = 0;
1067 do {
1068 byte code = code_peek(); // get next BC
1069 switch (code) {
1070 case kwTYPE_LINE:
1071 ready = 1; // finish flag
1072 break;
1073 case kwTYPE_EOC: // end of an expression (parameter)
1074 code_skipnext(); // ignore it
1075 break;
1076 case kwTYPE_SEP: // separator (comma or semi-colon)
1077 code_skipsep(); // ignore it
1078 break;
1079 case kwTYPE_LEVEL_END: // (right-parenthesis) which means: end of parameters
1080 code_skipnext();
1081 ready = 1; // finish flag
1082 break;
1083 case kwTYPE_VAR: // the parameter is a variable
1084 ofs = prog_ip; // keep expression's IP
1085
1086 if (code_isvar()) { // this parameter is a single variable (not an expression)
1087 var_p_t var = code_getvarptr(); // var_t pointer; the variable itself
1088 activate_task(udp_tid);
1089 stknode_t *param = code_push(kwTYPE_VAR); // push parameter, on unit's task
1090 param->x.param.res = var;
1091 param->x.param.vcheck = 0x3; // parameter can be used 'by value' or 'by reference'
1092 activate_task(my_tid);
1093 pcount++;
1094 break; // we finished with this parameter
1095 }
1096
1097 prog_ip = ofs; // back to the start of the expression
1098 // now we are sure, this parameter is not a single variable
1099 // no 'break' here
1100
1101 default:
1102 // default: the parameter is an expression
1103 arg = v_new(); // create a new temporary variable; it is the by-val value
1104 // 'arg' will be freed at udp's return
1105 eval(arg); // execute the expression and store the result to 'arg'
1106
1107 if (!prog_error) {
1108 activate_task(udp_tid);
1109 stknode_t *param = code_push(kwTYPE_VAR); // push parameter, on unit's task
1110 param->x.param.res = arg; // var_t pointer; the variable itself
1111 param->x.param.vcheck = 1; // parameter can be used only as 'by value'
1112
1113 activate_task(my_tid);
1114 pcount++;
1115 } else { // error; clean up and return
1116 v_free(arg);
1117 v_detach(arg);
1118 return;
1119 }
1120 }
1121 } while (!ready);
1122 }
1123
1124 if (prog_error) {
1125 return;
1126 }
1127
1128 // store call-info
1129 activate_task(udp_tid);
1130 if (prog_error) {
1131 return;
1132 }
1133
1134 stknode_t *vcall = code_push(cmd); // store it to stack, on unit's task
1135 vcall->x.vcall.pcount = pcount; // the number of parameter-nodes in the stack
1136 vcall->x.vcall.ret_ip = prog_ip; // where to go after exit (caller's next address)
1137 vcall->x.vcall.rvid = rvid; // return-variable ID
1138 vcall->x.vcall.task_id = my_tid;
1139
1140 if (rvid != INVALID_ADDR) { // if we call a function
1141 vcall->x.vcall.retvar = tvar[rvid]; // store previous data of RVID
1142 tvar[rvid] = v_new(); // create a temporary variable to store the
1143 // function's result value will be restored on udp-return
1144 }
1145
1146 prog_ip = goto_addr + ADDRSZ + 3; // jump to udp's code
1147}
1148
1149/**
1150 * Create dynamic-variables (actually local-variables)
1151 */
1152void cmd_crvar() {
1153 // number of variables to create
1154 int count = code_getnext();
1155 for (int i = 0; i < count; i++) {
1156 // an ID on global-variable-table is used
1157 bcip_t vid = code_getaddr();
1158
1159 // store previous variable to stack
1160 // we will restore it at 'return'
1161 stknode_t *node = code_push(kwTYPE_CRVAR);
1162 node->x.vdvar.vid = vid;
1163 node->x.vdvar.vptr = tvar[vid];
1164
1165 // create a new variable with the same ID
1166 tvar[vid] = v_new();
1167 }
1168}
1169
1170/**
1171 * user defined procedure or function - parse parameters code
1172 *
1173 * this code will be called by udp/f to check parameter nodes
1174 * stored in stack by the cmd_udp (call to udp/f)
1175 *
1176 * 'by value' parameters are stored as local variables in the stack (kwTYPE_CRVAR)
1177 * 'by reference' parameters are stored as local variables in the stack (kwTYPE_BYREF)
1178 */
1179void cmd_param() {
1180 // get caller's info-node
1181 stknode_t *ncall = &prog_stack[prog_stack_count - 1];
1182
1183 if (ncall->type != kwPROC && ncall->type != kwFUNC) {
1184 err_stackmess();
1185 return;
1186 }
1187
1188 int pcount = code_getnext();
1189 if (pcount != ncall->x.vcall.pcount) {
1190 // the number of the parameters that are required by this procedure/function
1191 // are different from the number that was passed by the caller
1192 err_parm_num(ncall->x.vcall.pcount, pcount);
1193 return;
1194 }
1195
1196 if (pcount) {
1197 for (int i = 0; i < pcount; i++) {
1198 // check parameters one-by-one
1199 byte vattr = code_getnext();
1200 bid_t vid = code_getaddr();
1201 int stack_pos = (prog_stack_count - 1 - pcount) + i;
1202 stknode_t *node = &prog_stack[stack_pos];
1203 var_t *param_var = node->x.param.res;
1204 int vcheck = node->x.param.vcheck;
1205
1206 if (node->type != kwTYPE_VAR) {
1207 err_stackmess();
1208 break;
1209 }
1210 else if ((vattr & 0x80) == 0) {
1211 // UDP requires a 'by value' parameter
1212 node->type = kwTYPE_CRVAR;
1213 node->x.vdvar.vid = vid;
1214 node->x.vdvar.vptr = tvar[vid];
1215
1216 // assign
1217 if (vcheck == 1) {
1218 // its already cloned by the CALL (expr)
1219 tvar[vid] = param_var;
1220 } else {
1221 tvar[vid] = v_clone(param_var);
1222 }
1223 } else if (vcheck == 1) {
1224 // error - the parameter can be used only 'by value'
1225 err_parm_byref(i);
1226 break;
1227 } else {
1228 // UDP requires 'by reference' parameter
1229 node->type = kwBYREF;
1230 node->x.vdvar.vid = vid;
1231 node->x.vdvar.vptr = tvar[vid];
1232 tvar[vid] = param_var;
1233 }
1234 }
1235 }
1236}
1237
1238/**
1239 * Return from user-defined procedure or function
1240 */
1241void cmd_udpret() {
1242 stknode_t ncall;
1243 code_pop(&ncall, 0);
1244
1245 // handle any values set with cmd_crvar()
1246 while (ncall.type == kwTYPE_CRVAR) {
1247 v_free(tvar[ncall.x.vdvar.vid]);
1248 v_detach(tvar[ncall.x.vdvar.vid]);
1249 tvar[ncall.x.vdvar.vid] = ncall.x.vdvar.vptr;
1250 code_pop(&ncall, 0);
1251 }
1252
1253 // next node should be the call node
1254 if (ncall.type != kwPROC && ncall.type != kwFUNC) {
1255 rt_raise(ERR_SYNTAX);
1256 dump_stack();
1257 return;
1258 }
1259
1260 // handle parameters
1261 int i;
1262 for (i = ncall.x.vcall.pcount; i > 0 && !prog_error; i--) {
1263 stknode_t node;
1264 code_pop(&node, 0);
1265
1266 // local variable - cleanup
1267 if (node.type == kwTYPE_CRVAR) {
1268 // free local variable data
1269 v_free(tvar[node.x.vdvar.vid]);
1270 v_detach(tvar[node.x.vdvar.vid]);
1271 // restore ptr (replace to pre-call variable)
1272 tvar[node.x.vdvar.vid] = node.x.vdvar.vptr;
1273 } else if (node.type == kwBYREF) {
1274 // variable 'by reference', restore ptr
1275 tvar[node.x.vdvar.vid] = node.x.vdvar.vptr;
1276 }
1277 }
1278
1279 // restore return value
1280 if (ncall.x.vcall.rvid != (bid_t) INVALID_ADDR) {
1281 // it is a function store value to stack
1282 stknode_t *rval = code_push(kwTYPE_RET);
1283 rval->x.vdvar.vptr = tvar[ncall.x.vcall.rvid];
1284 // restore ptr
1285 tvar[ncall.x.vcall.rvid] = ncall.x.vcall.retvar;
1286 }
1287
1288 // jump to caller's next address
1289 prog_ip = ncall.x.vcall.ret_ip;
1290}
1291
1292/**
1293 * EXIT [FOR|LOOP|FUNC|PROC]
1294 */
1295int cmd_exit() {
1296 stknode_t node;
1297 int ready = 0, exit_from_udp = 0;
1298 bcip_t addr = INVALID_ADDR;
1299 code_t code;
1300
1301 code = code_getnext();
1302 do {
1303 code_pop(&node, 0);
1304 if (prog_error) {
1305 return 0;
1306 }
1307 switch (node.type) {
1308 case kwIF:
1309 break;
1310 case kwGOSUB:
1311 if (code == 0) {
1312 addr = node.x.vgosub.ret_ip;
1313 ready = 1;
1314 }
1315 break;
1316 case kwFOR:
1317 if (code == 0 || code == kwFORSEP) {
1318 addr = node.x.vfor.exit_ip;
1319 ready = 1;
1320 if (node.x.vfor.subtype == kwIN) {
1321 if (node.x.vfor.flags & 1) { // allocated in for
1322 v_free(node.x.vfor.arr_ptr);
1323 v_detach(node.x.vfor.arr_ptr);
1324 }
1325 }
1326 }
1327 break;
1328 case kwWHILE:
1329 if (code == 0 || code == kwLOOPSEP) {
1330 addr = node.x.vloop.exit_ip;
1331 ready = 1;
1332 }
1333 break;
1334 case kwREPEAT:
1335 if (code == 0 || code == kwLOOPSEP) {
1336 addr = node.x.vloop.exit_ip;
1337 ready = 1;
1338 }
1339 break;
1340 case kwSELECT:
1341 // exiting loop from within select statement
1342 v_free(node.x.vcase.var_ptr);
1343 v_detach(node.x.vcase.var_ptr);
1344 break;
1345 case kwPROC:
1346 case kwFUNC:
1347 case kwTYPE_CRVAR:
1348 case kwBYREF:
1349 case kwTYPE_PARAM:
1350 if (code == 0 || code == kwPROCSEP || code == kwFUNCSEP) {
1351 stknode_t *stknode = code_push(node.type);
1352 *stknode = node;
1353 cmd_udpret();
1354 exit_from_udp = 1;
1355 addr = INVALID_ADDR;
1356 ready = 1;
1357 } else {
1358 if (code == kwFORSEP) {
1359 rt_raise(ERR_EXITFOR);
1360 } else {
1361 rt_raise(ERR_EXITLOOP);
1362 }
1363 }
1364 break;
1365 };
1366 } while (ready == 0);
1367
1368 if (addr != INVALID_ADDR) {
1369 code_jump(addr);
1370 }
1371 return exit_from_udp;
1372}
1373
1374/**
1375 * RETURN
1376 */
1377void cmd_return() {
1378 if (code_peek() == kwFUNC_RETURN) {
1379 // FUNC return statement
1380 code_skipnext();
1381 code_jump(code_getaddr());
1382 stknode_t *node = code_stackpeek();
1383 while (node != NULL && node->type != kwPROC && node->type != kwFUNC) {
1384 code_pop_and_free();
1385 node = code_stackpeek();
1386 }
1387 } else {
1388 // GOSUB/ RETURN
1389 stknode_t node;
1390 // get return-address and remove any other item (sub items) from stack
1391 code_pop(&node, kwGOSUB);
1392
1393 // 'GOTO'
1394 while (node.type != kwGOSUB) {
1395 code_pop(&node, kwGOSUB);
1396 if (prog_error) {
1397 return;
1398 }
1399 }
1400
1401 if (node.type != kwGOSUB) {
1402 rt_raise(ERR_SYNTAX);
1403 dump_stack();
1404 }
1405
1406 code_jump(node.x.vgosub.ret_ip);
1407 }
1408}
1409
1410/**
1411 * IF expr [THEN]
1412 */
1413void cmd_if() {
1414 bcip_t true_ip = code_getaddr();
1415 bcip_t false_ip = code_getaddr();
1416
1417 // expression
1418 var_t var;
1419 v_init(&var);
1420 eval(&var);
1421
1422 stknode_t *node = code_push(kwIF);
1423 node->x.vif.lcond = v_is_nonzero(&var);
1424 code_jump((node->x.vif.lcond) ? true_ip : false_ip);
1425 v_free(&var);
1426}
1427
1428/**
1429 * ELSE
1430 */
1431void cmd_else() {
1432 bcip_t true_ip = code_getaddr();
1433 bcip_t false_ip = code_getaddr();
1434
1435 stknode_t node;
1436 code_pop(&node, kwIF);
1437
1438 // 'GOTO'
1439 while (node.type != kwIF) {
1440 code_pop(&node, kwIF);
1441 if (prog_error) {
1442 return;
1443 }
1444 }
1445
1446 if (node.type != kwIF) {
1447 rt_raise(ERR_SYNTAX);
1448 dump_stack();
1449 return;
1450 }
1451
1452 stknode_t *stknode = code_push(kwIF);
1453 stknode->x.vif.lcond = node.x.vif.lcond;
1454 code_jump((!node.x.vif.lcond) ? true_ip : false_ip);
1455}
1456
1457/**
1458 * ELIF
1459 */
1460void cmd_elif() {
1461 bcip_t true_ip = code_getaddr();
1462 bcip_t false_ip = code_getaddr();
1463
1464 // else cond
1465 stknode_t node;
1466 code_pop(&node, kwIF);
1467
1468 // 'GOTO'
1469 while (node.type != kwIF) {
1470 code_pop(&node, kwIF);
1471 if (prog_error) {
1472 return;
1473 }
1474 }
1475
1476 if (node.type != kwIF) {
1477 rt_raise(ERR_SYNTAX);
1478 dump_stack();
1479 return;
1480 }
1481
1482 if (!node.x.vif.lcond) {
1483 // previous IF failed
1484 var_t var;
1485
1486 // expression
1487 v_init(&var);
1488 eval(&var);
1489 node.x.vif.lcond = v_is_nonzero(&var);
1490 code_jump((node.x.vif.lcond) ? true_ip : false_ip);
1491 v_free(&var);
1492 } else {
1493 // previous IF succeded
1494 code_jump(false_ip);
1495 }
1496
1497 stknode_t *stknode = code_push(kwIF);
1498 stknode->x.vif.lcond = node.x.vif.lcond;
1499}
1500
1501void cmd_endif() {
1502 stknode_t node;
1503
1504 code_pop(&node, kwIF);
1505 while (node.type != kwIF && !prog_error) {
1506 code_pop(&node, kwIF);
1507 }
1508
1509 if (!prog_error) {
1510 prog_ip += (ADDRSZ + ADDRSZ);
1511 }
1512}
1513
1514//
1515// FOR [EACH] v1 IN v2
1516//
1517void cmd_for_in(bcip_t true_ip, bcip_t false_ip, var_p_t var_p) {
1518 var_p_t array_p;
1519 code_skipnext();
1520
1521 stknode_t node;
1522 node.type = kwFOR;
1523 node.x.vfor.subtype = kwIN;
1524 node.x.vfor.exit_ip = false_ip + ADDRSZ + ADDRSZ + 1;
1525 node.x.vfor.jump_ip = true_ip;
1526 node.x.vfor.var_ptr = var_p;
1527 node.x.vfor.to_expr_ip = prog_ip;
1528 node.x.vfor.flags = 0;
1529 node.x.vfor.str_ptr = NULL;
1530
1531 if (code_isvar()) {
1532 // array variable
1533 node.x.vfor.arr_ptr = array_p = code_getvarptr();
1534 } else {
1535 // expression
1536 var_t *new_var = v_new();
1537 eval(new_var);
1538 if (prog_error) {
1539 v_detach(new_var);
1540 return;
1541 }
1542
1543 switch (new_var->type) {
1544 case V_MAP:
1545 case V_ARRAY:
1546 case V_STR:
1547 break;
1548
1549 default:
1550 v_free(new_var);
1551 v_detach(new_var);
1552 err_typemismatch();
1553 return;
1554 }
1555
1556 // allocated here
1557 node.x.vfor.flags = 1;
1558 node.x.vfor.arr_ptr = array_p = new_var;
1559 }
1560
1561 if (!prog_error) {
1562 // element-index
1563 node.x.vfor.step_expr_ip = 0;
1564
1565 var_p_t var_elem_ptr = 0;
1566 switch (array_p->type) {
1567 case V_MAP:
1568 var_elem_ptr = map_elem_key(array_p, 0);
1569 break;
1570
1571 case V_ARRAY:
1572 if (v_asize(array_p) > 0) {
1573 var_elem_ptr = v_elem(array_p, 0);
1574 }
1575 break;
1576
1577 case V_STR:
1578 var_elem_ptr = node.x.vfor.str_ptr = v_new();
1579 v_init_str(var_elem_ptr, 1);
1580 var_elem_ptr->v.p.ptr[0] = array_p->v.p.ptr[0];
1581 var_elem_ptr->v.p.ptr[1] = '\0';
1582 break;
1583
1584 default:
1585 break;
1586 }
1587
1588 if (var_elem_ptr) {
1589 v_set(var_p, var_elem_ptr);
1590 code_jump(true_ip);
1591 } else {
1592 code_jump(false_ip);
1593 }
1594
1595 stknode_t *stknode = code_push(kwFOR);
1596 stknode->x.vfor = node.x.vfor;
1597 }
1598}
1599
1600//
1601// FOR v1=exp1 TO exp2 [STEP exp3]
1602//
1603void cmd_for_to(bcip_t true_ip, bcip_t false_ip, var_p_t var_p) {
1604 var_t varstep;
1605 var_t var;
1606
1607 v_init(&varstep);
1608 v_init(&var);
1609
1610 stknode_t node;
1611 node.type = kwFOR;
1612 node.x.vfor.subtype = kwTO;
1613 node.x.vfor.exit_ip = false_ip + ADDRSZ + ADDRSZ + 1;
1614 node.x.vfor.jump_ip = true_ip;
1615 node.x.vfor.var_ptr = var_p;
1616
1617 // get the first expression
1618 eval(&var);
1619 if (!prog_error && (var.type == V_NUM || var.type == V_INT)) {
1620 //
1621 // assign FOR-variable
1622 //
1623 v_set(var_p, &var);
1624
1625 if (code_getnext() == kwTO) {
1626 //
1627 // get TO-expression
1628 //
1629 node.x.vfor.to_expr_ip = prog_ip;
1630 v_init(&var);
1631 eval(&var);
1632
1633 if (!prog_error && (var.type == V_NUM || var.type == V_INT)) {
1634 //
1635 // step
1636 //
1637 byte code = code_peek();
1638 if (code == kwSTEP) {
1639 code_skipnext();
1640 node.x.vfor.step_expr_ip = prog_ip;
1641 eval(&varstep);
1642 if (!(varstep.type == V_NUM || varstep.type == V_INT)) {
1643 if (!prog_error) {
1644 err_syntax(kwFOR, "%N");
1645 }
1646 }
1647 } else {
1648 node.x.vfor.step_expr_ip = INVALID_ADDR;
1649 varstep.type = V_INT;
1650 varstep.v.i = 1;
1651 }
1652 } else {
1653 if (!prog_error) {
1654 rt_raise(ERR_SYNTAX);
1655 }
1656 }
1657 } else {
1658 rt_raise(ERR_SYNTAX);
1659 }
1660 }
1661 //
1662 // run
1663 //
1664 if (!prog_error) {
1665 // var_p=FROM, var=TO
1666 int sign = v_sign(&varstep);
1667 int cmp = v_compare(var_p, &var);
1668 if (sign != 0) {
1669 bcip_t next_ip;
1670 if (sign < 0) {
1671 next_ip = cmp >= 0 ? true_ip : false_ip;
1672 } else {
1673 next_ip = cmp <= 0 ? true_ip : false_ip;
1674 }
1675 code_jump(next_ip);
1676 if (next_ip == false_ip) {
1677 // skip to after kwNEXT
1678 code_skipnext();
1679 code_jump(code_getaddr());
1680 } else {
1681 stknode_t *stknode = code_push(kwFOR);
1682 stknode->x.vfor = node.x.vfor;
1683 }
1684 } else {
1685 rt_raise(ERR_SYNTAX);
1686 }
1687 }
1688 v_free(&varstep);
1689 v_free(&var);
1690}
1691
1692/**
1693 * FOR var = expr TO expr [STEP expr]
1694 */
1695void cmd_for() {
1696 bcip_t true_ip = code_getaddr();
1697 bcip_t false_ip = code_getaddr();
1698 var_p_t var_for = code_getvarptr();
1699
1700 if (!prog_error) {
1701 v_free(var_for);
1702 if (code_peek() == kwIN) {
1703 cmd_for_in(true_ip, false_ip, var_for);
1704 } else {
1705 cmd_for_to(true_ip, false_ip, var_for);
1706 }
1707 }
1708}
1709
1710/**
1711 * WHILE expr
1712 */
1713void cmd_while() {
1714 bcip_t true_ip = code_getaddr();
1715 bcip_t false_ip = code_getaddr();
1716
1717 // expression
1718 var_t var;
1719 v_init(&var);
1720 eval(&var);
1721
1722 if (v_sign(&var)) {
1723 code_jump(true_ip);
1724 stknode_t *node = code_push(kwWHILE);
1725 node->x.vloop.exit_ip = false_ip + ADDRSZ + ADDRSZ + 1;
1726 } else {
1727 code_jump(false_ip + ADDRSZ + ADDRSZ + 1);
1728 }
1729 v_free(&var);
1730}
1731
1732/**
1733 * WEND
1734 */
1735void cmd_wend() {
1736 stknode_t node;
1737 bcip_t jump_ip;
1738
1739 code_skipaddr();
1740 jump_ip = code_getaddr();
1741 code_jump(jump_ip);
1742 code_pop(&node, kwWHILE);
1743}
1744
1745/**
1746 * REPEAT ... UNTIL
1747 */
1748void cmd_repeat() {
1749 code_skipaddr();
1750 bcip_t next_ip = (code_getaddr()) + 1;
1751 stknode_t *node = code_push(kwREPEAT);
1752 node->x.vloop.exit_ip = code_peekaddr(next_ip);
1753}
1754
1755/**
1756 * UNTIL expr
1757 */
1758void cmd_until() {
1759 bcip_t jump_ip;
1760 var_t var;
1761 stknode_t node;
1762
1763 code_pop(&node, kwREPEAT);
1764 code_skipaddr();
1765 jump_ip = code_getaddr();
1766
1767 // expression
1768 v_init(&var);
1769 eval(&var);
1770 if (!v_sign(&var)) {
1771 code_jump(jump_ip);
1772 }
1773 v_free(&var);
1774}
1775
1776//
1777// FOR chr in str
1778//
1779var_t *cmd_next_for_in_str(stknode_t *node) {
1780 var_t *result = NULL;
1781 var_t *array_p = node->x.vfor.arr_ptr;
1782 int index = ++node->x.vfor.step_expr_ip;
1783 if (index < v_strlen(array_p)) {
1784 result = node->x.vfor.str_ptr;
1785 result->v.p.ptr[0] = array_p->v.p.ptr[index];
1786 }
1787 return result;
1788}
1789
1790//
1791// FOR [EACH] v1 IN v2
1792//
1793void cmd_next_for_in(stknode_t *node, bcip_t next_ip) {
1794 var_t *array_p = node->x.vfor.arr_ptr;
1795 var_t *var_elem_ptr = NULL;
1796
1797 bcip_t jump_ip = node->x.vfor.jump_ip;
1798 var_t *var_p = node->x.vfor.var_ptr;
1799
1800 switch (array_p->type) {
1801 case V_STR:
1802 var_elem_ptr = cmd_next_for_in_str(node);
1803 break;
1804
1805 case V_MAP:
1806 var_elem_ptr = map_elem_key(array_p, ++node->x.vfor.step_expr_ip);
1807 break;
1808
1809 case V_ARRAY:
1810 if (v_asize(array_p) > (int) ++node->x.vfor.step_expr_ip) {
1811 var_elem_ptr = v_elem(array_p, node->x.vfor.step_expr_ip);
1812 }
1813 break;
1814
1815 default:
1816 break;
1817 }
1818
1819 if (var_elem_ptr) {
1820 v_set(var_p, var_elem_ptr);
1821 stknode_t *stknode = code_push(kwFOR);
1822 stknode->x.vfor = node->x.vfor;
1823 code_jump(jump_ip);
1824 } else {
1825 // end of iteration
1826 if (node->x.vfor.flags & 1) {
1827 // allocated in for
1828 v_free(node->x.vfor.arr_ptr);
1829 v_detach(node->x.vfor.arr_ptr);
1830 }
1831 if (node->x.vfor.str_ptr) {
1832 v_free(node->x.vfor.str_ptr);
1833 v_detach(node->x.vfor.str_ptr);
1834 node->x.vfor.str_ptr = NULL;
1835 }
1836 code_jump(next_ip);
1837 }
1838}
1839
1840//
1841// FOR v=exp1 TO exp2 [STEP exp3]
1842//
1843void cmd_next_for_to(stknode_t *node, bcip_t next_ip) {
1844 int check = 0;
1845 var_t var_to;
1846
1847 bcip_t jump_ip = node->x.vfor.jump_ip;
1848 var_t *var_p = node->x.vfor.var_ptr;
1849
1850 prog_ip = node->x.vfor.to_expr_ip;
1851 v_init(&var_to);
1852 eval(&var_to);
1853
1854 if (!prog_error && (var_to.type == V_INT || var_to.type == V_NUM)) {
1855 // get step val
1856 var_t var_step;
1857 var_step.const_flag = 0;
1858 var_step.type = V_INT;
1859 var_step.v.i = 1;
1860
1861 if (node->x.vfor.step_expr_ip != INVALID_ADDR) {
1862 prog_ip = node->x.vfor.step_expr_ip;
1863 eval(&var_step);
1864 }
1865
1866 if (!prog_error && (var_step.type == V_INT || var_step.type == V_NUM)) {
1867 v_inc(var_p, &var_step);
1868 if (v_sign(&var_step) < 0) {
1869 check = (v_compare(var_p, &var_to) >= 0);
1870 } else {
1871 check = (v_compare(var_p, &var_to) <= 0);
1872 }
1873 } else {
1874 if (!prog_error) {
1875 err_typemismatch();
1876 }
1877 }
1878 v_free(&var_step);
1879 } else {
1880 if (!prog_error) {
1881 rt_raise("FOR-TO: TO v IS NOT A NUMBER");
1882 }
1883 }
1884
1885 //
1886 // run
1887 //
1888 if (!prog_error) {
1889 if (check) {
1890 stknode_t *stknode = code_push(kwFOR);
1891 stknode->x.vfor = node->x.vfor;
1892 code_jump(jump_ip);
1893 } else {
1894 code_jump(next_ip);
1895 }
1896 }
1897 v_free(&var_to);
1898}
1899
1900/**
1901 * NEXT
1902 */
1903void cmd_next() {
1904 bcip_t next_ip = code_getaddr();
1905 code_skipaddr();
1906
1907 stknode_t node;
1908 code_pop(&node, kwFOR);
1909
1910 // 'GOTO'
1911 while (node.type != kwFOR) {
1912 code_pop(&node, kwFOR);
1913 if (prog_error) {
1914 return;
1915 }
1916 }
1917
1918 if (node.type != kwFOR) {
1919 rt_raise(ERR_SYNTAX);
1920 dump_stack();
1921 return;
1922 }
1923
1924
1925 if (node.x.vfor.subtype == kwTO) {
1926 cmd_next_for_to(&node, next_ip);
1927 } else {
1928 cmd_next_for_in(&node, next_ip);
1929 }
1930}
1931
1932/**
1933 * READ var [, var [, ...]]
1934 */
1935void cmd_read() {
1936 byte code, exitf = 0;
1937 var_t *vp = NULL;
1938
1939 if (prog_dp == INVALID_ADDR) {
1940 rt_raise(ERR_READ_DATA_START);
1941 return;
1942 }
1943
1944 do {
1945 code = code_peek();
1946 switch (code) {
1947 case kwTYPE_LINE:
1948 case kwTYPE_EOC:
1949 exitf = 1;
1950 break;
1951 case kwTYPE_SEP:
1952 code_skipsep(); // get 2 bytes
1953 break;
1954 default:
1955 vp = code_getvarptr();
1956 if (prog_error) {
1957 return;
1958 }
1959 if (!prog_error) {
1960 v_free(vp);
1961
1962 if (prog_dp >= prog_length) {
1963 rt_raise(ERR_READ_DATA_INDEX);
1964 return;
1965 }
1966
1967 switch (prog_source[prog_dp]) {
1968 case kwTYPE_EOC: // null data
1969 vp->type = V_INT;
1970 vp->v.i = 0;
1971 break;
1972 case kwTYPE_INT:
1973 prog_dp++;
1974 vp->type = V_INT;
1975 memcpy(&vp->v.i, prog_source + prog_dp,OS_INTSZ);
1976 prog_dp += OS_INTSZ;
1977 break;
1978 case kwTYPE_NUM:
1979 prog_dp++;
1980 vp->type = V_NUM;
1981 memcpy(&vp->v.n, &prog_source[prog_dp], OS_REALSZ);
1982 prog_dp += OS_REALSZ;
1983 break;
1984 case kwTYPE_STR: {
1985 uint32_t len;
1986 prog_dp++;
1987 vp->type = V_STR;
1988 memcpy(&len, prog_source + prog_dp, OS_STRLEN);
1989 prog_dp += OS_STRLEN;
1990
1991 vp->v.p.ptr = malloc(len + 1);
1992 vp->v.p.owner = 1;
1993 memcpy(vp->v.p.ptr, prog_source + prog_dp, len);
1994 *((vp->v.p.ptr + len)) = '\0';
1995 vp->v.p.length = len;
1996 prog_dp += len;
1997 }
1998 break;
1999 default:
2000 rt_raise(ERR_READ_DATA_INDEX_FMT, prog_dp);
2001 return;
2002 }
2003 if (prog_source[prog_dp] == kwTYPE_EOC) {
2004 prog_dp++;
2005 }
2006 }
2007 };
2008 } while (!exitf);
2009}
2010
2011/**
2012 * DATA ...
2013 */
2014void cmd_data() {
2015 rt_raise("CANNOT EXECUTE DATA");
2016}
2017
2018/**
2019 * RESTORE label
2020 */
2021void cmd_restore() {
2022 prog_dp = code_getaddr();
2023}
2024
2025/**
2026 * RANDOMIZE [num]
2027 */
2028void cmd_randomize() {
2029 var_int_t seed;
2030
2031 byte code = code_peek();
2032 switch (code) {
2033 case kwTYPE_LINE:
2034 case kwTYPE_EOC:
2035 pcg32_srand(clock());
2036 break;
2037 default:
2038 seed = par_getint();
2039 if (!prog_error) {
2040 pcg32_srand(seed);
2041 }
2042 };
2043}
2044
2045/**
2046 * DELAY
2047 */
2048void cmd_delay() {
2049 uint32_t ms = par_getint();
2050 if (prog_error) {
2051 return;
2052 }
2053 dev_delay(ms);
2054}
2055
2056/**
2057 * AT x,y
2058 */
2059void cmd_at() {
2060 var_int_t x, y;
2061
2062 par_massget("II", &x, &y);
2063 if (!prog_error) {
2064 dev_setxy(x, y, 1);
2065 }
2066}
2067
2068/**
2069 * LOCATE y,x
2070 */
2071void cmd_locate() {
2072 var_int_t x, y;
2073
2074 par_massget("II", &y, &x);
2075 if (prog_error) {
2076 return;
2077 }
2078 if (os_graphics) {
2079 dev_setxy(x * dev_textwidth("0"), y * dev_textheight("0"), 0);
2080 } else {
2081 dev_setxy(x, y, 0);
2082 }
2083}
2084
2085/**
2086 * PAUSE [secs]
2087 */
2088void cmd_pause() {
2089 int evc;
2090 long start, now;
2091
2092 var_int_t x = par_getval(0);
2093 dev_clrkb();
2094 if (x == 0) {
2095 while (dev_kbhit() == 0) {
2096 switch (dev_events(2)) {
2097 case 0: // no event
2098 break;
2099 case -2: // break
2100 brun_break();
2101 case -1: // break
2102 return;
2103 }
2104 dev_delay(CMD_PAUSE_DELAY);
2105 }
2106 dev_getch();
2107 } else if (x < 0) {
2108 dev_events(1);
2109 } else {
2110 struct tm tms;
2111 time_t timenow;
2112 time(&timenow);
2113 tms = *localtime(&timenow);
2114 start = tms.tm_hour * 3600L + tms.tm_min * 60L + tms.tm_sec;
2115
2116 while (!dev_kbhit()) {
2117 switch ((evc = dev_events(0))) {
2118 case 0: // no event
2119 break;
2120 case -2: // break
2121 brun_break();
2122 case -1: // break
2123 return;
2124 }
2125
2126 if (evc) {
2127 if (dev_kbhit()) {
2128 dev_getch();
2129 }
2130 break;
2131 }
2132 time(&timenow);
2133 tms = *localtime(&timenow);
2134 now = tms.tm_hour * 3600L + tms.tm_min * 60L + tms.tm_sec;
2135
2136 if (now >= start + x) {
2137 break;
2138 }
2139 dev_delay(CMD_PAUSE_DELAY);
2140 }
2141
2142 if (dev_kbhit()) {
2143 dev_getch();
2144 }
2145 }
2146}
2147
2148/**
2149 * COLOR fg[,text_bg]
2150 */
2151void cmd_color() {
2152 int fg, bg = -1;
2153
2154 fg = par_getint();
2155 if (prog_error) {
2156 return;
2157 }
2158 if (code_peek() == kwTYPE_SEP) {
2159 par_getcomma();
2160 if (prog_error) {
2161 return;
2162 }
2163 bg = par_getint();
2164 if (prog_error) {
2165 return;
2166 }
2167 }
2168
2169 dev_settextcolor(fg, bg);
2170}
2171
2172void cmd_split() {
2173 cmd_wsplit();
2174}
2175
2176/**
2177 * SPLIT string, delimiters, array() [, pairs] [USE ...]
2178 */
2179void cmd_wsplit() {
2180 char *p, *new_text;
2181 var_t *var_p;
2182 bcip_t use_ip, exit_ip = INVALID_ADDR;
2183 char *str = NULL, *del = NULL, *pairs = NULL;
2184
2185 par_massget("SSPs", &str, &del, &var_p, &pairs);
2186
2187 if (!prog_error) {
2188 // is there a use keyword ?
2189 if (code_peek() == kwUSE) {
2190 code_skipnext();
2191 use_ip = code_getaddr();
2192 exit_ip = code_getaddr();
2193 } else {
2194 use_ip = INVALID_ADDR;
2195 }
2196 //
2197 if (!pairs) {
2198 pairs = strdup("");
2199 }
2200 v_toarray1(var_p, 1);
2201
2202 // reformat
2203 new_text = strdup(str);
2204 int count = 0;
2205 int wait_q = 0;
2206 char *ps = p = new_text;
2207 char *z;
2208 var_t *elem_p;
2209
2210 while (*p) {
2211 if (wait_q == *p) {
2212 wait_q = 0;
2213 p++;
2214 } else if (wait_q == 0 && (z = strchr(pairs, *p)) != NULL) {
2215 int open_q = ((z - pairs) + 1) % 2;
2216 if (open_q) {
2217 wait_q = *(z + 1);
2218 } else {
2219 wait_q = 0;
2220 }
2221 p++;
2222 } else if (wait_q == 0 && strchr(del, *p)) {
2223 *p = '\0';
2224
2225 // add element (ps)
2226 if (v_asize(var_p) <= count) {
2227 // resize array
2228 v_resize_array(var_p, count + 16);
2229 }
2230 // store string
2231 elem_p = v_elem(var_p, count);
2232 v_setstr(elem_p, ps);
2233 count++;
2234
2235 // next word
2236 p++;
2237 ps = p;
2238 } else {
2239 p++;
2240 }
2241 }
2242
2243 // add the last element (ps)
2244 if (v_asize(var_p) <= count) {
2245 v_resize_array(var_p, count + 1);
2246 }
2247 elem_p = v_elem(var_p, count);
2248 if (*ps) {
2249 v_setstr(elem_p, ps);
2250 } else {
2251 v_setstr(elem_p, "");
2252 }
2253 count++;
2254
2255 // final resize
2256 v_resize_array(var_p, count);
2257
2258 // execute user's expression for each element
2259 if (use_ip != INVALID_ADDR) {
2260 for (int i = 0; i < v_asize(var_p) && !prog_error; i++) {
2261 elem_p = v_elem(var_p, i);
2262 exec_usefunc(elem_p, use_ip);
2263 }
2264
2265 // jmp to correct location
2266 code_jump(exit_ip);
2267 }
2268 // cleanup
2269 pfree3(str, del, pairs);
2270 free(new_text);
2271 }
2272}
2273
2274/**
2275 * JOIN array(), delimiter, dest-var
2276 */
2277void cmd_wjoin() {
2278 var_t del, *var_p;;
2279
2280 v_init(&del);
2281 var_p = par_getvarray();
2282 if (!var_p || var_p->type != V_ARRAY) {
2283 err_varisnotarray();
2284 return;
2285 }
2286 if (prog_error) {
2287 return;
2288 }
2289 par_getcomma();
2290 if (prog_error) {
2291 return;
2292 }
2293 par_getstr(&del);
2294 if (prog_error) {
2295 return;
2296 }
2297 par_getcomma();
2298 if (prog_error) {
2299 v_free(&del);
2300 return;
2301 }
2302 if (!code_isvar()) {
2303 err_syntax(kwWJOIN, "%P,%P");
2304 v_free(&del);
2305 return;
2306 }
2307
2308 var_t *str = code_getvarptr();
2309 int size = STR_INIT_SIZE;
2310 int len = 0;
2311 int del_len = v_strlen(&del);
2312 int i;
2313
2314 v_free(str);
2315 str->type = V_STR;
2316 str->v.p.ptr = malloc(size);
2317 str->v.p.owner = 1;
2318 str->v.p.ptr[0] = '\0';
2319
2320 for (i = 0; i < v_asize(var_p); i++) {
2321 var_t *elem_p = v_elem(var_p, i);
2322 var_t e_str;
2323
2324 v_init(&e_str);
2325 v_set(&e_str, elem_p);
2326 if (e_str.type != V_STR) {
2327 v_tostr(&e_str);
2328 }
2329
2330 int el_len = v_strlen(&e_str);
2331 if (el_len + del_len + 1 >= (size - len)) {
2332 size += el_len + del_len + STR_INIT_SIZE;
2333 str->v.p.ptr = realloc(str->v.p.ptr, size);
2334 }
2335
2336 len += el_len;
2337 strcat(str->v.p.ptr, e_str.v.p.ptr);
2338 v_free(&e_str);
2339
2340 if (i != var_p->v.p.length - 1) {
2341 strcat(str->v.p.ptr, del.v.p.ptr);
2342 len += del_len;
2343 }
2344 }
2345
2346 str->v.p.length = len;
2347
2348 // cleanup
2349 v_free(&del);
2350}
2351
2352/**
2353 * ENVIRON string
2354 */
2355void cmd_environ() {
2356 var_t str;
2357
2358 par_getstr(&str);
2359 if (prog_error) {
2360 return;
2361 }
2362 char *eq = strchr(str.v.p.ptr, '=');
2363 if (eq == NULL) {
2364 rt_raise(ERR_PUTENV);
2365 } else {
2366 *eq = '\0';
2367 if (dev_setenv(str.v.p.ptr, eq + 1) == -1) {
2368 rt_raise(ERR_PUTENV);
2369 }
2370 }
2371 v_free(&str);
2372}
2373
2374/**
2375 * DATEDMY string|julian, m, d, y
2376 */
2377void cmd_datedmy() {
2378 long d, m, y;
2379 var_t arg, *vd, *vm, *vy;
2380
2381 v_init(&arg);
2382 eval(&arg);
2383
2384 if (arg.type == V_STR) {
2385 date_str2dmy(arg.v.p.ptr, &d, &m, &y);
2386 v_free(&arg);
2387 } else {
2388 // julian
2389 d = v_igetval(&arg);
2390 v_free(&arg);
2391 date_jul2dmy(d, &d, &m, &y);
2392 }
2393
2394 // byref pars
2395 par_getcomma();
2396 if (prog_error) {
2397 return;
2398 }
2399 vd = par_getvar_ptr();
2400 if (prog_error) {
2401 return;
2402 }
2403 par_getcomma();
2404 if (prog_error) {
2405 return;
2406 }
2407 vm = par_getvar_ptr();
2408 if (prog_error) {
2409 return;
2410 }
2411 par_getcomma();
2412 if (prog_error) {
2413 return;
2414 }
2415 vy = par_getvar_ptr();
2416 if (prog_error) {
2417 return;
2418 }
2419 v_free(vd);
2420 v_free(vm);
2421 v_free(vy);
2422
2423 vd->type = V_INT;
2424 vd->v.i = d;
2425 vm->type = V_INT;
2426 vm->v.i = m;
2427 vy->type = V_INT;
2428 vy->v.i = y;
2429}
2430
2431/**
2432 * TIMEHMS string|timer, h, m, s
2433 */
2434void cmd_timehms() {
2435 long h, m, s;
2436 var_t arg, *vh, *vm, *vs;
2437
2438 v_init(&arg);
2439 eval(&arg);
2440
2441 if (arg.type == V_STR) {
2442 // string
2443 date_str2hms(arg.v.p.ptr, &h, &m, &s);
2444 v_free(&arg);
2445 } else {
2446 // timer
2447 h = v_igetval(&arg);
2448 v_free(&arg);
2449 date_tim2hms(h, &h, &m, &s);
2450 }
2451
2452 // byref pars
2453 par_getcomma();
2454 if (prog_error) {
2455 return;
2456 }
2457 vh = par_getvar_ptr();
2458 if (prog_error) {
2459 return;
2460 }
2461 par_getcomma();
2462 if (prog_error) {
2463 return;
2464 }
2465 vm = par_getvar_ptr();
2466 if (prog_error) {
2467 return;
2468 }
2469 par_getcomma();
2470 if (prog_error) {
2471 return;
2472 }
2473 vs = par_getvar_ptr();
2474 if (prog_error) {
2475 return;
2476 }
2477 v_free(vh);
2478 v_free(vm);
2479 v_free(vs);
2480
2481 vh->type = V_INT;
2482 vh->v.i = h;
2483 vm->type = V_INT;
2484 vm->v.i = m;
2485 vs->type = V_INT;
2486 vs->v.i = s;
2487}
2488
2489/**
2490 * SORT array [USE ...]
2491 */
2492int sb_qcmp(var_t *a, var_t *b, bcip_t use_ip) {
2493 if (use_ip == INVALID_ADDR) {
2494 return v_compare(a, b);
2495 } else {
2496 var_t v1, v2;
2497 int r;
2498
2499 v_init(&v1);
2500 v_init(&v2);
2501
2502 v_set(&v1, a);
2503 v_set(&v2, b);
2504 exec_usefunc2(&v1, &v2, use_ip);
2505 r = v_igetval(&v1);
2506 v_free(&v1);
2507 return r;
2508 }
2509}
2510
2511// using C's qsort()
2512static bcip_t static_qsort_last_use_ip;
2513
2514int qs_cmp(const void *a, const void *b) {
2515 var_t *ea = (var_t *)a;
2516 var_t *eb = (var_t *)b;
2517 return sb_qcmp(ea, eb, static_qsort_last_use_ip);
2518}
2519
2520void cmd_sort() {
2521 bcip_t use_ip, exit_ip;
2522 var_t *var_p;
2523 int errf = 0;
2524
2525 if (code_isvar()) {
2526 var_p = code_getvarptr();
2527 if (var_p->type != V_ARRAY) {
2528 errf = 1;
2529 }
2530 } else {
2531 err_typemismatch();
2532 return;
2533 }
2534
2535 // USE
2536 if (code_peek() == kwUSE) {
2537 code_skipnext();
2538 use_ip = code_getaddr();
2539 exit_ip = code_getaddr();
2540 } else {
2541 use_ip = exit_ip = INVALID_ADDR;
2542 }
2543 // sort
2544 if (!errf) {
2545 if (v_asize(var_p) > 1) {
2546 static_qsort_last_use_ip = use_ip;
2547 qsort(v_data(var_p), v_asize(var_p), sizeof(var_t), qs_cmp);
2548 }
2549 }
2550 // NO RTE anymore... there is no meaning on this because of empty
2551 // arrays/variables (example: TLOAD "data", V:SORT V)
2552 if (exit_ip != INVALID_ADDR) {
2553 code_jump(exit_ip);
2554 }
2555}
2556
2557/**
2558 * SEARCH A(), key, BYREF ridx [USE ...]
2559 */
2560void cmd_search() {
2561 bcip_t use_ip, exit_ip;
2562 var_t *var_p, *rv_p;
2563 var_t vkey;
2564 int errf = 0;
2565
2566 // parameters 1: the array
2567 if (code_isvar()) {
2568 var_p = code_getvarptr();
2569 if (var_p->type != V_ARRAY) {
2570 errf = 1;
2571 }
2572 } else {
2573 err_typemismatch();
2574 return;
2575 }
2576
2577 // parameters 2: the key
2578 par_getcomma();
2579 if (prog_error) {
2580 return;
2581 }
2582 v_init(&vkey);
2583 eval(&vkey);
2584 if (prog_error) {
2585 return;
2586 }
2587 // parameters 3: the return-variable
2588 par_getcomma();
2589 if (prog_error) {
2590 v_free(&vkey);
2591 return;
2592 }
2593 if (code_isvar()) {
2594 rv_p = code_getvarptr();
2595 v_free(rv_p);
2596 } else {
2597 v_free(&vkey);
2598 err_typemismatch();
2599 return;
2600 }
2601
2602 // USE
2603 if (code_peek() == kwUSE) {
2604 code_skipnext();
2605 use_ip = code_getaddr();
2606 exit_ip = code_getaddr();
2607 } else {
2608 use_ip = exit_ip = INVALID_ADDR;
2609 }
2610 // search
2611 if (!errf) {
2612 rv_p->v.i = v_lbound(var_p, 0) - 1;
2613 for (int i = 0; i < v_asize(var_p); i++) {
2614 var_t *elem_p = v_elem(var_p, i);
2615 int bcmp = sb_qcmp(elem_p, &vkey, use_ip);
2616 if (bcmp == 0) {
2617 rv_p->v.i = i + v_lbound(var_p, 0);
2618 break;
2619 }
2620 }
2621 }
2622 // NO RTE anymore... there is no meaning on this because of empty
2623 // arrays/variables (example: TLOAD "data", V:SEARCH V...)
2624 // else
2625 // rt_raise("SEARCH: Not an array");
2626 else {
2627 rv_p->v.i = -1;
2628 }
2629 // return
2630 if (exit_ip != INVALID_ADDR) {
2631 code_jump(exit_ip);
2632 }
2633 v_free(&vkey);
2634}
2635
2636/**
2637 * SWAP a, b
2638 */
2639void cmd_swap(void) {
2640 var_t *va, *vb, *vc;
2641
2642 if (code_isvar()) {
2643 va = code_getvarptr();
2644 } else {
2645 err_typemismatch();
2646 return;
2647 }
2648 par_getcomma();
2649 if (prog_error) {
2650 return;
2651 }
2652 if (code_isvar()) {
2653 vb = code_getvarptr();
2654 } else {
2655 err_typemismatch();
2656 return;
2657 }
2658
2659 vc = v_new();
2660 v_set(vc, va);
2661 v_set(va, vb);
2662 v_set(vb, vc);
2663 v_free(vc);
2664 v_detach(vc);
2665}
2666
2667/**
2668 * EXPRSEQ @array, xmin, xmax, count USE f(x)
2669 */
2670void cmd_exprseq(void) {
2671 var_t *var_p;
2672 bcip_t use_ip, exit_ip = INVALID_ADDR;
2673 var_num_t xmin, xmax, x, dx;
2674 var_int_t count;
2675
2676 par_massget("PFFI", &var_p, &xmin, &xmax, &count);
2677
2678 if (!prog_error) {
2679 // is there a use keyword ?
2680 if (code_peek() != kwUSE) {
2681 rt_raise(ERR_EXPRSEQ_WITHOUT_EXPR);
2682 return;
2683 }
2684 // get expr info
2685 code_skipnext();
2686 use_ip = code_getaddr();
2687 exit_ip = code_getaddr();
2688
2689 if (count > 1) {
2690 v_toarray1(var_p, count);
2691 dx = (xmax - xmin) / (count - 1);
2692 x = xmin;
2693 // add the entries
2694 for (int i = 0; i < count; i++, x += dx) {
2695 var_t *elem_p = v_elem(var_p, i);
2696 v_setreal(elem_p, x);
2697 exec_usefunc(elem_p, use_ip);
2698
2699 if (prog_error) {
2700 break;
2701 }
2702 }
2703 } else {
2704 v_toarray1(var_p, 0);
2705 }
2706
2707 code_jump(exit_ip);
2708 }
2709}
2710
2711/**
2712 * evaluate the select expression and then store it on the stack
2713 * syntax is:
2714 * select expr
2715 * case expr
2716 * stmt
2717 * case expr
2718 * stmt
2719 * case else
2720 * default stmt
2721 * end select
2722 */
2723void cmd_select() {
2724 var_t *expr = v_new();
2725 v_init(expr);
2726 eval(expr);
2727
2728 stknode_t *node = code_push(kwSELECT);
2729 node->x.vcase.var_ptr = expr;
2730 node->x.vcase.flags = 0;
2731}
2732
2733/**
2734 * compare the case expression with the saved select expression
2735 * if true then branch to true_ip otherwise branch to false_ip
2736 * which could either be another case line or "end select"
2737 */
2738void cmd_case() {
2739 var_t var_p;
2740 bcip_t true_ip = code_getaddr(); // matching case
2741 bcip_t false_ip = code_getaddr(); // non-matching case
2742
2743 v_init(&var_p);
2744 eval(&var_p);
2745
2746 stknode_t *node = code_stackpeek();
2747
2748 if (node->type != kwSELECT) {
2749 rt_raise(ERR_SYNTAX);
2750 return;
2751 }
2752
2753 if (node->x.vcase.flags) {
2754 // previous case already matches.
2755 code_jump(false_ip);
2756 } else {
2757 // compare select expr with case expr
2758 node->x.vcase.flags = v_compare(node->x.vcase.var_ptr, &var_p) == 0 ? 1 : 0;
2759 while (code_peek() == kwTYPE_SEP && node->x.vcase.flags == 0) {
2760 // evaluate futher comma separated items until there is a match
2761 code_skipnext();
2762 if (code_getnext() != ',') {
2763 err_missing_comma();
2764 break;
2765 }
2766 var_t vp_next;
2767 v_init(&vp_next);
2768 eval(&vp_next);
2769 node->x.vcase.flags = v_compare(node->x.vcase.var_ptr, &vp_next) == 0 ? 1 : 0;
2770 v_free(&vp_next);
2771 }
2772 code_jump(node->x.vcase.flags ? true_ip : false_ip);
2773 }
2774
2775 v_free(&var_p);
2776}
2777
2778/**
2779 * skip to cmd_end_select if a previous case was true
2780 */
2781void cmd_case_else() {
2782 bcip_t true_ip = code_getaddr(); // default block
2783 bcip_t false_ip = code_getaddr(); // end-select
2784 stknode_t *node = code_stackpeek();
2785 code_jump(node->x.vcase.flags ? false_ip : true_ip);
2786}
2787
2788/**
2789 * free the stored select expression created in cmd_select()
2790 */
2791void cmd_end_select() {
2792 int nodeType = code_pop_and_free();
2793 if (nodeType != kwSELECT) {
2794 err_stackmess();
2795 } else {
2796 code_jump(code_getaddr());
2797 }
2798}
2799
2800/**
2801 * define keyboard event handling
2802 */
2803void cmd_definekey(void) {
2804 var_t var;
2805
2806 v_init(&var);
2807 eval(&var);
2808
2809 int key = v_igetval(&var);
2810
2811 if (!prog_error) {
2812 par_getcomma();
2813 switch (code_peek()) {
2814 case kwTYPE_INT:
2815 prog_ip++;
2816 keymap_remove(key, code_getint());
2817 break;
2818 case kwTYPE_CALL_UDF:
2819 keymap_add(key, prog_ip);
2820
2821 // skip ahead to avoid immediate call
2822 prog_ip += BC_CTRLSZ + 1;
2823 break;
2824 default:
2825 err_syntax(kwDEFINEKEY, "%I,%G");
2826 break;
2827 }
2828 }
2829 v_free(&var);
2830}
2831
2832/**
2833 * Try handler for try/catch
2834 */
2835void cmd_try() {
2836 stknode_t *node = code_push(kwTRY);
2837 node->x.vtry.catch_ip = code_getaddr();
2838}
2839
2840/**
2841 * Handler for unthrown/uncaught exceptions
2842 */
2843void cmd_catch() {
2844 int nodeType = code_pop_and_free();
2845 if (nodeType != kwTRY) {
2846 err_stackmess();
2847 } else {
2848 // skip to end-try
2849 code_jump(code_getaddr());
2850 }
2851}
2852
2853/**
2854 * Handler for code block between CATCH and END_TRY
2855 */
2856void cmd_end_try() {
2857 stknode_t *node = code_stackpeek();
2858 if (node != NULL && node->type == kwCATCH) {
2859 code_pop_and_free();
2860 }
2861}
2862
2863/**
2864 * Call to object method
2865 */
2866void cmd_call_vfunc() {
2867 var_t *map = NULL;
2868 var_t *v_func = code_getvarptr_map(&map);
2869 if (v_func == NULL || (v_func->type != V_FUNC && v_func->type != V_PTR)) {
2870 rt_raise(ERR_NO_FUNC);
2871 } else if (v_func->type == V_PTR) {
2872 prog_ip = cmd_push_args(kwPROC, v_func->v.ap.p, v_func->v.ap.v);
2873 if (code_peek() == kwTYPE_PARAM) {
2874 code_skipnext();
2875 cmd_param();
2876 var_t *self = v_set_self(map);
2877 bc_loop(2);
2878 v_set_self(self);
2879 } else {
2880 rt_raise(ERR_NO_FUNC);
2881 }
2882 } else {
2883 if (code_peek() == kwTYPE_LEVEL_BEGIN) {
2884 code_skipnext();
2885 }
2886 v_func->v.fn.cb(map, NULL);
2887 if (code_peek() == kwTYPE_LEVEL_END) {
2888 code_skipnext();
2889 }
2890 }
2891}
2892
2893/**
2894 * Adds a timer
2895 */
2896void cmd_timer() {
2897 var_t var;
2898 v_init(&var);
2899 eval(&var);
2900
2901 var_num_t interval = v_getval(&var);
2902 if (!prog_error) {
2903 par_getcomma();
2904 if (code_peek() != kwTYPE_CALL_UDF) {
2905 err_syntax(kwTIMER, "%F,%G");
2906 } else {
2907 timer_add(interval, prog_ip);
2908 prog_ip += BC_CTRLSZ + 1;
2909 }
2910 }
2911 v_free(&var);
2912}
2913