1// This file is part of SmallBASIC
2//
3// SmallBASIC LIBRARY - STANDARD FUNCTIONS
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/str.h"
12#include "common/kw.h"
13#include "common/var.h"
14#include "common/blib.h"
15#include "common/pproc.h"
16#include "common/device.h"
17#include "common/blib_math.h"
18#include "common/fmt.h"
19#include "common/geom.h"
20#include "common/messages.h"
21#include "common/keymap.h"
22
23// relative coordinates (current x/y) from blib_graph
24extern int gra_x;
25extern int gra_y;
26
27// date
28static char *date_wd3_table[] = TABLE_WEEKDAYS_3C;
29static char *date_wdN_table[] = TABLE_WEEKDAYS_FULL;
30static char *date_m3_table[] = TABLE_MONTH_3C;
31static char *date_mN_table[] = TABLE_MONTH_FULL;
32
33#define BUF_LEN 64
34
35/*
36 */
37var_int_t r2int(var_num_t x, var_int_t l, var_int_t h) {
38 var_int_t nx;
39
40 if (x < 0.0) {
41 nx = (var_int_t) -floor(-x + .5);
42 } else {
43 nx = (var_int_t) floor(x + .5);
44 }
45
46 if (nx < l) {
47 nx = l;
48 } else if (nx > h) {
49 nx = h;
50 }
51 return nx;
52}
53
54/*
55 * PEN function
56 */
57void cmd_pen() {
58 byte code;
59 IF_ERR_RETURN;
60
61 code = code_getnext();
62 IF_ERR_RETURN;
63
64 if (code == kwOFF) {
65 dev_setpenmode(0);
66 } else if (code == kwON) {
67 dev_setpenmode(1);
68 } else {
69 rt_raise(ERR_SYNTAX);
70 }
71}
72
73/*
74 * ARRAY ROUTINES - First element
75 * funcCode is the function code, r is the return value of the
76 * function, elem_p is the element
77 */
78void dar_first(long funcCode, var_t *r, var_t *elem_p) {
79 var_num_t n;
80
81 switch (funcCode) {
82 case kwMAX:
83 case kwMIN:
84 v_set(r, elem_p);
85 break;
86 default:
87 r->type = V_NUM;
88 n = v_getval(elem_p);
89
90 switch (funcCode) {
91 case kwABSMAX:
92 case kwABSMIN:
93 r->v.n = fabsl(n);
94 break;
95 case kwSUM:
96 case kwSTATMEAN:
97 r->v.n = n;
98 break;
99 case kwSUMSV:
100 r->v.n = n * n;
101 break;
102 }
103 }
104}
105
106/*
107 * ARRAY ROUTINES - Next (each) element
108 * funcCode is the function code, r is the return value of
109 * the function, elem_p is the current element
110 */
111void dar_next(long funcCode, var_t *r, var_t *elem_p) {
112 var_num_t n;
113
114 switch (funcCode) {
115 case kwMAX:
116 if (v_compare(r, elem_p) < 0) {
117 v_set(r, elem_p);
118 }
119 break;
120 case kwMIN:
121 if (v_compare(r, elem_p) > 0) {
122 v_set(r, elem_p);
123 }
124 break;
125 default:
126 // numeric
127 n = v_getval(elem_p);
128
129 switch (funcCode) {
130 case kwABSMIN:
131 n = fabsl(n);
132 if (n < r->v.n) {
133 r->v.n = n;
134 }
135 break;
136 case kwABSMAX:
137 n = fabsl(n);
138 if (n > r->v.n) {
139 r->v.n = n;
140 }
141 break;
142 case kwSUM:
143 case kwSTATMEAN:
144 r->v.n += n;
145 break;
146 case kwSUMSV:
147 r->v.n += (n * n);
148 break;
149 }
150 }
151}
152
153/*
154 * ARRAY ROUTINES - Last element
155 * funcCode is the function code, r is the return value of
156 * the function, elem_p is the element
157 */
158void dar_final(long funcCode, var_t *r, int count) {
159 switch (funcCode) {
160 case kwSTATMEAN:
161 if (count) {
162 r->v.n = r->v.n / count;
163 }
164 break;
165 };
166}
167
168/*
169 * DATE mm/dd/yy string to ints
170 */
171void date_str2dmy(char *str, long *d, long *m, long *y) {
172 char *p;
173 char tmp[8];
174 int mode = 0, count = 0;
175
176 p = str;
177 while (*p) {
178 if (*p == '/') {
179 tmp[count] = '\0';
180 switch (mode) {
181 case 0: // day
182 *d = xstrtol(tmp);
183 if (*d < 1 || *d > 31) {
184 rt_raise(ERR_DATE, str);
185 return;
186 }
187 break;
188 case 1: // month
189 *m = xstrtol(tmp);
190 if (*m < 1 || *m > 12) {
191 rt_raise(ERR_DATE, str);
192 return;
193 }
194 break;
195 default:
196 rt_raise(ERR_DATE, str);
197 return;
198 };
199 mode++;
200 count = 0;
201 } else {
202 tmp[count] = *p;
203 count++;
204 }
205 p++;
206 }
207
208 if (mode != 2) {
209 rt_raise(ERR_DATE, str);
210 return;
211 }
212
213 tmp[count] = '\0';
214 *y = xstrtol(tmp);
215 if (*y < 100) {
216 *y += 2000;
217 }
218}
219
220/*
221 * TIME hh:mm:ss string to ints
222 */
223void date_str2hms(char *str, long *h, long *m, long *s) {
224 char *p;
225 char tmp[8];
226 int mode = 0, count = 0;
227
228 p = str;
229 while (*p) {
230 if (*p == ':') {
231 tmp[count] = '\0';
232 switch (mode) {
233 case 0: // hour
234 *h = xstrtol(tmp);
235 if (*h < 0 || *h > 23) {
236 rt_raise(ERR_TIME, str);
237 return;
238 }
239 break;
240 case 1: // min
241 *m = xstrtol(tmp);
242 if (*m < 0 || *m > 59) {
243 rt_raise(ERR_TIME, str);
244 return;
245 }
246 break;
247 default:
248 rt_raise(ERR_TIME, str);
249 return;
250 };
251 mode++;
252 count = 0;
253 } else {
254 tmp[count] = *p;
255 count++;
256 }
257 p++;
258 }
259
260 if (mode != 2) {
261 rt_raise(ERR_TIME, str);
262 return;
263 }
264
265 tmp[count] = '\0';
266 *s = xstrtol(tmp);
267 if (*s < 0 || *s > 59) {
268 rt_raise(ERR_TIME, str);
269 }
270}
271
272/*
273 * calc julian date
274 */
275long date_julian(long d, long m, long y) {
276 long j = -1L, t, jp;
277
278 if (y < 0) {
279 return j;
280 }
281 if (m < 1 || m > 12) {
282 return j;
283 }
284 if (d < 1 || d > 31) {
285 return j;
286 }
287 t = (m - 14L) / 12L;
288 jp = d - 32075L + (1461L * (y + 4800L + t) / 4L);
289 jp = jp + (367L * (m - 2L - t * 12L) / 12L);
290 j = jp - (3L * ((y + 4900L + t) / 100) / 4);
291 return j;
292}
293
294/*
295 * date: weekday (0=sun)
296 */
297int date_weekday(long d, long m, long y) {
298 if (y < 0) {
299 return -1;
300 }
301 if (m < 1 || m > 12) {
302 return -1;
303 }
304 if (d < 1 || d > 31) {
305 return -1;
306 }
307 if (y < 100) {
308 y += 2000;
309 }
310 return ((1461 * (y + 4800 + (m - 14) / 12) / 4 + 367 * (m - 2 - 12 * ((m - 14) / 12)) / 12
311 - 3 * ((y + 4900 + (m - 14) / 12) / 100) / 4 + d) % 7);
312}
313
314/*
315 * format date
316 */
317char *date_fmt(char *fmt, long d, long m, long y) {
318 int dc, mc, yc, wd, l;
319 char *p, tmp[32];
320 cstr str;
321
322 cstr_init(&str, BUF_LEN);
323 dc = 0;
324 mc = 0;
325 yc = 0;
326 p = fmt;
327 if (p == NULL || !(*p)) {
328 return str.buf;
329 }
330 while (1) {
331 if (*p == DATEFMT_DAY_U || *p == DATEFMT_DAY_L) {
332 dc++;
333 } else if (*p == DATEFMT_MONTH_U || *p == DATEFMT_MONTH_L) {
334 mc++;
335 } else if (*p == DATEFMT_YEAR_U || *p == DATEFMT_YEAR_L) {
336 yc++;
337 } else {
338 //
339 // Separator
340 //
341 if (dc) {
342 // day
343 switch (dc) {
344 case 1:
345 ltostr(d, tmp);
346 cstr_append(&str, tmp);
347 break;
348 case 2:
349 ltostr(d, tmp);
350 if (d < 10) {
351 cstr_append(&str, "0");
352 }
353 cstr_append(&str, tmp);
354 break;
355 default:
356 // weekday
357 wd = date_weekday(d, m, y);
358 if (wd >= 0 && wd <= 6) {
359 if (dc == 3) {
360 // 3 letters
361 cstr_append(&str, date_wd3_table[wd]);
362 } else {
363 // full name
364 cstr_append(&str, date_wdN_table[wd]);
365 }
366 } else {
367 cstr_append(&str, "***");
368 }
369 }
370
371 dc = 0;
372 }
373 else if (mc) {
374 // month
375 switch (mc) {
376 case 1:
377 ltostr(m, tmp);
378 cstr_append(&str, tmp);
379 break;
380 case 2:
381 ltostr(m, tmp);
382 if (m < 10) {
383 cstr_append(&str, "0");
384 }
385 cstr_append(&str, tmp);
386 break;
387 default:
388 // month
389 if (m >= 1 && m <= 12) {
390 if (mc == 3) {
391 // 3 letters
392 cstr_append(&str, date_m3_table[m - 1]);
393 } else {
394 // full name
395 cstr_append(&str, date_mN_table[m - 1]);
396 }
397 } else {
398 cstr_append(&str, "***");
399 }
400 }
401 mc = 0;
402 }
403 else if (yc) {
404 // year
405 ltostr(y, tmp);
406 l = strlen(tmp);
407 if (l < yc) {
408 for (int i = l; i < yc; i++) {
409 cstr_append(&str, "0");
410 }
411 } else {
412 cstr_append(&str, tmp + (l - yc));
413 }
414 yc = 0;
415 }
416
417 // add separator
418 tmp[0] = *p;
419 tmp[1] = '\0';
420 cstr_append(&str, tmp);
421 }
422
423 if (*p == '\0') {
424 break;
425 }
426 p++;
427 }
428 return str.buf;
429}
430
431/*
432 * date julian->d/m/y
433 */
434void date_jul2dmy(long j, long *d, long *m, long *y) {
435 long ta, tb, tc;
436
437 ta = j + 68569L;
438 tb = 4L * ta / 146097L;
439 ta = ta - (146097L * tb + 3L) / 4L;
440 *y = 4000L * (ta + 1L) / 1461001L;
441 tc = *y;
442 ta = ta - (1461L * tc / 4L) + 31L;
443 *m = 80L * ta / 2447L;
444 tc = *m;
445 *d = ta - (2447L * tc / 80L);
446 ta = *m / 11L;
447 *m = *m + 2L - (12L * ta);
448 *y = 100L * (tb - 49L) + *y + ta;
449}
450
451/*
452 * timer->hms
453 */
454void date_tim2hms(long t, long *h, long *m, long *s) {
455 *h = t / 3600L;
456 *m = (t - (*h * 3600L)) / 60L;
457 *s = t - (*h * 3600L + *m * 60L);
458}
459
460/*
461 * f <- FUNC ()
462 */
463var_num_t cmd_math0(long funcCode) {
464 var_num_t r;
465
466 IF_ERR_RETURN_0;
467 switch (funcCode) {
468 case kwXPOS:
469 if (os_graphics) {
470 r = dev_getx() / dev_textwidth("0");
471 } else {
472 r = dev_getx();
473 }
474 break;
475 case kwYPOS:
476 if (os_graphics) {
477 r = dev_gety() / dev_textheight("0");
478 } else {
479 r = dev_gety();
480 }
481 break;
482 case kwRND:
483 r = pcg32_rand();
484 break;
485 default:
486 rt_raise("Unsupported built-in function call %ld", funcCode);
487 r = 0;
488 }
489 return r;
490}
491
492/*
493 * f <- FUNC (f|i)
494 */
495var_num_t cmd_math1(long funcCode, var_t *arg) {
496 var_num_t r;
497 var_num_t x = v_getval(arg);
498 IF_ERR_RETURN_0;
499 switch (funcCode) {
500 case kwPENF:
501 r = dev_getpen(x);
502 break;
503 case kwCOS:
504 r = cos(x);
505 break;
506 case kwSIN:
507 r = sin(x);
508 break;
509 case kwTAN:
510 r = tan(x);
511 break;
512 case kwACOS:
513 r = acos(x);
514 break;
515 case kwASIN:
516 r = asin(x);
517 break;
518 case kwATAN:
519 r = atan(x);
520 break;
521 case kwCOSH:
522 r = cosh(x);
523 break;
524 case kwSINH:
525 r = sinh(x);
526 break;
527 case kwTANH:
528 r = tanh(x);
529 break;
530 case kwACOSH:
531#if defined(_Win32)
532 r = log(x + sqrt(x * x - 1));
533#else
534 r = acosh(x);
535#endif
536 break;
537 case kwASINH:
538#if defined(_Win32)
539 r = log(x + sqrt(x * x + 1));
540#else
541 r = asinh(x);
542#endif
543 break;
544 case kwATANH:
545#if defined(_Win32)
546 r = log((1 + x) / (1 - x)) / 2;
547#else
548 r = atanh(x);
549#endif
550 break;
551 case kwSEC:
552 r = 1.0 / cos(x);
553 break;
554 case kwASEC:
555 r = atan(sqrt(x * x - 1.0)) + (ZSGN(x) - 1.0) * M_PI / 2.0;
556 break;
557 case kwSECH:
558 r = 2.0 / (exp(x) + exp(-x));
559 break;
560 case kwASECH:
561 r = log((1.0 + sqrt(1.0 - x * x)) / x);
562 break;
563 case kwCSC:
564 r = 1.0 / sin(x);
565 break;
566 case kwACSC:
567 r = atan(1.0 / sqrt(x * x - 1.0)) + (ZSGN(x) - 1.0) * M_PI / 2.0;
568 break;
569 case kwCSCH:
570 r = 2.0 / (exp(x) - exp(-x));
571 break;
572 case kwACSCH:
573 r = log((ZSGN(x) * sqrt(x * x + 1.0) + 1.0) / x);
574 break;
575 case kwCOT:
576 r = 1.0 / tan(x);
577 break;
578 case kwACOT:
579 r = M_PI / 2.0 - atan(x);
580 break;
581 case kwCOTH:
582 r = 2.0 * exp(-x) / (exp(x) - exp(-x)) + 1.0;
583 break;
584 case kwACOTH:
585 r = log((x + 1.0) / (x - 1.0)) / 2.0;
586 break;
587 case kwSQR:
588 r = sqrt(x);
589 break;
590 case kwABS:
591 r = (x > 0.0) ? x : -x;
592 break;
593 case kwEXP:
594 r = exp(x);
595 break;
596 case kwLOG:
597 r = log(x);
598 break;
599 case kwLOG10:
600 r = log10(x);
601 break;
602 case kwINT:
603 r = (x < 0) ? -floor(-x) : floor(x);
604 break;
605 case kwFIX:
606 r = (x < 0) ? -ceil(-x) : ceil(x);
607 break;
608 case kwCEIL:
609 r = ceil(x);
610 break;
611 case kwFLOOR:
612 r = floor(x);
613 break;
614 case kwFRAC:
615 r = (x < 0) ? x + floor(-x) : x - floor(x);
616 break;
617 case kwDEG:
618 r = x * 180.0 / M_PI;
619 break;
620 case kwRAD:
621 r = x * M_PI / 180.0;
622 break;
623 case kwCDBL:
624 r = x;
625 break;
626 default:
627 rt_raise("Unsupported built-in function call %ld", funcCode);
628 r = 0.0;
629 };
630
631 return r;
632}
633
634//
635// QB-standard:
636// int <- FRE(0) // free memory
637// int <- FRE(-1) // largest block of integers
638// int <- FRE(-2) // free stack
639// int <- FRE(-3) // largest free block
640//
641// Our standard (it is optional for now):
642// int <- FRE(-10) // total ram
643// int <- FRE(-11) // used
644// int <- FRE(-12) // free
645//
646// Optional-set #1: memory related info (-1x)
647// int <- FRE(-13) // shared
648// int <- FRE(-14) // buffers
649// int <- FRE(-15) // cached
650// int <- FRE(-16) // total virtual memory size
651// int <- FRE(-17) // used virtual memory
652// int <- FRE(-18) // free virtual memory
653//
654// Optional-set #2: system related info (-2x)
655//
656// Optional-set #3: file-system related info (-3x)
657//
658// Optional-set #4: battery related info (-4x)
659// int <- FRE(-40) // battery voltage * 1000
660// int <- FRE(-41) // battery percent
661// int <- FRE(-42) // battery critical voltage value * 1000
662// int <- FRE(-43) // battery warning voltage value * 1000
663//
664var_int_t cmd_fre(var_int_t arg) {
665 var_int_t r = 0;
666#if defined(_Win32)
667 MEMORYSTATUS ms;
668 ms.dwLength = sizeof(MEMORYSTATUS);
669 GlobalMemoryStatus(&ms);
670
671 switch (arg) {
672 case 0: // free mem
673 case -3: // largest block
674 case -12: // free mem
675 r = ms.dwAvailPhys;
676 break;
677 case -1: // int
678 r = ms.dwAvailPhys / 4L;
679 break;
680 case -2: // stk
681 r = 0x120000;
682 break;
683 }
684#elif defined(_UnixOS) && !defined(__MACH__)
685 // assumes first two items are total + free
686 #define I_MEM_TOTAL 0
687 #define I_MEM_FREE 1
688 int memfd = open("/proc/meminfo", O_RDONLY);
689 if (memfd) {
690 int i_val = 0;
691 var_int_t total = 0;
692 ssize_t n;
693 char ch;
694
695 for (n = read(memfd, &ch, sizeof(ch));
696 r == 0 && n != 0; n = read(memfd, &ch, sizeof(ch))) {
697 if (ch == ':') {
698 // skip leading white space
699 n = read(memfd, &ch, sizeof(ch));
700 while (n != 0 && ch == ' ') {
701 n = read(memfd, &ch, sizeof(ch));
702 }
703
704 // read the value
705 long long val = 0;
706 while (n != 0 && isdigit(ch)) {
707 val = (val * 10) + (ch - '0');
708 n = read(memfd, &ch, sizeof(ch));
709 }
710
711 if (arg == i_val
712 || (arg == -10 && i_val == I_MEM_TOTAL)
713 || (arg == -12 && i_val == I_MEM_FREE)) {
714 r = val * 1024 / 1000;
715 }
716 if (i_val == I_MEM_TOTAL) {
717 total = val;
718 }
719 else if (i_val == I_MEM_FREE && arg == -11) {
720 // return used memory
721 r = (total - val) * 1024 / 1000;
722 }
723 i_val++;
724 }
725 }
726 close(memfd);
727 }
728#endif
729 return r;
730}
731
732/*
733 * i <- FUNC ()
734 */
735var_int_t cmd_imath0(long funcCode) {
736 var_int_t r;
737 struct tm tms;
738 time_t now;
739
740 IF_ERR_RETURN_0;
741 switch (funcCode) {
742 case kwTIMER:
743 //
744 // int <- TIMER // seconds from 00:00
745 //
746 time(&now);
747 tms = *localtime(&now);
748 r = tms.tm_hour * 3600L + tms.tm_min * 60L + tms.tm_sec;
749 break;
750 case kwTICKS:
751 //
752 // int <- TICKS // clock()
753 //
754 r = dev_get_millisecond_count();
755 break;
756 case kwPROGLINE:
757 //
758 // int <- current program line
759 //
760 r = prog_line;
761 break;
762 default:
763 rt_raise("Unsupported built-in function call %ld", funcCode);
764 r = 0;
765 };
766 return r;
767}
768
769/*
770 * i <- FUNC (f|i)
771 */
772var_int_t cmd_imath1(long funcCode, var_t *arg) {
773 var_int_t x = v_getint(arg);
774 var_int_t r;
775
776 IF_ERR_RETURN_0;
777 switch (funcCode) {
778 case kwCINT:
779 //
780 // int <- CINT(float)
781 //
782 r = x;
783 break;
784 case kwEOF:
785 //
786 // int <- EOF(file-handle)
787 //
788 if (!x) {
789 r = feof(stdin);
790 break;
791 }
792 r = dev_feof(x);
793 break;
794 case kwSEEKF:
795 //
796 // int <- SEEK(file-handle)
797 //
798 r = dev_ftell(x);
799 break;
800 case kwLOF:
801 //
802 // int <- LOF(file-handle)
803 //
804 r = dev_flength(x);
805 break;
806 case kwSGN:
807 //
808 // int <- SGN(n)
809 //
810 r = v_sign(arg);
811 break;
812 case kwFRE:
813 //
814 // int <- FRE(n)
815 //
816 r = cmd_fre(x);
817 break;
818
819 default:
820 rt_raise("Unsupported built-in function call %ld", funcCode);
821 r = 0;
822 };
823
824 return r;
825}
826
827//
828// i|f <- FUNC (str)
829//
830void cmd_ns1(long funcCode, var_t *arg, var_t *r) {
831 IF_ERR_RETURN;
832 if (arg->type != V_STR) {
833 v_tostr(arg);
834 IF_ERR_RETURN;
835 }
836
837 switch (funcCode) {
838 case kwASC:
839 //
840 // int <- ASC(s)
841 //
842 r->type = V_INT;
843 r->v.i = *((byte *) arg->v.p.ptr);
844 break;
845 case kwVAL:
846 //
847 // float <- VAL(s)
848 //
849 r->type = V_NUM;
850 r->v.n = numexpr_sb_strtof(arg->v.p.ptr);
851 break;
852 case kwTEXTWIDTH:
853 //
854 // int <- TXTW(s)
855 //
856 r->type = V_INT;
857 r->v.i = dev_textwidth(arg->v.p.ptr);
858 break;
859 case kwTEXTHEIGHT:
860 //
861 // int <- TXTH(s)
862 //
863 r->type = V_INT;
864 r->v.i = dev_textheight(arg->v.p.ptr);
865 break;
866 case kwEXIST:
867 //
868 // int <- EXIST(s)
869 //
870 r->type = V_INT;
871 r->v.i = dev_fexists(arg->v.p.ptr);
872 break;
873 case kwACCESSF:
874 //
875 // int <- ACCESS(s)
876 //
877 r->type = V_INT;
878 r->v.i = dev_faccess(arg->v.p.ptr);
879 break;
880 case kwISFILE:
881 //
882 // int <- ISFILE(s)
883 //
884 r->type = V_INT;
885 r->v.i = dev_fattr(arg->v.p.ptr) & VFS_ATTR_FILE;
886 break;
887 case kwISDIR:
888 //
889 // int <- ISDIR(s)
890 //
891 r->type = V_INT;
892 r->v.i = dev_fattr(arg->v.p.ptr) & VFS_ATTR_DIR;
893 break;
894 case kwISLINK:
895 //
896 // int <- ISLINK(s)
897 //
898 r->type = V_INT;
899 r->v.i = dev_fattr(arg->v.p.ptr) & VFS_ATTR_LINK;
900 break;
901 default:
902 rt_raise("Unsupported built-in function call %ld", funcCode);
903 };
904}
905
906//
907// str <- FUNC (any)
908//
909void cmd_str1(long funcCode, var_t *arg, var_t *r) {
910 char *tb;
911 char *wp;
912 char *p;
913 var_int_t l;
914
915 switch (funcCode) {
916 case kwCHR:
917 //
918 // str <- CHR$(n)
919 //
920 wp = r->v.p.ptr = (char *)malloc(2);
921 wp[0] = v_getint(arg);
922 wp[1] = '\0';
923 r->v.p.length = 2;
924 break;
925 case kwSTR:
926 //
927 // str <- STR$(n)
928 //
929 r->v.p.ptr = v_str(arg);
930 r->v.p.length = strlen(r->v.p.ptr) + 1;
931 break;
932 case kwCBS:
933 //
934 // str <- CBS$(str)
935 // convert C-Style string to BASIC-style string
936 //
937 if (!v_is_type(arg, V_STR)) {
938 v_init(r);
939 break;
940 }
941 r->v.p.ptr = cstrdup(arg->v.p.ptr);
942 r->v.p.length = strlen(r->v.p.ptr) + 1;
943 break;
944 case kwBCS:
945 //
946 // str <- BCS$(str)
947 // convert BASIC-Style string to C-style string
948 //
949 if (!v_is_type(arg, V_STR)) {
950 v_init(r);
951 break;
952 }
953 r->v.p.ptr = bstrdup(arg->v.p.ptr);
954 r->v.p.length = strlen(r->v.p.ptr) + 1;
955 break;
956 case kwOCT:
957 //
958 // str <- OCT$(n)
959 //
960 r->v.p.ptr = (char *)malloc(BUF_LEN);
961 sprintf(r->v.p.ptr, "%lo", (unsigned long) v_getint(arg));
962 r->v.p.length = strlen(r->v.p.ptr) + 1;
963 break;
964 //
965 // str <- BIN$(n)
966 //
967 case kwBIN:
968 l = v_getint(arg);
969 IF_ERR_RETURN;
970 tb = malloc(33);
971 memset(tb, 0, 33);
972 for (int i = 0; i < 32; i++) {
973 if (l & (1 << i)) {
974 tb[31 - i] = '1';
975 } else {
976 tb[31 - i] = '0';
977 }
978 }
979
980 r->v.p.ptr = tb;
981 r->v.p.length = strlen(r->v.p.ptr) + 1;
982 break;
983 case kwHEX:
984 //
985 // str <- HEX$(n)
986 //
987 r->v.p.ptr = (char *)malloc(BUF_LEN);
988 sprintf(r->v.p.ptr, "%lX", (unsigned long) v_getint(arg));
989 r->v.p.length = strlen(r->v.p.ptr) + 1;
990 break;
991 case kwLCASE:
992 //
993 // str <- LCASE$(s)
994 //
995 r->v.p.ptr = v_str(arg);
996 r->v.p.length = strlen(r->v.p.ptr) + 1;
997 p = r->v.p.ptr;
998 while (*p) {
999 *p = to_lower(*p);
1000 p++;
1001 }
1002 break;
1003 case kwUCASE:
1004 //
1005 // str <- UCASE$(s)
1006 //
1007 r->v.p.ptr = v_str(arg);
1008 r->v.p.length = strlen(r->v.p.ptr) + 1;
1009 p = r->v.p.ptr;
1010 while (*p) {
1011 *p = to_upper(*p);
1012 p++;
1013 }
1014 break;
1015 case kwLTRIM:
1016 //
1017 // str <- LTRIM$(s)
1018 //
1019 if (!v_is_type(arg, V_STR)) {
1020 v_init(r);
1021 break;
1022 }
1023 p = arg->v.p.ptr;
1024 while (is_wspace(*p)) {
1025 p++;
1026 }
1027 r->v.p.ptr = (char *)malloc(strlen(p) + 1);
1028 strcpy(r->v.p.ptr, p);
1029 r->v.p.length = strlen(r->v.p.ptr) + 1;
1030 break;
1031 case kwTRIM:
1032 //
1033 // str <- LTRIM(RTRIM(s))
1034 //
1035 case kwRTRIM:
1036 //
1037 // str <- RTRIM$(s)
1038 //
1039 if (!v_is_type(arg, V_STR)) {
1040 v_init(r);
1041 break;
1042 }
1043 p = arg->v.p.ptr;
1044 if (*p != '\0') {
1045 while (*p) {
1046 p++;
1047 }
1048 p--;
1049 while (p >= arg->v.p.ptr && (is_wspace(*p))) {
1050 p--;
1051 }
1052 p++;
1053 *p = '\0';
1054 }
1055 r->v.p.ptr = (char *)malloc(strlen(arg->v.p.ptr) + 1);
1056 strcpy(r->v.p.ptr, arg->v.p.ptr);
1057 r->v.p.length = strlen(r->v.p.ptr) + 1;
1058
1059 // alltrim
1060 if (funcCode == kwTRIM) {
1061 char *tmp_p = p = r->v.p.ptr;
1062 while (is_wspace(*p)) {
1063 p++;
1064 }
1065 r->v.p.ptr = (char *)malloc(strlen(p) + 1);
1066 strcpy(r->v.p.ptr, p);
1067 r->v.p.length = strlen(r->v.p.ptr) + 1;
1068 free(tmp_p);
1069 }
1070 break;
1071 case kwCAT:
1072 // we can add color codes
1073 r->v.p.ptr = malloc(8);
1074 strcpy(r->v.p.ptr, "");
1075 l = v_getint(arg);
1076 switch (l) {
1077 case 0: // reset
1078 strcpy(r->v.p.ptr, "\033[0m");
1079 break;
1080 case 1: // bold on
1081 strcpy(r->v.p.ptr, "\033[1m");
1082 break;
1083 case -1: // bold off
1084 strcpy(r->v.p.ptr, "\033[21m");
1085 break;
1086 case 2: // underline on
1087 strcpy(r->v.p.ptr, "\033[4m");
1088 break;
1089 case -2: // underline off
1090 strcpy(r->v.p.ptr, "\033[24m");
1091 break;
1092 case 3: // reverse on
1093 strcpy(r->v.p.ptr, "\033[7m");
1094 break;
1095 case -3: // reverse off
1096 strcpy(r->v.p.ptr, "\033[27m");
1097 break;
1098 case 80: // select system font
1099 case 81:
1100 case 82:
1101 case 83:
1102 case 84:
1103 case 85:
1104 case 86:
1105 case 87:
1106 case 88:
1107 case 89:
1108 sprintf(r->v.p.ptr, "\033[8%dm", (int) l - 80);
1109 break;
1110 case 90: // select custom font
1111 case 91:
1112 case 92:
1113 case 93:
1114 case 94:
1115 case 95:
1116 case 96:
1117 case 97:
1118 case 98:
1119 case 99:
1120 if (os_charset == 0)
1121 sprintf(r->v.p.ptr, "\033[9%dm", (int) l - 90);
1122 break;
1123 }
1124 r->v.p.length = strlen(r->v.p.ptr) + 1;
1125 break;
1126 case kwTAB:
1127 l = v_igetval(arg);
1128 r->v.p.ptr = malloc(16);
1129 *r->v.p.ptr = '\0';
1130 sprintf(r->v.p.ptr, "\033[%dG", (int) l);
1131 r->v.p.length = strlen(r->v.p.ptr) + 1;
1132 break;
1133 case kwSPACE:
1134 //
1135 // str <- SPACE$(n)
1136 //
1137 l = v_getint(arg);
1138 if (l < 0) {
1139 err_argerr();
1140 } else {
1141 wp = r->v.p.ptr = (char *)malloc(l + 1);
1142 for (int i = 0; i < l; i++) {
1143 wp[i] = ' ';
1144 }
1145 wp[l] = '\0';
1146 r->v.p.length = strlen(r->v.p.ptr) + 1;
1147 }
1148 break;
1149 case kwENVIRONF:
1150 //
1151 // str <- ENVIRON$(str)
1152 //
1153 if (v_is_type(arg, V_STR) && *arg->v.p.ptr != '\0') {
1154 // return the variable
1155 const char *v = dev_getenv(arg->v.p.ptr);
1156 if (v) {
1157 int l = strlen(v) + 1;
1158 r->v.p.ptr = malloc(l);
1159 strcpy(r->v.p.ptr, v);
1160 r->v.p.length = l;
1161 } else {
1162 r->v.p.ptr = malloc(2);
1163 *r->v.p.ptr = '\0';
1164 r->v.p.length = 1;
1165 }
1166 } else {
1167 // return all
1168 int count = dev_env_count();
1169 r->type = V_INT;
1170 if (count) {
1171 v_toarray1(r, count);
1172 for (int i = 0; i < count; i++) {
1173 const char *value = dev_getenv_n(i);
1174 var_t *elem_p = v_elem(r, i);
1175 elem_p->type = V_STR;
1176 elem_p->v.p.ptr = strdup(value != NULL ? value : "");
1177 elem_p->v.p.length = strlen(elem_p->v.p.ptr) + 1;
1178 }
1179 } else {
1180 // no vars found
1181 v_toarray1(r, 0);
1182 }
1183 }
1184 break;
1185 case kwTIMESTAMP:
1186 //
1187 // str <- TIMESTAMP(file)
1188 //
1189 r->v.p.length = dev_filemtime(arg, &r->v.p.ptr);
1190 break;
1191
1192 default:
1193 rt_raise("Unsupported built-in function call %ld", funcCode);
1194 };
1195}
1196
1197//
1198// str <- FUNC (void)
1199//
1200void cmd_str0(long funcCode, var_t *r) {
1201 struct tm tms;
1202 time_t now;
1203
1204 IF_ERR_RETURN;
1205 switch (funcCode) {
1206 case kwINKEY:
1207 //
1208 // str <- INKEY$
1209 //
1210 if (!dev_kbhit()) {
1211 dev_events(par_getval(2));
1212 }
1213 if (dev_kbhit()) {
1214 char tmp[3];
1215 uint32_t ch = dev_getch();
1216 if ((ch & 0xFF00) == 0xFF00) {
1217 // keypad or mouse keys
1218 tmp[0] = '\033';
1219 tmp[1] = ch & 0xFF;
1220 tmp[2] = '\0';
1221 } else if ((ch & SB_KEY_CTRL_ALT(0)) == SB_KEY_CTRL_ALT(0)) {
1222 tmp[0] = '\4';
1223 tmp[1] = ch & 0xFF;
1224 tmp[2] = '\0';
1225 } else if ((ch & SB_KEY_ALT_SHIFT(0)) == SB_KEY_ALT_SHIFT(0)) {
1226 tmp[0] = '\5';
1227 tmp[1] = ch & 0xFF;
1228 tmp[2] = '\0';
1229 } else if ((ch & SB_KEY_SHIFT_CTRL(0)) == SB_KEY_SHIFT_CTRL(0)) {
1230 tmp[0] = '\6';
1231 tmp[1] = ch & 0xFF;
1232 tmp[2] = '\0';
1233 } else if ((ch & SB_KEY_CTRL(0)) == SB_KEY_CTRL(0)) {
1234 tmp[0] = '\1';
1235 tmp[1] = ch & 0xFF;
1236 tmp[2] = '\0';
1237 } else if ((ch & SB_KEY_ALT(0)) == SB_KEY_ALT(0)) {
1238 tmp[0] = '\2';
1239 tmp[1] = ch & 0xFF;
1240 tmp[2] = '\0';
1241 } else if ((ch & SB_KEY_SHIFT(0)) == SB_KEY_SHIFT(0)) {
1242 tmp[0] = '\3';
1243 tmp[1] = ch & 0xFF;
1244 tmp[2] = '\0';
1245 } else {
1246 switch (os_charset) {
1247 case enc_sjis: // Japan
1248 if (IsJISFont(ch)) {
1249 tmp[0] = ch >> 8;
1250 tmp[1] = ch & 0xFF;
1251 tmp[2] = '\0';
1252 } else {
1253 tmp[0] = ch;
1254 tmp[1] = '\0';
1255 }
1256 break;
1257 case enc_big5: // China
1258 if (IsBig5Font(ch)) {
1259 tmp[0] = ch >> 8;
1260 tmp[1] = ch & 0xFF;
1261 tmp[2] = '\0';
1262 } else {
1263 tmp[0] = ch;
1264 tmp[1] = '\0';
1265 }
1266 break;
1267 case enc_gmb: // Generic multibyte
1268 if (IsGMBFont(ch)) {
1269 tmp[0] = ch >> 8;
1270 tmp[1] = ch & 0xFF;
1271 tmp[2] = '\0';
1272 } else {
1273 tmp[0] = ch;
1274 tmp[1] = '\0';
1275 }
1276 break;
1277 case enc_unicode: // Unicode
1278 tmp[0] = ch >> 8;
1279 tmp[1] = ch & 0xFF;
1280 tmp[2] = '\0';
1281 break;
1282 default: // Europe 8bit
1283 tmp[0] = ch;
1284 tmp[1] = '\0';
1285 };
1286 }
1287 v_createstr(r, tmp);
1288 } else {
1289 v_createstr(r, "");
1290 }
1291 break;
1292 case kwDATE:
1293 //
1294 // str <- DATE$
1295 //
1296 time(&now);
1297 tms = *localtime(&now);
1298 r->type = V_STR;
1299 r->v.p.ptr = malloc(32);
1300 r->v.p.owner = 1;
1301 sprintf(r->v.p.ptr, "%02d/%02d/%04d", tms.tm_mday, tms.tm_mon + 1, tms.tm_year + 1900);
1302 r->v.p.length = strlen(r->v.p.ptr) + 1;
1303 break;
1304 case kwTIME:
1305 //
1306 // str <- TIME$
1307 //
1308 time(&now);
1309 tms = *localtime(&now);
1310 r->type = V_STR;
1311 r->v.p.ptr = malloc(32);
1312 r->v.p.owner = 1;
1313 sprintf(r->v.p.ptr, "%02d:%02d:%02d", tms.tm_hour, tms.tm_min, tms.tm_sec);
1314 r->v.p.length = strlen(r->v.p.ptr) + 1;
1315 break;
1316 default:
1317 rt_raise("Unsupported built-in function call %ld", funcCode);
1318 }
1319}
1320
1321//
1322// str <- FUNC (...)
1323//
1324void cmd_strN(long funcCode, var_t *r) {
1325 var_t arg1, arg2;
1326 var_t *var_p1 = NULL;
1327 var_t *var_p2 = NULL;
1328 var_int_t i, count, lsrc, len, start, pc;
1329 char tmp[2];
1330 char *s1 = NULL, *s2 = NULL, *s3 = NULL;
1331
1332 v_init(&arg1);
1333 IF_ERR_RETURN;
1334 switch (funcCode) {
1335 case kwTRANSLATEF:
1336 //
1337 // s <- TRANSLATE(source, what [, with])
1338 //
1339 i = 0;
1340 par_massget("SSsi", &s1, &s2, &s3, &i);
1341 if (!prog_error) {
1342 if (s3) {
1343 r->v.p.ptr = transdup(s1, s2, s3, i);
1344 } else {
1345 r->v.p.ptr = transdup(s1, s2, "", i);
1346 }
1347 r->type = V_STR;
1348 r->v.p.length = strlen(r->v.p.ptr) + 1;
1349 }
1350 break;
1351 case kwCHOP:
1352 //
1353 // s <- CHOP(s)
1354 //
1355 par_massget("S", &s1);
1356 if (!prog_error) {
1357 if (strlen(s1)) {
1358 r->v.p.ptr = strdup(s1);
1359 r->v.p.ptr[strlen(r->v.p.ptr) - 1] = '\0';
1360 r->type = V_STR;
1361 r->v.p.length = strlen(r->v.p.ptr) + 1;
1362 } else {
1363 v_zerostr(r);
1364 }
1365 }
1366 break;
1367 case kwSTRING:
1368 //
1369 // str <- STRING$ ( int, int | str )
1370 //
1371 start = -1; // ascii code
1372 pc = par_massget("Iis", &count, &start, &s1);
1373 if (!prog_error) {
1374 char *tmp_p;
1375 if (s1) {
1376 len = strlen(s1);
1377 tmp_p = s1;
1378 } else {
1379 if (start == -1) {
1380 err_argerr();
1381 break;
1382 }
1383 tmp[0] = start;
1384 tmp[1] = '\0';
1385 tmp_p = tmp;
1386 len = 1;
1387 }
1388
1389 if (len == 0 || count == 0 || pc == 3) {
1390 err_argerr();
1391 r->type = V_INT; // dont try to free
1392 } else {
1393 r->v.p.ptr = malloc(count * len + 1);
1394 *((r->v.p.ptr)) = '\0';
1395 for (int i = 0; i < count; i++) {
1396 strcat(r->v.p.ptr, tmp_p);
1397 }
1398 r->v.p.length = strlen(r->v.p.ptr) + 1;
1399 }
1400 }
1401 break;
1402
1403 //
1404 // str <- SQUEEZE(str)
1405 //
1406 case kwSQUEEZE:
1407 par_massget("S", &s1);
1408 if (!prog_error) {
1409 r->type = V_STR;
1410 r->v.p.ptr = sqzdup(s1);
1411 r->v.p.length = strlen(r->v.p.ptr) + 1;
1412 }
1413 break;
1414 //
1415 // str <- ENCLOSE(str[, pairs])
1416 //
1417 case kwENCLOSE:
1418 par_massget("Ss", &s1, &s2);
1419 if (!prog_error) {
1420 r->type = V_STR;
1421 if (s2) {
1422 r->v.p.ptr = encldup(s1, s2);
1423 } else {
1424 r->v.p.ptr = encldup(s1, "\"\"");
1425 }
1426 r->v.p.length = strlen(r->v.p.ptr) + 1;
1427 }
1428 break;
1429 //
1430 // str <- DISCLOSE(str[, pairs [, ignore-pairs]])
1431 //
1432 case kwDISCLOSE:
1433 par_massget("Sss", &s1, &s2, &s3);
1434 if (!prog_error) {
1435 r->type = V_STR;
1436 if (s2) {
1437 if (s3) {
1438 r->v.p.ptr = discldup(s1, s2, s3);
1439 } else {
1440 r->v.p.ptr = discldup(s1, s2, "");
1441 }
1442 } else {
1443 // auto-mode
1444 char *p = s1;
1445 while (is_wspace(*p)) {
1446 p++;
1447 }
1448 switch (*p) {
1449 case '\"':
1450 r->v.p.ptr = discldup(s1, "\"\"", "''");
1451 break;
1452 case '\'':
1453 r->v.p.ptr = discldup(s1, "''", "\"\"");
1454 break;
1455 case '(':
1456 r->v.p.ptr = discldup(s1, "()", "\"\"''");
1457 break;
1458 case '[':
1459 r->v.p.ptr = discldup(s1, "[]", "\"\"''");
1460 break;
1461 case '{':
1462 r->v.p.ptr = discldup(s1, "{}", "\"\"''");
1463 break;
1464 case '<':
1465 r->v.p.ptr = discldup(s1, "<>", "\"\"''");
1466 break;
1467 default:
1468 r->v.p.ptr = discldup(s1, "\"\"", "''");
1469 }
1470 }
1471 r->v.p.length = strlen(r->v.p.ptr) + 1;
1472 }
1473 break;
1474
1475 case kwRUNF:
1476 //
1477 // str <- RUN(command)
1478 // Win32: use & at the end of the command to run-it in background
1479 //
1480 par_getstr(&arg1);
1481 if (!prog_error && !dev_run(arg1.v.p.ptr, r, 1)) {
1482 rt_raise(ERR_RUNFUNC_FILE, arg1.v.p.ptr);
1483 }
1484 break;
1485
1486 case kwLEFT:
1487 //
1488 // str <- LEFT$ ( str [, int] )
1489 //
1490 count = 1;
1491 par_massget("Si", &s1, &count);
1492 if (!prog_error) {
1493 len = strlen(s1);
1494 if (count > len) {
1495 count = len;
1496 }
1497 if (count < 0) {
1498 count = 0;
1499 }
1500 r->v.p.ptr = malloc(count + 1);
1501 memcpy(r->v.p.ptr, s1, count);
1502 r->v.p.ptr[count] = '\0';
1503 r->v.p.length = count + 1;
1504 }
1505 break;
1506
1507 case kwLEFTOF:
1508 //
1509 // str <- LEFTOF$(str, strof)
1510 //
1511 par_massget("SS", &s1, &s2);
1512 if (!prog_error) {
1513 char *p = strstr(s1, s2);
1514 if (p != NULL) {
1515 char lc = *p;
1516 *p = '\0';
1517 int l = strlen(s1) + 1;
1518 r->v.p.ptr = malloc(l);
1519 strcpy(r->v.p.ptr, s1);
1520 r->v.p.length = l;
1521 *p = lc;
1522 } else {
1523 v_zerostr(r);
1524 }
1525 }
1526 break;
1527
1528 case kwRIGHT:
1529 //
1530 // str <- RIGHT$ ( str [, int] )
1531 //
1532 count = 1;
1533 par_massget("Si", &s1, &count);
1534 if (!prog_error) {
1535 len = strlen(s1);
1536 if (count > len) {
1537 count = len;
1538 }
1539 if (count < 0) {
1540 count = 0;
1541 }
1542 r->v.p.ptr = malloc(count + 1);
1543 memcpy(r->v.p.ptr, s1 + (len - count), count + 1);
1544 r->v.p.ptr[count] = '\0';
1545 r->v.p.length = count + 1;
1546 }
1547 break;
1548
1549 case kwRIGHTOF:
1550 //
1551 // str <- RIGHTOF$(str, strof)
1552 //
1553 par_massget("SS", &s1, &s2);
1554 if (!prog_error) {
1555 char *p = strstr(s1, s2);
1556 if (p != NULL) {
1557 p += strlen(s2);
1558 int l = strlen(p) + 1;
1559 r->v.p.ptr = malloc(l);
1560 memcpy(r->v.p.ptr, p, l);
1561 r->v.p.length = l;
1562 } else {
1563 v_zerostr(r);
1564 }
1565 }
1566 break;
1567
1568 case kwLEFTOFLAST:
1569 //
1570 // str <- LEFTOFLAST$(str, strof)
1571 //
1572 par_massget("SS", &s1, &s2);
1573 if (!prog_error) {
1574 char *lp = s1;
1575 int l2 = strlen(s2);
1576 char *p = NULL;
1577 while ((lp = strstr(lp, s2)) != NULL) {
1578 p = lp;
1579 lp += l2;
1580 };
1581
1582 if (p) {
1583 char lc = *p;
1584 *p = '\0';
1585 int l = strlen(s1) + 1;
1586 r->v.p.ptr = malloc(l);
1587 memcpy(r->v.p.ptr, s1, l);
1588 r->v.p.length = l;
1589 *p = lc;
1590 } else {
1591 v_zerostr(r);
1592 }
1593 }
1594 break;
1595
1596 case kwRIGHTOFLAST:
1597 //
1598 // str <- RIGHTOFLAST$(str, strof)
1599 //
1600 par_massget("SS", &s1, &s2);
1601 if (!prog_error) {
1602 char *lp = s1;
1603 int l2 = strlen(s2);
1604 char *p = NULL;
1605 while ((lp = strstr(lp, s2)) != NULL) {
1606 p = lp;
1607 lp += l2;
1608 };
1609
1610 if (p) {
1611 p += l2;
1612 int l = strlen(p) + 1;
1613 r->v.p.ptr = malloc(l);
1614 memcpy(r->v.p.ptr, p, l);
1615 r->v.p.length = l;
1616 } else {
1617 v_zerostr(r);
1618 }
1619 }
1620 break;
1621
1622 case kwREPLACE:
1623 //
1624 // str <- REPLACE$(source, pos, str [, len])
1625 //
1626 v_init(&arg2);
1627 var_p1 = par_next_str(&arg1, 1);
1628 start = par_next_int(1);
1629 var_p2 = par_next_str(&arg2, 0);
1630 count = par_getval(-1);
1631 if (!prog_error) {
1632 // write str into pos of source the return the new string
1633 int len_source = v_strlen(var_p1);
1634 int len_str;
1635 char *str;
1636 if (var_p2->type != V_STR) {
1637 str = v_str(var_p2);
1638 len_str = strlen(str);
1639 } else {
1640 str = NULL;
1641 len_str = v_strlen(var_p2);
1642 }
1643
1644 start--;
1645 if (start < 0) {
1646 start = 0;
1647 }
1648 if (start > len_source) {
1649 start = len_source;
1650 }
1651 if (count < 0) {
1652 // how much of "str" to retain
1653 count = len_str;
1654 }
1655
1656 // calculate the final length
1657 r->v.p.length = start + len_str + 1;
1658 if (start + count < len_source) {
1659 r->v.p.length += (len_source - (start + count));
1660 }
1661 r->v.p.ptr = malloc(r->v.p.length);
1662
1663 // copy the left side of "source"
1664 memcpy(r->v.p.ptr, var_p1->v.p.ptr, start);
1665
1666 // insert "str"
1667 r->v.p.ptr[start] = '\0';
1668
1669 if (str != NULL) {
1670 strcat(r->v.p.ptr, str);
1671 free(str);
1672 } else {
1673 strcat(r->v.p.ptr, var_p2->v.p.ptr);
1674 }
1675
1676 // add the remainder of "source" startin at index "count"
1677 if (start + count < len_source) {
1678 strcat(r->v.p.ptr, var_p1->v.p.ptr + start + count);
1679 }
1680 }
1681 v_free(&arg2);
1682 break;
1683
1684 case kwMID:
1685 //
1686 // str <- MID$ ( str, start [, len] )
1687 //
1688 var_p1 = par_next_str(&arg1, 1);
1689 start = par_next_int(0);
1690 len = par_getval(-1);
1691 if (!prog_error) {
1692 lsrc = v_strlen(var_p1);
1693 if (start <= 0 || start > lsrc) {
1694 len = 0;
1695 start = 0;
1696 } else {
1697 start--;
1698 if (len < 0 || len + start >= lsrc) {
1699 len = lsrc - start;
1700 }
1701 }
1702 r->v.p.ptr = malloc(len + 1);
1703 memcpy(r->v.p.ptr, var_p1->v.p.ptr + start, len);
1704 r->v.p.ptr[len] = '\0';
1705 r->v.p.length = len + 1;
1706 }
1707 break;
1708
1709 default:
1710 rt_raise("Unsupported built-in function call %ld", funcCode);
1711 }
1712
1713 v_free(&arg1);
1714 pfree3(s1, s2, s3);
1715}
1716
1717void cmd_is_var_type(byte type, var_t *arg1, var_t *r) {
1718 var_t *var_p;
1719 if (code_isvar()) {
1720 var_p = code_getvarptr();
1721 } else {
1722 eval(arg1);
1723 var_p = arg1;
1724 }
1725 if (!prog_error) {
1726 r->v.i = (var_p->type == type);
1727 }
1728}
1729
1730//
1731// int <- FUNC (...)
1732//
1733void cmd_intN(long funcCode, var_t *r) {
1734 char *s1 = NULL, *s2 = NULL, *s3 = NULL;
1735 var_int_t start;
1736
1737 var_t arg1;
1738 int l;
1739 var_t *var_p = NULL;
1740
1741 r->type = V_INT;
1742 v_init(&arg1);
1743 IF_ERR_RETURN;
1744
1745 switch (funcCode) {
1746 case kwINSTR:
1747 case kwRINSTR:
1748 //
1749 // int <- INSTR ( [start,] str1, str2 )
1750 // int <- RINSTR ( [start,] str1, str2 )
1751 //
1752 r->v.i = 0;
1753 start = 1;
1754 if (par_massget("iSS", &start, &s1, &s2) > 1 &&
1755 !prog_error && s1[0] != '\0' && s2[0] != '\0') {
1756 start--;
1757 int s1_len = strlen(s1);
1758 if (start >= s1_len) {
1759 start = s1_len;
1760 }
1761 if (start < 0) {
1762 start = 0;
1763 }
1764 char *p = s1 + start;
1765 l = strlen(s2);
1766 while (*p) {
1767 if (strncmp(p, s2, l) == 0) {
1768 r->v.i = (p - s1) + 1;
1769 if (funcCode == kwINSTR) {
1770 break;
1771 }
1772 }
1773 p++;
1774 }
1775 }
1776 break;
1777 case kwISARRAY:
1778 cmd_is_var_type(V_ARRAY, &arg1, r);
1779 break;
1780 case kwISMAP:
1781 cmd_is_var_type(V_MAP, &arg1, r);
1782 break;
1783 case kwISSTRING:
1784 //
1785 // bool <- ISSTRING(v)
1786 //
1787 case kwISNUMBER:
1788 //
1789 // bool <- ISNUMBER(v)
1790 //
1791 if (code_isvar()) {
1792 var_p = code_getvarptr();
1793 } else {
1794 eval(&arg1);
1795 var_p = &arg1;
1796 }
1797
1798 r->v.i = 0;
1799
1800 if (!prog_error) {
1801 if (var_p->type == V_STR) {
1802 char buf[BUF_LEN], *np;
1803 int type;
1804 var_int_t lv = 0;
1805 var_num_t dv = 0;
1806
1807 np = get_numexpr(var_p->v.p.ptr, buf, &type, &lv, &dv);
1808
1809 if (type == 1 && *np == '\0') {
1810 r->v.i = (funcCode == kwISSTRING) ? 0 : 1;
1811 } else if (type == 2 && *np == '\0') {
1812 r->v.i = (funcCode == kwISSTRING) ? 0 : 1;
1813 } else {
1814 r->v.i = (funcCode == kwISSTRING) ? 1 : 0;
1815 }
1816 } else {
1817 if (var_p->type == V_NUM || var_p->type == V_INT) {
1818 r->v.i = (funcCode == kwISSTRING) ? 0 : 1;
1819 }
1820 }
1821 }
1822
1823 break;
1824 case kwLEN:
1825 //
1826 // int <- LEN(v)
1827 //
1828 if (code_isvar()) {
1829 var_p = code_getvarptr();
1830 } else {
1831 eval(&arg1);
1832 var_p = &arg1;
1833 }
1834
1835 if (!prog_error) {
1836 r->v.i = v_length(var_p);
1837 } else {
1838 r->v.i = 1;
1839 }
1840 break;
1841
1842 case kwEMPTY:
1843 //
1844 // bool <- EMPTY(x)
1845 //
1846 if (code_isvar()) {
1847 var_p = code_getvarptr();
1848 } else {
1849 eval(&arg1);
1850 var_p = &arg1;
1851 }
1852
1853 if (!prog_error) {
1854 r->v.i = v_isempty(var_p);
1855 } else {
1856 r->v.i = 1;
1857 }
1858 break;
1859 case kwLBOUND:
1860 //
1861 // int <- LBOUND(array [, dim])
1862 //
1863 if (code_peek() == kwTYPE_VAR) {
1864 var_p = code_getvarptr();
1865 if (!prog_error && var_p->type == V_ARRAY) {
1866 l = 1;
1867 if (code_peek() == kwTYPE_SEP) {
1868 par_getcomma();
1869 if (!prog_error) {
1870 eval(&arg1);
1871 if (!prog_error) {
1872 l = v_getint(&arg1);
1873 }
1874 v_free(&arg1);
1875 }
1876 }
1877
1878 if (!prog_error) {
1879 l--;
1880 if (l >= 0 && l < v_maxdim(var_p)) {
1881 r->v.i = v_lbound(var_p, l);
1882 } else {
1883 rt_raise(ERR_BOUND_DIM, v_maxdim(var_p), l);
1884 }
1885 }
1886 } else {
1887 rt_raise(ERR_BOUND_VAR);
1888 }
1889 } else {
1890 err_typemismatch();
1891 }
1892 break;
1893
1894 case kwUBOUND:
1895 //
1896 // int <- UBOUND(array [, dim])
1897 //
1898 if (code_peek() == kwTYPE_VAR) {
1899 var_p = code_getvarptr();
1900 if (!prog_error && var_p->type == V_ARRAY) {
1901 l = 1;
1902 if (code_peek() == kwTYPE_SEP) {
1903 par_getcomma();
1904 if (!prog_error) {
1905 eval(&arg1);
1906 if (!prog_error) {
1907 l = v_getint(&arg1);
1908 }
1909 v_free(&arg1);
1910 }
1911 }
1912
1913 if (!prog_error) {
1914 l--;
1915 if (l >= 0 && l < v_maxdim(var_p)) {
1916 r->v.i = v_ubound(var_p, l);
1917 } else {
1918 rt_raise(ERR_BOUND_DIM, v_maxdim(var_p));
1919 }
1920 }
1921 } else {
1922 rt_raise(ERR_BOUND_VAR);
1923 }
1924 } else {
1925 err_typemismatch();
1926 }
1927 break;
1928
1929 // i <- RGB(r,g,b)
1930 // i <- RGBF(r,g,b)
1931 case kwRGB:
1932 case kwRGBF: {
1933 var_num_t rc, gc, bc;
1934 int code;
1935
1936 par_massget("FFF", &rc, &gc, &bc);
1937 IF_ERR_RETURN;
1938 code = 0;
1939 if (funcCode == kwRGBF) {
1940 if ((rc >= 0 && rc <= 1) && (gc >= 0 && gc <= 1) && (bc >= 0 && bc <= 1)) {
1941 code = 1;
1942 }
1943 } else {
1944 if ((rc >= 0 && rc <= 255) && (gc >= 0 && gc <= 255) && (bc >= 0 && bc <= 255)) {
1945 code = 2;
1946 }
1947 }
1948
1949 switch (code) {
1950 case 1:
1951 r->v.i = (r2int(rc * 255.0, 0, 255) << 16) | (r2int(gc * 255.0, 0, 255) << 8)
1952 | r2int(bc * 255.0, 0, 255);
1953 break;
1954 case 2:
1955 r->v.i = ((uint32_t) rc << 16) | ((uint32_t) gc << 8) | (uint32_t) bc;
1956 break;
1957 default:
1958 err_argerr();
1959 }
1960
1961 r->v.i = -r->v.i;
1962 }
1963 break;
1964
1965 default:
1966 rt_raise("Unsupported built-in function call %ld", funcCode);
1967 }
1968
1969 v_free(&arg1);
1970 pfree3(s1, s2, s3);
1971}
1972
1973/*
1974 * fp <- FUNC (...)
1975 */
1976void cmd_numN(long funcCode, var_t *r) {
1977 var_num_t x, y, m;
1978
1979 r->type = V_NUM;
1980
1981 IF_ERR_RETURN;
1982 switch (funcCode) {
1983 case kwATAN2:
1984 // fp <- ATAN2(x,y)
1985 x = par_getnum();
1986 if (!prog_error) {
1987 par_getcomma();
1988 if (!prog_error) {
1989 y = par_getnum();
1990 r->v.n = atan2(x, y);
1991 }
1992 }
1993 break;
1994
1995 case kwPOW:
1996 // fp <- POW(x,y)
1997 x = par_getnum();
1998 if (!prog_error) {
1999 par_getcomma();
2000 if (!prog_error) {
2001 y = par_getnum();
2002 r->v.n = pow(x, y);
2003 }
2004 }
2005 break;
2006
2007 case kwROUND:
2008 // fp <- ROUND(x [,decs])
2009 x = par_getnum();
2010 if (!prog_error) {
2011 int pw;
2012 if (code_peek() == kwTYPE_SEP) {
2013 par_getcomma();
2014 if (!prog_error) {
2015 pw = par_getint();
2016 }
2017 } else {
2018 pw = 0;
2019 }
2020 if (!prog_error) {
2021 // round
2022 m = floor(pow(10.0, pw));
2023 if (SGN(x) < 0.0) {
2024 r->v.n = -floor((-x * m) + .5) / m;
2025 } else {
2026 r->v.n = floor((x * m) + .5) / m;
2027 }
2028 }
2029 }
2030 break;
2031 default:
2032 rt_raise("Unsupported built-in function call %ld", funcCode);
2033 }
2034}
2035
2036/*
2037 * any <- FUNC (...)
2038 */
2039void cmd_genfunc(long funcCode, var_t *r) {
2040 byte code, ready, first;
2041 int count, tcount, handle, len;
2042 bcip_t ofs;
2043 var_t arg, arg2;
2044 var_num_t *dar;
2045
2046 IF_ERR_RETURN;
2047 v_init(r);
2048
2049 switch (funcCode) {
2050 //
2051 // val = IF(cond,true,false)
2052 //
2053 case kwIFF:
2054 v_init(&arg);
2055 eval(&arg); // condition
2056 if (!prog_error) {
2057 par_getcomma();
2058 IF_ERR_RETURN;
2059 int ch = v_is_nonzero(&arg);
2060 v_free(&arg);
2061
2062 if (ch) {
2063 eval(&arg); // true-value
2064 if (!prog_error) {
2065 v_set(r, &arg); // set the true value
2066 v_free(&arg);
2067 }
2068 } else {
2069 par_skip();
2070 }
2071 IF_ERR_RETURN;
2072 par_getcomma();
2073 IF_ERR_RETURN;
2074 if (!ch) {
2075 eval(&arg); // false-value (there is no jump-optimization,
2076 // so we must
2077 // execute that)
2078 if (!prog_error) {
2079 v_set(r, &arg); // set the false value
2080 v_free(&arg);
2081 }
2082 } else {
2083 par_skip();
2084 }
2085 }
2086 break;
2087 //
2088 // str = FORMAT$(fmt, n | s, ...)
2089 //
2090 case kwFORMAT:
2091 v_init(&arg);
2092 eval(&arg);
2093 if (!prog_error) {
2094 par_getcomma();
2095 IF_ERR_RETURN;
2096 if (arg.type != V_STR) {
2097 rt_raise(ERR_FORMAT_INVALID_FORMAT);
2098 v_free(&arg);
2099 } else {
2100 char *buf = NULL;
2101 v_init(&arg2);
2102 eval(&arg2);
2103 if (!prog_error) {
2104 switch (arg2.type) {
2105 case V_STR:
2106 buf = format_str(arg.v.p.ptr, arg2.v.p.ptr);
2107 v_setstr(r, buf);
2108 break;
2109 case V_INT:
2110 buf = format_num(arg.v.p.ptr, arg2.v.i);
2111 v_setstr(r, buf);
2112 break;
2113 case V_NUM:
2114 buf = format_num(arg.v.p.ptr, arg2.v.n);
2115 v_setstr(r, buf);
2116 break;
2117 default:
2118 err_typemismatch();
2119 }
2120 }
2121
2122 v_free(&arg);
2123 v_free(&arg2);
2124 free(buf);
2125 } // arg.type = V_STR
2126 } // !prog_error
2127 break;
2128 //
2129 // int <- JULIAN(y, m, d) || JULIAN("[d]d/[m]m/[yy]yy")
2130 //
2131 case kwJULIAN: {
2132 long d, m, y;
2133
2134 r->type = V_INT;
2135
2136 v_init(&arg);
2137 eval(&arg);
2138 IF_ERR_RETURN;
2139
2140 if (arg.type == V_STR) {
2141 date_str2dmy(arg.v.p.ptr, &d, &m, &y);
2142 v_free(&arg);
2143 } else {
2144 d = v_igetval(&arg);
2145 v_free(&arg);
2146 par_getcomma();
2147 IF_ERR_RETURN;
2148
2149 m = par_getint();
2150 IF_ERR_RETURN;
2151
2152 par_getcomma();
2153 IF_ERR_RETURN;
2154
2155 y = par_getint();
2156 IF_ERR_RETURN;
2157 }
2158
2159 r->v.i = date_julian(d, m, y);
2160 }
2161 break;
2162
2163 //
2164 // str <- DATEFMT(format, date$ || julian || d [, m, y])
2165 //
2166
2167 //
2168 // int <- WEEKDAY(date$ | d,m,y | julian)
2169 //
2170 case kwDATEFMT:
2171 case kwWDAY: {
2172 long d, m, y;
2173
2174 r->type = V_INT;
2175 r->v.i = 0;
2176
2177 if (funcCode == kwDATEFMT) { // format
2178 v_init(&arg);
2179 eval(&arg);
2180 IF_ERR_RETURN;
2181
2182 par_getcomma();
2183 IF_ERR_RETURN;
2184 }
2185
2186 v_init(&arg2);
2187 eval(&arg2);
2188 if (arg2.type == V_STR) {
2189 date_str2dmy(arg2.v.p.ptr, &d, &m, &y);
2190 v_free(&arg2);
2191 } else {
2192 d = v_igetval(&arg2);
2193 v_free(&arg2);
2194 if (code_peek() == kwTYPE_SEP) {
2195 par_getcomma();
2196 if (prog_error) {
2197 v_free(&arg);
2198 return;
2199 }
2200 m = par_getint();
2201 if (prog_error) {
2202 v_free(&arg);
2203 return;
2204 }
2205 par_getcomma();
2206 if (prog_error) {
2207 v_free(&arg);
2208 return;
2209 }
2210 y = par_getint();
2211 if (prog_error) {
2212 v_free(&arg);
2213 return;
2214 }
2215 } else {
2216 // julian
2217 date_jul2dmy(d, &d, &m, &y);
2218 }
2219 }
2220
2221 if (funcCode == kwDATEFMT) {
2222 // format
2223 v_move_str(r, date_fmt(arg.v.p.ptr, d, m, y));
2224 v_free(&arg);
2225 } else {
2226 // weekday
2227 r->v.i = date_weekday(d, m, y);
2228 }
2229 }
2230 break;
2231
2232 //
2233 // STR <- INPUT$(len [, file])
2234 //
2235 case kwINPUTF:
2236 count = par_getint();
2237 IF_ERR_RETURN;
2238 if (code_peek() == kwTYPE_SEP) {
2239 par_getcomma();
2240 IF_ERR_RETURN;
2241
2242 handle = par_getint();
2243 IF_ERR_RETURN;
2244 } else {
2245 handle = -1;
2246 }
2247 if (handle == -1) {
2248 // keyboard
2249 r->type = V_STR;
2250 r->v.p.ptr = malloc((count << 1) + 1);
2251 r->v.p.ptr[0] = '\0';
2252 r->v.p.owner = 1;
2253 len = 0;
2254 char tmp[3];
2255 for (int i = 0; i < count; i++) {
2256 int ch = dev_getch();
2257 // MultiByte - dev_getchr() must return the extended
2258 // code (2 bytes char)
2259 if (ch == 0xFFFF || prog_error) {
2260 break;
2261 }
2262 if ((ch & 0xFF00) == 0xFF00) { // extra code - hardware keys
2263 tmp[0] = '\033';
2264 tmp[1] = ch & 0xFF;
2265 tmp[2] = '\0';
2266 len += 2;
2267 } else if (ch & 0xFF00) { // multibyte languages
2268 tmp[0] = ch >> 8;
2269 tmp[1] = ch & 0xFF;
2270 tmp[2] = '\0';
2271 len += 2;
2272 } else { // simple 8-bit character
2273 tmp[0] = ch;
2274 tmp[1] = '\0';
2275 len++;
2276 }
2277
2278 strcat(r->v.p.ptr, tmp);
2279 }
2280
2281 r->v.p.length = len + 1;
2282 r->v.p.ptr[len] = '\0';
2283 } else {
2284 // file
2285 v_init_str(r, count);
2286 dev_fread(handle, (byte *)r->v.p.ptr, count);
2287 r->v.p.ptr[count] = '\0';
2288 }
2289
2290 break;
2291 //
2292 // INT <- BGETC(file)
2293 //
2294 case kwBGETC:
2295 handle = par_getint();
2296 IF_ERR_RETURN;
2297
2298 // file
2299 dev_fread(handle, &code, 1);
2300 r->type = V_INT;
2301 r->v.i = (int) code;
2302 break;
2303 //
2304 // n<-POLYAREA(poly)
2305 //
2306 case kwPOLYAREA: {
2307 int count;
2308 pt_t *poly = NULL;
2309
2310 r->type = V_NUM;
2311
2312 count = par_getpoly(&poly);
2313 IF_ERR_RETURN;
2314
2315 r->v.n = 0.0;
2316 for (int i = 0; i < count - 1; i++) {
2317 r->v.n = r->v.n + (poly[i].x - poly[i + 1].x) * (poly[i].y + poly[i + 1].y);
2318 }
2319
2320 // hmm.... closed ?
2321 free(poly);
2322 }
2323 break;
2324
2325 //
2326 // [x,y]<-POLYCENT(poly)
2327 //
2328 case kwPOLYCENT: {
2329 pt_t *poly = NULL;
2330 int err, count;
2331 var_num_t x, y, area;
2332
2333 r->type = V_NUM;
2334
2335 count = par_getpoly(&poly);
2336 IF_ERR_RETURN;
2337
2338 err = geo_polycentroid(poly, count, &x, &y, &area);
2339 v_toarray1(r, 2);
2340 v_setreal(v_elem(r, 0), x);
2341 v_setreal(v_elem(r, 1), y);
2342 if (err == 2 && area == 0) {
2343 rt_raise(ERR_CENTROID);
2344 } else {
2345 rt_raise(ERR_WRONG_POLY);
2346 }
2347
2348 // hmm.... closed ?
2349 free(poly);
2350 }
2351 break;
2352
2353 //
2354 // CX <- POINT(0)
2355 // CY <- POINT(1)
2356 // color <- POINT(x,y)
2357 //
2358 case kwPOINT: {
2359 int x = -1, y = -1;
2360 int y_set = 0;
2361 if (code_isvar()) {
2362 var_t *v = code_getvarptr();
2363 if (v->type == V_ARRAY) {
2364 if (v_asize(v) != 2) {
2365 err_argerr();
2366 } else {
2367 x = v_getint(v_elem(v, 0));
2368 y = v_getint(v_elem(v, 1));
2369 y_set = 1;
2370 }
2371 } else {
2372 x = v_getint(v);
2373 if (code_peek() == kwTYPE_SEP) {
2374 par_getcomma();
2375 IF_ERR_RETURN;
2376 y = par_getint();
2377 y_set = 1;
2378 IF_ERR_RETURN;
2379 }
2380 }
2381 } else {
2382 x = par_getint();
2383 IF_ERR_RETURN;
2384 if (code_peek() == kwTYPE_SEP) {
2385 par_getcomma();
2386 IF_ERR_RETURN;
2387 y = par_getint();
2388 y_set = 1;
2389 IF_ERR_RETURN;
2390 }
2391 }
2392
2393 r->type = V_INT;
2394 r->v.i = 0;
2395 IF_ERR_RETURN;
2396
2397 if (y_set == 0) {
2398 switch (x) {
2399 case 0:
2400 r->v.i = gra_x;
2401 break;
2402 case 1:
2403 r->v.i = gra_y;
2404 break;
2405 default:
2406 rt_raise(ERR_POINT);
2407 }
2408 } else {
2409 r->v.i = dev_getpixel(x, y);
2410 }
2411 }
2412 break;
2413 //
2414 // ? <- SEGLEN(Ax,Ay,Bx,By)
2415 //
2416 case kwSEGLEN: {
2417 pt_t A, B;
2418 var_num_t dx, dy;
2419
2420 A = par_getpt();
2421 IF_ERR_RETURN;
2422
2423 par_getcomma();
2424 IF_ERR_RETURN;
2425
2426 B = par_getpt();
2427 IF_ERR_RETURN;
2428
2429 dx = B.x - A.x;
2430 dy = B.y - A.y;
2431
2432 r->type = V_NUM;
2433 r->v.n = sqrt(dx * dx + dy * dy);
2434 }
2435 break;
2436 //
2437 // ? <- PTSIGN(Ax,Ay,Bx,By,Qx,Qy)
2438 //
2439 case kwPTSIGN: {
2440 pt_t A, B, Q;
2441
2442 A = par_getpt();
2443 IF_ERR_RETURN;
2444
2445 par_getcomma();
2446 IF_ERR_RETURN;
2447
2448 B = par_getpt();
2449 IF_ERR_RETURN;
2450
2451 par_getcomma();
2452 IF_ERR_RETURN;
2453
2454 Q = par_getpt();
2455 IF_ERR_RETURN;
2456
2457 r->type = V_INT;
2458 r->v.i = PTSIGN(A.x, A.y, B.x, B.y, Q.x, Q.y);
2459 }
2460 break;
2461 //
2462 // ? <- PTDISTSEG(Bx,By,Cx,Cy,Ax,Ay)
2463 // ? <- PTDISTLN(Bx,By,Cx,Cy,Ax,Ay)
2464 //
2465 case kwPTDISTSEG:
2466 case kwPTDISTLN: {
2467 pt_t A, B, C;
2468
2469 B = par_getpt();
2470 IF_ERR_RETURN;
2471
2472 par_getcomma();
2473 IF_ERR_RETURN;
2474
2475 C = par_getpt();
2476 IF_ERR_RETURN;
2477
2478 par_getcomma();
2479 IF_ERR_RETURN;
2480
2481 A = par_getpt();
2482 IF_ERR_RETURN;
2483
2484 r->type = V_NUM;
2485
2486 if (funcCode == kwPTDISTLN) {
2487 r->v.n = geo_distfromline(B.x, B.y, C.x, C.y, A.x, A.y);
2488 } else {
2489 r->v.n = geo_distfromseg(B.x, B.y, C.x, C.y, A.x, A.y);
2490 }
2491 }
2492 break;
2493 //
2494 // ? <- SEGCOS(Ax,Ay,Bx,By,Cx,Cy,Dx,Dy)
2495 // ? <- SEGSIN(Ax,Ay,Bx,By,Cx,Cy,Dx,Dy)
2496 //
2497 case kwSEGCOS:
2498 case kwSEGSIN: {
2499 var_num_t Adx, Ady, Bdx, Bdy;
2500 pt_t A, B;
2501
2502 A = par_getpt();
2503 IF_ERR_RETURN;
2504
2505 par_getcomma();
2506 IF_ERR_RETURN;
2507
2508 B = par_getpt();
2509 IF_ERR_RETURN;
2510
2511 par_getcomma();
2512 IF_ERR_RETURN;
2513
2514 Adx = B.x - A.x;
2515 Ady = B.y - A.y;
2516
2517 A = par_getpt();
2518 IF_ERR_RETURN;
2519
2520 par_getcomma();
2521 IF_ERR_RETURN;
2522
2523 B = par_getpt();
2524 IF_ERR_RETURN;
2525
2526 Bdx = B.x - A.x;
2527 Bdy = B.y - A.y;
2528
2529 r->type = V_NUM;
2530 r->v.n = geo_segangle(funcCode, Adx, Ady, Bdx, Bdy);
2531 }
2532 break;
2533 //
2534 // ? <- MAX/MIN(...)
2535 //
2536 case kwMAX:
2537 case kwMIN:
2538 case kwABSMAX:
2539 case kwABSMIN:
2540 case kwSUM:
2541 case kwSUMSV:
2542 case kwSTATMEAN:
2543 ready = 0;
2544 first = 1;
2545 tcount = 0;
2546 r->type = V_NUM;
2547
2548 do {
2549 code = code_peek();
2550 switch (code) {
2551 case kwTYPE_SEP:
2552 code_skipsep();
2553 break;
2554 case kwTYPE_LEVEL_END:
2555 case kwTYPE_EOC:
2556 ready = 1;
2557 break;
2558 case kwTYPE_VAR:
2559 ofs = prog_ip;
2560 if (code_isvar()) {
2561 var_t *basevar_p = code_getvarptr();
2562 if (!prog_error && basevar_p->type == V_ARRAY) {
2563 count = v_asize(basevar_p);
2564 for (int i = 0; i < count; i++) {
2565 var_t *elem_p = v_elem(basevar_p, i);
2566 if (!prog_error) {
2567 if (first) {
2568 dar_first(funcCode, r, elem_p);
2569 first = 0;
2570 } else {
2571 dar_next(funcCode, r, elem_p);
2572 }
2573 tcount++;
2574 } else {
2575 return;
2576 }
2577 }
2578 break;
2579 }
2580 }
2581 prog_ip = ofs;
2582 // no 'break' here
2583 default:
2584 // default --- expression
2585 v_init(&arg);
2586 eval(&arg);
2587 if (!prog_error) {
2588 if (first) {
2589 dar_first(funcCode, r, &arg);
2590 first = 0;
2591 } else {
2592 dar_next(funcCode, r, &arg);
2593 }
2594 tcount++;
2595 } else {
2596 return;
2597 }
2598 v_free(&arg);
2599 }
2600 } while (!ready);
2601
2602 // final
2603 if (!prog_error) {
2604 dar_final(funcCode, r, tcount);
2605 }
2606 break;
2607 //
2608 //
2609 //
2610 case kwSTATMEANDEV:
2611 case kwSTATSPREADS:
2612 case kwSTATSPREADP:
2613 ready = 0;
2614 tcount = 0;
2615 len = BUF_LEN;
2616 dar = (var_num_t*) malloc(sizeof(var_num_t) * len);
2617
2618 do {
2619 code = code_peek();
2620 switch (code) {
2621 case kwTYPE_SEP:
2622 code_skipsep();
2623 break;
2624 case kwTYPE_LEVEL_END:
2625 case kwTYPE_EOC:
2626 ready = 1;
2627 break;
2628 case kwTYPE_VAR:
2629 ofs = prog_ip;
2630 if (code_isvar()) {
2631 var_t *basevar_p = code_getvarptr();
2632 if (!prog_error && basevar_p->type == V_ARRAY) {
2633 count = v_asize(basevar_p);
2634 for (int i = 0; i < count; i++) {
2635 var_t *elem_p = v_elem(basevar_p, i);
2636 if (!prog_error) {
2637 if (tcount >= len) {
2638 len += BUF_LEN;
2639 dar = (var_num_t*) realloc(dar, sizeof(var_num_t) * len);
2640 }
2641 dar[tcount] = v_getval(elem_p);
2642 tcount++;
2643 } else {
2644 free(dar);
2645 return;
2646 }
2647 }
2648 break;
2649 }
2650 }
2651 prog_ip = ofs;
2652 // no 'break' here
2653 default:
2654 // default --- expression
2655 v_init(&arg);
2656 eval(&arg);
2657 if (!prog_error) {
2658 if (tcount >= len) {
2659 len += BUF_LEN;
2660 dar = (var_num_t*) realloc(dar, sizeof(var_num_t) * len);
2661 }
2662
2663 dar[tcount] = v_getval(&arg);
2664 tcount++;
2665 } else {
2666 free(dar);
2667 return;
2668 }
2669 v_free(&arg);
2670 }
2671 } while (!ready);
2672
2673 // final
2674 if (!prog_error) {
2675 r->type = V_NUM;
2676 switch (funcCode) {
2677 case kwSTATMEANDEV:
2678 r->v.n = statmeandev(dar, tcount);
2679 break;
2680 case kwSTATSPREADS:
2681 r->v.n = statspreads(dar, tcount);
2682 break;
2683 case kwSTATSPREADP:
2684 r->v.n = statspreadp(dar, tcount);
2685 break;
2686 }
2687 free(dar);
2688 }
2689
2690 break;
2691 //
2692 // X <- LINEQGJ(A, B [, toler])
2693 // linear eq solve
2694 //
2695 case kwGAUSSJORDAN: {
2696 var_num_t toler = 0.0;
2697 var_num_t *m1;
2698 int32_t rows, cols;
2699
2700 v_init(r);
2701 var_t *a = par_getvarray();
2702 IF_ERR_RETURN;
2703 m1 = mat_toc(a, &rows, &cols);
2704 if (rows != cols || cols < 2) {
2705 if (m1) {
2706 free(m1);
2707 }
2708 rt_raise(ERR_LINEEQN_ADIM, rows, cols);
2709 } else {
2710 int32_t n = rows;
2711 par_getcomma();
2712 if (prog_error) {
2713 if (m1) {
2714 free(m1);
2715 }
2716 return;
2717 }
2718
2719 var_t *b = par_getvarray();
2720 if (prog_error) {
2721 if (m1) {
2722 free(m1);
2723 }
2724 return;
2725 }
2726 var_num_t *m2 = mat_toc(b, &rows, &cols);
2727 if (rows != n || cols != 1) {
2728 if (m1) {
2729 free(m1);
2730 }
2731 if (m2) {
2732 free(m2);
2733 }
2734 rt_raise(ERR_LINEEQN_BDIM, rows, cols);
2735 return;
2736 }
2737
2738 if (code_peek() == kwTYPE_SEP) {
2739 code_skipsep();
2740 toler = par_getnum();
2741 }
2742
2743 if (!prog_error) {
2744 mat_gauss_jordan(m1, m2, n, toler);
2745 mat_tov(r, m2, n, 1, 1);
2746 }
2747
2748 if (m1) {
2749 free(m1);
2750 }
2751 if (m2) {
2752 free(m2);
2753 }
2754 }
2755 }
2756 break;
2757 //
2758 // array <- INVERSE(A)
2759 //
2760 case kwINVERSE: {
2761 int32_t rows, cols;
2762
2763 v_init(r);
2764 var_t *a = par_getvarray();
2765 IF_ERR_RETURN;
2766
2767 var_num_t *m1 = mat_toc(a, &rows, &cols);
2768 if (rows != cols || cols < 2) {
2769 if (m1) {
2770 free(m1);
2771 }
2772 rt_raise(ERR_WRONG_MAT, rows, cols);
2773 } else {
2774 int32_t n = rows;
2775 mat_inverse(m1, n);
2776 mat_tov(r, m1, n, n, 1);
2777 free(m1);
2778 }
2779 }
2780 break;
2781 //
2782 // n <- DETERM(A)
2783 //
2784 case kwDETERM: {
2785 var_num_t *m1 = NULL, toler = 0;
2786 int32_t rows, cols;
2787
2788 v_init(r);
2789 var_t *a = par_getvarray();
2790 IF_ERR_RETURN;
2791
2792 if (code_peek() == kwTYPE_SEP) {
2793 code_skipsep();
2794 toler = par_getnum();
2795 }
2796
2797 m1 = mat_toc(a, &rows, &cols);
2798 if (rows != cols || cols < 2) {
2799 if (m1) {
2800 free(m1);
2801 }
2802 rt_raise(ERR_WRONG_MAT, rows, cols);
2803 } else {
2804 int32_t n = rows;
2805 r->type = V_NUM;
2806 r->v.n = mat_determ(m1, n, toler);
2807 free(m1);
2808 }
2809 }
2810 break;
2811
2812 case kwCODEARRAY:
2813 map_from_codearray(r);
2814 break;
2815
2816 //
2817 // array <- FILES([wildcards])
2818 //
2819 case kwFILES: {
2820 int count;
2821 var_t arg;
2822 char *wc = NULL;
2823
2824 v_init(&arg);
2825 if (code_peek() != kwTYPE_LEVEL_END) {
2826 par_getstr(&arg);
2827 wc = arg.v.p.ptr;
2828 }
2829
2830 if (!prog_error) {
2831 // get the files
2832 char_p_t *list = dev_create_file_list(wc, &count);
2833
2834 // create the array
2835 if (count && list != NULL) {
2836 v_toarray1(r, count);
2837
2838 // add the entries
2839 for (int i = 0; i < count; i++) {
2840 var_t *elem_p = v_elem(r, i);
2841 v_init_str(elem_p, strlen(list[i]));
2842 strcpy(elem_p->v.p.ptr, list[i]);
2843 }
2844 } else {
2845 v_toarray1(r, 0);
2846 }
2847 // cleanup
2848 if (list) {
2849 dev_destroy_file_list(list, count);
2850 }
2851 v_free(&arg);
2852 }
2853 }
2854
2855 break;
2856 //
2857 // array <- SEQ(min, max, count)
2858 //
2859 case kwSEQ: {
2860 var_int_t count;
2861 var_num_t xmin, xmax;
2862 par_massget("FFI", &xmin, &xmax, &count);
2863 if (!prog_error) {
2864 // create the array
2865 if (count > 1) {
2866 v_toarray1(r, count);
2867 var_num_t dx = (xmax - xmin) / (count - 1);
2868 var_num_t x = xmin;
2869
2870 // add the entries
2871 for (int i = 0; i < count; i++, x += dx) {
2872 var_t *elem_p = v_elem(r, i);
2873 elem_p->type = V_NUM;
2874 elem_p->v.n = x;
2875 }
2876 } else {
2877 v_toarray1(r, 0);
2878 }
2879 } else {
2880 v_toarray1(r, 0);
2881 }
2882 }
2883 break;
2884
2885 case kwIMAGE:
2886 v_create_image(r);
2887 break;
2888
2889 case kwFORM:
2890 v_create_form(r);
2891 break;
2892
2893 case kwWINDOW:
2894 v_create_window(r);
2895 break;
2896
2897 default:
2898 rt_raise("Unsupported built-in function call %ld", funcCode);
2899 };
2900}
2901