1 /*
2
3 YABASIC --- a simple Basic Interpreter
4 written by Marc Ihm 1995-2021
5 more info at www.yabasic.de
6
7 function.c -- code for functions
8
9 This file is part of yabasic and may be copied under the terms of
10 MIT License which can be found in the file LICENSE.
11
12 */
13
14
15 /* ------------- includes ---------------- */
16
17 #ifndef YABASIC_INCLUDED
18 #include "yabasic.h" /* all prototypes and structures */
19 #endif
20
21
22 /* ------------- external references ---------------- */
23
24 extern int mylineno; /* current line number */
25 extern int yyparse (); /* call bison parser */
26
27
28 /* ------------- local functions ---------------- */
29
30 static char *fromto (char *, int, int); /* get portion of string (mid$ et al) */
31 static void clear_buff (); /* clear system-input buffers */
32 static void store_buff (char *, int); /* store system-input buffer */
33 static int do_glob (char *, char *); /* actually do the globbing */
34 static double other2dec (char *, int); /* convert hex to decimal */
35 static char *dec2other (double, int); /* convert decimal to hex */
36 static double peek (char *); /* peek into internals */
37 static char *peek2 (char *, struct command *); /* peek into internals */
38 static char *peek3 (char *, char *); /* peek into internals */
39 static int peekfile (int); /* read a byte from stream */
40 static int do_system (char *); /* hand over execution of command to system, return exit code */
41 static char *do_system2 (char *); /* hand over execution of command to system, return output as string */
42 static double myrand (); /* generate random number in given range */
43
44 /* ------------- global variables ---------------- */
45
46 struct command *lastdata = NULL; /* used to associate all data-commands with each others */
47 static struct buff_chain *buffroot; /* start of sys-input buffer */
48 static struct buff_chain **buffcurr; /* current entry in buff_chain */
49 static int buffcount; /* number of filled buffers */
50 char *last_inkey; /* last result of inkey$ */
51
52 /* ------------- subroutines ---------------- */
53
54
55 void
token(struct command * cmd)56 token (struct command *cmd) /* extract token from variable */
57 {
58 int split;
59 struct stackentry *s;
60 struct symbol *sym;
61 struct array *ar;
62 int num = 0, i;
63 char *p, *q;
64 char **pp;
65 char *del, *line;
66 int wasdel, isdel;
67
68
69 if (cmd->type == cSPLIT2 || cmd->type == cTOKEN2) {
70 del = pop (stSTRING)->pointer;
71 } else {
72 del = " \t";
73 }
74 split = (cmd->type == cSPLIT || cmd->type == cSPLIT2);
75 s = pop (stSTRINGARRAYREF);
76 line = pop (stSTRING)->pointer;
77 sym = get_sym (s->pointer, syARRAY, amSEARCH);
78 if (!sym || !sym->pointer) {
79 sprintf (string, "array '%s()' is not defined", strip (s->pointer));
80 error (sERROR, string);
81 goto token_done;
82 }
83 ar = sym->pointer;
84 if (ar->dimension > 1) {
85 error (sERROR, "only one dimensional arrays allowed");
86 goto token_done;
87 }
88
89 /* count number of tokens */
90 isdel = TRUE;
91 if (split && *line) {
92 num = 1;
93 } else {
94 num = 0;
95 }
96 for (p = line; *p; ++p) {
97 wasdel = isdel;
98 isdel = (strchr (del, *p) != NULL);
99 if (split) {
100 if (isdel) {
101 num++;
102 }
103 } else {
104 if (isdel && isdel != wasdel) {
105 num++;
106 }
107 }
108 }
109 if (!split && !isdel) {
110 num++;
111 }
112
113 /* free previous array content */
114 for (i = 0; i < ar->bounds[0]; i++) {
115 free (((char **) ar->pointer)[i]);
116 }
117 free (ar->pointer);
118 ar->pointer = my_malloc ((num + 1) * sizeof (char *));
119 pp = ar->pointer;
120 pp[0] = my_strdup ("");
121
122 /* extract tokens */
123 i = 1;
124 isdel = TRUE;
125 if (*line) {
126 for (p = q = line;; p++) {
127 wasdel = isdel;
128 isdel = (strchr (del, *p) != NULL) || !*p;
129 if ((split && isdel) || (!split && (isdel && isdel != wasdel))) {
130 while (strchr (del, *q) && q < p) {
131 q++;
132 }
133 pp[i] = my_strndup (q, p - q + 1);
134 pp[i][p - q] = '\0';
135 q = p + 1;
136 i++;
137 }
138 if (!*p) {
139 break;
140 }
141 }
142 }
143
144 ar->bounds[0] = num + 1;
145 token_done:
146 s = push ();
147 s->type = stNUMBER;
148 s->value = num;
149 }
150
151
152 void
tokenalt(struct command * cmd)153 tokenalt (struct command *cmd) /* extract token from variable with alternate semantics */
154 {
155 char *del; /* delimiter for strings */
156 struct stackentry *t;
157 char *old, *new, *tok;
158 int split;
159
160 if (cmd->type == cSPLITALT2 || cmd->type == cTOKENALT2) {
161 del = pop (stSTRING)->pointer;
162 } else {
163 del = " \t";
164 }
165 split = (cmd->type == cSPLITALT || cmd->type == cSPLITALT2);
166
167 t = pop (stSTRING);
168 old = t->pointer;
169 t->pointer = NULL; /* prevent push from freeing the memory */
170 t = push ();
171 t->type = stSTRING;
172 new = old;
173 tok = NULL;
174 while (*new) {
175 if (!tok && (!strchr (del, *new) || split)) {
176 tok = new; /* found start of token */
177 }
178 if (tok && strchr (del, *new)) {
179 break; /* found end of token */
180 }
181 new++;
182 }
183 if (*new) {
184 *new = '\0'; /* terminate token */
185 new++;
186 if (!split) {
187 while (*new) {
188 if (!strchr (del, *new)) {
189 break; /* found start of next token */
190 }
191 new++;
192 }
193 }
194 }
195 t->pointer = my_strdup (tok ? tok : ""); /* copy token */
196 /* move rest of string */
197 while (*new) {
198 *old = *new;
199 old++;
200 new++;
201 };
202 *old = '\0';
203 }
204
205
206 void
glob(void)207 glob (void) /* check, if pattern globs string */
208 {
209 char *str, *pat;
210 struct stackentry *stack;
211 int res;
212
213 pat = (char *) pop (stSTRING)->pointer;
214 str = (char *) pop (stSTRING)->pointer;
215
216 res = do_glob (str, pat);
217 stack = push ();
218 stack->value = res;
219 stack->type = stNUMBER;
220 }
221
222
223 static int
do_glob(char * str,char * pat)224 do_glob (char *str, char *pat) /* actually do the globbing */
225 {
226 int res;
227
228 if (severity_threshold <= sDEBUG) {
229 sprintf (string, "globbing '%s' on '%s'", str, pat);
230 error (sDEBUG, string);
231 }
232 if (*pat == '\0' && *str == '\0') {
233 return TRUE;
234 } else if (*pat == '\0') {
235 return FALSE;
236 } else if (*pat == '?' && *str == '\0') {
237 return FALSE;
238 } else if (*pat == '?') {
239 if (*str == '\0') {
240 return FALSE;
241 }
242 pat++;
243 str++;
244 } else if (*pat == '*') {
245 pat++;
246 res = FALSE;
247 while (*str && !(res = do_glob (str, pat))) {
248 str++;
249 }
250 if (res) {
251 return TRUE;
252 }
253 } else if (*str == '\0') {
254 return FALSE;
255 } else {
256 while (*pat && *pat != '?' && *pat != '*') {
257 if (*pat != *str) {
258 return FALSE;
259 }
260 str++;
261 pat++;
262 }
263 }
264 return do_glob (str, pat);
265 }
266
267
268 void
concat()269 concat () /* concatenates two strings from stack */
270 {
271 struct stackentry *c;
272 char *aa, *bb, *cc;
273
274 aa = pop (stSTRING)->pointer;
275 bb = pop (stSTRING)->pointer;
276 cc = (char *) my_malloc (sizeof (char) *
277 (strlen (aa) + strlen (bb) + 1));
278 strcpy (cc, bb);
279 strcat (cc, aa);
280 c = push ();
281 c->type = stSTRING;
282 c->pointer = cc;
283 }
284
285
286 void
create_changestring(int type)287 create_changestring (int type) /* create command 'changestring' */
288 {
289 struct command *cmd;
290
291 cmd = add_command (cCHANGESTRING);
292 cmd->args = type;
293 }
294
295
296 void
changestring(struct command * cmd)297 changestring (struct command *cmd) /* changes a string */
298 {
299 int type, a2, a3;
300 char *newpart;
301 char *oldstring;
302 int i, len;
303 struct stackentry *a1;
304
305 type = cmd->args;
306 newpart = pop (stSTRING)->pointer;
307 if (type > fTWOARGS) {
308 a3 = (int) pop (stNUMBER)->value;
309 }
310 if (type > fONEARGS) {
311 a2 = (int) pop (stNUMBER)->value;
312 }
313 a1 = pop (stSTRING);
314 oldstring = a1->pointer;
315 a1->pointer = NULL; /* this prevents push from freeing the memory */
316
317 if (!oldstring || !*oldstring) {
318 return;
319 }
320 switch (type) {
321 case fMID:
322 for (i = 1; i < a2 + a3; i++) {
323 if (!oldstring[i - 1]) {
324 break;
325 }
326 if (i >= a2) {
327 if (!newpart[i - a2]) {
328 break;
329 }
330 oldstring[i - 1] = newpart[i - a2];
331 }
332 }
333 break;
334 case fMID2:
335 len = strlen (oldstring);
336 for (i = 1; i <= len; i++) {
337 if (!oldstring[i - 1]) {
338 break;
339 }
340 if (i >= a2) {
341 if (!newpart[i - a2]) {
342 break;
343 }
344 oldstring[i - 1] = newpart[i - a2];
345 }
346 }
347 break;
348 case fLEFT:
349 for (i = 1; i <= a2; i++) {
350 if (!oldstring[i - 1] || !newpart[i - 1]) {
351 break;
352 }
353 oldstring[i - 1] = newpart[i - 1];
354 }
355 break;
356 case fRIGHT:
357 len = strlen (oldstring);
358 for (i = 1; i <= len; i++) {
359 if (i > len - a2) {
360 if (!newpart[i - 1 - len + a2]) {
361 break;
362 }
363 oldstring[i - 1] = newpart[i - 1 - len + a2];
364 }
365 }
366 break;
367 }
368 }
369
370
371 void
create_function(int type)372 create_function (int type) /* create command 'function' */
373 /* type can be sin,cos,mid$ ... */
374 {
375 struct command *cmd;
376
377 cmd = add_command (cFUNCTION);
378 if (severity_threshold <= sDEBUG) {
379 sprintf(estring, "function '%s'",fexplanation[type]);
380 error (sDEBUG, estring);
381 }
382 cmd->args = type;
383 }
384
385
386 void
function(struct command * cmd)387 function (struct command *cmd) /* performs a function */
388 {
389 struct stackentry *stack, *a1, *a2, *a3, *a4;
390 char *pointer;
391 double value;
392 time_t datetime;
393 int type, result, len, start, i, max;
394 char *str, *str2;
395
396 a3 = NULL;
397 type = cmd->args;
398 if (type > fTHREEARGS) {
399 a4 = pop (stSTRING_OR_NUMBER);
400 }
401 if (type > fTWOARGS) {
402 a3 = pop (stSTRING_OR_NUMBER);
403 }
404 if (type > fONEARGS) {
405 a2 = pop (stSTRING_OR_NUMBER);
406 }
407 if (type > fZEROARGS) {
408 a1 = pop (stSTRING_OR_NUMBER);
409 }
410
411 if (severity_threshold <= sDEBUG) {
412 sprintf(estring, "function '%s'",fexplanation[type]);
413 error (sDEBUG, estring);
414 }
415
416 switch (type) {
417 case fSIN:
418 value = sin (a1->value);
419 result = stNUMBER;
420 break;
421 case fASIN:
422 value = asin (a1->value);
423 result = stNUMBER;
424 break;
425 case fCOS:
426 value = cos (a1->value);
427 result = stNUMBER;
428 break;
429 case fACOS:
430 value = acos (a1->value);
431 result = stNUMBER;
432 break;
433 case fTAN:
434 value = tan (a1->value);
435 result = stNUMBER;
436 break;
437 case fATAN:
438 value = atan (a1->value);
439 result = stNUMBER;
440 break;
441 case fEXP:
442 value = exp (a1->value);
443 result = stNUMBER;
444 break;
445 case fLOG:
446 value = log (a1->value);
447 result = stNUMBER;
448 break;
449 case fLOG2:
450 value = log (a1->value) / log (a2->value);
451 result = stNUMBER;
452 break;
453 case fLEN:
454 value = (double) strlen (a1->pointer);
455 result = stNUMBER;
456 break;
457 case fSTR:
458 sprintf (string, "%g", a1->value);
459 pointer = my_strdup (string);
460 result = stSTRING;
461 break;
462 case fSTR2:
463 case fSTR3:
464 result = stSTRING;
465 if (!myformat (string, INBUFFLEN, a1->value, a2->pointer, a3 ? a3->pointer : NULL)) {
466 pointer = my_strdup ("");
467 break;
468 }
469 pointer = my_strdup (string);
470 break;
471 case fSTR4:
472 result = stSTRING;
473 pointer = my_strdup (a1->pointer);
474 case fCHOMP:
475 result = stSTRING;
476 pointer = a1->pointer;
477 a1->pointer = NULL;
478 pointer[strcspn(pointer, "\r\n")] = 0;
479 break;
480 case fSQRT:
481 value = sqrt (a1->value);
482 result = stNUMBER;
483 break;
484 case fSQR:
485 value = a1->value * a1->value;
486 result = stNUMBER;
487 break;
488 case fINT:
489 if (a1->value < 0) {
490 value = -floor (-a1->value);
491 } else {
492 value = floor (a1->value);
493 }
494 result = stNUMBER;
495 break;
496 case fCEIL:
497 value = ceil(a1->value);
498 result = stNUMBER;
499 break;
500 case fFLOOR:
501 value = floor(a1->value);
502 result = stNUMBER;
503 break;
504 case fROUND:
505 value = round(a1->value);
506 result = stNUMBER;
507 break;
508 case fFRAC:
509 if (a1->value < 0) {
510 value = a1->value + floor (-a1->value);
511 } else {
512 value = a1->value - floor (a1->value);
513 }
514 result = stNUMBER;
515 break;
516 case fABS:
517 value = fabs (a1->value);
518 result = stNUMBER;
519 break;
520 case fSIG:
521 if (a1->value < 0) {
522 value = -1.;
523 } else if (a1->value > 0) {
524 value = 1.;
525 } else {
526 value = 0.;
527 }
528 result = stNUMBER;
529 break;
530 case fMOD:
531 value = a1->value - a2->value * (int) (a1->value / a2->value);
532 result = stNUMBER;
533 break;
534 case fRAN:
535 value = a1->value * myrand ();
536 result = stNUMBER;
537 break;
538 case fRAN2:
539 value = myrand ();
540 result = stNUMBER;
541 break;
542 case fMIN:
543 if (a1->value > a2->value) {
544 value = a2->value;
545 } else {
546 value = a1->value;
547 }
548 result = stNUMBER;
549 break;
550 case fMAX:
551 if (a1->value > a2->value) {
552 value = a1->value;
553 } else {
554 value = a2->value;
555 }
556 result = stNUMBER;
557 break;
558 case fVAL:
559 i = sscanf ((char *) a1->pointer, "%lf", &value);
560 if (i != 1) {
561 value = 0;
562 }
563 result = stNUMBER;
564 break;
565 case fATAN2:
566 value = atan2 (a1->value, a2->value);
567 result = stNUMBER;
568 break;
569 case fLEFT:
570 str = a1->pointer;
571 len = (int) a2->value;
572 pointer = fromto (str, 0, len - 1);
573 result = stSTRING;
574 break;
575 case fRIGHT:
576 str = a1->pointer;
577 max = strlen (str);
578 len = (int) a2->value;
579 pointer = fromto (str, max - len, max - 1);
580 result = stSTRING;
581 break;
582 case fMID:
583 str = a1->pointer;
584 start = (int) a2->value;
585 len = (int) a3->value;
586 pointer = fromto (str, start - 1, start + len - 2);
587 result = stSTRING;
588 break;
589 case fMID2:
590 str = a1->pointer;
591 start = (int) a2->value;
592 pointer = fromto (str, start - 1, strlen (str));
593 result = stSTRING;
594 break;
595 case fINKEY:
596 pointer = inkey (a1->value);
597 strcpy(last_inkey, pointer);
598 result = stSTRING;
599 break;
600 case fAND:
601 value = (unsigned int) a1->value & (unsigned int) a2->value;
602 result = stNUMBER;
603 break;
604 case fOR:
605 value = (unsigned int) a1->value | (unsigned int) a2->value;
606 result = stNUMBER;
607 break;
608 case fEOR:
609 value = (unsigned int) a1->value ^ (unsigned int) a2->value;
610 result = stNUMBER;
611 break;
612 case fBITNOT:
613 value = ~ (unsigned int) a1->value;
614 result = stNUMBER;
615 break;
616 case fSHL:
617 value = (unsigned int) a1->value << (int) a2->value;
618 result = stNUMBER;
619 break;
620 case fSHR:
621 value = (unsigned int) a1->value >> (int) a2->value;
622 result = stNUMBER;
623 break;
624 case fMOUSEX:
625 getmousexybm (a1->pointer, &i, NULL, NULL, NULL);
626 value = i;
627 result = stNUMBER;
628 break;
629 case fMOUSEY:
630 getmousexybm (a1->pointer, NULL, &i, NULL, NULL);
631 value = i;
632 result = stNUMBER;
633 break;
634 case fMOUSEB:
635 getmousexybm (a1->pointer, NULL, NULL, &i, NULL);
636 value = i;
637 result = stNUMBER;
638 break;
639 case fMOUSEMOD:
640 getmousexybm (a1->pointer, NULL, NULL, NULL, &i);
641 value = i;
642 result = stNUMBER;
643 break;
644 case fCHR:
645 pointer = my_malloc (2);
646 i = (int) floor (a1->value);
647 if (i > 255 || i < 0) {
648 sprintf (string, "can't convert %g to character", a1->value);
649 error (sERROR, string);
650 return;
651 }
652 pointer[1] = '\0';
653 pointer[0] = (unsigned char) i;
654 result = stSTRING;
655 break;
656 case fASC:
657 value = ((unsigned char *) a1->pointer)[0];
658 result = stNUMBER;
659 break;
660 case fBIN:
661 pointer = dec2other (a1->value, 2);
662 result = stSTRING;
663 break;
664 case fHEX:
665 pointer = dec2other (a1->value, 16);
666 result = stSTRING;
667 break;
668 case fDEC:
669 value = other2dec (a1->pointer, 16);
670 result = stNUMBER;
671 break;
672 case fDEC2:
673 value = other2dec (a1->pointer, (int) (a2->value));
674 result = stNUMBER;
675 break;
676 case fUPPER:
677 str = a1->pointer;
678 pointer = my_malloc (strlen (str) + 1);
679 i = -1;
680 do {
681 i++;
682 pointer[i] = toupper ((int) str[i]);
683 } while (pointer[i]);
684 result = stSTRING;
685 break;
686 case fLOWER:
687 str = a1->pointer;
688 pointer = my_malloc (strlen (str) + 1);
689 i = -1;
690 do {
691 i++;
692 pointer[i] = tolower ((int) str[i]);
693 } while (pointer[i]);
694 result = stSTRING;
695 break;
696 case fLTRIM:
697 str = a1->pointer;
698 while (isspace (*str)) {
699 str++;
700 }
701 pointer = my_strdup (str);
702 result = stSTRING;
703 break;
704 case fRTRIM:
705 str = a1->pointer;
706 i = strlen (str) - 1;
707 while (isspace (str[i]) && i >= 0) {
708 i--;
709 }
710 str[i + 1] = '\0';
711 pointer = my_strdup (str);
712 result = stSTRING;
713 break;
714 case fTRIM:
715 str = a1->pointer;
716 i = strlen (str) - 1;
717 while (isspace (str[i]) && i >= 0) {
718 i--;
719 }
720 str[i + 1] = '\0';
721 while (isspace (*str)) {
722 str++;
723 }
724 pointer = my_strdup (str);
725 result = stSTRING;
726 break;
727 case fINSTR:
728 str = a1->pointer;
729 str2 = a2->pointer;
730 if (*str2) {
731 pointer = strstr (str, str2);
732 } else {
733 pointer = NULL;
734 }
735 if (pointer == NULL) {
736 value = 0;
737 } else {
738 value = pointer - str + 1;
739 }
740 result = stNUMBER;
741 break;
742 case fINSTR2:
743 str = a1->pointer;
744 str2 = a2->pointer;
745 start = (int) a3->value;
746 if (start > (int) strlen (str)) {
747 value = 0;
748 } else {
749 if (start < 1) {
750 start = 1;
751 }
752 pointer = strstr (str + start - 1, str2);
753 if (pointer == NULL) {
754 value = 0;
755 } else {
756 value = pointer - str + 1;
757 }
758 }
759 result = stNUMBER;
760 break;
761 case fRINSTR:
762 str = a1->pointer;
763 str2 = a2->pointer;
764 len = strlen (str2);
765 for (i = strlen (str) - 1; i >= 0; i--)
766 if (!strncmp (str + i, str2, len)) {
767 break;
768 }
769 value = i + 1;
770 result = stNUMBER;
771 break;
772 case fRINSTR2:
773 str = a1->pointer;
774 str2 = a2->pointer;
775 len = strlen (str2);
776 start = (int) a3->value;
777 if (start < 1) {
778 value = 0;
779 } else {
780 if (start > (int) strlen (str)) {
781 start = strlen (str);
782 }
783 for (i = start - 1; i >= 0; i--)
784 if (!strncmp (str + i, str2, len)) {
785 break;
786 }
787 value = i + 1;
788 }
789 result = stNUMBER;
790 break;
791 case fDATE:
792 pointer = my_malloc (100);
793 time (&datetime);
794 strftime (pointer, 100, "%w-%m-%d-%Y-%a-%b", localtime (&datetime));
795 result = stSTRING;
796 break;
797 case fTIME:
798 pointer = my_malloc (100);
799 time (&datetime);
800 strftime (pointer, 100, "%H-%M-%S", localtime (&datetime));
801 sprintf (pointer + strlen (pointer), "-%d",
802 (int) ((current_millis () - compilation_start)/1000));
803 result = stSTRING;
804 break;
805 case fSYSTEM:
806 str = a1->pointer;
807 value = do_system (str);
808 result = stNUMBER;
809 break;
810 case fSYSTEM2:
811 str = a1->pointer;
812 pointer = do_system2 (str);
813 result = stSTRING;
814 break;
815 case fFRNFN_CALL:
816 frnfn_call (type, &value, &pointer);
817 result = stNUMBER;
818 break;
819 case fFRNFN_CALL2:
820 frnfn_call (type, &value, &pointer);
821 result = stSTRING;
822 break;
823 case fFRNBF_ALLOC:
824 pointer = frnbf_alloc ();
825 result = stSTRING;
826 break;
827 case fFRNBF_SIZE:
828 value = frnbf_size ();
829 result = stNUMBER;
830 break;
831 case fFRNBF_DUMP:
832 case fFRNBF_DUMP2:
833 pointer = frnbf_dump (type);
834 result = stSTRING;
835 break;
836 case fFRNFN_SIZE:
837 value = frnfn_size ();
838 result = stNUMBER;
839 break;
840 case fFRNBF_GET_NUMBER:
841 value = frnbf_get ();
842 result = stNUMBER;
843 break;
844 case fFRNBF_GET_STRING:
845 pointer = frnbf_get2 ();
846 result = stSTRING;
847 break;
848 case fFRNBF_GET_BUFFER:
849 pointer = frnbf_get_buffer ();
850 result = stSTRING;
851 break;
852 case fPEEK:
853 str = a1->pointer;
854 value = peek (str);
855 result = stNUMBER;
856 break;
857 case fPEEK2:
858 str = a1->pointer;
859 pointer = peek2 (str, currcmd);
860 result = stSTRING;
861 break;
862 case fPEEK3:
863 str = a1->pointer;
864 str2 = a2->pointer;
865 pointer = peek3 (str, str2);
866 result = stSTRING;
867 break;
868 case fPEEK4:
869 value = peekfile ((int) a1->value);
870 result = stNUMBER;
871 break;
872 case fGETBIT:
873 pointer =
874 getbit ((int) a1->value, (int) a2->value, (int) a3->value,
875 (int) a4->value);
876 result = stSTRING;
877 break;
878 case fGETCHAR:
879 pointer =
880 getchars ((int) a1->value, (int) a2->value, (int) a3->value,
881 (int) a4->value);
882 result = stSTRING;
883 break;
884 case fTELL:
885 i = (int) (a1->value);
886 if (badstream (i, 0)) {
887 return;
888 }
889 if (!(stream_modes[i] & (mREAD | mWRITE))) {
890 sprintf (string, "stream %d not opened", i);
891 error (sERROR, string);
892 value = 0;
893 } else {
894 value = ftell (streams[i]);
895 }
896 result = stNUMBER;
897 break;
898 default:
899 error (sERROR, "function called but not implemented");
900 return;
901 }
902
903 stack = push ();
904 /* copy result */
905 stack->type = result;
906 if (result == stSTRING) {
907 stack->pointer = pointer;
908 } else {
909 stack->value = value;
910 }
911 }
912
913
914 static int
do_system(char * cmd)915 do_system (char *cmd) /* hand over execution of command to system, return exit code */
916 {
917 #ifdef UNIX
918 int ret;
919 if (curinized) {
920 reset_shell_mode ();
921 putp (exit_ca_mode);
922 }
923 ret = system (cmd);
924 if (curinized) {
925 if (tcsetpgrp(STDIN_FILENO, getpgid(getpid()))) {
926 sprintf(string,"could not get control of terminal: %s",
927 my_strerror(errno));
928 error (sERROR,string);
929 return ret;
930 }
931 putp (enter_ca_mode);
932 reset_prog_mode ();
933 }
934
935 return ret;
936 #else
937 STARTUPINFO start;
938 PROCESS_INFORMATION proc;
939 DWORD ec; /* exit code */
940 SECURITY_ATTRIBUTES prosec;
941 SECURITY_ATTRIBUTES thrsec;
942 char *comspec;
943
944 ZeroMemory (&prosec, sizeof (prosec));
945 prosec.nLength = sizeof (prosec);
946 prosec.bInheritHandle = TRUE;
947 ZeroMemory (&thrsec, sizeof (thrsec));
948 thrsec.nLength = sizeof (thrsec);
949 thrsec.bInheritHandle = TRUE;
950 ZeroMemory (&start, sizeof (start));
951 start.cb = sizeof (STARTUPINFO);
952 start.dwFlags = STARTF_USESTDHANDLES;
953 start.hStdOutput = GetStdHandle (STD_OUTPUT_HANDLE);
954 start.hStdError = GetStdHandle (STD_ERROR_HANDLE);
955 start.hStdInput = GetStdHandle (STD_INPUT_HANDLE);
956 comspec = getenv ("COMSPEC");
957 if (!comspec) {
958 comspec = "command.com";
959 }
960 sprintf (string, "%s /C %s", comspec, cmd);
961 if (!CreateProcess (NULL, string, &prosec, &thrsec, TRUE, 0,
962 NULL, NULL, &start, &proc)) {
963 sprintf (string, "couldn't execute '%s'", cmd);
964 error (sERROR, string);
965 return -1;
966 }
967 WaitForSingleObject (proc.hProcess, INFINITE);
968 if (!GetExitCodeProcess (proc.hProcess, &ec)) {
969 ec = -1;
970 }
971 CloseHandle (proc.hProcess);
972 CloseHandle (proc.hThread);
973 return ec;
974 #endif
975 }
976
977
978 static double
myrand()979 myrand ()
980 {
981 long ran;
982
983 ran = (((long) rand ()) & 0x7fffL) << 15 | ((long) rand () & 0x7fffL);
984
985 return ((double) ran) / ((double) 0x3fffffffL);
986 }
987
988
989 static void
clear_buff()990 clear_buff () /* clear system-input buffers */
991 {
992 buffcurr = &buffroot;
993 buffcount = 0;
994 }
995
996
997 static void
store_buff(char * buff,int len)998 store_buff (char *buff, int len) /* store system-input buffer */
999 {
1000 *buffcurr = my_malloc (sizeof (struct buff_chain));
1001 memcpy ((*buffcurr)->buff, buff, PIPEBUFFLEN + 1);
1002 (*buffcurr)->len = len;
1003 (*buffcurr)->next = NULL;
1004 buffcurr = &((*buffcurr)->next);
1005 buffcount++;
1006 }
1007
1008
1009 char *
recall_buff()1010 recall_buff () /* recall store buffer */
1011 {
1012 struct buff_chain *curr, *old;
1013 char *result;
1014 int done, len;
1015
1016 result = (char *) my_malloc (buffcount * (PIPEBUFFLEN + 1));
1017 curr = buffroot;
1018 len = 0;
1019 for (done = 0; done < buffcount && curr; done++) {
1020 memcpy (result + len, curr->buff, PIPEBUFFLEN);
1021 len += curr->len;
1022 old = curr;
1023 curr = curr->next;
1024 my_free (old);
1025 }
1026 return result;
1027 }
1028
1029
1030 static char *
do_system2(char * cmd)1031 do_system2 (char *cmd) /* hand over execution of command to system, return output as string */
1032 {
1033 static char buff[PIPEBUFFLEN + 1]; /* buffer to store command */
1034 int len; /* number of bytes read */
1035 #ifdef UNIX
1036 FILE *p; /* points to pipe */
1037 int c; /* char read from pipe */
1038 #else
1039 int ret;
1040 STARTUPINFO start;
1041 PROCESS_INFORMATION proc;
1042 HANDLE piperead, pipewrite; /* both ends of pipes */
1043 SECURITY_ATTRIBUTES prosec;
1044 SECURITY_ATTRIBUTES thrsec;
1045 char *comspec;
1046 #endif
1047
1048 clear_buff ();
1049
1050 #ifdef UNIX
1051 p = popen (cmd, "r");
1052 if (p == NULL) {
1053 sprintf (string, "couldn't execute '%s'", cmd);
1054 error (sERROR, string);
1055 return my_strdup ("");
1056 }
1057 do {
1058 len = 0;
1059 while (len < PIPEBUFFLEN) {
1060 c = fgetc (p);
1061 if (c == EOF) {
1062 buff[len] = '\0';
1063 break;
1064 }
1065 buff[len] = c;
1066 len++;
1067 }
1068 store_buff (buff, len);
1069 } while (c != EOF);
1070 pclose (p);
1071 #else
1072 ZeroMemory (&prosec, sizeof (prosec));
1073 prosec.nLength = sizeof (prosec);
1074 prosec.bInheritHandle = TRUE;
1075 ZeroMemory (&thrsec, sizeof (thrsec));
1076 thrsec.nLength = sizeof (thrsec);
1077 thrsec.bInheritHandle = TRUE;
1078
1079 /* create pipe for writing */
1080 CreatePipe (&piperead, &pipewrite, &prosec, 0);
1081
1082 ZeroMemory (&start, sizeof (start));
1083 start.cb = sizeof (STARTUPINFO);
1084 start.dwFlags = STARTF_USESTDHANDLES;
1085 start.hStdOutput = pipewrite;
1086 start.hStdError = pipewrite;
1087 start.hStdInput = GetStdHandle (STD_INPUT_HANDLE);
1088
1089 comspec = getenv ("COMSPEC");
1090 if (!comspec) {
1091 comspec = "command.com";
1092 }
1093 sprintf (string, "%s /C %s", comspec, cmd);
1094 if (!CreateProcess (NULL, string, &prosec, &thrsec, TRUE, 0,
1095 NULL, NULL, &start, &proc)) {
1096 sprintf (string, "couldn't execute '%s'", cmd);
1097 error (sERROR, string);
1098 return my_strdup ("");
1099 }
1100 CloseHandle (pipewrite);
1101
1102 do {
1103 /* wait for output to arrive */
1104 if (!ReadFile (piperead, buff, PIPEBUFFLEN, (LPDWORD) & len, NULL)) {
1105 ret = GetLastError ();
1106 } else {
1107 ret = 0;
1108 }
1109 buff[len] = '\0';
1110 if (len > 0) {
1111 store_buff (buff, len);
1112 }
1113 } while (ret != ERROR_BROKEN_PIPE && ret != ERROR_HANDLE_EOF);
1114 CloseHandle (piperead);
1115 CloseHandle (proc.hProcess);
1116 CloseHandle (proc.hThread);
1117 #endif
1118 return recall_buff ();
1119 }
1120
1121
1122 void
getmousexybm(char * s,int * px,int * py,int * pb,int * pm)1123 getmousexybm (char *s, int *px, int *py, int *pb, int *pm) /* get mouse coordinates */
1124 {
1125 int x = 0, y = 0, b = 0, m = 0;
1126 char c;
1127
1128 if (!*s) s=last_inkey;
1129 if (*s) {
1130 sscanf (s, "MB%d%c+%d:%04d,%04d", &b, &c, &m, &x, &y);
1131 if (px) {
1132 *px = x;
1133 }
1134 if (py) {
1135 *py = y;
1136 }
1137 if (pb) {
1138 if (c == 'd') {
1139 *pb = b;
1140 } else {
1141 *pb = -b;
1142 }
1143 }
1144 if (pm) {
1145 *pm = m;
1146 }
1147 return;
1148 }
1149 if (px) {
1150 *px = mousex;
1151 }
1152 if (py) {
1153 *py = mousey;
1154 }
1155 if (pb) {
1156 *pb = mouseb;
1157 }
1158 if (pm) {
1159 *pm = mousemod;
1160 }
1161 }
1162
1163
1164 static char *
dec2other(double d,int base)1165 dec2other (double d, int base) /* convert double to hex or binary number */
1166 {
1167 int len;
1168 double dec, dec2;
1169 char *other;
1170 int negative = FALSE;
1171
1172 if (d < 0) {
1173 dec2 = floor (-d);
1174 negative = TRUE;
1175 } else {
1176 dec2 = floor (d);
1177 }
1178 len = negative ? 2 : 1;
1179 for (dec = dec2; dec >= base; dec /= base) {
1180 len++;
1181 }
1182 other = my_malloc (len + 1);
1183 other[len] = '\0';
1184 dec = dec2;
1185 for (len--; len >= 0; len--) {
1186 other[len] =
1187 "0123456789abcdef"[(int)
1188 (floor
1189 (dec - base * floor (dec / base) + 0.5))];
1190 dec = floor (dec / base);
1191 }
1192 if (negative) {
1193 other[0] = '-';
1194 }
1195 return other;
1196 }
1197
1198
1199 static double
other2dec(char * hex,int base)1200 other2dec (char *hex, int base) /* convert hex or binary to double number */
1201 {
1202 double dec;
1203 static char *digits = "0123456789abcdef";
1204 char *found;
1205 int i, len;
1206
1207 if (base != 2 && base != 16) {
1208 sprintf (string, "Cannot convert base-%d numbers", base);
1209 error (sERROR, string);
1210 return 0.;
1211 }
1212 dec = 0;
1213 len = strlen (hex);
1214 for (i = 0; i < len; i++) {
1215 dec *= base;
1216 found = strchr (digits, tolower (hex[i]));
1217 if (!found || found - digits >= base) {
1218 sprintf (string, "Not a base-%d number: '%s'", base, hex);
1219 error (sERROR, string);
1220 return 0.;
1221 }
1222 dec += found - digits;
1223 }
1224 return dec;
1225 }
1226
1227
1228 int
myformat(char * dest,int max,double num,char * format,char * sep)1229 myformat (char *dest, int max, double num, char *format, char *sep) /* format number according to string */
1230 {
1231 int ret = myformat2 (dest, max, num, format, sep);
1232 if (ret == 0) return TRUE;
1233 if (ret == 1) sprintf (estring, "'%s' is not a valid format", format);
1234 if (ret == 2) sprintf (estring, "length of formatted string exceeds maximum of %d bytes", INBUFFLEN);
1235 error (sERROR, estring);
1236 return FALSE;
1237 }
1238
1239
1240 int
myformat2(char * dest,int max,double num,char * format,char * sep)1241 myformat2 (char *dest, int max, double num, char *format, char *sep) /* do the work for myformat */
1242 {
1243 static char *ctrl = "+- #0"; /* allowed control chars for c-format */
1244 char formchar;
1245 char *found, *form;
1246 int pre, post, len, nread, digit, commas, dots, i, cr;
1247 int neg = FALSE;
1248 double ipdbl, fp, round;
1249 unsigned long ip;
1250 static char *digits = "0123456789";
1251
1252 form = format;
1253 if (*form == '%') {
1254 /* c-style format */
1255 form++;
1256 while ((found = strchr (ctrl, *form)) != NULL) form++;
1257 if (sscanf (form, "%*u.%*u%c%n", &formchar, &nread) != 1 &&
1258 sscanf (form, "%*u.%c%n", &formchar, &nread) != 1 &&
1259 sscanf (form, ".%*u%c%n", &formchar, &nread) != 1 &&
1260 sscanf (form, "%*u%c%n", &formchar, &nread) != 1 &&
1261 sscanf (form, "%c%n", &formchar, &nread) != 1) {
1262 return 1;
1263 }
1264 if (!strchr ("feEgG", formchar) || form[nread]) {
1265 return 1;
1266 }
1267 /* seems okay, let's try to print */
1268 len = snprintf (dest, max, format, num);
1269 if (len >= max) {
1270 return 2;
1271 }
1272 } else {
1273 /* basic-style format */
1274
1275 /* make num positive and remember if it has been negative initially */
1276 if (num < 0) {
1277 neg = TRUE;
1278 num = fabs (num);
1279 }
1280
1281 /* verify form of ##.###.###,## (e.g.) up front to be able to rely on this;
1282 also count various parts */
1283 commas = 0;
1284 dots = 0;
1285 pre = 0;
1286 post = 0;
1287 for (form = format; *form; form++) {
1288 if (*form == ',') {
1289 if (dots) {
1290 /* commas in fractional part are not supported */
1291 return 1;
1292 }
1293 commas++;
1294 } else if (*form == '.') {
1295 if (dots) {
1296 /* format has more than one decimal dot */
1297 return 1;
1298 }
1299 dots++;
1300 } else if (*form == '#') {
1301 if (dots) {
1302 post++;
1303 } else {
1304 pre++;
1305 }
1306 } else {
1307 /* neither '#' nor '.' nor ',' */
1308 return 1;
1309 }
1310 }
1311
1312 /* prepare destination */
1313 len = strlen (format);
1314 dest[len] = '\0';
1315
1316 /* round to given precision; round away from zero */
1317 round = 0.5;
1318 for (i = 0; i < post; i++) {
1319 round /= 10.;
1320 }
1321 /* if number is below round offset, treat it as zero */
1322 if (num < round) {
1323 neg = FALSE;
1324 num = 0.0;
1325 } else {
1326 /* do the rounding away from zero */
1327 num += round;
1328 }
1329
1330 /* because we cast to long we cannot cope with numbers larger than its max */
1331 /* not casting to long on the other hand leads to frequent arithmetic errors */
1332 if (num > LONG_MAX) {
1333 strcpy (dest, format);
1334 return 0;
1335 }
1336
1337 /* disassemble in integer and fractional part; both ip and fp will be consumed stepwise in the process */
1338 fp = modf(num, &ipdbl);
1339 ip = (unsigned long) ipdbl;
1340
1341 /* variable cr serves as our cursor running from right to left and marks the position to be written next */
1342
1343 /* write integer part */
1344 cr = pre + commas - 1;
1345 do {
1346 if (format[cr] == '#') {
1347 /* get digit and reduce integer part */
1348 digit = ip % 10;
1349 ip = ip/10;
1350 dest[cr--] = digits[digit];
1351 } else {
1352 /* format[cr] == ','; i.e. we do not need a new digit */
1353 dest[cr--] = ip ? ',' : ' ';
1354 }
1355 } while (ip && cr >= 0);
1356
1357 /* given format does not have enough room, this is an error; just copy format into dest and return */
1358 if ((neg && cr < 0) || ip) {
1359 strcpy (dest, format);
1360 return 0;
1361 }
1362
1363 /* minus if appropriate */
1364 if (neg) {
1365 dest[cr--] = '-';
1366 }
1367
1368 /* fill from cursor position back to start */
1369 while (cr >= 0) {
1370 dest[cr--] = ' ';
1371 }
1372
1373 /* cursor cr now runs from left to right */
1374
1375 /* do we need to write a fractional part ? */
1376 cr = pre + commas;
1377 if (dots) {
1378 /* write decimal dot */
1379 dest[cr++] = '.';
1380 /* construct fractional part digit by digit */
1381 while (cr < len) {
1382 fp *= 10;
1383 digit = ((unsigned long) fp) % 10;
1384 dest[cr++] = digits[digit];
1385 }
1386 } else {
1387 /* no fractional part needed */
1388 dest[cr++] = '\0';
1389 }
1390
1391 /* until now we used fixed separators ',' for thousands and '.' for decimal; but if
1392 user has given his own separators (e.g. german or swiss style) we need to correct this */
1393 if (sep) {
1394 if (sep[0] && sep[1]) {
1395 for (i = 0; i < len; i++) {
1396 if (dest[i] == ',') {
1397 dest[i++] = sep[0];
1398 }
1399 if (dest[i] == '.') {
1400 dest[i++] = sep[1];
1401 }
1402 }
1403 } else {
1404 return 1;
1405 }
1406 }
1407 }
1408 return 0;
1409 }
1410
1411
1412 static char *
fromto(char * str,int from,int to)1413 fromto (char *str, int from, int to) /* gives back portion of string */
1414 /* from and to can be in the range 1...strlen(str) */
1415 {
1416 int len, i;
1417 char *part;
1418
1419 len = strlen (str);
1420 if (from > to || to < 0 || from > len - 1) {
1421 /* give back empty string */
1422 part = my_malloc (1);
1423 part[0] = '\0';
1424 } else {
1425 if (from <= 0) {
1426 from = 0;
1427 }
1428 if (to >= len) {
1429 to = len - 1;
1430 }
1431 part = my_malloc (sizeof (char) * (to - from + 2)); /* characters and '/0' */
1432 for (i = from; i <= to; i++) {
1433 part[i - from] = str[i]; /* copy */
1434 }
1435 part[i - from] = '\0';
1436 }
1437 return part;
1438 }
1439
1440
1441
1442 void
mywait()1443 mywait () /* wait given number of seconds */
1444 {
1445 double delay;
1446
1447 #ifdef UNIX
1448 struct timeval tv;
1449 #else
1450 MSG msg;
1451 int timerid;
1452 #endif
1453
1454 delay = pop (stNUMBER)->value;
1455 if (delay < 0) {
1456 delay = 0.;
1457 }
1458 #ifdef UNIX
1459 tv.tv_sec = (long) delay;
1460 tv.tv_usec = (delay - (long) delay) * 1000000;
1461 select (0, NULL, NULL, NULL, &tv);
1462 #else /* WINDOWS */
1463 timerid = SetTimer (NULL, 0, (int) (delay * 1000), (TIMERPROC) NULL);
1464 GetMessage ((LPMSG) & msg, NULL, WM_TIMER, WM_TIMER);
1465 KillTimer (NULL, timerid);
1466 #endif
1467 }
1468
1469
1470 void
mybell()1471 mybell () /* ring ascii bell */
1472 {
1473 #ifdef UNIX
1474 printf ("\007");
1475 fflush (stdout);
1476 #else /* WINDOWS */
1477 Beep (1000, 100);
1478 #endif
1479 }
1480
1481
1482
1483 void
create_poke(char flag)1484 create_poke (char flag) /* create Command 'cPOKE' */
1485 {
1486 struct command *cmd;
1487
1488 if (flag == 'S' || flag == 'D') {
1489 cmd = add_command (cPOKEFILE);
1490 } else {
1491 cmd = add_command (cPOKE);
1492 }
1493 cmd->tag = flag;
1494 }
1495
1496
1497 void
poke(struct command * cmd)1498 poke (struct command *cmd) /* poke into internals */
1499 {
1500 char *dest, *s, c;
1501 char *string_arg = NULL;
1502 double double_arg;
1503 struct stackentry *stack;
1504 int count;
1505
1506 if (cmd->tag == 's') {
1507 string_arg = pop (stSTRING)->pointer;
1508 } else {
1509 double_arg = pop (stNUMBER)->value;
1510 }
1511
1512 dest = pop (stSTRING)->pointer;
1513 for (s = dest; *s; s++) {
1514 *s = tolower ((int) *s);
1515 }
1516 if (!strcmp (dest, "fontheight") && !string_arg) {
1517 fontheight = (int) double_arg;
1518 #ifdef UNIX
1519 calc_psscale ();
1520 #endif
1521 } else if (!strcmp (dest, "font") && string_arg) {
1522 fontname = my_strdup (string_arg);
1523 } else if (!strcmp (dest, "dump") && string_arg) {
1524 dump_commands (string_arg);
1525 } else if (!strcmp (dest, "dump") && string_arg && !strcmp (string_arg, "symbols")) {
1526 dump_sym ();
1527 } else if (!strcmp (dest, "dump") && string_arg &&
1528 (!strcmp (string_arg, "sub") || !strcmp (string_arg, "subs")
1529 || !strcmp (string_arg, "subroutine")
1530 || !strcmp (string_arg, "subroutines"))) {
1531 dump_sub (0);
1532 } else if (!strcmp (dest, "textalign") && string_arg) {
1533 if (!check_alignment (string_arg)) {
1534 return;
1535 }
1536 strncpy (text_align, string_arg, 2);
1537 } else if (!strcmp (dest, "windoworigin") && string_arg) {
1538 moveorigin (string_arg);
1539 } else if (!strcmp (dest, "infolevel") && string_arg) {
1540 c = tolower ((int) *string_arg);
1541 switch (c) {
1542 case 'd':
1543 severity_threshold = sDEBUG;
1544 break;
1545 case 'n':
1546 severity_threshold = sNOTE;
1547 break;
1548 case 'w':
1549 severity_threshold = sWARNING;
1550 break;
1551 case 'e':
1552 severity_threshold = sERROR;
1553 break;
1554 case 'f':
1555 severity_threshold = sFATAL;
1556 break;
1557 default:
1558 error (sERROR, "invalid infolevel");
1559 return;
1560 }
1561 if (severity_threshold <= sDEBUG) {
1562 sprintf (string, "switching infolevel to '%c'", c);
1563 error (sDEBUG, string);
1564 }
1565 } else if (!strcmp (dest, "stdout") && string_arg) {
1566 fputs (string_arg, stdout);
1567 } else if (!strcmp (dest, "random_seed") && !string_arg) {
1568 srand((unsigned int) double_arg);
1569 } else if (!strcmp (dest, "__assert_stack_size") && !string_arg) {
1570 count = -1;
1571 stack = stackhead;
1572 while ( stack != stackroot) {
1573 count++;
1574 stack = stack->prev;
1575 }
1576 if (count != (int) double_arg) {
1577 sprintf (string, "assertion failed for number of entries on stack; expected = %d, actual = %d",(int) double_arg,count);
1578 error (sFATAL, string);
1579 }
1580 } else if (dest[0] == '#') {
1581 error (sERROR, "don't use quotes when poking into file");
1582 } else {
1583 sprintf(string,"invalid poke: '%s'",dest);
1584 error (sERROR, string);
1585 }
1586 return;
1587 }
1588
1589
1590 void
pokefile(struct command * cmd)1591 pokefile (struct command *cmd) /* poke into file */
1592 {
1593 char *sarg = NULL;
1594 double darg;
1595 int stream;
1596
1597 if (cmd->tag == 'S') {
1598 sarg = pop (stSTRING)->pointer;
1599 } else {
1600 darg = pop (stNUMBER)->value;
1601 }
1602 stream = (int) (pop (stNUMBER)->value);
1603
1604 if (badstream (stream, 0)) {
1605 return;
1606 }
1607
1608 if (!(stream_modes[stream] & mWRITE)) {
1609 sprintf (string, "Stream %d not open for writing", stream);
1610 error (sERROR, string);
1611 return;
1612 }
1613 if (sarg) {
1614 fputs (sarg, streams[stream]);
1615 } else {
1616 if (darg < 0 || darg > 255) {
1617 error (sERROR, "stream poke out of byte range (0..255)");
1618 return;
1619 }
1620 fputc ((int) darg, streams[stream]);
1621 }
1622 }
1623
1624
1625 static double
peek(char * dest)1626 peek (char *dest) /* peek into internals */
1627 {
1628 char *s;
1629
1630 for (s = dest; *s; s++) {
1631 *s = tolower ((int) *s);
1632 }
1633 if (!strcmp (dest, "winwidth")) {
1634 return winwidth;
1635 } else if (!strcmp (dest, "winheight")) {
1636 return winheight;
1637 } else if (!strcmp (dest, "fontheight")) {
1638 return fontheight;
1639 } else if (!strcmp (dest, "screenheight")) {
1640 return LINES;
1641 } else if (!strcmp (dest, "screenwidth")) {
1642 return COLS;
1643 } else if (!strcmp (dest, "argument") || !strcmp (dest, "arguments")) {
1644 return yabargc;
1645 } else if (!strcmp (dest, "version")) {
1646 return strtod (VERSION, NULL);
1647 } else if (!strcmp (dest, "error")) {
1648 return errorcode;
1649 } else if (!strcmp (dest, "isbound")) {
1650 return is_bound;
1651 } else if (!strcmp (dest, "last_foreign_function_call_okay") || !strcmp (dest, "last_frnfn_call_okay")) {
1652 return (double) last_frnfn_call_okay;
1653 } else if (!strcmp (dest, "secondsrunning")) {
1654 return (double)((current_millis () - compilation_start)/1000);
1655 } else if (!strcmp (dest, "millisrunning")) {
1656 return (double)(current_millis () - compilation_start);
1657 } else if (dest[0] == '#') {
1658 error (sERROR, "don't use quotes when peeking into a file");
1659 return 0;
1660 }
1661
1662 error (sERROR, "invalid peek");
1663 return 0;
1664 }
1665
1666
1667 static int
peekfile(int s)1668 peekfile (int s) /* read a byte from stream */
1669 {
1670 if (s && badstream (s, 0)) {
1671 return 0;
1672 }
1673 if (s && !(stream_modes[s] & mREAD)) {
1674 sprintf (string, "stream %d not open for reading", s);
1675 error (sERROR, string);
1676 return 0;
1677 }
1678 return fgetc (s ? streams[s] : stdin);
1679 }
1680
1681
1682 static char *
peek2(char * dest,struct command * curr)1683 peek2 (char *dest, struct command *curr) /* peek into internals */
1684 {
1685 char *s;
1686
1687 for (s = dest; *s; s++) {
1688 *s = tolower ((int) *s);
1689 }
1690 if (!strcmp (dest, "infolevel")) {
1691 if (severity_threshold == sDEBUG) {
1692 return my_strdup ("debug");
1693 } else if (severity_threshold == sNOTE) {
1694 return my_strdup ("note");
1695 } else if (severity_threshold == sWARNING) {
1696 return my_strdup ("warning");
1697 } else if (severity_threshold == sERROR) {
1698 return my_strdup ("error");
1699 } else if (severity_threshold == sFATAL) {
1700 return my_strdup ("fatal");
1701 } else {
1702 return my_strdup ("unknown");
1703 }
1704 } else if (!strcmp (dest, "textalign")) {
1705 return my_strdup (text_align);
1706 } else if (!strcmp (dest, "windoworigin")) {
1707 return my_strdup (winorigin);
1708 } else if (!strcmp (dest, "error")) {
1709 return my_strdup (estring);
1710 } else if (!strcmp (dest, "program_file_name")) {
1711 return my_strdup(main_file_name);
1712 } else if (!strcmp (dest, "program_name")) {
1713 return my_strdup(progname);
1714 } else if (!strcmp (dest, "interpreter_path")) {
1715 return my_strdup(inter_path);
1716 } else if (!strcmp (dest, "library")) {
1717 return my_strdup (curr->lib->short_name);
1718 } else if (!strcmp (dest, "version")) {
1719 return my_strdup (PACKAGE_VERSION);
1720 } else if (!strcmp (dest, "os")) {
1721 #ifdef UNIX
1722 return my_strdup ("unix");
1723 #else
1724 return my_strdup ("windows");
1725 #endif
1726 } else if (!strcmp (dest, "font")) {
1727 return my_strdup (fontname);
1728 } else if (!strcmp (dest, "last_foreign_function_call_error_text") || !strcmp (dest, "last_frnfn_call_error_text")) {
1729 return my_strdup (last_frnfn_call_error_text);
1730 } else if (!strcmp (dest, "argument") || !strcmp (dest, "arguments")) {
1731 if (yabargc > 0) {
1732 s = yabargv[0];
1733 yabargc--;
1734 yabargv++;
1735 } else {
1736 s = "";
1737 }
1738 return my_strdup (s);
1739 } else {
1740 error (sERROR, "invalid peek");
1741 }
1742 return my_strdup ("");
1743 }
1744
1745
1746 static char *
peek3(char * dest,char * cont)1747 peek3 (char *dest, char *cont) /* peek into internals */
1748 {
1749 char *s;
1750
1751 for (s = dest; *s; s++) {
1752 *s = tolower ((int) *s);
1753 }
1754 if (!strcmp (dest, "env") || !strcmp (dest, "environment")) {
1755 return my_strdup (getenv (cont));
1756 } else {
1757 error (sERROR, "invalid peek");
1758 }
1759 return my_strdup ("");
1760 }
1761
1762
1763 void
create_exception(int flag)1764 create_exception (int flag) /* create command 'exception' */
1765 {
1766 struct command *cmd;
1767
1768 cmd = add_command (cEXCEPTION);
1769 cmd->args = flag;
1770 }
1771
1772
1773 void
exception(struct command * cmd)1774 exception (struct command *cmd) /* change handling of exceptions */
1775 {
1776 if (cmd->args) {
1777 signal (SIGINT, signal_handler); /* enable keyboard interrupt */
1778 #ifdef SIGHUP
1779 signal (SIGHUP, signal_handler);
1780 #endif
1781 #ifdef SIGQUIT
1782 signal (SIGQUIT, signal_handler);
1783 #endif
1784 #ifdef SIGABRT
1785 signal (SIGABRT, signal_handler);
1786 #endif
1787 #ifdef SIGTERM
1788 signal (SIGTERM, signal_handler);
1789 #endif
1790 } else {
1791 signal (SIGINT, SIG_IGN); /* ignore keyboard interrupt */
1792 #ifdef SIGHUP
1793 signal (SIGHUP, SIG_IGN);
1794 #endif
1795 #ifdef SIGQUIT
1796 signal (SIGQUIT, SIG_IGN);
1797 #endif
1798 #ifdef SIGABRT
1799 signal (SIGABRT, SIG_IGN);
1800 #endif
1801 #ifdef SIGTERM
1802 signal (SIGTERM, SIG_IGN);
1803 #endif
1804 }
1805 return;
1806 }
1807
1808
current_millis()1809 long long current_millis() { /* return current number of milliseconds */
1810 #ifdef WINDOWS
1811 return GetTickCount();
1812 #else
1813 struct timespec tsnow;
1814 clock_gettime(CLOCK_MONOTONIC, &tsnow);
1815 return tsnow.tv_sec*1000LL + tsnow.tv_nsec/1000000LL;
1816 #endif
1817 }
1818
1819
1820 void
create_restore(char * label)1821 create_restore (char *label) /* create command 'restore' */
1822 {
1823 struct command *c;
1824
1825 c = add_command (cRESTORE);
1826 c->pointer = my_strdup (label);
1827 }
1828
1829
1830 void
restore(struct command * cmd)1831 restore (struct command *cmd) /* reset data pointer to given label */
1832 {
1833 struct command *label;
1834 struct command **datapointer;
1835
1836 datapointer = &(cmd->lib->datapointer);
1837 if (cmd->type == cRESTORE) {
1838 /* first time; got to search the label */
1839 if (*((char *) cmd->pointer) == '\0') {
1840 /* no label, restore to first command */
1841 label = cmd->lib->firstdata;
1842 } else {
1843 label = search_label (cmd->pointer, srmLABEL | srmGLOBAL);
1844 if (!label) {
1845 /* did not find label */
1846 sprintf (string, "can't find label '%s'",
1847 (char *) cmd->pointer);
1848 error (sERROR, string);
1849 return;
1850 }
1851 }
1852 *datapointer = label;
1853 if (lastdata) {
1854 while ((*datapointer)->type != cDATA
1855 && (*datapointer) != cmd_head) {
1856 *datapointer = (*datapointer)->next;
1857 }
1858 }
1859 cmd->pointer = *datapointer;
1860 cmd->type = cQRESTORE;
1861 } else {
1862 *datapointer = cmd->pointer;
1863 }
1864 return;
1865 }
1866
1867
1868 void
create_dbldata(double value)1869 create_dbldata (double value) /* create command dbldata */
1870 {
1871 struct command *c;
1872
1873 c = add_command (cDATA);
1874 c->pointer = my_malloc (sizeof (double));
1875 if (lastdata) {
1876 lastdata->next_assoc = c;
1877 }
1878 lastdata = c;
1879 *((double *) c->pointer) = value;
1880 c->tag = 'd'; /* double value */
1881 }
1882
1883
1884 void
create_strdata(char * value)1885 create_strdata (char *value) /* create command strdata */
1886 {
1887 struct command *c;
1888
1889 c = add_command (cDATA);
1890 if (lastdata) {
1891 lastdata->next_assoc = c;
1892 }
1893 lastdata = c;
1894 c->pointer = my_strdup (value);
1895 c->tag = 's'; /* string value */
1896 }
1897
1898
1899 void
create_readdata(char type)1900 create_readdata (char type) /* create command readdata */
1901 {
1902 struct command *cmd;
1903
1904 cmd = add_command (cREADDATA);
1905 cmd->tag = type;
1906 }
1907
1908
1909 void
readdata(struct command * cmd)1910 readdata (struct command *cmd) /* read data items */
1911 {
1912 struct stackentry *read;
1913 char type;
1914 struct command **datapointer;
1915
1916 datapointer = &(cmd->lib->datapointer);
1917 type = cmd->tag;
1918 while (*datapointer
1919 && ((*datapointer)->type != cDATA
1920 || cmd->lib != (*datapointer)->lib)) {
1921 *datapointer = (*datapointer)->next_assoc;
1922 }
1923 if (!*datapointer) {
1924 error (sERROR, "run out of data items");
1925 return;
1926 }
1927 if (type != (*datapointer)->tag) {
1928 error (sERROR, "type of READ and DATA don't match");
1929 return;
1930 }
1931 read = push ();
1932 if (type == 'd') {
1933 /* read a double value */
1934 read->type = stNUMBER;
1935 read->value = *((double *) (*datapointer)->pointer);
1936 } else {
1937 read->type = stSTRING;
1938 read->pointer = my_strdup ((*datapointer)->pointer);
1939 }
1940 *datapointer = (*datapointer)->next_assoc; /* next item */
1941 }
1942
1943
1944 void
create_dblrelop(char c)1945 create_dblrelop (char c) /* create command dblrelop */
1946 {
1947 int type;
1948
1949 switch (c) {
1950 case '=':
1951 type = cEQ;
1952 break;
1953 case '!':
1954 type = cNE;
1955 break;
1956 case '<':
1957 type = cLT;
1958 break;
1959 case '{':
1960 type = cLE;
1961 break;
1962 case '>':
1963 type = cGT;
1964 break;
1965 case '}':
1966 type = cGE;
1967 break;
1968 }
1969 add_command (type);
1970 }
1971
1972
1973 void
dblrelop(struct command * cmd)1974 dblrelop (struct command *cmd) /* compare topmost double-values */
1975 {
1976 double a, b, c;
1977 struct stackentry *result;
1978
1979 b = pop (stNUMBER)->value;
1980 a = pop (stNUMBER)->value;
1981 switch (cmd->type) {
1982 case cEQ:
1983 c = (a == b);
1984 break;
1985 case cNE:
1986 c = (a != b);
1987 break;
1988 case cLE:
1989 c = (a <= b);
1990 break;
1991 case cLT:
1992 c = (a < b);
1993 break;
1994 case cGE:
1995 c = (a >= b);
1996 break;
1997 case cGT:
1998 c = (a > b);
1999 break;
2000 }
2001 result = push ();
2002 result->value = c;
2003 result->type = stNUMBER;
2004 }
2005
2006
2007 void
create_strrelop(char c)2008 create_strrelop (char c) /* create command strrelop */
2009 {
2010 int type;
2011
2012 switch (c) {
2013 case '=':
2014 type = cSTREQ;
2015 break;
2016 case '!':
2017 type = cSTRNE;
2018 break;
2019 case '<':
2020 type = cSTRLT;
2021 break;
2022 case '{':
2023 type = cSTRLE;
2024 break;
2025 case '>':
2026 type = cSTRGT;
2027 break;
2028 case '}':
2029 type = cSTRGE;
2030 break;
2031 }
2032 add_command (type);
2033 }
2034
2035
2036 void
strrelop(struct command * cmd)2037 strrelop (struct command *cmd) /* compare topmost string-values */
2038 {
2039 char *a, *b;
2040 double c;
2041 struct stackentry *result;
2042
2043 b = pop (stSTRING)->pointer;
2044 a = pop (stSTRING)->pointer;
2045 switch (cmd->type) {
2046 case cSTREQ:
2047 c = (strcmp (a, b) == 0);
2048 break;
2049 case cSTRNE:
2050 c = (strcmp (a, b) != 0);
2051 break;
2052 case cSTRLT:
2053 c = (strcmp (a, b) < 0);
2054 break;
2055 case cSTRLE:
2056 c = (strcmp (a, b) <= 0);
2057 break;
2058 case cSTRGT:
2059 c = (strcmp (a, b) > 0);
2060 break;
2061 case cSTRGE:
2062 c = (strcmp (a, b) >= 0);
2063 break;
2064 }
2065 result = push ();
2066 result->value = c;
2067 result->type = stNUMBER;
2068 }
2069
2070 void
switch_compare(void)2071 switch_compare (void) /* compare topmost values for switch statement */
2072 {
2073 struct stackentry *result, *first, *second;
2074 double r = 0.;
2075
2076 first = pop (stANY);
2077 second = stackhead->prev;
2078
2079 /* stSWITCH_STRING and stSWITCH_NUMBER compare true to any string or number */
2080 if ((second->type == stSWITCH_STRING || second->type == stSTRING)
2081 && first->type == stSTRING) {
2082 if (second->type == stSWITCH_STRING) {
2083 r = 1.;
2084 } else {
2085 r = (strcmp (first->pointer, second->pointer) == 0) ? 1. : 0.;
2086 }
2087 } else if ((second->type == stSWITCH_NUMBER || second->type == stNUMBER)
2088 && first->type == stNUMBER) {
2089 if (second->type == stSWITCH_NUMBER) {
2090 r = 1.;
2091 } else {
2092 r = (first->value == second->value) ? 1. : 0.;
2093 }
2094 } else {
2095 error (sERROR,
2096 "mixing strings and numbers in a single switch statement is not allowed");
2097 }
2098
2099 /* if comparison was successful once, remember this for all future comparisons */
2100 if (r == 1.) {
2101 if (second->type == stNUMBER) second->type=stSWITCH_NUMBER;
2102 if (second->type == stSTRING) second->type=stSWITCH_STRING;
2103 }
2104
2105 result = push ();
2106 result->type = stNUMBER;
2107 result->value = r;
2108 }
2109
2110
2111 void
logical_shortcut(struct command * cmd)2112 logical_shortcut (struct command *cmd) /* shortcut and/or if possible */
2113 {
2114 struct stackentry *result;
2115 double is;
2116
2117 is = stackhead->prev->value;
2118 if ((cmd->type == cORSHORT && is != 0)
2119 || (cmd->type == cANDSHORT && is == 0)) {
2120 result = push ();
2121 error (sDEBUG, "logical shortcut taken");
2122 result->type = stNUMBER;
2123 result->value = is;
2124 } else {
2125 currcmd = currcmd->next;
2126 }
2127 }
2128
2129
2130 void
create_boole(char c)2131 create_boole (char c) /* create command boole */
2132 {
2133 int type;
2134
2135 switch (c) {
2136 case '|':
2137 type = cOR;
2138 break;
2139 case '&':
2140 type = cAND;
2141 break;
2142 case '!':
2143 type = cNOT;
2144 break;
2145 }
2146 add_command (type);
2147 }
2148
2149
2150 void
boole(struct command * cmd)2151 boole (struct command *cmd) /* perform and/or/not */
2152 {
2153 int a, b, c;
2154 struct stackentry *result;
2155
2156 a = (int) pop (stNUMBER)->value;
2157 if (cmd->type == cNOT) {
2158 c = !a;
2159 } else {
2160 b = (int) pop (stNUMBER)->value;
2161 if (cmd->type == cAND) {
2162 c = a && b;
2163 } else {
2164 c = a || b;
2165 }
2166 }
2167 result = push ();
2168 result->value = c;
2169 result->type = stNUMBER;
2170 }
2171