1 /***************************************************************
2
3 bwb_var.c Variable-Handling Routines
4 for Bywater BASIC Interpreter
5
6 Copyright (c) 1993, Ted A. Campbell
7 Bywater Software
8
9 email: tcamp@delphi.com
10
11 Copyright and Permissions Information:
12
13 All U.S. and international rights are claimed by the author,
14 Ted A. Campbell.
15
16 This software is released under the terms of the GNU General
17 Public License (GPL), which is distributed with this software
18 in the file "COPYING". The GPL specifies the terms under
19 which users may copy and use the software in this distribution.
20
21 A separate license is available for commercial distribution,
22 for information on which you should contact the author.
23
24 ***************************************************************/
25
26 /*---------------------------------------------------------------*/
27 /* NOTE: Modifications marked "JBV" were made by Jon B. Volkoff, */
28 /* 11/1995 (eidetics@cerf.net). */
29 /* */
30 /* Those additionally marked with "DD" were at the suggestion of */
31 /* Dale DePriest (daled@cadence.com). */
32 /* */
33 /* Version 3.00 by Howard Wulf, AF5NE */
34 /* */
35 /* Version 3.10 by Howard Wulf, AF5NE */
36 /* */
37 /* Version 3.20 by Howard Wulf, AF5NE */
38 /* */
39 /*---------------------------------------------------------------*/
40
41
42
43 #include "bwbasic.h"
44
45
46 /* Prototypes for functions visible to this file only */
47
48 static void clear_virtual (VirtualType * Z);
49 static void clear_virtual_by_variable (VariableType * Variable);
50 static int dim_check (VariableType * variable);
51 static size_t dim_unit (VariableType * v, int *pp);
52 static LineType *dio_lrset (LineType * l, int rset);
53 static void field_clear (FieldType * Field);
54 static FieldType *field_new (void);
55 static VirtualType *find_virtual_by_variable (VariableType * Variable);
56 static LineType *internal_swap (LineType * l);
57 static VariableType *mat_islocal (char *buffer);
58 static VirtualType *new_virtual (void);
59 static int var_defx (LineType * l, int TypeCode);
60 static VariableType *var_islocal (char *buffer, int dimensions);
61 static void var_link_new_variable (VariableType * v);
62
63 extern int
var_init(void)64 var_init (void)
65 {
66 assert( My != NULL );
67
68 My->VariableHead = NULL;
69
70 return TRUE;
71 }
72
73 extern LineType *
bwb_COMMON(LineType * l)74 bwb_COMMON (LineType * l)
75 {
76 /*
77 SYNTAX: COMMON scalar
78 SYNTAX: COMMON matrix( dimnesions ) ' COMMON A(1), B(2), C(3)
79 SYNTAX: COMMON matrix( [, [,]] ) ' COMMON A(), B(,), C(,,)
80 */
81
82 assert (l != NULL);
83
84 do
85 {
86 int dimensions;
87 VariableType *variable;
88 char varname[NameLengthMax + 1];
89
90 dimensions = 0;
91 /* get variable name and find variable */
92 if (line_read_varname (l, varname) == FALSE)
93 {
94 WARN_SYNTAX_ERROR;
95 return (l);
96 }
97 if (line_skip_LparenChar (l))
98 {
99 line_skip_spaces (l); /* keep this */
100 if (bwb_isdigit (l->buffer[l->position]))
101 {
102 /* COMMON A(3) : DIM A( 5, 10, 20 ) */
103 if (line_read_integer_expression (l, &dimensions) == FALSE)
104 {
105 WARN_SYNTAX_ERROR;
106 return (l);
107 }
108 }
109 else
110 {
111 /* COMMON A(,,) : DIM A( 5, 10, 20 ) */
112 dimensions++;
113 while (line_skip_seperator (l));
114 {
115 dimensions++;
116 }
117 }
118 if (line_skip_RparenChar (l) == FALSE)
119 {
120 WARN_SYNTAX_ERROR;
121 return (l);
122 }
123 }
124 if ((variable = var_find (varname, dimensions, TRUE)) == NULL)
125 {
126 WARN_VARIABLE_NOT_DECLARED;
127 return (l);
128 }
129
130 /* mark as COMMON */
131 variable->VariableFlags |= VARIABLE_COMMON;
132 }
133 while (line_skip_seperator (l));
134
135 return (l);
136 }
137
138 extern LineType *
bwb_ERASE(LineType * l)139 bwb_ERASE (LineType * l)
140 {
141 /*
142 SYNTAX: ERASE variable [, ...] ' ERASE A, B, C
143 */
144
145 assert (l != NULL);
146 assert( My != NULL );
147
148 do
149 {
150 char varname[NameLengthMax + 1];
151
152 /* get variable name and find variable */
153
154 if (line_read_varname (l, varname))
155 {
156 /* erase all matching SCALAR and ARRAY variables */
157 int dimensions;
158
159 for (dimensions = 0; dimensions < MAX_DIMS; dimensions++)
160 {
161 VariableType *variable;
162
163 variable = var_find (varname, dimensions, FALSE);
164 if (variable != NULL)
165 {
166 /* found a variable */
167 VariableType *p; /* previous variable in linked list */
168
169 /* find then previous variable in chain */
170 if (variable == My->VariableHead)
171 {
172 /* free head */
173 My->VariableHead = variable->next;
174 variable->next = NULL;
175 var_free (variable);
176 }
177 else
178 {
179 /* free tail */
180 for (p = My->VariableHead; p != NULL && p->next != variable;
181 p = p->next)
182 {
183 ;
184 }
185 if (p == NULL)
186 {
187 /* this should never happen */
188 WARN_INTERNAL_ERROR;
189 return NULL;
190 }
191 if (p->next != variable)
192 {
193 /* this should never happen */
194 WARN_INTERNAL_ERROR;
195 return NULL;
196 }
197 /* reassign linkage */
198 p->next = variable->next;
199 variable->next = NULL;
200 var_free (variable);
201 }
202 }
203 }
204 }
205 }
206 while (line_skip_seperator (l));
207 return (l);
208 }
209
210 static LineType *
internal_swap(LineType * l)211 internal_swap (LineType * l)
212 {
213 VariableType *lhs;
214 VariableType *rhs;
215
216 assert (l != NULL);
217
218 if (line_skip_LparenChar (l))
219 {
220 /* optional */
221 }
222
223 /* get left variable */
224 if ((lhs = line_read_scalar (l)) == NULL)
225 {
226 WARN_SYNTAX_ERROR;
227 return (l);
228 }
229
230 /* get required comma */
231 if (line_skip_seperator (l) == FALSE)
232 {
233 WARN_SYNTAX_ERROR;
234 return (l);
235 }
236
237 /* get right variable */
238 if ((rhs = line_read_scalar (l)) == NULL)
239 {
240 WARN_SYNTAX_ERROR;
241 return (l);
242 }
243
244 if (line_skip_RparenChar (l))
245 {
246 /* optional */
247 }
248
249 /* check to be sure that both variables are compatible */
250 if (VAR_IS_STRING (rhs) != VAR_IS_STRING (lhs))
251 {
252 WARN_TYPE_MISMATCH;
253 return (l);
254 }
255
256 /* swap the values */
257 {
258 VariantType L;
259 VariantType R;
260 CLEAR_VARIANT (&L);
261 CLEAR_VARIANT (&R);
262
263 if (var_get (lhs, &L) == FALSE)
264 {
265 WARN_SYNTAX_ERROR;
266 return (l);
267 }
268 if (var_get (rhs, &R) == FALSE)
269 {
270 WARN_SYNTAX_ERROR;
271 return (l);
272 }
273
274 if (var_set (lhs, &R) == FALSE)
275 {
276 WARN_SYNTAX_ERROR;
277 return (l);
278 }
279 if (var_set (rhs, &L) == FALSE)
280 {
281 WARN_SYNTAX_ERROR;
282 return (l);
283 }
284 }
285 /* return */
286 return (l);
287 }
288
289 extern LineType *
bwb_EXCHANGE(LineType * l)290 bwb_EXCHANGE (LineType * l)
291 {
292 /*
293 SYNTAX: EXCHANGE variable, variable
294 SYNTAX: EXCHANGE ( variable, variable )
295 */
296
297 assert (l != NULL);
298 return internal_swap (l);
299 }
300
301
302
303 extern LineType *
bwb_SWAP(LineType * l)304 bwb_SWAP (LineType * l)
305 {
306 /*
307 SYNTAX: SWAP variable, variable
308 SYNTAX: SWAP ( variable, variable )
309 */
310
311 assert (l != NULL);
312 return internal_swap (l);
313 }
314
315 extern VariableType *
var_free(VariableType * variable)316 var_free (VariableType * variable)
317 {
318 /*
319 Release all the memory associated with a specific variable.
320 This function returns NULL, so you can use it like this:
321 variable = var_new(...);
322 ...
323 variable = var_free( variable );
324 */
325
326
327 if (variable != NULL)
328 {
329 if (variable->next != NULL)
330 {
331 /* This allows variable chains to be easily released. */
332 variable->next = var_free (variable->next);
333 }
334 /* cleanup this variable */
335 field_free_variable (variable);
336 clear_virtual_by_variable (variable);
337 if (VAR_IS_STRING (variable))
338 {
339 if (variable->Value.String != NULL)
340 {
341 int j;
342 for (j = 0; j < variable->array_units; j++)
343 {
344 if (variable->Value.String[j].sbuffer != NULL)
345 {
346 free (variable->Value.String[j].sbuffer);
347 }
348 variable->Value.String[j].length = 0;
349 }
350 free (variable->Value.String);
351 variable->Value.String = NULL;
352 }
353 }
354 else
355 {
356 if (variable->Value.Number != NULL)
357 {
358 free (variable->Value.Number);
359 variable->Value.Number = NULL;
360 }
361 }
362 free (variable);
363 }
364 return NULL;
365 }
366
367 extern void
var_CLEAR(void)368 var_CLEAR (void)
369 {
370 /*
371 free all variables except PRESET
372 */
373 VariableType *variable;
374 assert( My != NULL );
375
376
377 for (variable = My->VariableHead; variable != NULL;)
378 {
379 if (variable->VariableFlags & VARIABLE_PRESET)
380 {
381 /* keep */
382 variable = variable->next;
383 }
384 else if (variable == My->VariableHead)
385 {
386 /* free head */
387 My->VariableHead = variable->next;
388 variable->next = NULL;
389 var_free (variable);
390 variable = My->VariableHead;
391 }
392 else
393 {
394 /* free tail */
395 VariableType *z;
396 z = variable->next;
397 variable->next = NULL;
398 var_free (variable);
399 variable = z;
400 }
401 }
402 }
403
404 extern LineType *
bwb_CLEAR(LineType * l)405 bwb_CLEAR (LineType * l)
406 {
407 /*
408 SYNTAX: CLEAR
409 */
410
411 assert (l != NULL);
412 var_CLEAR ();
413 line_skip_eol (l);
414 return (l);
415 }
416
417
418 LineType *
bwb_CLR(LineType * l)419 bwb_CLR (LineType * l)
420 {
421
422 assert (l != NULL);
423 return bwb_CLEAR (l);
424 }
425
426 /***********************************************************
427
428 FUNCTION: var_delcvars()
429
430 DESCRIPTION: This function deletes all variables
431 in memory except those previously marked
432 as common.
433
434 ***********************************************************/
435
436 int
var_delcvars(void)437 var_delcvars (void)
438 {
439 VariableType *v;
440
441 assert( My != NULL );
442
443 for (v = My->VariableHead; v != NULL;)
444 {
445 if (v->VariableFlags & VARIABLE_PRESET)
446 {
447 /* keep */
448 v = v->next;
449 }
450 else if (v->VariableFlags & VARIABLE_COMMON)
451 {
452 /* keep */
453 v = v->next;
454 }
455 else if (v == My->VariableHead)
456 {
457 /* free head */
458 My->VariableHead = v->next;
459 v->next = NULL;
460 var_free (v);
461 v = My->VariableHead;
462 }
463 else
464 {
465 /* free tail */
466 VariableType *z; /* next variable */
467
468 z = v->next;
469 v->next = NULL;
470 var_free (v);
471 v = z;
472 }
473 }
474 return TRUE;
475 }
476
477 /***********************************************************
478
479 FUNCTION: bwb_mid()
480
481 DESCRIPTION: This function implements the BASIC
482 MID$ command.
483
484 Same as MID$ function, except it will set
485 the desired substring and not return its
486 value. Added by JBV 10/95
487
488 SYNTAX: MID$( string-variable$, start-position-in-string
489 [, number-of-spaces ] ) = expression
490
491 ***********************************************************/
492
493 LineType *
bwb_MID4(LineType * l)494 bwb_MID4 (LineType * l)
495 {
496 /* MID$( target$, start% [ , length% ] ) = source$ */
497 VariableType *variable;
498 VariantType target;
499 int start;
500 int length;
501 VariantType source;
502 int maxlen;
503
504 assert (l != NULL);
505
506 CLEAR_VARIANT (&source);
507 CLEAR_VARIANT (&target);
508 start = 0;
509 length = 0;
510 maxlen = 0;
511 if (line_skip_LparenChar (l) == FALSE)
512 {
513 WARN_SYNTAX_ERROR;
514 return (l);
515 }
516 if ((variable = line_read_scalar (l)) == NULL)
517 {
518 WARN_SYNTAX_ERROR;
519 return (l);
520 }
521 if (VAR_IS_STRING (variable))
522 {
523 /* OK */
524 }
525 else
526 {
527 /* ERROR */
528 WARN_TYPE_MISMATCH;
529 return (l);
530 }
531 if (var_get (variable, &target) == FALSE)
532 {
533 WARN_SYNTAX_ERROR;
534 return (l);
535 }
536 if (target.VariantTypeCode != StringTypeCode)
537 {
538 WARN_TYPE_MISMATCH;
539 return (l);
540 }
541 if (line_skip_seperator (l) == FALSE)
542 {
543 WARN_SYNTAX_ERROR;
544 return (l);
545 }
546 if (line_read_integer_expression (l, &start) == FALSE)
547 {
548 WARN_SYNTAX_ERROR;
549 return (l);
550 }
551 if (start < 1)
552 {
553 WARN_ILLEGAL_FUNCTION_CALL;
554 return (l);
555 }
556 if (start > target.Length)
557 {
558 WARN_ILLEGAL_FUNCTION_CALL;
559 return (l);
560 }
561 maxlen = 1 + target.Length - start;
562 if (line_skip_seperator (l))
563 {
564 if (line_read_integer_expression (l, &length) == FALSE)
565 {
566 WARN_SYNTAX_ERROR;
567 return (l);
568 }
569 if (length < 0)
570 {
571 WARN_ILLEGAL_FUNCTION_CALL;
572 return (l);
573 }
574 }
575 else
576 {
577 length = -1; /* MAGIC */
578 }
579 if (line_skip_RparenChar (l) == FALSE)
580 {
581 WARN_SYNTAX_ERROR;
582 return (l);
583 }
584 /* skip the equal sign */
585 if (line_skip_EqualChar (l) == FALSE)
586 {
587 WARN_SYNTAX_ERROR;
588 return (l);
589 }
590 if (line_read_expression (l, &source) == FALSE) /* bwb_MID4 */
591 {
592 WARN_SYNTAX_ERROR;
593 return (l);
594 }
595 if (source.VariantTypeCode != StringTypeCode)
596 {
597 WARN_TYPE_MISMATCH;
598 return (l);
599 }
600 if (length == -1 /* MAGIC */ )
601 {
602 length = source.Length;
603 }
604 length = MIN (length, maxlen);
605 length = MIN (length, source.Length);
606 if (length < 0)
607 {
608 WARN_INTERNAL_ERROR;
609 return (l);
610 }
611 if (length > 0)
612 {
613 int i;
614
615 start--; /* BASIC to C */
616 for (i = 0; i < length; i++)
617 {
618 target.Buffer[start + i] = source.Buffer[i];
619 }
620 target.Buffer[target.Length] = NulChar;
621 if (var_set (variable, &target) == FALSE)
622 {
623 WARN_SYNTAX_ERROR;
624 return (l);
625 }
626 }
627 RELEASE_VARIANT (&source);
628 RELEASE_VARIANT (&target);
629 return (l);
630 }
631
632
633 /***********************************************************
634
635 FUNCTION: bwb_ddbl()
636
637 DESCRIPTION: This function implements the BASIC
638 DEFDBL command.
639
640 SYNTAX: DEFDBL letter[-letter](, letter[-letter])...
641
642 ***********************************************************/
643
644 LineType *
bwb_DEFBYT(LineType * l)645 bwb_DEFBYT (LineType * l)
646 {
647 /*
648 DEFBYT letter[-letter](, letter[-letter])...
649 */
650
651 assert (l != NULL);
652 var_defx (l, ByteTypeCode);
653 return (l);
654 }
655
656 LineType *
bwb_DEFCUR(LineType * l)657 bwb_DEFCUR (LineType * l)
658 {
659 /*
660 DEFCUR letter[-letter](, letter[-letter])...
661 */
662
663 assert (l != NULL);
664 var_defx (l, CurrencyTypeCode);
665 return (l);
666 }
667
668 LineType *
bwb_DEFDBL(LineType * l)669 bwb_DEFDBL (LineType * l)
670 {
671 /*
672 DEFDBL letter[-letter](, letter[-letter])...
673 */
674
675 assert (l != NULL);
676 var_defx (l, DoubleTypeCode);
677 return (l);
678 }
679
680 /***********************************************************
681
682 FUNCTION: bwb_dint()
683
684 DESCRIPTION: This function implements the BASIC
685 DEFINT command.
686
687 SYNTAX: DEFINT letter[-letter](, letter[-letter])...
688
689 ***********************************************************/
690
691 LineType *
bwb_DEFINT(LineType * l)692 bwb_DEFINT (LineType * l)
693 {
694 /*
695 DEFINT letter[-letter](, letter[-letter])...
696 */
697
698 assert (l != NULL);
699 var_defx (l, IntegerTypeCode);
700 return (l);
701 }
702
703 LineType *
bwb_DEFLNG(LineType * l)704 bwb_DEFLNG (LineType * l)
705 {
706 /*
707 DEFLNG letter[-letter](, letter[-letter])...
708 */
709
710 assert (l != NULL);
711 var_defx (l, LongTypeCode);
712 return (l);
713 }
714
715 /***********************************************************
716
717 FUNCTION: bwb_dsng()
718
719 DESCRIPTION: This function implements the BASIC
720 DEFSNG command.
721
722 SYNTAX: DEFSNG letter[-letter](, letter[-letter])...
723
724 ***********************************************************/
725
726 LineType *
bwb_DEFSNG(LineType * l)727 bwb_DEFSNG (LineType * l)
728 {
729 /*
730 DEFSNG letter[-letter](, letter[-letter])...
731 */
732
733 assert (l != NULL);
734 var_defx (l, SingleTypeCode);
735 return (l);
736 }
737
738 /***********************************************************
739
740 FUNCTION: bwb_dstr()
741
742 DESCRIPTION: This function implements the BASIC
743 DEFSTR command.
744
745 SYNTAX: DEFSTR letter[-letter](, letter[-letter])...
746
747 ***********************************************************/
748
749 LineType *
bwb_DEFSTR(LineType * l)750 bwb_DEFSTR (LineType * l)
751 {
752 /*
753 DEFSTR letter[-letter](, letter[-letter])...
754 */
755
756 assert (l != NULL);
757 var_defx (l, StringTypeCode);
758 return (l);
759 }
760
761 LineType *
bwb_TEXT(LineType * l)762 bwb_TEXT (LineType * l)
763 {
764 /*
765 TEXT letter[-letter](, letter[-letter])...
766 */
767
768 assert (l != NULL);
769 var_defx (l, StringTypeCode);
770 return (l);
771 }
772
773 LineType *
bwb_TRACE(LineType * l)774 bwb_TRACE (LineType * l)
775 {
776 assert (l != NULL);
777
778 return bwb_TRACE_ON(l);
779 }
780
781 LineType *
bwb_TRACE_ON(LineType * l)782 bwb_TRACE_ON (LineType * l)
783 {
784 assert (l != NULL);
785 assert( My != NULL );
786 assert( My->SYSOUT != NULL );
787 assert( My->SYSOUT->cfp != NULL );
788
789 fprintf (My->SYSOUT->cfp, "Trace is ON\n");
790 ResetConsoleColumn ();
791 My->IsTraceOn = TRUE;
792
793 return (l);
794 }
795
796 LineType *
bwb_TRACE_OFF(LineType * l)797 bwb_TRACE_OFF (LineType * l)
798 {
799
800 assert (l != NULL);
801 assert( My != NULL );
802 assert( My->SYSOUT != NULL );
803 assert( My->SYSOUT->cfp != NULL );
804
805 fprintf (My->SYSOUT->cfp, "Trace is OFF\n");
806 ResetConsoleColumn ();
807 My->IsTraceOn = FALSE;
808
809 return (l);
810 }
811
812 int
VarTypeIndex(char C)813 VarTypeIndex (char C)
814 {
815
816 switch (C)
817 {
818 case 'A':
819 return 0;
820 case 'B':
821 return 1;
822 case 'C':
823 return 2;
824 case 'D':
825 return 3;
826 case 'E':
827 return 4;
828 case 'F':
829 return 5;
830 case 'G':
831 return 6;
832 case 'H':
833 return 7;
834 case 'I':
835 return 8;
836 case 'J':
837 return 9;
838 case 'K':
839 return 10;
840 case 'L':
841 return 11;
842 case 'M':
843 return 12;
844 case 'N':
845 return 13;
846 case 'O':
847 return 14;
848 case 'P':
849 return 15;
850 case 'Q':
851 return 16;
852 case 'R':
853 return 17;
854 case 'S':
855 return 18;
856 case 'T':
857 return 19;
858 case 'U':
859 return 20;
860 case 'V':
861 return 21;
862 case 'W':
863 return 22;
864 case 'X':
865 return 23;
866 case 'Y':
867 return 24;
868 case 'Z':
869 return 25;
870 case 'a':
871 return 0;
872 case 'b':
873 return 1;
874 case 'c':
875 return 2;
876 case 'd':
877 return 3;
878 case 'e':
879 return 4;
880 case 'f':
881 return 5;
882 case 'g':
883 return 6;
884 case 'h':
885 return 7;
886 case 'i':
887 return 8;
888 case 'j':
889 return 9;
890 case 'k':
891 return 10;
892 case 'l':
893 return 11;
894 case 'm':
895 return 12;
896 case 'n':
897 return 13;
898 case 'o':
899 return 14;
900 case 'p':
901 return 15;
902 case 'q':
903 return 16;
904 case 'r':
905 return 17;
906 case 's':
907 return 18;
908 case 't':
909 return 19;
910 case 'u':
911 return 20;
912 case 'v':
913 return 21;
914 case 'w':
915 return 22;
916 case 'x':
917 return 23;
918 case 'y':
919 return 24;
920 case 'z':
921 return 25;
922 }
923 return -1;
924 }
925
926 /***********************************************************
927
928 Function: var_defx()
929
930 DESCRIPTION: This function is a generalized DEFxxx handler.
931
932 ***********************************************************/
933
934 static int
var_defx(LineType * l,int TypeCode)935 var_defx (LineType * l, int TypeCode)
936 {
937 /*
938 DEFxxx letter[-letter](, letter[-letter])...
939 */
940
941 assert (l != NULL);
942 assert( My != NULL );
943 assert( My->DefaultVariableType != NULL );
944
945 do
946 {
947 char firstc;
948 char lastc;
949 int first;
950 int last;
951 int c;
952
953 /* find a sequence of letters for variables */
954 if (line_read_letter_sequence (l, &firstc, &lastc) == FALSE)
955 {
956 /* DEFINT 0-9 */
957 WARN_SYNTAX_ERROR;
958 return FALSE;
959 }
960 first = VarTypeIndex (firstc);
961 if (first < 0)
962 {
963 /* DEFINT 0-Z */
964 WARN_SYNTAX_ERROR;
965 return FALSE;
966 }
967 last = VarTypeIndex (lastc);
968 if (last < 0)
969 {
970 /* DEFINT A-9 */
971 WARN_SYNTAX_ERROR;
972 return FALSE;
973 }
974 if (first > last)
975 {
976 /* DEFINT Z-A */
977 WARN_SYNTAX_ERROR;
978 return FALSE;
979 }
980 for (c = first; c <= last; c++)
981 {
982 My->DefaultVariableType[c] = TypeCode; /* var_defx */
983 }
984 }
985 while (line_skip_seperator (l));
986
987 return TRUE;
988
989 }
990
991 /***************************************************************
992
993 FUNCTION: var_find()
994
995 DESCRIPTION: This C function attempts to find a variable
996 name matching the argument in buffer. If
997 it fails to find a matching name, it
998 sets up a new variable with that name.
999
1000 ***************************************************************/
1001
1002 VariableType *
mat_find(char * name)1003 mat_find (char *name)
1004 {
1005 /*
1006 similar to var_find, but returns the first matrix found
1007 */
1008 VariableType *v;
1009 assert( My != NULL );
1010
1011
1012 /* check for NULL variable name */
1013 if (name == NULL)
1014 {
1015 WARN_INTERNAL_ERROR;
1016 return NULL;
1017 }
1018 if (is_empty_string (name))
1019 {
1020 WARN_SYNTAX_ERROR;
1021 return NULL;
1022 }
1023 /* check for a local variable at this EXEC level */
1024
1025 v = mat_islocal (name);
1026 if (v != NULL)
1027 {
1028 return v;
1029 }
1030 /* now run through the global variable list and try to find a match */
1031 for (v = My->VariableHead; v != NULL; v = v->next)
1032 {
1033 assert( v != NULL );
1034 if (v->dimensions > 0)
1035 {
1036 if (bwb_stricmp (v->name, name) == 0)
1037 {
1038 return v;
1039 }
1040 }
1041 }
1042 return NULL;
1043 }
1044
1045 VariableType *
var_find(char * name,int dimensions,int IsImplicit)1046 var_find (char *name, int dimensions, int IsImplicit)
1047 {
1048 VariableType *v;
1049 int n;
1050
1051 assert( My != NULL );
1052 assert( My->CurrentVersion != NULL );
1053 assert( My->DefaultVariableType != NULL );
1054
1055 /* check for NULL variable name */
1056 if (name == NULL)
1057 {
1058 WARN_INTERNAL_ERROR;
1059 return NULL;
1060 }
1061 if (is_empty_string (name))
1062 {
1063 WARN_SYNTAX_ERROR;
1064 return NULL;
1065 }
1066 if (dimensions < 0)
1067 {
1068 WARN_INTERNAL_ERROR;
1069 return NULL;
1070 }
1071
1072 /* check for a local variable at this EXEC level */
1073
1074 v = var_islocal (name, dimensions);
1075 if (v != NULL)
1076 {
1077 return v;
1078 }
1079 /* now run through the global variable list and try to find a match */
1080 for (v = My->VariableHead; v != NULL; v = v->next)
1081 {
1082 assert( v != NULL );
1083 if (v->dimensions == dimensions)
1084 {
1085 if (bwb_stricmp (v->name, name) == 0)
1086 {
1087 return v;
1088 }
1089 }
1090 }
1091 if (IsImplicit == FALSE)
1092 {
1093 return NULL;
1094 }
1095 if (My->CurrentVersion->OptionFlags & OPTION_EXPLICIT_ON)
1096 {
1097 /* NO implicit creation - all variables must be created via DIM */
1098 WARN_VARIABLE_NOT_DECLARED;
1099 return NULL;
1100 }
1101 if (My->CurrentVersion->OptionFlags & OPTION_STRICT_ON)
1102 {
1103 if (dimensions > 0)
1104 {
1105 /* Implicit ARRAY is not allowed */
1106 WARN_VARIABLE_NOT_DECLARED;
1107 return NULL;
1108 }
1109 }
1110
1111 /* this is a IMPLICIT variable, so initialize it... */
1112
1113 /* initialize new variable */
1114 if ((v = (VariableType *) calloc (1, sizeof (VariableType))) == NULL)
1115 {
1116 WARN_OUT_OF_MEMORY;
1117 return NULL;
1118 }
1119
1120 /* copy the name into the appropriate structure */
1121
1122 assert( v != NULL );
1123 bwb_strcpy (v->name, name);
1124
1125 /* determine variable TypeCode */
1126 v->VariableTypeCode = var_nametype (name);
1127 if (v->VariableTypeCode == NulChar)
1128 {
1129 /* variable name has no declared TypeCode */
1130 n = VarTypeIndex (name[0]);
1131 if (n < 0)
1132 {
1133 v->VariableTypeCode = DoubleTypeCode; /* default */
1134 }
1135 else
1136 {
1137 v->VariableTypeCode = My->DefaultVariableType[n];
1138 }
1139 }
1140 v->VariableFlags = 0;
1141 v->dimensions = dimensions;
1142 v->array_units = 1;
1143 for (n = 0; n < v->dimensions; n++)
1144 {
1145 v->LBOUND[n] = My->CurrentVersion->OptionBaseInteger; /* implicit lower bound */
1146 v->UBOUND[n] = 10; /* implicit upper bound */
1147 if (v->UBOUND[n] < v->LBOUND[n])
1148 {
1149 WARN_SUBSCRIPT_OUT_OF_RANGE;
1150 return NULL;
1151 }
1152 v->VINDEX[n] = v->LBOUND[n];
1153 v->array_units *= v->UBOUND[n] - v->LBOUND[n] + 1;
1154 }
1155
1156 /* assign array memory */
1157 if (VAR_IS_STRING (v))
1158 {
1159 if ((v->Value.String =
1160 (StringType *) calloc (v->array_units, sizeof (StringType))) == NULL)
1161 {
1162 WARN_OUT_OF_MEMORY;
1163 return NULL;
1164 }
1165 }
1166 else
1167 {
1168 if ((v->Value.Number =
1169 (DoubleType *) calloc (v->array_units, sizeof (DoubleType))) == NULL)
1170 {
1171 WARN_OUT_OF_MEMORY;
1172 return NULL;
1173 }
1174 }
1175
1176 /* insert variable at the beginning of the variable chain */
1177 v->next = My->VariableHead;
1178 My->VariableHead = v;
1179 return v;
1180 }
1181
1182 /***************************************************************
1183
1184 FUNCTION: var_new()
1185
1186 DESCRIPTION: This function assigns memory for a new variable.
1187
1188 ***************************************************************/
1189
1190 VariableType *
var_new(char * name,char TypeCode)1191 var_new (char *name, char TypeCode)
1192 {
1193 VariableType *v;
1194
1195
1196 /* get memory for new variable */
1197
1198 if (name == NULL)
1199 {
1200 WARN_INTERNAL_ERROR;
1201 return NULL;
1202 }
1203 if (is_empty_string (name))
1204 {
1205 WARN_SYNTAX_ERROR;
1206 return NULL;
1207 }
1208 if ((v = (VariableType *) calloc (1, sizeof (VariableType))) == NULL)
1209 {
1210 WARN_OUT_OF_MEMORY;
1211 return NULL;
1212 }
1213 /* copy the name into the appropriate structure */
1214
1215 assert( v != NULL );
1216 bwb_strcpy (v->name, name);
1217
1218 /* set memory in the new variable */
1219 var_make (v, TypeCode);
1220
1221 /* and return */
1222
1223 return v;
1224
1225 }
1226
1227
1228 /***************************************************************
1229
1230 FUNCTION: bwb_dim()
1231
1232 DESCRIPTION: This function implements the BASIC DIM
1233 statement, allocating memory for a
1234 dimensioned array of variables.
1235
1236 SYNTAX: DIM variable(elements...)[,variable(elements...)]
1237
1238 ***************************************************************/
1239
1240 static void
var_link_new_variable(VariableType * v)1241 var_link_new_variable (VariableType * v)
1242 {
1243 /*
1244 We are called by DIM, so this is an explicitly created variable.
1245 There are only two possibilities:
1246 1. We are a LOCAL variable of a SUB or FUNCTION.
1247 2. We are a GLOBAL variable.
1248 */
1249
1250 assert (v != NULL);
1251 assert( My != NULL );
1252
1253 if (My->StackHead != NULL)
1254 {
1255 StackType *StackItem;
1256 for (StackItem = My->StackHead; StackItem != NULL;
1257 StackItem = StackItem->next)
1258 {
1259 if (StackItem->LoopTopLine != NULL)
1260 {
1261 switch (StackItem->LoopTopLine->cmdnum)
1262 {
1263 case C_FUNCTION:
1264 case C_SUB:
1265 /* we have found a FUNCTION or SUB boundary, must be LOCAL */
1266 v->next = StackItem->local_variable;
1267 StackItem->local_variable = v;
1268 return;
1269 /* break; */
1270 }
1271 }
1272 }
1273 }
1274 /* no FUNCTION or SUB on the stack, must be GLOBAL */
1275 v->next = My->VariableHead;
1276 My->VariableHead = v;
1277 }
1278
1279
1280 static VirtualType *
new_virtual(void)1281 new_virtual (void)
1282 {
1283 VirtualType *Z;
1284 assert( My != NULL );
1285
1286
1287 /* look for an empty slot */
1288 for (Z = My->VirtualHead; Z != NULL; Z = Z->next)
1289 {
1290 if (Z->Variable == NULL)
1291 {
1292 /* FOUND */
1293 return Z;
1294 }
1295 }
1296 /* NOT FOUND */
1297 if ((Z = (VirtualType *) calloc (1, sizeof (VirtualType))) == NULL)
1298 {
1299 WARN_OUT_OF_MEMORY;
1300 return NULL;
1301 }
1302 Z->next = My->VirtualHead;
1303 My->VirtualHead = Z;
1304 return Z;
1305 }
1306 static void
clear_virtual(VirtualType * Z)1307 clear_virtual (VirtualType * Z)
1308 {
1309
1310 assert (Z != NULL);
1311
1312 Z->Variable = NULL;
1313 Z->FileNumber = 0;
1314 Z->FileOffset = 0;
1315 Z->FileLength = 0;
1316 }
1317 static void
clear_virtual_by_variable(VariableType * Variable)1318 clear_virtual_by_variable (VariableType * Variable)
1319 {
1320 VirtualType *Z;
1321
1322 assert (Variable != NULL);
1323 assert( My != NULL );
1324
1325 for (Z = My->VirtualHead; Z != NULL; Z = Z->next)
1326 {
1327 if (Z->Variable == Variable)
1328 {
1329 /* FOUND */
1330 clear_virtual (Z);
1331 }
1332 }
1333 }
1334 extern void
clear_virtual_by_file(int FileNumber)1335 clear_virtual_by_file (int FileNumber)
1336 {
1337 /* called by file_clear() */
1338 VirtualType *Z;
1339
1340 assert( My != NULL );
1341
1342 for (Z = My->VirtualHead; Z != NULL; Z = Z->next)
1343 {
1344 if (Z->FileNumber == FileNumber)
1345 {
1346 /* FOUND */
1347 clear_virtual (Z);
1348 }
1349 }
1350 }
1351 static VirtualType *
find_virtual_by_variable(VariableType * Variable)1352 find_virtual_by_variable (VariableType * Variable)
1353 {
1354 VirtualType *Z;
1355
1356 assert (Variable != NULL);
1357 assert( My != NULL );
1358
1359 for (Z = My->VirtualHead; Z != NULL; Z = Z->next)
1360 {
1361 if (Z->Variable == Variable)
1362 {
1363 /* FOUND */
1364 return Z;
1365 }
1366 }
1367 /* NOT FOUND */
1368 return NULL;
1369 }
1370
1371 LineType *
bwb_LOCAL(LineType * l)1372 bwb_LOCAL (LineType * l)
1373 {
1374 /* only supported inside a FUNCTION or SUB */
1375
1376 assert (l != NULL);
1377 return bwb_DIM (l);
1378 }
1379
1380 LineType *
bwb_DIM(LineType * l)1381 bwb_DIM (LineType * l)
1382 {
1383 int FileNumber; /* the file might not be OPEN when the variable is declared */
1384 size_t FileOffset; /* from beginning of file */
1385 int FileLength; /* sizeof( DoubleType ) or Fixed String Length */
1386
1387 assert (l != NULL);
1388 assert( My != NULL );
1389 assert( My->DefaultVariableType != NULL );
1390
1391
1392 FileNumber = 0;
1393 FileOffset = 0;
1394 FileLength = 0;
1395 if (line_skip_FilenumChar (l))
1396 {
1397 /* DIM # filenum , ... */
1398 if (line_read_integer_expression (l, &FileNumber) == FALSE)
1399 {
1400 WARN_BAD_FILE_NUMBER;
1401 return (l);
1402 }
1403 if (FileNumber <= 0)
1404 {
1405 WARN_BAD_FILE_NUMBER;
1406 return (l);
1407 }
1408 if (line_skip_seperator (l) == FALSE)
1409 {
1410 WARN_BAD_FILE_NUMBER;
1411 return (l);
1412 }
1413 FileOffset = 0;
1414 FileLength = 0;
1415 }
1416
1417 do
1418 {
1419 VariableType *v;
1420 int n;
1421 int dimensions;
1422 int LBOUND[MAX_DIMS];
1423 int UBOUND[MAX_DIMS];
1424 char TypeCode;
1425 char varname[NameLengthMax + 1];
1426
1427
1428 /* Get variable name */
1429 if (line_read_varname (l, varname) == FALSE)
1430 {
1431 WARN_SYNTAX_ERROR;
1432 return (l);
1433 }
1434
1435 /* read parameters */
1436 dimensions = 0;
1437 if (line_peek_LparenChar (l))
1438 {
1439 if (line_read_array_redim (l, &dimensions, LBOUND, UBOUND) == FALSE)
1440 {
1441 WARN_SYNTAX_ERROR;
1442 return (l);
1443 }
1444 /* check array dimensions */
1445 for (n = 0; n < dimensions; n++)
1446 {
1447 if (UBOUND[n] < LBOUND[n])
1448 {
1449 WARN_SUBSCRIPT_OUT_OF_RANGE;
1450 return (l);
1451 }
1452 }
1453 }
1454
1455 /* determine variable TypeCode */
1456 TypeCode = var_nametype (varname);
1457 if (TypeCode == NulChar)
1458 {
1459 /* variable has no explicit TypeCode char */
1460 TypeCode = line_read_type_declaration (l); /* AS DOUBLE and so on */
1461 if (TypeCode == NulChar)
1462 {
1463 /* variable has no declared TypeCode */
1464 int i;
1465 i = VarTypeIndex (varname[0]);
1466 if (i < 0)
1467 {
1468 TypeCode = DoubleTypeCode; /* default */
1469 }
1470 else
1471 {
1472 TypeCode = My->DefaultVariableType[i];
1473 }
1474 }
1475 }
1476
1477 switch (TypeCode)
1478 {
1479 case ByteTypeCode:
1480 /* DIM # file_num , var_name AS BYTE */
1481 FileLength = sizeof (ByteType);
1482 break;
1483 case IntegerTypeCode:
1484 /* DIM # file_num , var_name AS INTEGER */
1485 FileLength = sizeof (IntegerType);
1486 break;
1487 case LongTypeCode:
1488 /* DIM # file_num , var_name AS LONG */
1489 FileLength = sizeof (LongType);
1490 break;
1491 case CurrencyTypeCode:
1492 /* DIM # file_num , var_name AS CURRENCY */
1493 FileLength = sizeof (CurrencyType);
1494 break;
1495 case SingleTypeCode:
1496 /* DIM # file_num , var_name AS SINGLE */
1497 FileLength = sizeof (SingleType);
1498 break;
1499 case DoubleTypeCode:
1500 /* DIM # file_num , var_name AS DOUBLE */
1501 FileLength = sizeof (DoubleType);
1502 break;
1503 case StringTypeCode:
1504 /* DIM # file_num , var_name AS STRING * fixed_length */
1505
1506 FileLength = 16; /* default */
1507 if (line_skip_StarChar (l) || line_skip_EqualChar (l))
1508 {
1509 /* optional fixed length */
1510 if (line_read_integer_expression (l, &FileLength) == FALSE)
1511 {
1512 WARN_SYNTAX_ERROR;
1513 return (l);
1514 }
1515 if (FileLength <= 0)
1516 {
1517 WARN_SYNTAX_ERROR;
1518 return (l);
1519 }
1520 if (FileLength > MAXLEN)
1521 {
1522 WARN_STRING_TOO_LONG; /* bwb_DIM */
1523 FileLength = MAXLEN;
1524 }
1525 }
1526 break;
1527 default:
1528 {
1529 WARN_INTERNAL_ERROR;
1530 return (l);
1531 }
1532 }
1533
1534 v = var_find (varname, dimensions, FALSE);
1535 if (v == NULL)
1536 {
1537 /* a new variable */
1538 if ((v = (VariableType *) calloc (1, sizeof (VariableType))) == NULL)
1539 {
1540 WARN_OUT_OF_MEMORY;
1541 return (l);
1542 }
1543 bwb_strcpy (v->name, varname);
1544 v->VariableTypeCode = TypeCode;
1545 /* assign array dimensions */
1546 v->dimensions = dimensions;
1547 for (n = 0; n < dimensions; n++)
1548 {
1549 v->LBOUND[n] = LBOUND[n];
1550 v->UBOUND[n] = UBOUND[n];
1551 }
1552 /* assign initial array position */
1553 for (n = 0; n < dimensions; n++)
1554 {
1555 v->VINDEX[n] = v->LBOUND[n];
1556 }
1557 /* calculate the array size */
1558 v->array_units = 1;
1559 for (n = 0; n < dimensions; n++)
1560 {
1561 v->array_units *= v->UBOUND[n] - v->LBOUND[n] + 1;
1562 }
1563 /* assign array memory */
1564
1565 if (FileNumber > 0)
1566 {
1567 /* the new variable is VIRTUAL */
1568 v->VariableFlags = VARIABLE_VIRTUAL;
1569 /* if( TRUE ) */
1570 {
1571 /* OK */
1572 VirtualType *Z;
1573 Z = find_virtual_by_variable (v);
1574 if (Z == NULL)
1575 {
1576 Z = new_virtual ();
1577 if (Z == NULL)
1578 {
1579 WARN_OUT_OF_MEMORY;
1580 return (l);
1581 }
1582 Z->Variable = v;
1583 }
1584 /* update file information */
1585 Z->FileNumber = FileNumber;
1586 Z->FileOffset = FileOffset;
1587 Z->FileLength = FileLength;
1588 FileOffset += FileLength * v->array_units;
1589 }
1590 }
1591 else if (VAR_IS_STRING (v))
1592 {
1593 if ((v->Value.String =
1594 (StringType *) calloc (v->array_units,
1595 sizeof (StringType))) == NULL)
1596 {
1597 WARN_OUT_OF_MEMORY;
1598 return (l);
1599 }
1600 }
1601 else
1602 {
1603 if ((v->Value.Number =
1604 (DoubleType *) calloc (v->array_units,
1605 sizeof (DoubleType))) == NULL)
1606 {
1607 WARN_OUT_OF_MEMORY;
1608 return (l);
1609 }
1610 }
1611 /* set place at beginning of variable chain */
1612 var_link_new_variable (v);
1613
1614 /* end of conditional for new variable */
1615 }
1616 else
1617 {
1618 /* old variable */
1619 if (v->VariableTypeCode != TypeCode)
1620 {
1621 WARN_TYPE_MISMATCH;
1622 return (l);
1623 }
1624
1625 /* check to be sure the number of dimensions is the same */
1626 if (v->dimensions != dimensions)
1627 {
1628 WARN_REDIMENSION_ARRAY;
1629 return (l);
1630 }
1631 /* check to be sure sizes for each dimension are the same */
1632 for (n = 0; n < dimensions; n++)
1633 {
1634 if (v->LBOUND[n] != LBOUND[n])
1635 {
1636 WARN_REDIMENSION_ARRAY;
1637 return (l);
1638 }
1639 if (v->UBOUND[n] != UBOUND[n])
1640 {
1641 WARN_REDIMENSION_ARRAY;
1642 return (l);
1643 }
1644 }
1645 if (FileNumber > 0)
1646 {
1647 /* the existing variable MUST be Virtual */
1648 if (v->VariableFlags & VARIABLE_VIRTUAL)
1649 {
1650 /* OK */
1651 VirtualType *Z;
1652 Z = find_virtual_by_variable (v);
1653 if (Z == NULL)
1654 {
1655 Z = new_virtual ();
1656 if (Z == NULL)
1657 {
1658 WARN_OUT_OF_MEMORY;
1659 return (l);
1660 }
1661 Z->Variable = v;
1662 }
1663 /* update file information */
1664 Z->FileNumber = FileNumber;
1665 Z->FileOffset = FileOffset;
1666 Z->FileLength = FileLength;
1667 FileOffset += FileLength * v->array_units;
1668 }
1669 else
1670 {
1671 /* the existing variable is NOT virtual */
1672 WARN_TYPE_MISMATCH;
1673 return (l);
1674 }
1675 }
1676 else
1677 {
1678 /* the existing variable CANNOT be Virtual */
1679 if (v->VariableFlags & VARIABLE_VIRTUAL)
1680 {
1681 /* the existing variable IS virtual */
1682 WARN_TYPE_MISMATCH;
1683 return (l);
1684 }
1685 else
1686 {
1687 /* OK */
1688 }
1689 }
1690 /* end of conditional for old variable */
1691 }
1692
1693 }
1694 while (line_skip_seperator (l));
1695
1696 /* return */
1697 return (l);
1698 }
1699
1700
1701
1702
1703 /***************************************************************
1704
1705 FUNCTION: dim_unit()
1706
1707 DESCRIPTION: This function calculates the unit
1708 position for an array.
1709
1710 ***************************************************************/
1711
1712 static size_t
dim_unit(VariableType * v,int * pp)1713 dim_unit (VariableType * v, int *pp)
1714 {
1715 size_t r;
1716 size_t b;
1717 int n;
1718
1719 assert (v != NULL);
1720 assert (pp != NULL);
1721
1722 /* Calculate and return the address of the dimensioned array */
1723
1724 /* Check EACH dimension for out-of-bounds, AND check correct number
1725 * of dimensions. NBS_P076_0250 errors correctly. */
1726
1727 /*
1728 Ux = Upper bound of dimension
1729 Lx = Lower bound of dimension
1730 Ix = Selected idex in dimension
1731
1732 dimensions b
1733 0 1
1734 1 b0 * ( U0 - L0 + 1 )
1735 2 b1 * ( U1 - L1 + 1 )
1736 3 b2 * ( U2 - L2 + 1 )
1737
1738
1739 dimensions r
1740 0 0
1741 1 r0 + ( I0 - L0 ) * b0
1742 2 r1 + ( I1 - L1 ) * b1
1743 3 r2 + ( I2 - L2 ) * b2
1744
1745 */
1746
1747 r = 0;
1748 b = 1;
1749 for (n = 0; n < v->dimensions; n++)
1750 {
1751 if (pp[n] < v->LBOUND[n] || pp[n] > v->UBOUND[n])
1752 {
1753 WARN_SUBSCRIPT_OUT_OF_RANGE;
1754 return 0;
1755 }
1756 r += b * (pp[n] - v->LBOUND[n]);
1757 b *= v->UBOUND[n] - v->LBOUND[n] + 1;
1758 }
1759
1760
1761 if (r > v->array_units)
1762 {
1763 WARN_SUBSCRIPT_OUT_OF_RANGE;
1764 return 0;
1765 }
1766 return r;
1767
1768 }
1769
1770
1771 /***************************************************************
1772
1773 FUNCTION: bwb_option()
1774
1775 DESCRIPTION: This function implements the BASIC OPTION
1776 BASE statement, designating the base (1 or
1777 0) for addressing DIM arrays.
1778
1779 SYNTAX: OPTION BASE number
1780
1781 ***************************************************************/
1782
1783 void
OptionVersionSet(int i)1784 OptionVersionSet (int i)
1785 {
1786 assert( i >= 0 && i < NUM_VERSIONS );
1787 assert( My != NULL );
1788
1789 My->CurrentVersion = &bwb_vertable[i];
1790 }
1791
1792 LineType *
bwb_OPTION(LineType * l)1793 bwb_OPTION (LineType * l)
1794 {
1795 assert (l != NULL);
1796
1797 WARN_SYNTAX_ERROR;
1798 return (l);
1799 }
1800
1801 LineType *
bwb_OPTION_ANGLE(LineType * l)1802 bwb_OPTION_ANGLE (LineType * l)
1803 {
1804 assert (l != NULL);
1805
1806 WARN_SYNTAX_ERROR;
1807 return (l);
1808 }
1809
1810 LineType *
bwb_OPTION_ANGLE_DEGREES(LineType * l)1811 bwb_OPTION_ANGLE_DEGREES (LineType * l)
1812 {
1813 assert (l != NULL);
1814 assert( My != NULL );
1815 assert( My->CurrentVersion != NULL );
1816
1817 /* OPTION ANGLE DEGREES */
1818 My->CurrentVersion->OptionFlags |= OPTION_ANGLE_DEGREES;
1819 My->CurrentVersion->OptionFlags &= ~OPTION_ANGLE_GRADIANS;
1820 return (l);
1821 }
1822
1823 LineType *
bwb_OPTION_ANGLE_GRADIANS(LineType * l)1824 bwb_OPTION_ANGLE_GRADIANS (LineType * l)
1825 {
1826 assert (l != NULL);
1827 assert( My != NULL );
1828 assert( My->CurrentVersion != NULL );
1829
1830 /* OPTION ANGLE GRADIANS */
1831 My->CurrentVersion->OptionFlags &= ~OPTION_ANGLE_DEGREES;
1832 My->CurrentVersion->OptionFlags |= OPTION_ANGLE_GRADIANS;
1833 return (l);
1834 }
1835
1836 LineType *
bwb_OPTION_ANGLE_RADIANS(LineType * l)1837 bwb_OPTION_ANGLE_RADIANS (LineType * l)
1838 {
1839 assert (l != NULL);
1840 assert( My != NULL );
1841 assert( My->CurrentVersion != NULL );
1842
1843 /* OPTION ANGLE RADIANS */
1844 My->CurrentVersion->OptionFlags &= ~OPTION_ANGLE_DEGREES;
1845 My->CurrentVersion->OptionFlags &= ~OPTION_ANGLE_GRADIANS;
1846 return (l);
1847 }
1848
1849 LineType *
bwb_OPTION_ARITHMETIC(LineType * l)1850 bwb_OPTION_ARITHMETIC (LineType * l)
1851 {
1852 assert (l != NULL);
1853 WARN_SYNTAX_ERROR;
1854 return (l);
1855 }
1856
1857 LineType *
bwb_OPTION_ARITHMETIC_DECIMAL(LineType * l)1858 bwb_OPTION_ARITHMETIC_DECIMAL (LineType * l)
1859 {
1860 /* OPTION ARITHMETIC DECIMAL */
1861 assert (l != NULL);
1862 return (l);
1863 }
1864
1865 LineType *
bwb_OPTION_ARITHMETIC_FIXED(LineType * l)1866 bwb_OPTION_ARITHMETIC_FIXED (LineType * l)
1867 {
1868 /* OPTION ARITHMETIC FIXED */
1869 assert (l != NULL);
1870 return (l);
1871 }
1872
1873 LineType *
bwb_OPTION_ARITHMETIC_NATIVE(LineType * l)1874 bwb_OPTION_ARITHMETIC_NATIVE (LineType * l)
1875 {
1876 /* OPTION ARITHMETIC NATIVE */
1877 assert (l != NULL);
1878 return (l);
1879 }
1880
1881 LineType *
bwb_OPTION_BASE(LineType * l)1882 bwb_OPTION_BASE (LineType * l)
1883 {
1884 /* OPTION BASE integer */
1885 assert (l != NULL);
1886 assert( My != NULL );
1887 assert( My->CurrentVersion != NULL );
1888
1889 return bwb_option_range_integer (l,
1890 &(My->CurrentVersion->OptionBaseInteger),
1891 MININT, MAXINT);
1892 }
1893
1894 LineType *
bwb_OPTION_BUGS(LineType * l)1895 bwb_OPTION_BUGS (LineType * l)
1896 {
1897 assert (l != NULL);
1898 WARN_SYNTAX_ERROR;
1899 return (l);
1900 }
1901
1902 LineType *
bwb_OPTION_BUGS_BOOLEAN(LineType * l)1903 bwb_OPTION_BUGS_BOOLEAN (LineType * l)
1904 {
1905 assert (l != NULL);
1906 assert( My != NULL );
1907 assert( My->CurrentVersion != NULL );
1908
1909 /* OPTION BUGS BOOLEAN */
1910 My->CurrentVersion->OptionFlags |= OPTION_BUGS_BOOLEAN;
1911 return (l);
1912 }
1913
1914 LineType *
bwb_OPTION_BUGS_ON(LineType * l)1915 bwb_OPTION_BUGS_ON (LineType * l)
1916 {
1917 assert (l != NULL);
1918 assert( My != NULL );
1919 assert( My->CurrentVersion != NULL );
1920
1921 /* OPTION BUGS ON */
1922 My->CurrentVersion->OptionFlags |= OPTION_BUGS_ON;
1923 return (l);
1924 }
1925
1926 LineType *
bwb_OPTION_BUGS_OFF(LineType * l)1927 bwb_OPTION_BUGS_OFF (LineType * l)
1928 {
1929 assert (l != NULL);
1930 assert( My != NULL );
1931 assert( My->CurrentVersion != NULL );
1932
1933 /* OPTION BUGS OFF */
1934 My->CurrentVersion->OptionFlags &= ~OPTION_BUGS_ON;
1935 My->CurrentVersion->OptionFlags &= ~OPTION_BUGS_BOOLEAN;
1936 return (l);
1937 }
1938
1939 LineType *
bwb_option_punct_char(LineType * l,char * c)1940 bwb_option_punct_char (LineType * l, char *c)
1941 {
1942 /* OPTION ... char$ */
1943
1944 assert (l != NULL);
1945 assert (c != NULL);
1946
1947 {
1948 char *Value;
1949 char C;
1950
1951 Value = NULL;
1952 if (line_read_string_expression (l, &Value) == FALSE)
1953 {
1954 WARN_SYNTAX_ERROR;
1955 return (l);
1956 }
1957 if (Value == NULL)
1958 {
1959 WARN_SYNTAX_ERROR;
1960 return (l);
1961 }
1962 C = Value[0];
1963 free (Value);
1964 /* OK */
1965 if (bwb_ispunct (C))
1966 {
1967 /* enable */
1968 *c = C;
1969 }
1970 else
1971 {
1972 /* disable */
1973 *c = NulChar;
1974 }
1975 }
1976 return (l);
1977 }
1978
1979 LineType *
bwb_option_range_integer(LineType * l,int * Integer,int MinVal,int MaxVal)1980 bwb_option_range_integer (LineType * l, int *Integer, int MinVal, int MaxVal)
1981 {
1982 /* OPTION ... integer */
1983
1984 assert (l != NULL);
1985 assert (Integer != NULL);
1986 assert (MinVal < MaxVal);
1987
1988 {
1989 int Value;
1990
1991 Value = 0;
1992 if (line_read_integer_expression (l, &Value) == FALSE)
1993 {
1994 WARN_SYNTAX_ERROR;
1995 return (l);
1996 }
1997 if (Value < MinVal || Value > MaxVal)
1998 {
1999 WARN_ILLEGAL_FUNCTION_CALL;
2000 return (l);
2001 }
2002 *Integer = Value;
2003 }
2004 return (l);
2005 }
2006
2007 LineType *
bwb_OPTION_PUNCT_COMMENT(LineType * l)2008 bwb_OPTION_PUNCT_COMMENT (LineType * l)
2009 {
2010 /* OPTION PUNCT COMMENT char$ */
2011 assert (l != NULL);
2012 assert( My != NULL );
2013 assert( My->CurrentVersion != NULL );
2014
2015 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionCommentChar));
2016 }
2017
2018 LineType *
bwb_OPTION_COMPARE(LineType * l)2019 bwb_OPTION_COMPARE (LineType * l)
2020 {
2021 assert (l != NULL);
2022 WARN_SYNTAX_ERROR;
2023 return (l);
2024 }
2025
2026 LineType *
bwb_OPTION_COMPARE_BINARY(LineType * l)2027 bwb_OPTION_COMPARE_BINARY (LineType * l)
2028 {
2029 assert (l != NULL);
2030 assert( My != NULL );
2031 assert( My->CurrentVersion != NULL );
2032
2033 /* OPTION COMPARE BINARY */
2034 My->CurrentVersion->OptionFlags &= ~OPTION_COMPARE_TEXT;
2035 return (l);
2036 }
2037
2038 LineType *
bwb_OPTION_COMPARE_DATABASE(LineType * l)2039 bwb_OPTION_COMPARE_DATABASE (LineType * l)
2040 {
2041 assert (l != NULL);
2042 assert( My != NULL );
2043 assert( My->CurrentVersion != NULL );
2044
2045 /* OPTION COMPARE DATABASE */
2046 My->CurrentVersion->OptionFlags |= OPTION_COMPARE_TEXT;
2047 return (l);
2048 }
2049
2050 LineType *
bwb_OPTION_COMPARE_TEXT(LineType * l)2051 bwb_OPTION_COMPARE_TEXT (LineType * l)
2052 {
2053 assert (l != NULL);
2054 assert( My != NULL );
2055 assert( My->CurrentVersion != NULL );
2056
2057 /* OPTION COMPARE TEXT */
2058 My->CurrentVersion->OptionFlags |= OPTION_COMPARE_TEXT;
2059 return (l);
2060 }
2061
2062 LineType *
bwb_OPTION_COVERAGE(LineType * l)2063 bwb_OPTION_COVERAGE (LineType * l)
2064 {
2065 assert (l != NULL);
2066 WARN_SYNTAX_ERROR;
2067 return (l);
2068 }
2069
2070 LineType *
bwb_OPTION_COVERAGE_ON(LineType * l)2071 bwb_OPTION_COVERAGE_ON (LineType * l)
2072 {
2073 assert (l != NULL);
2074 assert( My != NULL );
2075 assert( My->CurrentVersion != NULL );
2076
2077 /* OPTION COVERAGE ON */
2078 My->CurrentVersion->OptionFlags |= OPTION_COVERAGE_ON;
2079 return (l);
2080 }
2081
2082 LineType *
bwb_OPTION_COVERAGE_OFF(LineType * l)2083 bwb_OPTION_COVERAGE_OFF (LineType * l)
2084 {
2085 assert (l != NULL);
2086 assert( My != NULL );
2087 assert( My->CurrentVersion != NULL );
2088
2089 /* OPTION COVERAGE OFF */
2090 My->CurrentVersion->OptionFlags &= ~OPTION_COVERAGE_ON;
2091 return (l);
2092 }
2093
2094 LineType *
bwb_OPTION_DATE(LineType * l)2095 bwb_OPTION_DATE (LineType * l)
2096 {
2097 /* OPTION DATE format$ */
2098 char *Value;
2099
2100 assert (l != NULL);
2101 assert( My != NULL );
2102 assert( My->CurrentVersion != NULL );
2103
2104
2105 Value = NULL;
2106 if (line_read_string_expression (l, &Value) == FALSE)
2107 {
2108 WARN_SYNTAX_ERROR;
2109 return (l);
2110 }
2111 if (Value == NULL)
2112 {
2113 WARN_SYNTAX_ERROR;
2114 return (l);
2115 }
2116 /* OK */
2117 My->CurrentVersion->OptionDateFormat = Value;
2118 #if FALSE /* keep this ... */
2119 /*
2120 ** Yes, this can theoretically cause a memory leak.
2121 ** No, we are not going to fix it.
2122 ** This command is only supported in the profile.
2123 ** This will only execute at most once,
2124 ** so there is no actual memory leak.
2125 **
2126 */
2127 free (Value);
2128 #endif
2129 return (l);
2130 }
2131
2132 LineType *
bwb_OPTION_DIGITS(LineType * l)2133 bwb_OPTION_DIGITS (LineType * l)
2134 {
2135 int Value;
2136
2137 assert (l != NULL);
2138 assert( My != NULL );
2139
2140 /* OPTION DIGITS integer */
2141 Value = 0;
2142 if (line_read_integer_expression (l, &Value))
2143 {
2144 /* OK */
2145 if (Value == 0)
2146 {
2147 /* default */
2148 Value = SIGNIFICANT_DIGITS;
2149 }
2150 if (Value < MINIMUM_DIGITS || Value > MAXIMUM_DIGITS)
2151 {
2152 WARN_ILLEGAL_FUNCTION_CALL;
2153 return (l);
2154 }
2155 My->OptionDigitsInteger = Value;
2156 }
2157 return (l);
2158 }
2159
2160 LineType *
bwb_OPTION_DISABLE(LineType * l)2161 bwb_OPTION_DISABLE (LineType * l)
2162 {
2163 assert (l != NULL);
2164 WARN_SYNTAX_ERROR;
2165 return (l);
2166 }
2167
2168 LineType *
bwb_OPTION_DISABLE_COMMAND(LineType * l)2169 bwb_OPTION_DISABLE_COMMAND (LineType * l)
2170 {
2171 /* OPTION DISABLE COMMAND name$ */
2172 int IsFound;
2173 char *Value;
2174
2175 assert (l != NULL);
2176 assert( My != NULL );
2177 assert( My->CurrentVersion != NULL );
2178
2179
2180 IsFound = FALSE;
2181 Value = NULL;
2182
2183 /* Get COMMAND */
2184 if (line_read_string_expression (l, &Value) == FALSE)
2185 {
2186 WARN_SYNTAX_ERROR;
2187 return (l);
2188 }
2189 if (Value == NULL)
2190 {
2191 WARN_SYNTAX_ERROR;
2192 return (l);
2193 }
2194 /* OK */
2195 {
2196 /* Name */
2197 int i;
2198 for (i = 0; i < NUM_COMMANDS; i++)
2199 {
2200 if (bwb_stricmp (Value, IntrinsicCommandTable[i].name) == 0)
2201 {
2202 /* FOUND */
2203 /* DISABLE COMMAND */
2204 IntrinsicCommandTable[i].OptionVersionBitmask &=
2205 ~My->CurrentVersion->OptionVersionValue;
2206 IsFound = TRUE;
2207 }
2208 }
2209 }
2210 free (Value);
2211 if (IsFound == FALSE)
2212 {
2213 /* display warning message */
2214 fprintf (My->SYSOUT->cfp, "IGNORED: %s\n", l->buffer);
2215 ResetConsoleColumn ();
2216 }
2217 return (l);
2218 }
2219
2220
2221 LineType *
bwb_OPTION_DISABLE_FUNCTION(LineType * l)2222 bwb_OPTION_DISABLE_FUNCTION (LineType * l)
2223 {
2224 /* OPTION DISABLE FUNCTION name$ */
2225 int IsFound;
2226
2227 assert (l != NULL);
2228 assert( My != NULL );
2229 assert( My->CurrentVersion != NULL );
2230
2231
2232 IsFound = FALSE;
2233 /* Get FUNCTION */
2234 {
2235 char *Value;
2236
2237 Value = NULL;
2238 if (line_read_string_expression (l, &Value) == FALSE)
2239 {
2240 WARN_SYNTAX_ERROR;
2241 return (l);
2242 }
2243 if (Value == NULL)
2244 {
2245 WARN_SYNTAX_ERROR;
2246 return (l);
2247 }
2248 /* OK */
2249 {
2250 /* Name */
2251 int i;
2252 for (i = 0; i < NUM_FUNCTIONS; i++)
2253 {
2254 if (bwb_stricmp (Value, IntrinsicFunctionTable[i].Name) == 0)
2255 {
2256 /* FOUND */
2257 /* DISABLE FUNCTION */
2258 IntrinsicFunctionTable[i].OptionVersionBitmask &=
2259 ~My->CurrentVersion->OptionVersionValue;
2260 IsFound = TRUE;
2261 }
2262 }
2263 }
2264 free (Value);
2265 }
2266 if (IsFound == FALSE)
2267 {
2268 /* display warning message */
2269 fprintf (My->SYSOUT->cfp, "IGNORED: %s\n", l->buffer);
2270 ResetConsoleColumn ();
2271 }
2272 return (l);
2273 }
2274
2275 LineType *
bwb_OPTION_EDIT(LineType * l)2276 bwb_OPTION_EDIT (LineType * l)
2277 {
2278 /* OPTION EDIT string$ */
2279 char *Value;
2280
2281 assert (l != NULL);
2282 assert( My != NULL );
2283
2284 Value = NULL;
2285 if (line_read_string_expression (l, &Value) == FALSE)
2286 {
2287 WARN_SYNTAX_ERROR;
2288 return (l);
2289 }
2290 if (Value == NULL)
2291 {
2292 WARN_SYNTAX_ERROR;
2293 return (l);
2294 }
2295 /* OK */
2296 My->OptionEditString = Value;
2297 #if FALSE /* keep this ... */
2298 /*
2299 ** Yes, this can theoretically cause a memory leak.
2300 ** No, we are not going to fix it.
2301 ** This command is only supported in the profile.
2302 ** This will only execute at most once,
2303 ** so there is no actual memory leak.
2304 **
2305 */
2306 free (Value);
2307 #endif
2308 return (l);
2309 }
2310
2311 LineType *
bwb_OPTION_EXTENSION(LineType * l)2312 bwb_OPTION_EXTENSION (LineType * l)
2313 {
2314 /* OPTION EXTENSION ext$ */
2315 char *Value;
2316
2317 assert (l != NULL);
2318 assert( My != NULL );
2319
2320 Value = NULL;
2321 if (line_read_string_expression (l, &Value) == FALSE)
2322 {
2323 WARN_SYNTAX_ERROR;
2324 return (l);
2325 }
2326 if (Value == NULL)
2327 {
2328 WARN_SYNTAX_ERROR;
2329 return (l);
2330 }
2331 /* OK */
2332 My->OptionExtensionString = Value;
2333 #if FALSE /* keep this ... */
2334 /*
2335 ** Yes, this can theoretically cause a memory leak.
2336 ** No, we are not going to fix it.
2337 ** This command is only supported in the profile.
2338 ** This command will only execute at most once,
2339 ** so there is no actual memory leak.
2340 **
2341 */
2342 free (Value);
2343 #endif
2344 return (l);
2345 }
2346
2347 LineType *
bwb_OPTION_FILES(LineType * l)2348 bwb_OPTION_FILES (LineType * l)
2349 {
2350 /* OPTION FILES name$ */
2351 char *Value;
2352
2353 assert (l != NULL);
2354 assert( My != NULL );
2355
2356
2357 Value = NULL;
2358 if (line_read_string_expression (l, &Value) == FALSE)
2359 {
2360 WARN_SYNTAX_ERROR;
2361 return (l);
2362 }
2363 if (Value == NULL)
2364 {
2365 WARN_SYNTAX_ERROR;
2366 return (l);
2367 }
2368 /* OK */
2369 My->OptionFilesString = Value;
2370 #if FALSE /* keep this ... */
2371 /*
2372 ** Yes, this can theoretically cause a memory leak.
2373 ** No, we are not going to fix it.
2374 ** This command is only supported in the profile.
2375 ** This will only execute at most once,
2376 ** so there is no actual memory leak.
2377 **
2378 */
2379 free (Value);
2380 #endif
2381 return (l);
2382 }
2383
2384 LineType *
bwb_OPTION_PROMPT(LineType * l)2385 bwb_OPTION_PROMPT (LineType * l)
2386 {
2387 /* OPTION PROMPT prompt$ */
2388 char *Value;
2389
2390 assert (l != NULL);
2391 assert( My != NULL );
2392
2393
2394 Value = NULL;
2395 if (line_read_string_expression (l, &Value) == FALSE)
2396 {
2397 WARN_SYNTAX_ERROR;
2398 return (l);
2399 }
2400 if (Value == NULL)
2401 {
2402 WARN_SYNTAX_ERROR;
2403 return (l);
2404 }
2405 /* OK */
2406 My->OptionPromptString = Value;
2407 #if FALSE /* keep this ... */
2408 /*
2409 ** Yes, this can theoretically cause a memory leak.
2410 ** No, we are not going to fix it.
2411 ** This command is only supported in the profile.
2412 ** This will only execute at most once,
2413 ** so there is no actual memory leak.
2414 **
2415 */
2416 free (Value);
2417 #endif
2418 return (l);
2419 }
2420
2421 LineType *
bwb_OPTION_RENUM(LineType * l)2422 bwb_OPTION_RENUM (LineType * l)
2423 {
2424 /* OPTION RENUM name$ */
2425 char *Value;
2426
2427 assert (l != NULL);
2428 assert( My != NULL );
2429
2430
2431 Value = NULL;
2432 if (line_read_string_expression (l, &Value) == FALSE)
2433 {
2434 WARN_SYNTAX_ERROR;
2435 return (l);
2436 }
2437 if (Value == NULL)
2438 {
2439 WARN_SYNTAX_ERROR;
2440 return (l);
2441 }
2442 /* OK */
2443 My->OptionRenumString = Value;
2444 #if FALSE /* keep this ... */
2445 /*
2446 ** Yes, this can theoretically cause a memory leak.
2447 ** No, we are not going to fix it.
2448 ** This command is only supported in the profile.
2449 ** This will only execute at most once,
2450 ** so there is no actual memory leak.
2451 **
2452 */
2453 free (Value);
2454 #endif
2455 return (l);
2456 }
2457
2458 LineType *
bwb_OPTION_ENABLE(LineType * l)2459 bwb_OPTION_ENABLE (LineType * l)
2460 {
2461 assert (l != NULL);
2462 WARN_SYNTAX_ERROR;
2463 return (l);
2464 }
2465
2466 LineType *
bwb_OPTION_ENABLE_COMMAND(LineType * l)2467 bwb_OPTION_ENABLE_COMMAND (LineType * l)
2468 {
2469 /* OPTION ENABLE COMMAND name$ */
2470 int IsFound;
2471
2472 assert (l != NULL);
2473 assert( My != NULL );
2474 assert( My->CurrentVersion != NULL );
2475
2476
2477 IsFound = FALSE;
2478 /* Get COMMAND */
2479 {
2480 char *Value;
2481
2482 Value = NULL;
2483 if (line_read_string_expression (l, &Value) == FALSE)
2484 {
2485 WARN_SYNTAX_ERROR;
2486 return (l);
2487 }
2488 if (Value == NULL)
2489 {
2490 WARN_SYNTAX_ERROR;
2491 return (l);
2492 }
2493 /* OK */
2494 {
2495 /* Name */
2496 int i;
2497 for (i = 0; i < NUM_COMMANDS; i++)
2498 {
2499 if (bwb_stricmp (Value, IntrinsicCommandTable[i].name) == 0)
2500 {
2501 /* FOUND */
2502 /* ENABLE COMMAND */
2503 IntrinsicCommandTable[i].OptionVersionBitmask |=
2504 My->CurrentVersion->OptionVersionValue;
2505 IsFound = TRUE;
2506 }
2507 }
2508 }
2509 free (Value);
2510 }
2511 if (IsFound == FALSE)
2512 {
2513 /* display warning message */
2514 fprintf (My->SYSOUT->cfp, "IGNORED: %s\n", l->buffer);
2515 ResetConsoleColumn ();
2516 }
2517 return (l);
2518 }
2519
2520 LineType *
bwb_OPTION_ENABLE_FUNCTION(LineType * l)2521 bwb_OPTION_ENABLE_FUNCTION (LineType * l)
2522 {
2523 /* OPTION ENABLE FUNCTION name$ */
2524 int IsFound;
2525
2526 assert (l != NULL);
2527 assert( My != NULL );
2528 assert( My->CurrentVersion != NULL );
2529
2530
2531 IsFound = FALSE;
2532 /* Get FUNCTION */
2533 {
2534 char *Value;
2535
2536 Value = NULL;
2537 if (line_read_string_expression (l, &Value) == FALSE)
2538 {
2539 WARN_SYNTAX_ERROR;
2540 return (l);
2541 }
2542 if (Value == NULL)
2543 {
2544 WARN_SYNTAX_ERROR;
2545 return (l);
2546 }
2547 /* OK */
2548 {
2549 /* Name */
2550 int i;
2551 for (i = 0; i < NUM_FUNCTIONS; i++)
2552 {
2553 if (bwb_stricmp (Value, IntrinsicFunctionTable[i].Name) == 0)
2554 {
2555 /* FOUND */
2556 /* ENABLE FUNCTION */
2557 IntrinsicFunctionTable[i].OptionVersionBitmask |=
2558 My->CurrentVersion->OptionVersionValue;
2559 IsFound = TRUE;
2560 }
2561 }
2562 }
2563 free (Value);
2564 }
2565 if (IsFound == FALSE)
2566 {
2567 /* display warning message */
2568 fprintf (My->SYSOUT->cfp, "IGNORED: %s\n", l->buffer);
2569 ResetConsoleColumn ();
2570 }
2571 return (l);
2572 }
2573
2574 LineType *
bwb_OPTION_ERROR(LineType * l)2575 bwb_OPTION_ERROR (LineType * l)
2576 {
2577 assert (l != NULL);
2578 WARN_SYNTAX_ERROR;
2579 return (l);
2580 }
2581
2582 LineType *
bwb_OPTION_ERROR_GOSUB(LineType * l)2583 bwb_OPTION_ERROR_GOSUB (LineType * l)
2584 {
2585 /* OPTION ERROR GOSUB */
2586 assert (l != NULL);
2587 assert( My != NULL );
2588 assert( My->CurrentVersion != NULL );
2589
2590 My->CurrentVersion->OptionFlags |= OPTION_ERROR_GOSUB;
2591 return (l);
2592 }
2593
2594 LineType *
bwb_OPTION_ERROR_GOTO(LineType * l)2595 bwb_OPTION_ERROR_GOTO (LineType * l)
2596 {
2597 /* OPTION ERROR GOTO */
2598 assert (l != NULL);
2599 assert( My != NULL );
2600 assert( My->CurrentVersion != NULL );
2601
2602 My->CurrentVersion->OptionFlags &= ~OPTION_ERROR_GOSUB;
2603 return (l);
2604 }
2605
2606 LineType *
bwb_OPTION_EXPLICIT(LineType * l)2607 bwb_OPTION_EXPLICIT (LineType * l)
2608 {
2609 /* OPTION EXPLICIT */
2610 assert (l != NULL);
2611 assert( My != NULL );
2612 assert( My->CurrentVersion != NULL );
2613
2614 My->CurrentVersion->OptionFlags |= OPTION_EXPLICIT_ON;
2615 return (l);
2616 }
2617
2618
2619 LineType *
bwb_OPTION_PUNCT_IMAGE(LineType * l)2620 bwb_OPTION_PUNCT_IMAGE (LineType * l)
2621 {
2622 /* OPTION PUNCT IMAGE char$ */
2623 assert (l != NULL);
2624 assert( My != NULL );
2625 assert( My->CurrentVersion != NULL );
2626
2627 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionImageChar));
2628 }
2629
2630 LineType *
bwb_OPTION_IMPLICIT(LineType * l)2631 bwb_OPTION_IMPLICIT (LineType * l)
2632 {
2633 /* OPTION IMPLICIT */
2634 assert (l != NULL);
2635 assert( My != NULL );
2636 assert( My->CurrentVersion != NULL );
2637
2638 My->CurrentVersion->OptionFlags &= ~OPTION_EXPLICIT_ON;
2639 return (l);
2640 }
2641
2642 LineType *
bwb_OPTION_INDENT(LineType * l)2643 bwb_OPTION_INDENT (LineType * l)
2644 {
2645 /* OPTION INDENT integer */
2646 assert (l != NULL);
2647 assert( My != NULL );
2648
2649 return bwb_option_range_integer (l, &(My->OptionIndentInteger), 0, 7);
2650 }
2651
2652 LineType *
bwb_OPTION_PUNCT_INPUT(LineType * l)2653 bwb_OPTION_PUNCT_INPUT (LineType * l)
2654 {
2655 /* OPTION PUNCT INPUT char$ */
2656 assert (l != NULL);
2657 assert( My != NULL );
2658 assert( My->CurrentVersion != NULL );
2659
2660 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionInputChar));
2661 }
2662
2663 LineType *
bwb_OPTION_LABELS(LineType * l)2664 bwb_OPTION_LABELS (LineType * l)
2665 {
2666 assert (l != NULL);
2667 WARN_SYNTAX_ERROR;
2668 return (l);
2669 }
2670
2671 LineType *
bwb_OPTION_LABELS_ON(LineType * l)2672 bwb_OPTION_LABELS_ON (LineType * l)
2673 {
2674 assert (l != NULL);
2675 assert( My != NULL );
2676 assert( My->CurrentVersion != NULL );
2677
2678 /* OPTION LABELS ON */
2679 My->CurrentVersion->OptionFlags |= OPTION_LABELS_ON;
2680 return (l);
2681 }
2682
2683 LineType *
bwb_OPTION_LABELS_OFF(LineType * l)2684 bwb_OPTION_LABELS_OFF (LineType * l)
2685 {
2686 assert (l != NULL);
2687 assert( My != NULL );
2688 assert( My->CurrentVersion != NULL );
2689
2690 /* OPTION LABELS OFF */
2691 My->CurrentVersion->OptionFlags &= ~OPTION_LABELS_ON;
2692 return (l);
2693 }
2694
2695 LineType *
bwb_OPTION_PUNCT_PRINT(LineType * l)2696 bwb_OPTION_PUNCT_PRINT (LineType * l)
2697 {
2698 /* OPTION PUNCT PRINT char$ */
2699 assert (l != NULL);
2700 assert( My != NULL );
2701 assert( My->CurrentVersion != NULL );
2702
2703 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionPrintChar));
2704 }
2705
2706 LineType *
bwb_OPTION_PUNCT_QUOTE(LineType * l)2707 bwb_OPTION_PUNCT_QUOTE (LineType * l)
2708 {
2709 /* OPTION PUNCT QUOTE char$ */
2710 assert (l != NULL);
2711 assert( My != NULL );
2712 assert( My->CurrentVersion != NULL );
2713
2714 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionQuoteChar));
2715 }
2716
2717 LineType *
bwb_OPTION_ROUND(LineType * l)2718 bwb_OPTION_ROUND (LineType * l)
2719 {
2720 assert (l != NULL);
2721 WARN_SYNTAX_ERROR;
2722 return (l);
2723 }
2724
2725 LineType *
bwb_OPTION_ROUND_BANK(LineType * l)2726 bwb_OPTION_ROUND_BANK (LineType * l)
2727 {
2728 /* OPTION ROUND BANK */
2729 assert (l != NULL);
2730 assert( My != NULL );
2731
2732 My->OptionRoundType = C_OPTION_ROUND_BANK;
2733 return (l);
2734 }
2735
2736 LineType *
bwb_OPTION_ROUND_MATH(LineType * l)2737 bwb_OPTION_ROUND_MATH (LineType * l)
2738 {
2739 /* OPTION ROUND MATH */
2740 assert (l != NULL);
2741 assert( My != NULL );
2742
2743 My->OptionRoundType = C_OPTION_ROUND_MATH;
2744 return (l);
2745 }
2746
2747 LineType *
bwb_OPTION_ROUND_TRUNCATE(LineType * l)2748 bwb_OPTION_ROUND_TRUNCATE (LineType * l)
2749 {
2750 /* OPTION ROUND TRUNCATE */
2751 assert (l != NULL);
2752 assert( My != NULL );
2753
2754 My->OptionRoundType = C_OPTION_ROUND_TRUNCATE;
2755 return (l);
2756 }
2757
2758 LineType *
bwb_OPTION_SCALE(LineType * l)2759 bwb_OPTION_SCALE (LineType * l)
2760 {
2761 /* OPTION SCALE integer */
2762 assert (l != NULL);
2763 assert( My != NULL );
2764
2765 return bwb_option_range_integer (l, &(My->OptionScaleInteger),
2766 MINIMUM_SCALE, MAXIMUM_SCALE);
2767 }
2768
2769
2770 LineType *
bwb_OPTION_SLEEP(LineType * l)2771 bwb_OPTION_SLEEP (LineType * l)
2772 {
2773 /* OPTION SLEEP number */
2774 assert (l != NULL);
2775 assert( My != NULL );
2776
2777 if (line_read_numeric_expression (l, &My->OptionSleepDouble) == FALSE)
2778 {
2779 WARN_SYNTAX_ERROR;
2780 return (l);
2781 }
2782 return (l);
2783 }
2784
2785 LineType *
bwb_OPTION_STDERR(LineType * l)2786 bwb_OPTION_STDERR (LineType * l)
2787 {
2788 /* OPTION STDERR filename$ */
2789
2790 assert (l != NULL);
2791 assert( My != NULL );
2792 assert( My->SYSPRN != NULL );
2793 assert( My->SYSPRN->cfp != NULL );
2794
2795
2796 if (line_is_eol (l))
2797 {
2798 bwb_fclose (My->SYSPRN->cfp);
2799 My->SYSPRN->cfp = stderr;
2800 }
2801 else
2802 {
2803 char *Value;
2804
2805 Value = NULL;
2806 if (line_read_string_expression (l, &Value) == FALSE)
2807 {
2808 WARN_SYNTAX_ERROR;
2809 return (l);
2810 }
2811 if (Value == NULL)
2812 {
2813 WARN_SYNTAX_ERROR;
2814 return (l);
2815 }
2816 /* OK */
2817 if (is_empty_string (Value))
2818 {
2819 bwb_fclose (My->SYSPRN->cfp);
2820 My->SYSPRN->cfp = stderr;
2821 }
2822 else
2823 {
2824 bwb_fclose (My->SYSPRN->cfp);
2825 My->SYSPRN->cfp = fopen (Value, "w+");
2826 if (My->SYSPRN->cfp == NULL)
2827 {
2828 /* sane default */
2829 My->SYSPRN->cfp = stderr;
2830 WARN_BAD_FILE_NAME;
2831 }
2832 }
2833 free (Value);
2834 }
2835 return (l);
2836 }
2837
2838 LineType *
bwb_OPTION_STDIN(LineType * l)2839 bwb_OPTION_STDIN (LineType * l)
2840 {
2841 /* OPTION STDIN filename$ */
2842
2843 assert (l != NULL);
2844 assert( My != NULL );
2845 assert( My->SYSIN != NULL );
2846 assert( My->SYSIN->cfp != NULL );
2847
2848 if (line_is_eol (l))
2849 {
2850 bwb_fclose (My->SYSIN->cfp);
2851 My->SYSIN->cfp = stdin;
2852 }
2853 else
2854 {
2855 char *Value;
2856
2857 Value = NULL;
2858 if (line_read_string_expression (l, &Value) == FALSE)
2859 {
2860 WARN_SYNTAX_ERROR;
2861 return (l);
2862 }
2863 if (Value == NULL)
2864 {
2865 WARN_SYNTAX_ERROR;
2866 return (l);
2867 }
2868 /* OK */
2869 if (is_empty_string (Value))
2870 {
2871 bwb_fclose (My->SYSIN->cfp);
2872 My->SYSIN->cfp = stdin;
2873 }
2874 else
2875 {
2876 bwb_fclose (My->SYSIN->cfp);
2877 My->SYSIN->cfp = fopen (Value, "r");
2878 if (My->SYSIN->cfp == NULL)
2879 {
2880 /* sane default */
2881 My->SYSIN->cfp = stdin;
2882 WARN_BAD_FILE_NAME;
2883 }
2884 }
2885 free (Value);
2886 }
2887 return (l);
2888 }
2889
2890 LineType *
bwb_OPTION_STDOUT(LineType * l)2891 bwb_OPTION_STDOUT (LineType * l)
2892 {
2893 /* OPTION STDOUT filename$ */
2894
2895 assert (l != NULL);
2896 assert( My != NULL );
2897 assert( My->SYSOUT != NULL );
2898 assert( My->SYSOUT->cfp != NULL );
2899
2900 if (line_is_eol (l))
2901 {
2902 bwb_fclose (My->SYSOUT->cfp);
2903 My->SYSOUT->cfp = stdout;
2904 }
2905 else
2906 {
2907 char *Value;
2908
2909 Value = NULL;
2910 if (line_read_string_expression (l, &Value) == FALSE)
2911 {
2912 WARN_SYNTAX_ERROR;
2913 return (l);
2914 }
2915 if (Value == NULL)
2916 {
2917 WARN_SYNTAX_ERROR;
2918 return (l);
2919 }
2920 /* OK */
2921 if (is_empty_string (Value))
2922 {
2923 bwb_fclose (My->SYSOUT->cfp);
2924 My->SYSOUT->cfp = stdout;
2925 }
2926 else
2927 {
2928 bwb_fclose (My->SYSOUT->cfp);
2929 My->SYSOUT->cfp = fopen (Value, "w+");
2930 if (My->SYSOUT->cfp == NULL)
2931 {
2932 /* sane default */
2933 My->SYSOUT->cfp = stdout;
2934 WARN_BAD_FILE_NAME;
2935 }
2936 }
2937 free (Value);
2938 }
2939 return (l);
2940 }
2941
2942 LineType *
bwb_OPTION_PUNCT_STATEMENT(LineType * l)2943 bwb_OPTION_PUNCT_STATEMENT (LineType * l)
2944 {
2945 /* OPTION PUNCT STATEMENT char$ */
2946 assert (l != NULL);
2947 assert( My != NULL );
2948 assert( My->CurrentVersion != NULL );
2949
2950 return bwb_option_punct_char (l,
2951 &(My->CurrentVersion->OptionStatementChar));
2952 }
2953
2954 LineType *
bwb_OPTION_STRICT(LineType * l)2955 bwb_OPTION_STRICT (LineType * l)
2956 {
2957 assert (l != NULL);
2958 WARN_SYNTAX_ERROR;
2959 return (l);
2960 }
2961
2962 LineType *
bwb_OPTION_STRICT_ON(LineType * l)2963 bwb_OPTION_STRICT_ON (LineType * l)
2964 {
2965 assert (l != NULL);
2966 assert( My != NULL );
2967 assert( My->CurrentVersion != NULL );
2968
2969 /* OPTION STRICT ON */
2970 My->CurrentVersion->OptionFlags |= OPTION_STRICT_ON;
2971 return (l);
2972 }
2973
2974 LineType *
bwb_OPTION_STRICT_OFF(LineType * l)2975 bwb_OPTION_STRICT_OFF (LineType * l)
2976 {
2977 assert (l != NULL);
2978 assert( My != NULL );
2979 assert( My->CurrentVersion != NULL );
2980
2981 /* OPTION STRICT OFF */
2982 My->CurrentVersion->OptionFlags &= ~OPTION_STRICT_ON;
2983 return (l);
2984 }
2985
2986 LineType *
bwb_OPTION_PUNCT(LineType * l)2987 bwb_OPTION_PUNCT (LineType * l)
2988 {
2989 assert (l != NULL);
2990 WARN_SYNTAX_ERROR;
2991 return (l);
2992 }
2993
2994 LineType *
bwb_OPTION_PUNCT_STRING(LineType * l)2995 bwb_OPTION_PUNCT_STRING (LineType * l)
2996 {
2997 /* OPTION PUNCT STRING char$ */
2998 assert (l != NULL);
2999 assert( My != NULL );
3000 assert( My->CurrentVersion != NULL );
3001
3002 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionStringChar));
3003 }
3004
3005 LineType *
bwb_OPTION_PUNCT_DOUBLE(LineType * l)3006 bwb_OPTION_PUNCT_DOUBLE (LineType * l)
3007 {
3008 /* OPTION PUNCT DOUBLE char$ */
3009 assert (l != NULL);
3010 assert( My != NULL );
3011 assert( My->CurrentVersion != NULL );
3012
3013 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionDoubleChar));
3014 }
3015
3016 LineType *
bwb_OPTION_PUNCT_SINGLE(LineType * l)3017 bwb_OPTION_PUNCT_SINGLE (LineType * l)
3018 {
3019 /* OPTION PUNCT SINGLE char$ */
3020 assert (l != NULL);
3021 assert( My != NULL );
3022 assert( My->CurrentVersion != NULL );
3023
3024 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionSingleChar));
3025 }
3026
3027 LineType *
bwb_OPTION_PUNCT_CURRENCY(LineType * l)3028 bwb_OPTION_PUNCT_CURRENCY (LineType * l)
3029 {
3030 /* OPTION PUNCT CURRENCY char$ */
3031 assert (l != NULL);
3032 assert( My != NULL );
3033 assert( My->CurrentVersion != NULL );
3034
3035 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionCurrencyChar));
3036 }
3037
3038 LineType *
bwb_OPTION_PUNCT_LONG(LineType * l)3039 bwb_OPTION_PUNCT_LONG (LineType * l)
3040 {
3041 /* OPTION PUNCT LONG char$ */
3042 assert (l != NULL);
3043 assert( My != NULL );
3044 assert( My->CurrentVersion != NULL );
3045
3046 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionLongChar));
3047 }
3048
3049 LineType *
bwb_OPTION_PUNCT_INTEGER(LineType * l)3050 bwb_OPTION_PUNCT_INTEGER (LineType * l)
3051 {
3052 /* OPTION PUNCT INTEGER char$ */
3053 assert (l != NULL);
3054 assert( My != NULL );
3055 assert( My->CurrentVersion != NULL );
3056
3057 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionIntegerChar));
3058 }
3059
3060 LineType *
bwb_OPTION_PUNCT_BYTE(LineType * l)3061 bwb_OPTION_PUNCT_BYTE (LineType * l)
3062 {
3063 /* OPTION PUNCT BYTE char$ */
3064 assert (l != NULL);
3065 assert( My != NULL );
3066 assert( My->CurrentVersion != NULL );
3067
3068 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionByteChar));
3069 }
3070
3071 LineType *
bwb_OPTION_PUNCT_LPAREN(LineType * l)3072 bwb_OPTION_PUNCT_LPAREN (LineType * l)
3073 {
3074 /* OPTION PUNCT LPAREN char$ */
3075 assert (l != NULL);
3076 assert( My != NULL );
3077 assert( My->CurrentVersion != NULL );
3078
3079 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionLparenChar));
3080 }
3081
3082 LineType *
bwb_OPTION_PUNCT_RPAREN(LineType * l)3083 bwb_OPTION_PUNCT_RPAREN (LineType * l)
3084 {
3085 /* OPTION PUNCT RPAREN char$ */
3086 assert (l != NULL);
3087 assert( My != NULL );
3088 assert( My->CurrentVersion != NULL );
3089
3090 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionRparenChar));
3091 }
3092
3093 LineType *
bwb_OPTION_PUNCT_FILENUM(LineType * l)3094 bwb_OPTION_PUNCT_FILENUM (LineType * l)
3095 {
3096 /* OPTION PUNCT FILENUM char$ */
3097 assert (l != NULL);
3098 assert( My != NULL );
3099 assert( My->CurrentVersion != NULL );
3100
3101 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionFilenumChar));
3102 }
3103
3104 LineType *
bwb_OPTION_PUNCT_AT(LineType * l)3105 bwb_OPTION_PUNCT_AT (LineType * l)
3106 {
3107 /* OPTION PUNCT AT char$ */
3108 assert (l != NULL);
3109 assert( My != NULL );
3110 assert( My->CurrentVersion != NULL );
3111
3112 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionAtChar));
3113 }
3114
3115 LineType *
bwb_OPTION_RECLEN(LineType * l)3116 bwb_OPTION_RECLEN (LineType * l)
3117 {
3118 /* OPTION RECLEN integer */
3119 assert (l != NULL);
3120 assert( My != NULL );
3121 assert( My->CurrentVersion != NULL );
3122
3123 return bwb_option_range_integer (l,
3124 &(My->CurrentVersion->OptionReclenInteger),
3125 0, MAXINT);
3126 }
3127
3128 LineType *
bwb_OPTION_TERMINAL(LineType * l)3129 bwb_OPTION_TERMINAL (LineType * l)
3130 {
3131 assert (l != NULL);
3132 WARN_SYNTAX_ERROR;
3133 return (l);
3134 }
3135
3136 LineType *
bwb_OPTION_TERMINAL_NONE(LineType * l)3137 bwb_OPTION_TERMINAL_NONE (LineType * l)
3138 {
3139 /* OPTION TERMINAL NONE */
3140 assert (l != NULL);
3141 assert( My != NULL );
3142
3143 My->OptionTerminalType = C_OPTION_TERMINAL_NONE;
3144 return (l);
3145 }
3146
3147 LineType *
bwb_OPTION_TERMINAL_ADM(LineType * l)3148 bwb_OPTION_TERMINAL_ADM (LineType * l)
3149 {
3150 /* OPTION TERMINAL ADM-3A */
3151 assert (l != NULL);
3152 assert( My != NULL );
3153
3154 My->OptionTerminalType = C_OPTION_TERMINAL_ADM;
3155 return (l);
3156 }
3157
3158 LineType *
bwb_OPTION_TERMINAL_ANSI(LineType * l)3159 bwb_OPTION_TERMINAL_ANSI (LineType * l)
3160 {
3161 /* OPTION TERMINAL ANSI */
3162 assert (l != NULL);
3163 assert( My != NULL );
3164
3165 My->OptionTerminalType = C_OPTION_TERMINAL_ANSI;
3166 return (l);
3167 }
3168
3169 LineType *
bwb_OPTION_TIME(LineType * l)3170 bwb_OPTION_TIME (LineType * l)
3171 {
3172 /* OPTION TIME format$ */
3173 char *Value;
3174
3175 assert (l != NULL);
3176 assert( My != NULL );
3177 assert( My->CurrentVersion != NULL );
3178
3179 Value = NULL;
3180 if (line_read_string_expression (l, &Value) == FALSE)
3181 {
3182 WARN_SYNTAX_ERROR;
3183 return (l);
3184 }
3185 if (Value == NULL)
3186 {
3187 WARN_SYNTAX_ERROR;
3188 return (l);
3189 }
3190 /* OK */
3191 My->CurrentVersion->OptionTimeFormat = Value;
3192 #if FALSE /* keep this ... */
3193 /*
3194 ** Yes, this can theoretically cause a memory leak.
3195 ** No, we are not going to fix it.
3196 ** This command is only supported in the profile.
3197 ** This will only execute at most once,
3198 ** so there is no actual memory leak.
3199 **
3200 */
3201 free (Value);
3202 #endif
3203 return (l);
3204 }
3205
3206 LineType *
bwb_OPTION_TRACE(LineType * l)3207 bwb_OPTION_TRACE (LineType * l)
3208 {
3209
3210 assert (l != NULL);
3211 WARN_SYNTAX_ERROR;
3212 return (l);
3213 }
3214
3215 LineType *
bwb_OPTION_TRACE_ON(LineType * l)3216 bwb_OPTION_TRACE_ON (LineType * l)
3217 {
3218 /* OPTION TRACE ON */
3219 assert (l != NULL);
3220 assert( My != NULL );
3221 assert( My->CurrentVersion != NULL );
3222
3223 My->CurrentVersion->OptionFlags |= OPTION_TRACE_ON;
3224 return (l);
3225 }
3226
3227 LineType *
bwb_OPTION_TRACE_OFF(LineType * l)3228 bwb_OPTION_TRACE_OFF (LineType * l)
3229 {
3230 /* OPTION TRACE OFF */
3231 assert (l != NULL);
3232 assert( My != NULL );
3233 assert( My->CurrentVersion != NULL );
3234
3235 My->CurrentVersion->OptionFlags &= ~OPTION_TRACE_ON;
3236 return (l);
3237 }
3238
3239 LineType *
bwb_OPTION_USING(LineType * l)3240 bwb_OPTION_USING (LineType * l)
3241 {
3242 assert (l != NULL);
3243 WARN_SYNTAX_ERROR;
3244 return (l);
3245 }
3246
3247 LineType *
bwb_OPTION_USING_DIGIT(LineType * l)3248 bwb_OPTION_USING_DIGIT (LineType * l)
3249 {
3250 /* OPTION USING DIGIT char$ */
3251 assert (l != NULL);
3252 assert( My != NULL );
3253 assert( My->CurrentVersion != NULL );
3254
3255 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionUsingDigit));
3256 }
3257
3258 LineType *
bwb_OPTION_USING_COMMA(LineType * l)3259 bwb_OPTION_USING_COMMA (LineType * l)
3260 {
3261 /* OPTION USING COMMA char$ */
3262 assert (l != NULL);
3263 assert( My != NULL );
3264 assert( My->CurrentVersion != NULL );
3265
3266 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionUsingComma));
3267 }
3268
3269 LineType *
bwb_OPTION_USING_PERIOD(LineType * l)3270 bwb_OPTION_USING_PERIOD (LineType * l)
3271 {
3272 /* OPTION USING PERIOD char$ */
3273 assert (l != NULL);
3274 assert( My != NULL );
3275 assert( My->CurrentVersion != NULL );
3276
3277 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionUsingPeriod));
3278 }
3279
3280 LineType *
bwb_OPTION_USING_PLUS(LineType * l)3281 bwb_OPTION_USING_PLUS (LineType * l)
3282 {
3283 /* OPTION USING PLUS char$ */
3284 assert (l != NULL);
3285 assert( My != NULL );
3286 assert( My->CurrentVersion != NULL );
3287
3288 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionUsingPlus));
3289 }
3290
3291 LineType *
bwb_OPTION_USING_MINUS(LineType * l)3292 bwb_OPTION_USING_MINUS (LineType * l)
3293 {
3294 /* OPTION USING MINUS char$ */
3295 assert (l != NULL);
3296 assert( My != NULL );
3297 assert( My->CurrentVersion != NULL );
3298
3299 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionUsingMinus));
3300 }
3301
3302 LineType *
bwb_OPTION_USING_EXRAD(LineType * l)3303 bwb_OPTION_USING_EXRAD (LineType * l)
3304 {
3305 /* OPTION USING EXRAD char$ */
3306 assert (l != NULL);
3307 assert( My != NULL );
3308 assert( My->CurrentVersion != NULL );
3309
3310 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionUsingExrad));
3311 }
3312
3313 LineType *
bwb_OPTION_USING_DOLLAR(LineType * l)3314 bwb_OPTION_USING_DOLLAR (LineType * l)
3315 {
3316 /* OPTION USING DOLLAR char$ */
3317 assert (l != NULL);
3318 assert( My != NULL );
3319 assert( My->CurrentVersion != NULL );
3320
3321 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionUsingDollar));
3322 }
3323
3324 LineType *
bwb_OPTION_USING_FILLER(LineType * l)3325 bwb_OPTION_USING_FILLER (LineType * l)
3326 {
3327 /* OPTION USING FILLER char$ */
3328 assert (l != NULL);
3329 assert( My != NULL );
3330 assert( My->CurrentVersion != NULL );
3331
3332 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionUsingFiller));
3333 }
3334
3335 LineType *
bwb_OPTION_USING_LITERAL(LineType * l)3336 bwb_OPTION_USING_LITERAL (LineType * l)
3337 {
3338 /* OPTION USING LITERAL char$ */
3339 assert (l != NULL);
3340 assert( My != NULL );
3341 assert( My->CurrentVersion != NULL );
3342
3343 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionUsingLiteral));
3344 }
3345
3346 LineType *
bwb_OPTION_USING_FIRST(LineType * l)3347 bwb_OPTION_USING_FIRST (LineType * l)
3348 {
3349 /* OPTION USING FIRST char$ */
3350 assert (l != NULL);
3351 assert( My != NULL );
3352 assert( My->CurrentVersion != NULL );
3353
3354 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionUsingFirst));
3355 }
3356
3357 LineType *
bwb_OPTION_USING_ALL(LineType * l)3358 bwb_OPTION_USING_ALL (LineType * l)
3359 {
3360 /* OPTION USING ALL char$ */
3361 assert (l != NULL);
3362 assert( My != NULL );
3363 assert( My->CurrentVersion != NULL );
3364
3365 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionUsingAll));
3366 }
3367
3368 LineType *
bwb_OPTION_USING_LENGTH(LineType * l)3369 bwb_OPTION_USING_LENGTH (LineType * l)
3370 {
3371 /* OPTION USING LENGTH char$ */
3372 assert (l != NULL);
3373 assert( My != NULL );
3374 assert( My->CurrentVersion != NULL );
3375
3376 return bwb_option_punct_char (l, &(My->CurrentVersion->OptionUsingLength));
3377 }
3378
3379 extern LineType *
bwb_OPTION_VERSION(LineType * l)3380 bwb_OPTION_VERSION (LineType * l)
3381 {
3382 /* OPTION VERSION [version$] */
3383 char *Name;
3384 int i;
3385
3386 assert (l != NULL);
3387 assert( My != NULL );
3388 assert( My->SYSOUT != NULL );
3389 assert( My->SYSOUT->cfp != NULL );
3390
3391
3392 Name = NULL;
3393 if (line_is_eol (l))
3394 {
3395 /* OPTIONAL */
3396 }
3397 else if (line_read_string_expression (l, &Name))
3398 {
3399 if (is_empty_string (Name) == FALSE)
3400 {
3401 /* a version was specified */
3402 for (i = 0; i < NUM_VERSIONS; i++)
3403 {
3404 if (bwb_stricmp (Name, bwb_vertable[i].Name) == 0)
3405 {
3406 /* FOUND */
3407 OptionVersionSet (i);
3408 return (l);
3409 }
3410 }
3411 /* NOT FOUND */
3412 fprintf (My->SYSOUT->cfp, "OPTION VERSION \"%s\" IS INVALID\n", Name);
3413 }
3414 }
3415 fprintf (My->SYSOUT->cfp, "VALID CHOICES ARE:\n");
3416 for (i = 0; i < NUM_VERSIONS; i++)
3417 {
3418 char *tbuf;
3419
3420 tbuf = My->ConsoleOutput;
3421 bwb_strcpy (tbuf, "\"");
3422 bwb_strcat (tbuf, bwb_vertable[i].Name);
3423 bwb_strcat (tbuf, "\"");
3424 fprintf (My->SYSOUT->cfp, "OPTION VERSION %-16s ' %s\n", tbuf,
3425 bwb_vertable[i].Description);
3426 }
3427 ResetConsoleColumn ();
3428 line_skip_eol (l);
3429 return (l);
3430 }
3431
3432 LineType *
bwb_OPTION_ZONE(LineType * l)3433 bwb_OPTION_ZONE (LineType * l)
3434 {
3435 /* OPTION ZONE integer */
3436 int Value;
3437
3438 assert (l != NULL);
3439 assert( My != NULL );
3440
3441 Value = 0;
3442 if (line_read_integer_expression (l, &Value))
3443 {
3444 /* OK */
3445 if (Value == 0)
3446 {
3447 /* default */
3448 Value = ZONE_WIDTH;
3449 }
3450 if (Value < MINIMUM_ZONE || Value > MAXIMUM_ZONE)
3451 {
3452 WARN_ILLEGAL_FUNCTION_CALL;
3453 return (l);
3454 }
3455 My->OptionZoneInteger = Value;
3456 }
3457 return (l);
3458 }
3459
3460
3461
3462 int
var_get(VariableType * variable,VariantType * variant)3463 var_get (VariableType * variable, VariantType * variant)
3464 {
3465 size_t offset;
3466
3467 /* check sanity */
3468 if (variable == NULL)
3469 {
3470 WARN_INTERNAL_ERROR;
3471 return FALSE;
3472 }
3473 if (variant == NULL)
3474 {
3475 WARN_INTERNAL_ERROR;
3476 return FALSE;
3477 }
3478
3479 /* Check subscripts */
3480 if (dim_check (variable) == FALSE)
3481 {
3482 WARN_SUBSCRIPT_OUT_OF_RANGE;
3483 return FALSE;
3484 }
3485
3486 /* Determine offset from array base ( for scalars the offset is always zero ) */
3487 offset = dim_unit (variable, variable->VINDEX);
3488
3489 CLEAR_VARIANT (variant);
3490
3491 /* Force compatibility */
3492 variant->VariantTypeCode = variable->VariableTypeCode;
3493
3494 if (variable->VariableTypeCode == StringTypeCode)
3495 {
3496 /* Variable is a STRING */
3497 StringType Value;
3498
3499 Value.sbuffer = NULL;
3500 Value.length = 0;
3501 /* both STRING */
3502
3503 if (variable->VariableFlags & VARIABLE_VIRTUAL) /* var_get() */
3504 {
3505 /* get file information */
3506 VirtualType *Z;
3507 FileType *F;
3508
3509 Z = find_virtual_by_variable (variable);
3510 if (Z == NULL)
3511 {
3512 WARN_INTERNAL_ERROR;
3513 return FALSE;
3514 }
3515 offset *= Z->FileLength; /* Byte offset */
3516 offset += Z->FileOffset; /* Beginning of this data */
3517 /* update file information */
3518 F = find_file_by_number (Z->FileNumber);
3519 if (F == NULL)
3520 {
3521 WARN_BAD_FILE_MODE;
3522 return FALSE;
3523 }
3524 if (F->DevMode != DEVMODE_VIRTUAL)
3525 {
3526 WARN_BAD_FILE_MODE;
3527 return FALSE;
3528 }
3529 if (F->cfp == NULL)
3530 {
3531 WARN_BAD_FILE_MODE;
3532 return FALSE;
3533 }
3534 if (fseek (F->cfp, offset, SEEK_SET) != 0)
3535 {
3536 WARN_BAD_FILE_MODE;
3537 return FALSE;
3538 }
3539 Value.length = Z->FileLength;
3540 if ((Value.sbuffer =
3541 (char *) calloc (Value.length + 1 /* NulChar */ ,
3542 sizeof (char))) == NULL)
3543 {
3544 WARN_OUT_OF_MEMORY;
3545 return FALSE;
3546 }
3547 if (fread (Value.sbuffer, Value.length, 1, F->cfp) != 1)
3548 {
3549 WARN_DISK_IO_ERROR;
3550 return FALSE;
3551 }
3552 }
3553 else
3554 {
3555 StringType *string;
3556
3557 string = variable->Value.String;
3558 if (string == NULL)
3559 {
3560 WARN_INTERNAL_ERROR;
3561 return FALSE;
3562 }
3563 string += offset;
3564 if (str_btob (&Value, string) == FALSE)
3565 {
3566 WARN_INTERNAL_ERROR;
3567 return FALSE;
3568 }
3569 }
3570 variant->Buffer = Value.sbuffer;
3571 variant->Length = Value.length;
3572 }
3573 else
3574 {
3575 /* Variable is a NUMBER */
3576 DoubleType Value;
3577 /* both NUMBER */
3578
3579 if (variable->VariableFlags & VARIABLE_VIRTUAL) /* var_get() */
3580 {
3581 /* get file information */
3582 VirtualType *Z;
3583 FileType *F;
3584
3585 Z = find_virtual_by_variable (variable);
3586 if (Z == NULL)
3587 {
3588 WARN_INTERNAL_ERROR;
3589 return FALSE;
3590 }
3591 offset *= Z->FileLength; /* Byte offset */
3592 offset += Z->FileOffset; /* Beginning of this data */
3593 /* update file information */
3594 F = find_file_by_number (Z->FileNumber);
3595 if (F == NULL)
3596 {
3597 WARN_BAD_FILE_MODE;
3598 return FALSE;
3599 }
3600 if (F->DevMode != DEVMODE_VIRTUAL)
3601 {
3602 WARN_BAD_FILE_MODE;
3603 return FALSE;
3604 }
3605 if (F->cfp == NULL)
3606 {
3607 WARN_BAD_FILE_MODE;
3608 return FALSE;
3609 }
3610 if (fseek (F->cfp, offset, SEEK_SET) != 0)
3611 {
3612 WARN_BAD_FILE_MODE;
3613 return FALSE;
3614 }
3615 switch (variable->VariableTypeCode)
3616 {
3617 case ByteTypeCode:
3618 {
3619 ByteType X;
3620 if (fread (&X, sizeof (X), 1, F->cfp) != 1)
3621 {
3622 WARN_DISK_IO_ERROR;
3623 return FALSE;
3624 }
3625 Value = X;
3626 }
3627 break;
3628 case IntegerTypeCode:
3629 {
3630 IntegerType X;
3631 if (fread (&X, sizeof (X), 1, F->cfp) != 1)
3632 {
3633 WARN_DISK_IO_ERROR;
3634 return FALSE;
3635 }
3636 Value = X;
3637 }
3638 break;
3639 case LongTypeCode:
3640 {
3641 LongType X;
3642 if (fread (&X, sizeof (X), 1, F->cfp) != 1)
3643 {
3644 WARN_DISK_IO_ERROR;
3645 return FALSE;
3646 }
3647 Value = X;
3648 }
3649 break;
3650 case CurrencyTypeCode:
3651 {
3652 CurrencyType X;
3653 if (fread (&X, sizeof (X), 1, F->cfp) != 1)
3654 {
3655 WARN_DISK_IO_ERROR;
3656 return FALSE;
3657 }
3658 Value = X;
3659 }
3660 break;
3661 case SingleTypeCode:
3662 {
3663 SingleType X;
3664 if (fread (&X, sizeof (X), 1, F->cfp) != 1)
3665 {
3666 WARN_DISK_IO_ERROR;
3667 return FALSE;
3668 }
3669 Value = X;
3670 }
3671 break;
3672 case DoubleTypeCode:
3673 {
3674 DoubleType X;
3675 if (fread (&X, sizeof (X), 1, F->cfp) != 1)
3676 {
3677 WARN_DISK_IO_ERROR;
3678 return FALSE;
3679 }
3680 Value = X;
3681 }
3682 break;
3683 case StringTypeCode:
3684 {
3685 WARN_INTERNAL_ERROR;
3686 return FALSE;
3687 }
3688 /* break; */
3689 default:
3690 {
3691 WARN_INTERNAL_ERROR;
3692 return FALSE;
3693 }
3694 }
3695 }
3696 else
3697 {
3698 DoubleType *number;
3699
3700 number = variable->Value.Number;
3701 if (number == NULL)
3702 {
3703 WARN_INTERNAL_ERROR;
3704 return FALSE;
3705 }
3706 number += offset;
3707 /* copy value */
3708 Value = *number;
3709 }
3710
3711 /* VerifyNumeric */
3712 if (isnan (Value))
3713 {
3714 /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/
3715 WARN_INTERNAL_ERROR;
3716 return FALSE;
3717 }
3718 if (isinf (Value))
3719 {
3720 /* - Evaluation of an expression results in an overflow
3721 * (nonfatal, the recommended recovery procedure is to supply
3722 * machine in- finity with the algebraically correct sign and
3723 * continue). */
3724 if (Value < 0)
3725 {
3726 Value = MINDBL;
3727 }
3728 else
3729 {
3730 Value = MAXDBL;
3731 }
3732 if (WARN_OVERFLOW)
3733 {
3734 /* ERROR */
3735 return FALSE;
3736 }
3737 /* CONTINUE */
3738 }
3739 /* OK */
3740 switch (variable->VariableTypeCode)
3741 {
3742 case ByteTypeCode:
3743 case IntegerTypeCode:
3744 case LongTypeCode:
3745 case CurrencyTypeCode:
3746 /* integer values */
3747 Value = bwb_rint (Value);
3748 break;
3749 case SingleTypeCode:
3750 case DoubleTypeCode:
3751 /* float values */
3752 break;
3753 default:
3754 /* ERROR */
3755 WARN_INTERNAL_ERROR;
3756 return FALSE;
3757 /* break; */
3758 }
3759 variant->Number = Value;
3760 }
3761 return TRUE;
3762 }
3763
3764 int
var_set(VariableType * variable,VariantType * variant)3765 var_set (VariableType * variable, VariantType * variant)
3766 {
3767 size_t offset;
3768
3769 assert( My != NULL );
3770 assert( My->SYSOUT != NULL );
3771 assert( My->SYSOUT->cfp != NULL );
3772
3773 /* check sanity */
3774 if (variable == NULL)
3775 {
3776 WARN_INTERNAL_ERROR;
3777 return FALSE;
3778 }
3779 if (variant == NULL)
3780 {
3781 WARN_INTERNAL_ERROR;
3782 return FALSE;
3783 }
3784
3785 /* check CONST */
3786 if (variable->VariableFlags & (VARIABLE_CONSTANT))
3787 {
3788 /* attempting to assign to a constant */
3789 WARN_VARIABLE_NOT_DECLARED;
3790 return FALSE;
3791 }
3792
3793 /* Check subscripts */
3794 if (dim_check (variable) == FALSE)
3795 {
3796 WARN_SUBSCRIPT_OUT_OF_RANGE;
3797 return FALSE;
3798 }
3799
3800 /* Determine offset from array base ( for scalars the offset is always zero ) */
3801 offset = dim_unit (variable, variable->VINDEX);
3802
3803 /* Verify compatibility */
3804 if (variable->VariableTypeCode == StringTypeCode)
3805 {
3806 /* Variable is a STRING */
3807 StringType Value;
3808
3809 /* Verify value is a STRING */
3810 if (variant->VariantTypeCode != StringTypeCode)
3811 {
3812 WARN_TYPE_MISMATCH;
3813 return FALSE;
3814 }
3815 Value.sbuffer = variant->Buffer;
3816 Value.length = variant->Length;
3817 /* both STRING */
3818
3819 if (variable->VariableFlags & VARIABLE_VIRTUAL) /* var_set() */
3820 {
3821 /* get file information */
3822 VirtualType *Z;
3823 FileType *F;
3824 int count;
3825
3826 Z = find_virtual_by_variable (variable);
3827 if (Z == NULL)
3828 {
3829 WARN_INTERNAL_ERROR;
3830 return FALSE;
3831 }
3832 offset *= Z->FileLength; /* Byte offset */
3833 offset += Z->FileOffset; /* Beginning of this data */
3834 /* update file information */
3835 F = find_file_by_number (Z->FileNumber);
3836 if (F == NULL)
3837 {
3838 WARN_BAD_FILE_MODE;
3839 return FALSE;
3840 }
3841 if (F->DevMode != DEVMODE_VIRTUAL)
3842 {
3843 WARN_BAD_FILE_MODE;
3844 return FALSE;
3845 }
3846 if (F->cfp == NULL)
3847 {
3848 WARN_BAD_FILE_MODE;
3849 return FALSE;
3850 }
3851 if (fseek (F->cfp, offset, SEEK_SET) != 0)
3852 {
3853 WARN_BAD_FILE_MODE;
3854 return FALSE;
3855 }
3856 count = MIN (Value.length, Z->FileLength);
3857 if (fwrite (Value.sbuffer, sizeof (char), count, F->cfp) != count)
3858 {
3859 WARN_DISK_IO_ERROR;
3860 return FALSE;
3861 }
3862 /* PADR */
3863 while (count < Z->FileLength)
3864 {
3865 if (fputc (' ', F->cfp) == EOF)
3866 {
3867 WARN_BAD_FILE_MODE;
3868 return FALSE;
3869 }
3870 count++;
3871 }
3872 }
3873 else
3874 {
3875 StringType *string;
3876
3877 string = variable->Value.String;
3878 if (string == NULL)
3879 {
3880 WARN_INTERNAL_ERROR;
3881 return FALSE;
3882 }
3883 string += offset;
3884 if (str_btob (string, &Value) == FALSE)
3885 {
3886 WARN_INTERNAL_ERROR;
3887 return FALSE;
3888 }
3889 }
3890 if (variable->VariableFlags & VARIABLE_DISPLAY) /* var_set() */
3891 {
3892 if (My->ThisLine) /* var_set() */
3893 {
3894 if (My->ThisLine->LineFlags & (LINE_USER)) /* var_set() */
3895 {
3896 /* immediate mode */
3897 }
3898 else
3899 {
3900 fprintf (My->SYSOUT->cfp, "#%d %s=%s\n", My->ThisLine->number, variable->name, variant->Buffer); /* var_set() */
3901 ResetConsoleColumn ();
3902 }
3903 }
3904 }
3905 }
3906 else
3907 {
3908 /* Variable is a NUMBER */
3909 DoubleType Value;
3910
3911 /* Verify value is a NUMBER */
3912 if (variant->VariantTypeCode == StringTypeCode)
3913 {
3914 WARN_TYPE_MISMATCH;
3915 return FALSE;
3916 }
3917
3918 /* both NUMBER */
3919
3920 /* VerifyNumeric */
3921 if (isnan (variant->Number))
3922 {
3923 /*** FATAL - INTERNAL ERROR - SHOULD NEVER HAPPEN ***/
3924 WARN_INTERNAL_ERROR;
3925 return FALSE;
3926 }
3927 if (isinf (variant->Number))
3928 {
3929 /* - Evaluation of an expression results in an overflow
3930 * (nonfatal, the recommended recovery procedure is to supply
3931 * machine in- finity with the algebraically correct sign and
3932 * continue). */
3933 if (variant->Number < 0)
3934 {
3935 variant->Number = MINDBL;
3936 }
3937 else
3938 {
3939 variant->Number = MAXDBL;
3940 }
3941 if (WARN_OVERFLOW)
3942 {
3943 /* ERROR */
3944 return FALSE;
3945 }
3946 /* CONTINUE */
3947 }
3948 /* OK */
3949 switch (variable->VariableTypeCode)
3950 {
3951 case ByteTypeCode:
3952 variant->Number = bwb_rint (variant->Number);
3953 if (variant->Number < MINBYT)
3954 {
3955 if (WARN_OVERFLOW)
3956 {
3957 return FALSE;
3958 }
3959 variant->Number = MINBYT;
3960 }
3961 else if (variant->Number > MAXBYT)
3962 {
3963 if (WARN_OVERFLOW)
3964 {
3965 return FALSE;
3966 }
3967 variant->Number = MAXBYT;
3968 }
3969 break;
3970 case IntegerTypeCode:
3971 variant->Number = bwb_rint (variant->Number);
3972 if (variant->Number < MININT)
3973 {
3974 if (WARN_OVERFLOW)
3975 {
3976 return FALSE;
3977 }
3978 variant->Number = MININT;
3979 }
3980 else if (variant->Number > MAXINT)
3981 {
3982 if (WARN_OVERFLOW)
3983 {
3984 return FALSE;
3985 }
3986 variant->Number = MAXINT;
3987 }
3988 break;
3989 case LongTypeCode:
3990 variant->Number = bwb_rint (variant->Number);
3991 if (variant->Number < MINLNG)
3992 {
3993 if (WARN_OVERFLOW)
3994 {
3995 return FALSE;
3996 }
3997 variant->Number = MINLNG;
3998 }
3999 else if (variant->Number > MAXLNG)
4000 {
4001 if (WARN_OVERFLOW)
4002 {
4003 return FALSE;
4004 }
4005 variant->Number = MAXLNG;
4006 }
4007 break;
4008 case CurrencyTypeCode:
4009 variant->Number = bwb_rint (variant->Number);
4010 if (variant->Number < MINCUR)
4011 {
4012 if (WARN_OVERFLOW)
4013 {
4014 return FALSE;
4015 }
4016 variant->Number = MINCUR;
4017 }
4018 else if (variant->Number > MAXCUR)
4019 {
4020 if (WARN_OVERFLOW)
4021 {
4022 return FALSE;
4023 }
4024 variant->Number = MAXCUR;
4025 }
4026 break;
4027 case SingleTypeCode:
4028 if (variant->Number < MINSNG)
4029 {
4030 if (WARN_OVERFLOW)
4031 {
4032 return FALSE;
4033 }
4034 variant->Number = MINSNG;
4035 }
4036 else if (variant->Number > MAXSNG)
4037 {
4038 if (WARN_OVERFLOW)
4039 {
4040 return FALSE;
4041 }
4042 variant->Number = MAXSNG;
4043 }
4044 break;
4045 case DoubleTypeCode:
4046 if (variant->Number < MINDBL)
4047 {
4048 if (WARN_OVERFLOW)
4049 {
4050 return FALSE;
4051 }
4052 variant->Number = MINDBL;
4053 }
4054 else if (variant->Number > MAXDBL)
4055 {
4056 if (WARN_OVERFLOW)
4057 {
4058 return FALSE;
4059 }
4060 variant->Number = MAXDBL;
4061 }
4062 break;
4063 default:
4064 WARN_INTERNAL_ERROR;
4065 return FALSE;
4066 /* break; */
4067 }
4068 Value = variant->Number;
4069 if (variable->VariableFlags & VARIABLE_VIRTUAL) /* var_set() */
4070 {
4071 /* get file information */
4072 VirtualType *Z;
4073 FileType *F;
4074
4075 Z = find_virtual_by_variable (variable);
4076 if (Z == NULL)
4077 {
4078 WARN_INTERNAL_ERROR;
4079 return FALSE;
4080 }
4081 offset *= Z->FileLength; /* Byte offset */
4082 offset += Z->FileOffset; /* Beginning of this data */
4083 /* update file information */
4084 F = find_file_by_number (Z->FileNumber);
4085 if (F == NULL)
4086 {
4087 WARN_BAD_FILE_MODE;
4088 return FALSE;
4089 }
4090 if (F->DevMode != DEVMODE_VIRTUAL)
4091 {
4092 WARN_BAD_FILE_MODE;
4093 return FALSE;
4094 }
4095 if (F->cfp == NULL)
4096 {
4097 WARN_BAD_FILE_MODE;
4098 return FALSE;
4099 }
4100 if (fseek (F->cfp, offset, SEEK_SET) != 0)
4101 {
4102 WARN_BAD_FILE_MODE;
4103 return FALSE;
4104 }
4105 switch (variable->VariableTypeCode)
4106 {
4107 case ByteTypeCode:
4108 {
4109 ByteType X;
4110 X = Value;
4111 if (fwrite (&X, sizeof (X), 1, F->cfp) != 1)
4112 {
4113 WARN_DISK_IO_ERROR;
4114 return FALSE;
4115 }
4116 }
4117 break;
4118 case IntegerTypeCode:
4119 {
4120 IntegerType X;
4121 X = Value;
4122 if (fwrite (&X, sizeof (X), 1, F->cfp) != 1)
4123 {
4124 WARN_DISK_IO_ERROR;
4125 return FALSE;
4126 }
4127 }
4128 break;
4129 case LongTypeCode:
4130 {
4131 LongType X;
4132 X = Value;
4133 if (fwrite (&X, sizeof (X), 1, F->cfp) != 1)
4134 {
4135 WARN_DISK_IO_ERROR;
4136 return FALSE;
4137 }
4138 }
4139 break;
4140 case CurrencyTypeCode:
4141 {
4142 CurrencyType X;
4143 X = Value;
4144 if (fwrite (&X, sizeof (X), 1, F->cfp) != 1)
4145 {
4146 WARN_DISK_IO_ERROR;
4147 return FALSE;
4148 }
4149 }
4150 break;
4151 case SingleTypeCode:
4152 {
4153 SingleType X;
4154 X = Value;
4155 if (fwrite (&X, sizeof (X), 1, F->cfp) != 1)
4156 {
4157 WARN_DISK_IO_ERROR;
4158 return FALSE;
4159 }
4160 }
4161 break;
4162 case DoubleTypeCode:
4163 {
4164 DoubleType X;
4165 X = Value;
4166 if (fwrite (&X, sizeof (X), 1, F->cfp) != 1)
4167 {
4168 WARN_DISK_IO_ERROR;
4169 return FALSE;
4170 }
4171 }
4172 break;
4173 case StringTypeCode:
4174 {
4175 WARN_INTERNAL_ERROR;
4176 return FALSE;
4177 }
4178 /* break; */
4179 default:
4180 {
4181 WARN_INTERNAL_ERROR;
4182 return FALSE;
4183 }
4184 }
4185 }
4186 else
4187 {
4188 DoubleType *number;
4189 number = variable->Value.Number;
4190 if (number == NULL)
4191 {
4192 WARN_INTERNAL_ERROR;
4193 return FALSE;
4194 }
4195 number += offset;
4196 *number = Value;
4197 }
4198 if (variable->VariableFlags & VARIABLE_DISPLAY) /* var_set() */
4199 {
4200 if (My->ThisLine) /* var_set() */
4201 {
4202 if (My->ThisLine->LineFlags & (LINE_USER)) /* var_set() */
4203 {
4204 /* immediate mode */
4205 }
4206 else
4207 {
4208 FormatBasicNumber (Value, My->NumLenBuffer);
4209 fprintf (My->SYSOUT->cfp, "#%d %s=%s\n", My->ThisLine->number, variable->name, My->NumLenBuffer); /* var_set() */
4210 ResetConsoleColumn ();
4211 }
4212 }
4213 }
4214 }
4215 return TRUE;
4216 }
4217
4218 /***************************************************************
4219
4220 FUNCTION: dim_check()
4221
4222 DESCRIPTION: This function checks subscripts of a
4223 specific variable to be sure that they
4224 are within the correct range.
4225
4226 ***************************************************************/
4227
4228 static int
dim_check(VariableType * variable)4229 dim_check (VariableType * variable)
4230 {
4231 /* Check for validly allocated array */
4232 int n;
4233
4234 assert (variable != NULL);
4235
4236
4237 if (variable->VariableFlags & VARIABLE_VIRTUAL) /* var_set() */
4238 {
4239 if (variable->Value.String != NULL)
4240 {
4241 WARN_INTERNAL_ERROR;
4242 return FALSE;
4243 }
4244 if (variable->Value.Number != NULL)
4245 {
4246 WARN_INTERNAL_ERROR;
4247 return FALSE;
4248 }
4249 }
4250 else if (VAR_IS_STRING (variable))
4251 {
4252 if (variable->Value.String == NULL)
4253 {
4254 WARN_INTERNAL_ERROR;
4255 return FALSE;
4256 }
4257 }
4258 else
4259 {
4260 if (variable->Value.Number == NULL)
4261 {
4262 WARN_INTERNAL_ERROR;
4263 return FALSE;
4264 }
4265 }
4266 /* Now check subscript values */
4267 for (n = 0; n < variable->dimensions; n++)
4268 {
4269 if (variable->VINDEX[n] < variable->LBOUND[n]
4270 || variable->VINDEX[n] > variable->UBOUND[n])
4271 {
4272 WARN_SUBSCRIPT_OUT_OF_RANGE;
4273 return FALSE;
4274 }
4275 }
4276 /* No problems found */
4277 return TRUE;
4278 }
4279
4280 /***************************************************************
4281
4282 FUNCTION: var_make()
4283
4284 DESCRIPTION: This function initializes a variable,
4285 allocating necessary memory for it.
4286
4287 ***************************************************************/
4288
4289 int
var_make(VariableType * variable,char TypeCode)4290 var_make (VariableType * variable, char TypeCode)
4291 {
4292 /* ALL variables are created here */
4293
4294 assert (variable != NULL);
4295
4296 switch (TypeCode)
4297 {
4298 case ByteTypeCode:
4299 case IntegerTypeCode:
4300 case LongTypeCode:
4301 case CurrencyTypeCode:
4302 case SingleTypeCode:
4303 case DoubleTypeCode:
4304 case StringTypeCode:
4305 /* OK */
4306 break;
4307 default:
4308 /* ERROR */
4309 WARN_TYPE_MISMATCH;
4310 return FALSE;
4311 }
4312
4313 variable->VariableTypeCode = TypeCode;
4314
4315 /* get memory for array */
4316
4317 /* First cleanup the joint (JBV) */
4318 if (variable->Value.Number != NULL)
4319 {
4320 free (variable->Value.Number);
4321 variable->Value.Number = NULL;
4322 }
4323 if (variable->Value.String != NULL)
4324 {
4325 /* Remember to deallocate those far-flung branches! (JBV) */
4326 StringType *sp; /* JBV */
4327 int n; /* JBV */
4328
4329 sp = variable->Value.String;
4330 for (n = 0; n < (int) variable->array_units; n++)
4331 {
4332 if (sp[n].sbuffer != NULL)
4333 {
4334 free (sp[n].sbuffer);
4335 sp[n].sbuffer = NULL;
4336 }
4337 sp[n].length = 0;
4338 }
4339 free (variable->Value.String);
4340 variable->Value.String = NULL;
4341 }
4342
4343 variable->dimensions = 0;
4344 variable->array_units = 1;
4345
4346 if (VAR_IS_STRING (variable))
4347 {
4348 if ((variable->Value.String =
4349 calloc (variable->array_units, sizeof (StringType))) == NULL)
4350 {
4351 WARN_OUT_OF_MEMORY;
4352 return FALSE;
4353 }
4354 }
4355 else
4356 {
4357 if ((variable->Value.Number =
4358 calloc (variable->array_units, sizeof (DoubleType))) == NULL)
4359 {
4360 WARN_OUT_OF_MEMORY;
4361 return FALSE;
4362 }
4363 }
4364 return TRUE;
4365
4366 }
4367
4368 /***************************************************************
4369
4370 FUNCTION: var_islocal()
4371
4372 DESCRIPTION: This function determines whether the string
4373 pointed to by 'buffer' has the name of
4374 a local variable at the present EXEC stack
4375 level.
4376
4377 ***************************************************************/
4378
4379 static VariableType *
mat_islocal(char * buffer)4380 mat_islocal (char *buffer)
4381 {
4382 /*
4383 similar to var_islocal, but returns first matrix found.
4384 */
4385
4386 assert (buffer != NULL);
4387 assert( My != NULL );
4388
4389 if (My->StackHead != NULL)
4390 {
4391 StackType *StackItem;
4392 for (StackItem = My->StackHead; StackItem != NULL;
4393 StackItem = StackItem->next)
4394 {
4395 if (StackItem->LoopTopLine != NULL)
4396 {
4397 switch (StackItem->LoopTopLine->cmdnum)
4398 {
4399 case C_DEF:
4400 case C_FUNCTION:
4401 case C_SUB:
4402 /* we have found a FUNCTION or SUB boundary */
4403 {
4404 VariableType *variable;
4405
4406 for (variable = StackItem->local_variable; variable != NULL;
4407 variable = variable->next)
4408 {
4409 if (variable->dimensions > 0)
4410 {
4411 if (bwb_stricmp (variable->name, buffer) == 0)
4412 {
4413 /* FOUND */
4414 return variable;
4415 }
4416 }
4417 }
4418 }
4419 /* we have checked all the way to a FUNCTION or SUB boundary */
4420 /* NOT FOUND */
4421 return NULL;
4422 /* break; */
4423 }
4424 }
4425 }
4426 }
4427 /* NOT FOUND */
4428 return NULL;
4429 }
4430
4431
4432 static VariableType *
var_islocal(char * buffer,int dimensions)4433 var_islocal (char *buffer, int dimensions)
4434 {
4435
4436 assert (buffer != NULL);
4437 assert( My != NULL );
4438
4439 if (My->StackHead != NULL)
4440 {
4441 StackType *StackItem;
4442 for (StackItem = My->StackHead; StackItem != NULL;
4443 StackItem = StackItem->next)
4444 {
4445 if (StackItem->LoopTopLine != NULL)
4446 {
4447 switch (StackItem->LoopTopLine->cmdnum)
4448 {
4449 case C_DEF:
4450 case C_FUNCTION:
4451 case C_SUB:
4452 /* we have found a FUNCTION or SUB boundary */
4453 {
4454 VariableType *variable;
4455
4456 for (variable = StackItem->local_variable; variable != NULL;
4457 variable = variable->next)
4458 {
4459 if (variable->dimensions == dimensions)
4460 {
4461 if (bwb_stricmp (variable->name, buffer) == 0)
4462 {
4463 /* FOUND */
4464 return variable;
4465 }
4466 }
4467 }
4468 }
4469 /* we have checked all the way to a FUNCTION or SUB boundary */
4470 /* NOT FOUND */
4471 return NULL;
4472 /* break; */
4473 }
4474 }
4475 }
4476 }
4477 /* NOT FOUND */
4478 return NULL;
4479 }
4480
4481 /***************************************************************
4482
4483 FUNCTION: bwb_vars()
4484
4485 DESCRIPTION: This function implements the Bywater-
4486 specific debugging command VARS, which
4487 gives a list of all variables defined
4488 in memory.
4489
4490 ***************************************************************/
4491
4492
4493 LineType *
bwb_VARS(LineType * l)4494 bwb_VARS (LineType * l)
4495 {
4496 VariableType *variable;
4497
4498 assert (l != NULL);
4499 assert( My != NULL );
4500 assert( My->SYSOUT != NULL );
4501 assert( My->SYSOUT->cfp != NULL );
4502
4503 /* run through the variable list and print variables */
4504
4505
4506 fprintf (My->SYSOUT->cfp, "%-*s %-6s %-4s %s\n", NameLengthMax, "Name",
4507 "Type", "Dims", "Value");
4508
4509 for (variable = My->VariableHead; variable != NULL;
4510 variable = variable->next)
4511 {
4512 VariantType variant;
4513 CLEAR_VARIANT (&variant);
4514
4515 if (var_get (variable, &variant) == FALSE)
4516 {
4517 WARN_VARIABLE_NOT_DECLARED;
4518 return (l);
4519 }
4520 if (variant.VariantTypeCode == StringTypeCode)
4521 {
4522 fprintf (My->SYSOUT->cfp, "%-*s %-6s %-4d %s\n", NameLengthMax,
4523 variable->name, "STRING", variable->dimensions,
4524 variant.Buffer);
4525 }
4526 else
4527 {
4528 FormatBasicNumber (variant.Number, My->NumLenBuffer);
4529 fprintf (My->SYSOUT->cfp, "%-*s %-6s %-4d %s\n", NameLengthMax,
4530 variable->name, "NUMBER", variable->dimensions,
4531 My->NumLenBuffer);
4532 }
4533 RELEASE_VARIANT (&variant);
4534 }
4535 ResetConsoleColumn ();
4536 return (l);
4537 }
4538
4539 /***************************************************************
4540
4541 FUNCTION: bwb_field()
4542
4543 DESCRIPTION: This C function implements the BASIC
4544 FIELD command.
4545
4546 ***************************************************************/
4547
4548 static void
field_clear(FieldType * Field)4549 field_clear (FieldType * Field)
4550 {
4551 int i;
4552
4553 assert (Field != NULL);
4554
4555 Field->File = NULL;
4556 Field->FieldOffset = 0;
4557 Field->FieldLength = 0;
4558 Field->Var = NULL;
4559 for (i = 0; i < MAX_DIMS; i++)
4560 {
4561 Field->VINDEX[i] = 0;
4562 }
4563 }
4564
4565 static FieldType *
field_new(void)4566 field_new (void)
4567 {
4568 /* search for an empty slot */
4569 FieldType *Field;
4570
4571 assert( My != NULL );
4572
4573 for (Field = My->FieldHead; Field != NULL; Field = Field->next)
4574 {
4575 if (Field->File == NULL || Field->Var == NULL)
4576 {
4577 field_clear (Field);
4578 return Field;
4579 }
4580 }
4581 /* not found */
4582 if ((Field = calloc (1, sizeof (FieldType))) == NULL)
4583 {
4584 WARN_OUT_OF_MEMORY;
4585 return NULL;
4586 }
4587 Field->next = My->FieldHead;
4588 My->FieldHead = Field;
4589 return Field;
4590 }
4591
4592 void
field_close_file(FileType * File)4593 field_close_file (FileType * File)
4594 {
4595 /* a CLOSE of a file is in progress, release associated fields */
4596 FieldType *Field;
4597
4598 assert (File != NULL);
4599 assert( My != NULL );
4600
4601 for (Field = My->FieldHead; Field != NULL; Field = Field->next)
4602 {
4603 if (Field->File == File)
4604 {
4605 Field->File = NULL;
4606 Field->Var = NULL;
4607 }
4608 }
4609 }
4610 void
field_free_variable(VariableType * Var)4611 field_free_variable (VariableType * Var)
4612 {
4613 /* an ERASE of a variable is in progress, release associated fields */
4614 FieldType *Field;
4615
4616 assert (Var != NULL);
4617 assert( My != NULL );
4618
4619 for (Field = My->FieldHead; Field != NULL; Field = Field->next)
4620 {
4621 if (Field->Var == Var)
4622 {
4623 Field->File = NULL;
4624 Field->Var = NULL;
4625 }
4626 }
4627 }
4628
4629
4630 void
field_get(FileType * File)4631 field_get (FileType * File)
4632 {
4633 /* a GET of the RANDOM file is in progress, update variables from FILE buffer */
4634 FieldType *Field;
4635
4636 assert( My != NULL );
4637
4638 if (File == NULL)
4639 {
4640 WARN_BAD_FILE_NUMBER;
4641 return;
4642 }
4643 if (File->buffer == NULL)
4644 {
4645 WARN_BAD_FILE_MODE;
4646 return;
4647 }
4648 for (Field = My->FieldHead; Field != NULL; Field = Field->next)
4649 {
4650 if (Field->File == File && Field->Var != NULL)
4651 {
4652 /* from file to variable */
4653 VariantType variant;
4654 CLEAR_VARIANT (&variant);
4655
4656 if (Field->FieldOffset < 0)
4657 {
4658 WARN_FIELD_OVERFLOW;
4659 return;
4660 }
4661 if (Field->FieldLength <= 0)
4662 {
4663 WARN_FIELD_OVERFLOW;
4664 return;
4665 }
4666 if ((Field->FieldOffset + Field->FieldLength) > File->width)
4667 {
4668 WARN_FIELD_OVERFLOW;
4669 return;
4670 }
4671 variant.VariantTypeCode = StringTypeCode;
4672 variant.Length = Field->FieldLength;
4673 if ((variant.Buffer =
4674 (char *) calloc (variant.Length + 1 /* NulChar */ ,
4675 sizeof (char))) == NULL)
4676 {
4677 WARN_OUT_OF_MEMORY;
4678 return;
4679 }
4680 /* if( TRUE ) */
4681 {
4682 int i;
4683
4684 for (i = 0; i < Field->Var->dimensions; i++)
4685 {
4686 Field->Var->VINDEX[i] = Field->VINDEX[i];
4687 }
4688 }
4689 /* if( TRUE ) */
4690 {
4691 int i;
4692 char *Buffer;
4693
4694 Buffer = File->buffer;
4695 Buffer += Field->FieldOffset;
4696 for (i = 0; i < variant.Length; i++)
4697 {
4698 variant.Buffer[i] = Buffer[i];
4699 }
4700 variant.Buffer[variant.Length] = NulChar;
4701 }
4702 if (var_set (Field->Var, &variant) == FALSE)
4703 {
4704 WARN_VARIABLE_NOT_DECLARED;
4705 return;
4706 }
4707 RELEASE_VARIANT (&variant);
4708 }
4709 }
4710 }
4711 void
field_put(FileType * File)4712 field_put (FileType * File)
4713 {
4714 /* a PUT of the RANDOM file is in progress, update FILE buffer from variables */
4715 FieldType *Field;
4716
4717 assert( My != NULL );
4718
4719 if (File == NULL)
4720 {
4721 WARN_BAD_FILE_NUMBER;
4722 return;
4723 }
4724 if (File->buffer == NULL)
4725 {
4726 WARN_BAD_FILE_MODE;
4727 return;
4728 }
4729 for (Field = My->FieldHead; Field != NULL; Field = Field->next)
4730 {
4731 if (Field->File == File && Field->Var != NULL)
4732 {
4733 /* from variable to file */
4734 VariantType variant;
4735 CLEAR_VARIANT (&variant);
4736
4737 if (Field->FieldOffset < 0)
4738 {
4739 WARN_FIELD_OVERFLOW;
4740 return;
4741 }
4742 if (Field->FieldLength <= 0)
4743 {
4744 WARN_FIELD_OVERFLOW;
4745 return;
4746 }
4747 if ((Field->FieldOffset + Field->FieldLength) > File->width)
4748 {
4749 WARN_FIELD_OVERFLOW;
4750 return;
4751 }
4752 /* if( TRUE ) */
4753 {
4754 int i;
4755
4756 for (i = 0; i < Field->Var->dimensions; i++)
4757 {
4758 Field->Var->VINDEX[i] = Field->VINDEX[i];
4759 }
4760 }
4761 if (var_get (Field->Var, &variant) == FALSE)
4762 {
4763 WARN_VARIABLE_NOT_DECLARED;
4764 return;
4765 }
4766 if (variant.VariantTypeCode != StringTypeCode)
4767 {
4768 WARN_TYPE_MISMATCH;
4769 return;
4770 }
4771 /* if( TRUE ) */
4772 {
4773 int i;
4774 int n;
4775 char *Buffer;
4776
4777 i = 0;
4778 n = 0;
4779 Buffer = File->buffer;
4780 Buffer += Field->FieldOffset;
4781
4782 if (variant.Buffer != NULL)
4783 {
4784 n = MIN (variant.Length, Field->FieldLength);
4785 }
4786 for (i = 0; i < n; i++)
4787 {
4788 Buffer[i] = variant.Buffer[i];
4789 }
4790 for (i = n; i < Field->FieldLength; i++)
4791 {
4792 /* Pad on the right with spaces */
4793 Buffer[i] = ' ';
4794 }
4795 }
4796 RELEASE_VARIANT (&variant);
4797 }
4798 }
4799 }
4800
4801
4802 LineType *
bwb_FIELD(LineType * l)4803 bwb_FIELD (LineType * l)
4804 {
4805 FileType *File;
4806 int FileNumber;
4807 int FieldOffset;
4808
4809 assert (l != NULL);
4810
4811 FileNumber = 0;
4812 FieldOffset = 0;
4813
4814 /* first read device number */
4815 if (line_skip_FilenumChar (l))
4816 {
4817 /* optional */
4818 }
4819 if (line_read_integer_expression (l, &FileNumber) == FALSE)
4820 {
4821 WARN_SYNTAX_ERROR;
4822 return (l);
4823 }
4824 if (FileNumber <= 0)
4825 {
4826 /* FIELD # 0 is an error */
4827 WARN_BAD_FILE_NUMBER;
4828 return (l);
4829 }
4830 File = find_file_by_number (FileNumber);
4831 if (File == NULL)
4832 {
4833 WARN_BAD_FILE_NUMBER;
4834 return (l);
4835 }
4836 if (File->DevMode != DEVMODE_RANDOM)
4837 {
4838 WARN_BAD_FILE_MODE;
4839 return (l);
4840 }
4841 /* loop to read variables */
4842
4843
4844 /* read the comma and advance beyond it */
4845 while (line_skip_seperator (l))
4846 {
4847 int FieldLength;
4848 VariableType *variable;
4849 VariantType variant;
4850
4851 CLEAR_VARIANT (&variant);
4852
4853 /* first find the size of the field */
4854 FieldLength = 0;
4855 if (line_read_integer_expression (l, &FieldLength) == FALSE)
4856 {
4857 WARN_SYNTAX_ERROR;
4858 return (l);
4859 }
4860 if (FieldLength <= 0)
4861 {
4862 WARN_SYNTAX_ERROR;
4863 return (l);
4864 }
4865
4866 /* read the AS */
4867 if (line_skip_word (l, "AS") == FALSE)
4868 {
4869 WARN_SYNTAX_ERROR;
4870 return (l);
4871 }
4872
4873 /* read the string variable name */
4874 if ((variable = line_read_scalar (l)) == NULL)
4875 {
4876 WARN_VARIABLE_NOT_DECLARED;
4877 return (l);
4878 }
4879
4880 if (VAR_IS_STRING (variable))
4881 {
4882 /* OK */
4883 }
4884 else
4885 {
4886 WARN_TYPE_MISMATCH;
4887 return (l);
4888 }
4889 /* check for overflow of record length */
4890 if ((FieldOffset + FieldLength) > File->width)
4891 {
4892 WARN_FIELD_OVERFLOW;
4893 return (l);
4894 }
4895 /* set buffer */
4896 variant.VariantTypeCode = StringTypeCode;
4897 /* if( TRUE ) */
4898 {
4899 FieldType *Field;
4900 int i;
4901
4902 Field = field_new ();
4903 if (Field == NULL)
4904 {
4905 WARN_OUT_OF_MEMORY;
4906 return (l);
4907 }
4908 Field->File = File;
4909 Field->FieldOffset = FieldOffset;
4910 Field->FieldLength = FieldLength;
4911 Field->Var = variable;
4912 for (i = 0; i < variable->dimensions; i++)
4913 {
4914 Field->VINDEX[i] = variable->VINDEX[i];
4915 }
4916 variant.Length = FieldLength;
4917 if ((variant.Buffer =
4918 (char *) calloc (variant.Length + 1 /* NulChar */ ,
4919 sizeof (char))) == NULL)
4920 {
4921 WARN_OUT_OF_MEMORY;
4922 return (l);
4923 }
4924 bwb_memset (variant.Buffer, ' ', variant.Length);
4925 variant.Buffer[variant.Length] = NulChar;
4926 }
4927 if (var_set (variable, &variant) == FALSE)
4928 {
4929 WARN_VARIABLE_NOT_DECLARED;
4930 return (l);
4931 }
4932 RELEASE_VARIANT (&variant);
4933 FieldOffset += FieldLength;
4934 }
4935 /* return */
4936 return (l);
4937 }
4938
4939 /***************************************************************
4940
4941 FUNCTION: bwb_lset()
4942
4943 DESCRIPTION: This C function implements the BASIC
4944 LSET command.
4945
4946 SYNTAX: LSET string-variable$ = expression
4947
4948 ***************************************************************/
4949
4950 LineType *
bwb_LSET(LineType * l)4951 bwb_LSET (LineType * l)
4952 {
4953
4954 assert (l != NULL);
4955 return dio_lrset (l, FALSE);
4956 }
4957
4958 /***************************************************************
4959
4960 FUNCTION: bwb_rset()
4961
4962 DESCRIPTION: This C function implements the BASIC
4963 RSET command.
4964
4965 SYNTAX: RSET string-variable$ = expression
4966
4967 ***************************************************************/
4968
4969 LineType *
bwb_RSET(LineType * l)4970 bwb_RSET (LineType * l)
4971 {
4972
4973 assert (l != NULL);
4974 return dio_lrset (l, TRUE);
4975 }
4976
4977 /***************************************************************
4978
4979 FUNCTION: dio_lrset()
4980
4981 DESCRIPTION: This C function implements the BASIC
4982 RSET and LSET commands.
4983
4984 ***************************************************************/
4985
4986 static LineType *
dio_lrset(LineType * l,int rset)4987 dio_lrset (LineType * l, int rset)
4988 {
4989 /* LSET and RSET */
4990 VariantType variant;
4991 int n;
4992 int i;
4993 int startpos;
4994 VariableType *v;
4995 VariantType t;
4996 VariantType *T;
4997
4998 assert (l != NULL);
4999
5000 T = &t;
5001 CLEAR_VARIANT (T);
5002 CLEAR_VARIANT (&variant);
5003 /* get the variable */
5004 if ((v = line_read_scalar (l)) == NULL)
5005 {
5006 WARN_VARIABLE_NOT_DECLARED;
5007 return (l);
5008 }
5009 if (VAR_IS_STRING (v) == FALSE)
5010 {
5011 WARN_TYPE_MISMATCH;
5012 return (l);
5013 }
5014
5015 /* skip the equals sign */
5016 if (line_skip_EqualChar (l) == FALSE)
5017 {
5018 WARN_SYNTAX_ERROR;
5019 return (l);
5020 }
5021
5022 /* get the value */
5023 if (line_read_expression (l, T) == FALSE) /* dio_lrset */
5024 {
5025 WARN_SYNTAX_ERROR;
5026 return (l);
5027 }
5028 if (T->VariantTypeCode != StringTypeCode)
5029 {
5030 WARN_TYPE_MISMATCH;
5031 return (l);
5032 }
5033 if (var_get (v, &variant) == FALSE)
5034 {
5035 WARN_VARIABLE_NOT_DECLARED;
5036 return (l);
5037 }
5038 /* determine starting position */
5039 startpos = 0;
5040 if (rset == TRUE && T->Length < variant.Length)
5041 {
5042 /*
5043 LET A$ = "123_456" ' variant.Length = 7
5044 LET B$ = "789" ' T->Length = 3
5045 RSET A$ = B$ ' startpos = 4
5046 PRINT "[";A$;"]" ' [123_789]
5047 */
5048 startpos = variant.Length - T->Length;
5049 }
5050 /* write characters to new position */
5051 for (n = startpos, i = 0;
5052 (n < (int) variant.Length) && (i < (int) T->Length); n++, i++)
5053 {
5054 variant.Buffer[n] = T->Buffer[i];
5055 }
5056 if (var_set (v, &variant) == FALSE)
5057 {
5058 WARN_VARIABLE_NOT_DECLARED;
5059 return (l);
5060 }
5061 /* OK */
5062 RELEASE_VARIANT (T);
5063 RELEASE_VARIANT (&variant);
5064
5065 return (l);
5066 }
5067
5068 /* EOF */
5069