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