On the internet you can find some small basic - interpreters. As a programming language these interpreters usually have an instruction - set that is much smaller than the instruction - set of FreeBASIC. These interpreters are, however, a nice way to get an idea of how interpreters work.
Mini - basic is such a (direct - execution) interpreter with a small instruction set (roundabout 45 functions). The original interpreter has been written in C and I am in the proces of translating it to FreeBASIC. So far I've translated most of the function/sub - declarations and the body of a couple of functions.
The original program consist of one long (206 kB) C - file. I hope to be done with the translation within a couple of days.
Due to the fact that the original program has been written in C the original program contains identifiers that are keywords in FreeBASIC. To deal with this I used the following solution:
A constant with a name that resembles a keyword in FreeBASIC has been given the prefix 'k'.
A variable with a name that resembles a keyword in FreeBASIC has been given the extension _ (as in str_).
A function/sub with a name that resembles a keyword in FreeBASIC has been given the prefix _ (as in _line).
The source has been updated again.
Update 10 - 02: The source has been removed (temporarily) from the forum. It just did not look good online (indentation was nowhere near acceptable).
I have found a source pretty printer that makes the source look great (even online). I hope to have the source online in, say, three pieces within a day or two. It will look as good as it can with line - numbering and of course the syntax highlighting this site provides.
Update 11-02: I uploaded the source code again with better indentation and now the lines are numbed.
C - source: 3065 lines
FB - source: 2907 lines
Mini-basic (a basic interpreter)
Mini-basic (a basic interpreter)
Last edited by AGS on Feb 11, 2008 17:03, edited 14 times in total.
-
E.K.Virtanen
- Posts: 785
- Joined: May 28, 2005 9:19
- Location: Finland
Code: Select all
1 /'***************************************************************
2 * Mini BASIC *
3 * by Malcolm McLean *
4 * version 1.0 *
5 * *
6 * Translated To FreeBASIC by *
7 * Arjan Schillemans *
8 ****************************************************************'/
9
10 #include "crt/stdio.bi"
11 #include "crt/stdlib.bi"
12 #include "crt/string.bi"
13 #include "crt/math.bi"
14 #include "crt/limits.bi"
15 #include "crt/ctype.bi"
16
17
18 /' tokens defined '/
19 #define EOS 0
20 #define VALUE 1
21 #define PI 2
22 #define E 3
23
24 #define kDIV 10
25 #define MULT 11
26 #define OPAREN 12
27 #define CPAREN 13
28 #define PLUS 14
29 #define MINUS 15
30 #define SHRIEK 16
31 #define COMMA 17
32 #define kMOD 200
33
34 #define kERROR 20
35 #define EOL 21
36 #define EQUALS 22
37 #define STRID 23
38 #define FLTID 24
39 #define DIMFLTID 25
40 #define DIMSTRID 26
41 #define QUOTE 27
42 #define GREATER 28
43 #define LESS 29
44 #define SEMICOLON 30
45
46 #define kPRINT 100
47 #define kLET 101
48 #define kDIM 102
49 #define kIF 103
50 #define kTHEN 104
51 #define kAND 105
52 #define kOR 106
53 #define kGOTO 107
54 #define kINPUT 108
55 #define kREM 109
56 #define kFOR 110
57 #define kTO 111
58 #define kNEXT 112
59 #define kSTEP 113
60
61 #define kSIN 5
62 #define kCOS 6
63 #define kTAN 7
64 #define LN 8
65 #define kPOW 9
66 #define kSQRT 18
67 #define kABS 201
68 #define kLEN 202
69 #define ASCII 203
70 #define kASIN 204
71 #define kACOS 205
72 #define kATAN 206
73 #define kINT 207
74 #define kRND 208
75 #define kVAL 209
76 #define VALLEN 210
77 #define kINSTR 211
78
79 #define CHRSTRING 300
80 #define STRSTRING 301
81 #define LEFTSTRING 302
82 #define RIGHTSTRING 303
83 #define MIDSTRING 304
84 #define STRINGSTRING 305
85
86 /' relational operators defined '/
87
88 #define ROP_EQ 1 /' equals '/
89 #define ROP_NEQ 2 /' doesn't equal '/
90 #define ROP_LT 3 /' less than '/
91 #define ROP_LTE 4 /' less than or equals '/
92 #define ROP_GT 5 /' greater than '/
93 #define ROP_GTE 6 /' greater than or equals '/
94
95 /' error codes (in BASIC script) defined '/
96 #define ERR_CLEAR 0
97 #define ERR_SYNTAX 1
98 #define ERR_OUTOFMEMORY 2
99 #define ERR_IDTOOLONG 3
100 #define ERR_NOSUCHVARIABLE 4
101 #define ERR_BADSUBSCRIPT 5
102 #define ERR_TOOMANYDIMS 6
103 #define ERR_TOOMANYINITS 7
104 #define ERR_BADTYPE 8
105 #define ERR_TOOMANYFORS 9
106 #define ERR_NONEXT 10
107 #define ERR_NOFOR 11
108 #define ERR_DIVIDEBYZERO 12
109 #define ERR_NEGLOG 13
110 #define ERR_NEGSQRT 14
111 #define ERR_BADSINCOS 15
112 #define ERR_EOF 16
113 #define ERR_ILLEGALOFFSET 17
114 #define ERR_TYPEMISMATCH 18
115 #define ERR_INPUTTOOLONG 19
116 #define ERR_BADVALUE 20
117 #define ERR_NOTINT 21
118
119 #define MAXFORS 32 /' maximum number of nested fors '/
120
121 Type LINE_
122 no As Integer /' line number '/
123 str_ As Zstring Ptr /' points to start of line '/
124 End Type
125
126 /' str = str_ '/
127 /' LINE = LINE_ '/
128
129 Type VARIABLE
130 id As ZString * 34 /' id of variable '/
131 dval As Double /' its value if a real '/
132 sval As ZString Ptr /' its value if a string (malloced) '/
133 End Type
134
135 Type DIMVAR
136 id As ZString * 34 /' id of dimensioned variable '/
137 type_ As Integer /' its type, STRID or FLTID '/
138 ndims As Integer /' number of dimensions '/
139 Dim_(5) As Integer /' dimensions in x y order '/
140 str_ As ZString Ptr Ptr /' pointer to string data '/
141 dval As Double Ptr /' pointer to real data '/
142 End Type
143
144 /' dim = dim_ and str = str_ '/
145 /' type = type_ '/
146
147 Type LVALUE
148 Type As Integer /' type of variable (STRID or FLTID or ERROR) '/
149 sval As ZString Ptr Ptr /' pointer to string data '/
150 dval As Double Ptr /' pointer to real data '/
151 End Type
152
153 Type FORLOOP
154 id As ZString * 34 /' id of control variable '/
155 nextline As Integer /' line below FOR to which control passes '/
156 toval As Double /' terminal value '/
157 step_ As Duoble /' step size '/
158 End Type
159
160 /' step = step_ '/
161
162 Static Forstack(MAXFORS) As FORLOOP /' stack for for loop conrol '/
163
164 Static nfors As Integer /' number of fors on stack '/
165
166 Static variables As VARIABLE Ptr /' the script's variables '/
167 Static nvariables As Integer /' number of variables '/
168
169 Static dimvariables As DIMVAR Ptr /' dimensioned arrays '/
170 Static ndimvariables As Integer /' number of dimensioned arrays '/
171
172 Static lines As LINE_ Ptr /' list of line starts '/
173 Static nlines As Integer /' number of BASIC lines in program '/
174
175 Static fpin As FILE Ptr /' input stream '/
176 Static fpout As FILE Ptr /' output strem '/
177 Static fperr As FILE Ptr /' error stream '/
178
179 Static string_ As ZString Ptr /' string we are parsing string = string_'/
180 Static token As Integer /' current token (lookahead) '/
181 Static errorflag As Integer /' set when error in input encountered '/
182
183 Declare Function Setup(Byval script As ZString Ptr) As Integer
184 Declare Sub Cleanup()
185
186 Declare Sub Reporterror(Byval lineno As Integer)
187 Declare Function Findline(Byval no As Integer) As Integer
188
189 Declare Function _line() As Integer
190 Declare Sub Doprint()
191 Declare Sub Dolet()
192 Declare Sub Dodim()
193 Declare Function Doif() As Integer
194 Declare Function Dogoto() As Integer
195 Declare Sub Doinput()
196 Declare Sub Dorem()
197 Declare Function Dofor() As Integer
198 Declare Function Donext() As Integer
199
200 Declare Sub Lvalue(Byval lv As LVALUE Ptr)
201
202 Declare Function Boolexpr() As Integer
203 Declare Function Boolfactor() As Integer
204 Declare Function Relop() As Integer
205
206
207 Declare Function Expr() As Double
208 Declare Function Term() As Double
209 Declare Function Factor() As Double
210 Declare Function _instr() As Double
211 Declare Function Variable() As Double
212 Declare Function Dimvariable() As Double
213
214
215 Declare Function Findvariable(Byval id As ZString Ptr) As VARIABLE Ptr
216 Declare Function Finddimvar(Byval id As ZString Ptr) As DIMVAR Ptr
217 Declare Function Dimension(Byval id As ZString Ptr, Byval ndims As Integer, ...) As DIMVAR Ptr
218 Declare Function Getdimvar(Byval dv As DIMVAR Ptr, ...) As Any Ptr
219 Declare Function Addfloat(Byval id As ZString Ptr) As VARIABLE Ptr
220 Declare Function Addstring(Byval id As ZString Ptr) As VARIABLE Ptr
221 Declare Function Adddimvar(Byval id As ZString Ptr) As DIMVAR Ptr
222
223 Declare Function Stringexpr() As ZString Ptr
224 Declare Function Chrstring(void) As ZString Ptr
225 Declare Function Strstring() As ZString Ptr
226 Declare Function Leftstring() As ZString Ptr
227 Declare Function Rightstring() As ZString Ptr
228 Declare Function Midstring() As ZString Ptr
229 Declare Function Stringstring() As ZString Ptr
230 Declare Function Stringdimvar() As ZString Ptr
231 Declare Function Stringvar() As ZString Ptr
232 Declare Function Stringliteral() As ZString Ptr
233
234 Declare Function _integer(Byval x As Double) As Integer /' integer = integer_ '/
235
236 Declare Sub Match(Byval tok As Integerint)
237 Declare Sub Seterror(Byval errorcode As Integer)
238 Declare Function Getnextline( Byval str_ As ZString Ptr) As Integer /' str = str_ '/
239 Declare Function Gettoken(Byval str_ As ZString Ptr) As Integer /' str = str_ '/
240 Declare Function Tokenlen(Byval str_ As ZString Ptr, Byval Token As Integer token) As Integer /' str = str_ '/
241
242 Declare Function Isstring(Byval token As Integer token) As Integer
243 Declare Function Getvalue(Byval str_ As ZString Ptr, Byval len As Integer Ptr) As Double /' str = str_ '/
244 Declare Sub Getid(Byval str_ As ZString Ptr, Byval out As ZString Ptr, Byval len As Integer Ptr) /' str = _str
245
246 Declare Sub Mystrgrablit(Byval dest As ZString Ptr, Byval src As ZString Ptr)
247 Declare Function Mystrend(Byval str_ As ZString Ptr, Byval quote As UByte) As ZString Ptr /' str = str_ '/
248 Declare Mystrcount(Byval str_ As ZString Ptr, Byval ch As UByte) As Integer /' str = str_'/
249 Declare Function Mystrdup(Byval str_ As ZString Ptr) As ZString Ptr /' str = _str '/
250 Declare Function Mystrconcat(Byval str_ As ZString Ptr, Byval cat As ZString Ptr) As ZString Ptr /' str = str_'/
251 Declare Function Factorial(Byval x As Double ) As Double
252 Declare Function Basic(Byval script As ZString Ptr, Byval In As FILE Ptr, Byval out_ As FILE Ptr, Byval err_ As FILE Ptr) As Integer
253
254
255 /'
256 Interpret a BASIC script
257
258 Params: script - the script To run
259 In - input stream
260 out_ - output stream
261 err_ - Error stream
262 Returns: 0 On success, 1 On Error condition.
263 '/
264 Function Basic(Byval script As ZString Ptr, Byval In As FILE Ptr, Byval out_ As FILE Ptr, Byval err_ As FILE Ptr) As Integer
265
266 Dim curline As Integer = 0
267 Dim nextline As Integer
268 Dim answer As Integer = 0
269
270 fpin = In
271 fpout = out_
272 fperr = err_
273
274 If (Setup(script) = -1) Then
275 Return 1
276 End If
277
278 While (curline <> -1)
279 string_ = lines[curline].str_
280 token = Gettoken(string_)
281 errorflag = 0
282
283 nextline = _line()
284 If (errorflag) Then
285 Reporterror(Lines(curline).no)
286 answer = 1
287 Exit While
288 End If
289
290 If (nextline = -1) Then
291 Exit While
292 End If
293
294 If (nextline = 0) Then
295 curline += 1
296 If (curline = nlines) Then
297 Exit While
298 Else
299 curline = Findline(nextline)
300 If (curline = -1) Then
301 If (fperr) Then
302 Fprintf(fperr, "line %d not found\n", nextline)
303 End If
304 answer = 1
305 Exit While
306 End If
307 End If
308 Wend
309
310 Cleanup()
311
312 Return answer
313 End Function
314
315 /'
316 Sets up all our globals, including the list of lines.
317 Params: script - the script passed by the user
318 Returns: 0 On success, -1 On failure
319 '/
320 Private Function Setup(Byval script As ZString Ptr) As Integer
321 Dim i As Integer
322
323 nlines = Mystrcount(script, "\n")
324 lines = Malloc(nlines * Sizeof(LINE_))
325 If (Not(lines)) Then
326 If (fperr) Then
327 Fprintf(fperr, "Out of memory\n")
328 End If
329 Return -1
330 End If
331 For i = 0 To nlines - 1
332 If (Isdigit(*script)) Then
333 lines[i].str_ = script
334 lines[i].no = Strtol(script, 0, 10)
335 Else
336 i -= 1
337 nlines -= 1
338 End If
339 script = Strchr(script, "\n")
340 script += 1
341 Next i
342 If (Not(nlines)) Then
343 If (fperr) Then
344 Fprintf(fperr, "Can't read program\n")
345 End If
346 Free(lines)
347 Return -1
348 End If
349
350 For i = 1 To nlines - 1
351 If (lines[i].no <= lines[i-1].no) Then
352 If (fperr) Then
353 Fprintf(fperr, "program lines %d and %d not in order\n", _
354 lines[i-1].no, lines[i].no)
355 End If
356 Free(lines)
357 Return -1
358 End If
359 Next i
360 nvariables = 0
361 variables = 0
362
363 dimvariables = 0
364 ndimvariables = 0
365
366 Return 0
367 End Function
368
369 /'
370 frees all the memory we have allocated
371 '/
372
373 Private Sub Cleanup()
374 Dim i As Integer
375 Dim ii As Integer
376 Dim size As Integer
377
378 For i=0 To nvariables - 1
379 If (variables[i].sval) Then
380 Free(variables[i].sval)
381 End If
382 Next i
383 If (variables) Then
384 Free(variables)
385 End If
386 variables = 0
387 nvariables = 0
388
389 For i=0 To ndimvariables - 1
390 If(dimvariables[i].type_ = STRID) Then
391 If (dimvariables[i].str_) Then
392 size = 1
393 For ii = 0 To dimvariables[i].ndims - 1
394 size *= dimvariables[i].dim_[ii]
395 Next ii
396 For ii=0 To size - 1
397 If (dimvariables[i].str_[ii]) Then
398 Free(dimvariables[i].str_[ii])
399 End If
400 Free(dimvariables[i].str_)
401 End If
402 Else
403 If (dimvariables[i].dval) Then
404 Free(dimvariables[i].dval)
405 End If
406 End If
407 Next i
408
409 If (dimvariables) Then
410 Free(dimvariables)
411 End If
412
413 dimvariables = 0
414 ndimvariables = 0
415
416 If (lines) Then
417 Free(lines)
418 End If
419
420 lines = 0
421 nlines = 0
422
423 End Sub
424
425 /'
426 Error report Function.
427 For reporting errors In the user's script.
428 checks the Global errorflag.
429 writes To fperr.
430 Params: lineno - the line On which the Error occurred
431 '/
432
433 Private Sub Reporterror(Byval lineno As Integer)
434 If (Not(fperr)) Then
435 Return
436 End If
437
438 Select Case errorflag
439 Case ERR_CLEAR
440 Assert(0)
441 Case ERR_SYNTAX
442 Fprintf(fperr, "Syntax error line %d\n", lineno)
443 Case ERR_OUTOFMEMORY
444 Fprintf(fperr, "Out of memory line %d\n", lineno)
445 Case ERR_IDTOOLONG
446 Fprintf(fperr, "Identifier too long line %d\n", lineno)
447 Case ERR_NOSUCHVARIABLE
448 Fprintf(fperr, "No such variable line %d\n", lineno)
449 Case ERR_BADSUBSCRIPT
450 Fprintf(fperr, "Bad subscript line %d\n", lineno)
451 Case ERR_TOOMANYDIMS
452 Fprintf(fperr, "Too many dimensions line %d\n", lineno)
453 Case ERR_TOOMANYINITS
454 Fprintf(fperr, "Too many initialisers line %d\n", lineno)
455 Case ERR_BADTYPE
456 Fprintf(fperr, "Illegal type line %d\n", lineno)
457 Case ERR_TOOMANYFORS
458 Fprintf(fperr, "Too many nested fors line %d\n", lineno)
459 Case ERR_NONEXT
460 Fprintf(fperr, "For without matching next line %d\n", lineno)
461 Case ERR_NOFOR
462 Fprintf(fperr, "Next without matching for line %d\n", lineno)
463 Case ERR_DIVIDEBYZERO
464 Fprintf(fperr, "Divide by zero lne %d\n", lineno)
465 Case ERR_NEGLOG
466 Fprintf(fperr, "Negative logarithm line %d\n", lineno)
467 Case ERR_NEGSQRT
468 Fprintf(fperr, "Negative square root line %d\n", lineno)
469 Case ERR_BADSINCOS
470 Fprintf(fperr, "Sine or cosine out of range line %d\n", lineno)
471 Case ERR_EOF
472 Fprintf(fperr, "End of input file %d\n", lineno)
473 Case ERR_ILLEGALOFFSET
474 Fprintf(fperr, "Illegal offset line %d\n", lineno)
475 Case ERR_TYPEMISMATCH
476 Fprintf(fperr, "Type mismatch line %d\n", lineno)
477 Case ERR_INPUTTOOLONG
478 Fprintf(fperr, "Input too long line %d\n", lineno)
479 Case ERR_BADVALUE
480 Fprintf(fperr, "Bad value at line %d\n", lineno)
481 Case ERR_NOTINT
482 Fprintf(fperr, "Not an integer at line %d\n", lineno)
483 Case Else
484 Fprintf(fperr, "ERROR line %d\n", lineno)
485 End Select
486 End Sub
487
488 /'
489 binary search For a line
490 Params: no - line number To find
491 Returns: index of the line, Or -1 On fail.
492 '/
493
494 Function Findline(Byval no As Integer) As Integer
495
496 Dim high As Integer
497 Dim low As Integer
498 Dim mid_ As Integer
499
500 low = 0
501 high = nlines-1
502 While (high > low + 1)
503 mid_ = (high + low)/2
504 If (lines[mid_].no = no) Then
505 Return mid_
506 End If
507 If(lines[mid_].no > no) Then
508 high = mid_
509 Else
510 low = mid_
511 End If
512 Wend
513
514 If (lines[low].no = no) Then
515 mid_ = low
516 Elseif (lines[high].no = no) Then
517 mid_ = high
518 Else
519 mid_ = -1
520 End If
521 Return Mid
522 End Function
523
524 /'
525 Parse a line. High level parse Function
526 '/
527 Private Function _line() As Integer
528 Dim answer As Integer = 0
529 Dim str_ As ZString Ptr
530
531 Match(VALUE)
532
533 Select token
534 Case kPRINT
535 Doprint()
536 Case kLET
537 Dolet()
538 Case kDIM
539 Dodim()
540 Case kIF
541 answer = Doif()
542 Case kGOTO
543 answer = Dogoto()
544 Case kINPUT
545 Doinput()
546 Case kREM
547 Dorem()
548 Return 0
549 Case kFOR
550 answer = Dofor()
551 Case kNEXT
552 answer = Donext()
553 Case Else
554 Seterror(ERR_SYNTAX)
555 End Select
556
557 If (token <> EOS) Then
558 /'match(VALUE)'/
559 /' check for a newline '/
560 str_ = string_
561 While (Isspace(*str_))
562 If (*str_ = "\n") Then
563 Exit While
564 End If
565 str_ += 1
566 Wend
567
568 If (*str_ <> "\n") Then
569 Seterror(ERR_SYNTAX)
570 End If
571 End If
572
573 Return answer
574 End Function
575
576 /'
577 the PRINT statement
578 '/
579 Private Sub Doprint()
580
581 Dim str_ As ZString Ptr
582 Dim x As Double
583
584 Match(kPRINT)
585
586 While (1)
587 If (Isstring(token)) Then
588 str_ = Stringexpr()
589 If (str_) Then
590 Fprintf(fpout, "%s", str_)
591 Free(str_)
592 End If
593 Else
594 x = Expr()
595 Fprintf(fpout, "%g", x)
596 End If
597
598 If (token = COMMA) Then
599 Fprintf(fpout, " ")
600 Match(COMMA)
601 Else
602 Exit While
603 End If
604 Wend
605
606 If (token = SEMICOLON) Then
607 Match(SEMICOLON)
608 Fflush(fpout)
609 Else
610 Fprintf(fpout, "\n")
611 End If
612 End Sub
613
614 /'
615 the Let statement
616 '/
617
618 Private Sub Dolet()
619 Dim lv As LVALUE
620 Dim temp As ZString Ptr
621
622 Match(kLET)
623 Lvalue(&lv)
624 Match(EQUALS)
625 Select lv.type_
626 Case FLTID
627 *lv.dval = Expr()
628 Case STRID
629 temp = *lv.sval
630 *lv.sval = Stringexpr()
631 If(temp) Then
632 Free(temp)
633 End If
634 Case Else
635 Continue
636 End Select
637 End Sub
638
639 /'
640 the Dim statement
641 '/
642 Private Sub Dodim()
643 Dim ndims As Integer = 0
644 Dim dims[6] As Double
645 Dim name_ As ZSting * 32
646 Dim len_ As Integer
647 Dim dimvar_ As DIMVAR Ptr
648 Dim i As Integer
649 Dim size As Integer = 1
650
651 Match(kDIM)
652
653 Select Case token
654 Case DIMFLTID
655 Case DIMSTRID
656 Getid(string_, name_, &len_)
657 Match(token)
658 dims[ndims] = Expr()
659 ndims += 1
660 While (token = COMMA)
661 Match(COMMA)
662 dims[ndims++] = Expr()
663 If (ndims > 5) Then
664 Seterror(ERR_TOOMANYDIMS)
665 Return
666 End If
667 Wend
668
669 Match(CPAREN)
670
671 For i=0 To ndims - 1
672 If (dims[i] < 0 Or dims[i] <> Cast(Integer,(dims[i])) Then
673 Seterror(ERR_BADSUBSCRIPT)
674 Return
675 End If
676 Next i
677 Case Select ndims
678 Case 1
679 dimvar_ = Dimension(name_, 1, Cast(Integer,dims[0]))
680 Case 2
681 dimvar_ = Dimension(name_, 2, Cast(Integer,dims[0]), Cast(Integer,dims[1]))
682 Case 3
683 dimvar_ = Dimension(name_, 3, Cast(Integer,dims[0]), Cast(Integer,dims[1]),Cast(Integer,dims[2]))
684 Case 4
685 dimvar_ = Dimension(name_, 4, Cast(Integer,dims[0]), Cast(Integer,dims[1]),Cast(Integer,dims[2]), Cast(Integer,dims[3]))
686 Case 5
687 dimvar_ = Dimension(name_, 5, Cast(Integer,dims[0]), Cast(Integer,dims[1]),Cast(Integer,dims[2]), Cast(Integer,dims[3]), Cast(Integer,
688 dims[4]))
689 End Select
690 Case Else
691 Seterror(ERR_SYNTAX)
692 Return
693 End Select
694 If (dimvar_ = 0) Then
695 /' out of memory '/
696 Seterror(ERR_OUTOFMEMORY)
697 End If
698 Return
699
700 End If
701
702
703 If (token = EQUALS) Then
704 Match(EQUALS)
705 For i=0 To dimvar_->ndims - 1
706 size *= dimvar_->dim_[i]
707 Next i
708 Select Case dimvar_->type_
709 Case FLTID
710 i = 0
711 dimvar_->dval[i] = Expr()
712 i += 1
713 While (token = COMMA And i < size)
714 Match(COMMA)
715 dimvar_->dval[i] = Expr()
716 i += 1
717 If (errorflag) Then
718 Exit While
719 End If
720 Wend
721 Case STRID
722 i = 0
723 If (dimvar_->str_[i]) Then
724 Free(dimvar_->str_[i])
725 End If
726 dimvar_->str_[i] = Stringexpr()
727 i += 1
728 While (token = COMMA And i < size)
729 Match(COMMA)
730 If (dimvar_->str_[i]) Then
731 Free(dimvar_->str_[i])
732 End If
733 dimvar_->str_[i] = Stringexpr()
734 i += 1
735 If (errorflag) Then
736 Exit
737 End If
738 Wend
739
740 If (token = COMMA) Then
741 Seterror(ERR_TOOMANYINITS)
742 End If
743 End Sub
744
745 /'
746 the If statement.
747 If jump taken, returns New line no, Else returns 0
748 '/
749 Private Function Doif() As Integer
750 Dim condition As Integer
751 Dim jump As Integer
752
753 Match(kIF)
754 condition = Boolexpr()
755 Match(kTHEN)
756 jump = _integer( Expr() )
757 If (condition) Then
758 Return jump
759 Else
760 Return 0
761 End If
762 End Function
763
764 /'
765 the Goto statement
766 returns New line number
767 '/
768
769 Private Function Dogoto() As Integer
770 Match(kGOTO)
771 Return _integer( Expr() )
772 End Function
773
774 /'
775 The For statement.
776
777 Pushes the For stack.
778 Returns line To jump To, Or -1 To End program
779
780 '/
781
782 Private Function Dofor() As Integer
783 Dim lv As LVALUE
784 Dim id As ZString * 34
785 Dim nextid As ZString * 34
786 Dim len_ As Integer
787 Dim initval As Double
788 Dim toval As Double
789 Dim stepval As Double
790 Dim savestring As ZString Ptr
791 Dim answer As Integer
792
793 Match(For)
794 Getid(string_, id, &len)
795
796 Lvalue(&lv)
797 If (lv.Type <> FLTID) Then
798 Seterror(ERR_BADTYPE)
799 Return -1
800 End If
801 Match(EQUALS)
802 initval = Expr()
803 Match(kTO)
804 toval = Expr()
805 If (token = kSTEP) Then
806 Match(kSTEP)
807 stepval = Expr()
808 Else
809 stepval = 1.0
810 End If
811
812 *lv.dval = initval
813
814 If (nfors > MAXFORS - 1) Then
815 Seterror(ERR_TOOMANYFORS)
816 Return -1
817 End If
818
819 If (stepval < 0 And initval < toval Or stepval > 0 And initval > toval) Then
820 savestring = string_
821 While (string_ = Strchr(string_, "\n"))
822 errorflag = 0
823 token = Gettoken(string_)
824 Match(VALUE)
825 If (token = kNEXT) Then
826 Match(kNEXT)
827 If (token = FLTID Or token = DIMFLTID) Then
828 Getid(string_, nextid, &len_)
829 End If
830 If (Not(Strcmp(id, nextid)) Then
831 answer = Getnextline(string_)
832 string_ = savestring
833 token = Gettoken(string_)
834 If (answer) Then
835 Return answer
836 Else
837 Return -1
838 End If
839 End If
840 End If
841 Reterror(ERR_NONEXT)
842 Return -1
843 Wend
844 Else
845 Strcpy(forstack[nfors].id, id)
846 forstack[nfors].nextline = Getnextline(string_)
847 forstack[nfors].step = stepval
848 forstack[nfors].toval = toval
849 nfors += 1
850 Return 0
851 End If
852 End Function
853
854 /'
855 the Next statement
856 updates the counting index, And returns line To jump To
857 '/
Code: Select all
858
859 Private Function Donext() As Integer
860 Dim id As ZString * 34
861 Dim len_ As Integer
862 Dim lv As LVALUE
863
864 Match(kNEXT)
865
866 If (nfors) Then
867 Getid(string_, id, &len_)
868 Lvalue(&lv)
869 If (lv.type_ <> FLTID) Then
870 Seterror(ERR_BADTYPE)
871 Return -1
872 End If
873 *lv.dval += forstack[nfors-1].step_
874 If ((forstack[nfors-1].step_ < 0 And *lv.dval < forstack[nfors-1].toval) Or _
875 (forstack[nfors-1].step_ > 0 And *lv.dval > forstack[nfors-1].toval)) Then
876 nfors -= 1
877 Return 0
878 Else
879 Return forstack[nfors-1].nextline
880 End If
881 Else
882 Seterror(ERR_NOFOR)
883 Return -1
884 End If
885 End Function
886
887 /'
888 the INPUT statement
889 '/
890
891 Private Sub Doinput()
892 Dim lv As LVALUE
893 Dim buff As ZString * 1024
894 Dim end_ As ZString Ptr
895
896 Match(kINPUT)
897 Lvalue(&lv)
898
899 Select Case lv.type_
900 Case FLTID:
901 While (Fscanf(fpin, "%lf", lv.dval) <> 1)
902 Fgetc(fpin)
903 If (Feof(fpin)) Then
904 Seterror(ERR_EOF)
905 Return
906 End If
907 Wend
908 Case STRID:
909 If (*lv.sval) Then
910 Free(*lv.sval)
911 *lv.sval = 0
912 End If
913 If (Fgets(buff, Sizeof(buff), fpin) = 0) Then
914 Seterror(ERR_EOF)
915 Return
916 End If
917 end_ = Strchr(buff, "\n")
918 If (Not(end_)) Then
919 Seterror(ERR_INPUTTOOLONG)
920 Return
921 End If
922 *end_ = 0
923 *lv.sval = Mystrdup(buff)
924 If (Not(*lv.sval)) Then
925 Seterror(ERR_OUTOFMEMORY)
926 Return
927 End If
928 Case Else:
929 Return
930 End Select
931 End Sub
932
933 /'
934 the REM statement.
935 Note is unique As the rest of the line is Not parsed
936
937 '/
938
939 Private Sub Dorem()
940 Match(kREM)
941 Return
942 End Sub
943
944 /'
945 Get an lvalue from the environment
946 Params: lv - structure To fill.
947 Notes: missing Variables (but Not out of range subscripts)
948 are added To the variable list.
949 '/
950
951 Private Sub Lvalue(Byval lv As LVALUE Ptr)
952 Dim name_ As ZString * 34
953 Dim len_ As Integer
954 Dim var_ As VARIABLE Ptr
955 Dim dimvar_ As DIMVAR Ptr
956 Dim Index(5) As Integer
957 Dim valptr As Any Ptr = 0
958 Dim type_ As Integer
959
960 lv->type_ = Error
961 lv->dval = 0
962 lv->sval = 0
963
964 Select Case token
965 Case FLTID
966 Getid(string_, name_, &len_)
967 Match(FLTID)
968 var = Findvariable(name_)
969 If (Not(var_)) Then
970 var = Addfloat(name_)
971 End If
972 If (Not(var_)) Then
973 Seterror(ERR_OUTOFMEMORY)
974 Return
975 End If
976 lv->type_ = FLTID
977 lv->dval = &var->dval
978 lv->sval = 0
979 Case STRID
980 Getid(string_, name_, &len_)
981 Match(STRID)
982 var_ = Findvariable(name_)
983 If (Not(var_)) Then
984 var = Addstring(name_)
985 End If
986 If (Not(var_)) Then
987 Seterror(ERR_OUTOFMEMORY)
988 Return
989 End If
990 lv->type_ = STRID
991 lv->sval = &var->sval
992 lv->dval = 0
993 Case DIMFLTID
994 Continue
995 Case DIMSTRID
996 If (token = DIMFLTID) Then
997 type_ = FLTID
998 Else
999 type_ = STRID
1000 End If
1001 Getid(string_, name_, &len_)
1002 Match(token)
1003 dimvar_ = Finddimvar(name_)
1004 If(dimvar_) Then
1005 Select Case dimvar_->ndims
1006 Case 1
1007 Index(0) = _integer( Expr() )
1008 If (errorflag = 0) Then
1009 valptr = Getdimvar(dimvar_, Index(0))
1010 End If
1011 Case 2
1012 Index(0) = _integer( Expr() )
1013 Match(COMMA)
1014 Index(1) = _integer( Expr() )
1015 If (errorflag = 0) Then
1016 valptr = Getdimvar(dimvar_, Index(0), Index(1))
1017 End If
1018 Case 3
1019 Index(0) = _integer( Expr() )
1020 Match(COMMA)
1021 Index(1) = _integer( Expr() )
1022 Match(COMMA)
1023 Index(2) = _integer( Expr() )
1024 If (errorflag = 0) Then
1025 valptr = Getdimvar(dimvar_, Index(0), Index(1), Index(2))
1026 End If
1027 Case 4
1028 Index(0) = _integer( Expr() )
1029 Match(COMMA)
1030 Index(1) = _integer( Expr() )
1031 Match(COMMA)
1032 Index(2) = _integer( Expr() )
1033 Match(COMMA)
1034 Index(3) = _integer( Expr() )
1035 If(errorflag = 0) Then
1036 valptr = Getdimvar(dimvar_, Index(0), Index(1), Index(2), Index(3))
1037 End If
1038 Case 5
1039 Index(0) = _integer( Expr() )
1040 Match(COMMA)
1041 Index(1) = _integer( Expr() )
1042 Match(COMMA)
1043 Index(2) = _integer( Expr() )
1044 Match(COMMA)
1045 Index(3) = _integer( Expr() )
1046 Match(COMMA)
1047 Index(4) = _integer( Expr() )
1048 If(errorflag = 0) Then
1049 valptr = Getdimvar(dimvar_, Index(0), Index(1), Index(2), Index(3))
1050 End If
1051 End Select
1052 Match(CPAREN)
1053 Else
1054 Seterror(ERR_NOSUCHVARIABLE)
1055 Return
1056 End If
1057 If (valptr) Then
1058 lv->type_ = type_
1059 End If
1060 If (type_ = FLTID) Then
1061 lv->dval = valptr
1062 Elseif (type_ = STRID) Then
1063 lv->sval = valptr
1064 Else
1065 Assert(0)
1066 End If
1067 Case Else
1068 Seterror(ERR_SYNTAX)
1069 End Select
1070 End Sub
1071
1072 /'
1073 parse a Boolean expression
1074 consists of expressions Or strings And relational operators,
1075 And parentheses
1076 '/
1077 Private Function Boolexpr() As Integer
1078 Dim left_ As Integer
1079 Dim right_ As Integer
1080
1081 left = Boolfactor()
1082
1083 While(1)
1084 Select Case token
1085 Case kAND
1086 Match(kAND)
1087 right_ = Boolexpr()
1088 If (left_ And right_) Then
1089 Return 1
1090 Else
1091 Return 0
1092 Case kOR
1093 Match(kOR)
1094 right_ = Boolexpr()
1095 If (left_ Or right_) Then
1096 Return 1
1097 Else
1098 Return 0
1099 End If
1100 Case Else
1101 Return left_
1102 End Select
1103 Wend
1104 End Function
1105
1106 /'
1107 Boolean factor, consists of expression relop expression
1108 Or String relop String, Or ( Boolexpr() )
1109 '/
1110 Private Function Boolfactor() As Integer
1111 Dim answer As Integer
1112 Dim left_ As Double
1113 Dim right_ As Double
1114 Dim op As Integer
1115 Dim strleft As ZString Ptr
1116 Dim strright As ZString Ptr
1117 Dim cmp As Integer
1118
1119 Select Case token
1120 Case OPAREN
1121 Match(OPAREN)
1122 answer = Boolexpr()
1123 Match(CPAREN)
1124 Case Else
1125 If(Isstring(token)) Then
1126 strleft = Stringexpr()
1127 op = Relop()
1128 strright = Stringexpr()
1129 If (Not(strleft) Or Not(strright)) Then
1130 If (strleft) Then
1131 Free(strleft)
1132 End If
1133 If (strright) Then
1134 Free(strright)
1135 End If
1136 Return 0
1137 End If
1138 cmp = Strcmp(strleft, strright)
1139 Select Case op
1140 Case ROP_EQ
1141 If (cmp = 0) Then
1142 answer = 1
1143 Else
1144 answer = 0
1145 End If
1146 Case ROP_NEQ
1147 If (cmp = 0) Then
1148 answer = 0
1149 Else
1150 answer = 1
1151 End If
1152 Case ROP_LT
1153 If (cmp < 0) Then
1154 answer = 1
1155 Else
1156 answer = 0
1157 End If
1158 Case ROP_LTE
1159 If (cmp <= 0) Then
1160 answer = 1
1161 Else
1162 answer = 0
1163 End If
1164 Case ROP_GT
1165 If (cmp > 0) Then
1166 answer = 1
1167 Else
1168 answer = 0
1169 End If
1170 Case ROP_GTE
1171 If (cmp >= 0) Then
1172 answer = 1
1173 Else
1174 answer = 0
1175 End If
1176 Case Else
1177 answer = 0
1178 End Select
1179 Free(strleft)
1180 Free(strright)
1181 Else
1182 left_ = Expr()
1183 op = Relop()
1184 right_ = Expr()
1185 Select Case op
1186 Case ROP_EQ
1187 If (left_ = rigth_) Then
1188 answer = 1
1189 Else
1190 answer = 0
1191 End If
1192 Case ROP_NEQ
1193 If (left_ <> rigth_) Then
1194 answer = 1
1195 Else
1196 answer = 0
1197 End If
1198 Case ROP_LT:
1199 If (left_ < rigth_) Then
1200 answer = 1
1201 Else
1202 answer = 0
1203 End If
1204 Case ROP_LTE:
1205 If (left_ <= rigth_) Then
1206 answer = 1
1207 Else
1208 answer = 0
1209 End If
1210 Case ROP_GT
1211 If (left_ > rigth_) Then
1212 answer = 1
1213 Else
1214 answer = 0
1215 End If
1216 Case ROP_GTE
1217 If (left_ >= rigth_) Then
1218 answer = 1
1219 Else
1220 answer = 0
1221 End If
1222 Case Else
1223 errorflag = 1
1224 Return 0
1225 End Select
1226 End If
1227 End Select
1228 Return answer
1229 End Function
1230
1231 /'
1232 Get a relational operator
1233 returns operator parsed Or Error
1234 '/
1235 Private Relop() As Integer
1236 Select Case token
1237 Case EQUALS
1238 Match(EQUALS)
1239 Return ROP_EQ
1240 Case GREATER
1241 Match(GREATER)
1242 If (token = EQUALS) Then
1243 Match(EQUALS)
1244 Return ROP_GTE
1245 End If
1246 Return ROP_GT
1247 Case LESS
1248 Match(LESS)
1249 If (token = EQUALS) Then
1250 Match(EQUALS)
1251 Return ROP_LTE
1252 Elseif (token = GREATER) Then
1253 Match(GREATER)
1254 Return ROP_NEQ
1255 End If
1256 Return ROP_LT
1257 Case Else
1258 Seterror(ERR_SYNTAX)
1259 Return Error
1260 End Case
1261 End Function
1262
1263 /'
1264 parses an expression
1265 '/
1266
1267 Private Function Expr() As Double
1268 Dim left_ As Double
1269 Dim right_ As Double
1270
1271 left_ = Term()
1272
1273 While(1)
1274 Select Case token
1275 Case PLUS
1276 Match(PLUS)
1277 right_ = Term()
1278 left_ += right_
1279 Case MINUS
1280 Match(MINUS)
1281 right_ = Term()
1282 left_ -= right_
1283 Case Else
1284 Return left_
1285 End Select
1286 Wend
1287 End Function
1288
1289 /'
1290 parses a term
1291 '/
1292 Private Function Term() As Double
1293 Dim left_ As Double
1294 Dim right_ As Double
1295
1296 left_ = Factor()
1297
1298 While(1)
1299 Select Case token
1300 Case MULT
1301 Match(MULT)
1302 right_ = Factor()
1303 left_ *= right_
1304 Case DIV
1305 Match(DIV)
1306 right_ = Factor()
1307 If (right_ <> 0.0) Then
1308 left_ /= right_
1309 Else
1310 Seterror(ERR_DIVIDEBYZERO)
1311 End If
1312 Case kMOD
1313 Match(kMOD)
1314 right_ = Factor()
1315 left_ = Fmod(left_, right_)
1316 Case Else
1317 Return left_
1318 End Select
1319 Wend
1320 End Function
1321
1322 /'
1323 parses a factor
1324 '/
1325 Private Function Factor() As Double
1326 Dim answer As Double = 0
1327 Dim str_ As ZString Ptr
1328 Dim end_ As ZString Ptr
1329 Dim len_ As Integer
1330
1331 Select Case token
1332 Case OPAREN:
1333 Match(OPAREN)
1334 answer = Expr()
1335 Match(CPAREN)
1336
1337 Case VALUE
1338 answer = Getvalue(string_, &len_)
1339 Match(VALUE)
1340 Case MINUS
1341 Match(MINUS)
1342 answer = -Factor()
1343 Case FLTID
1344 answer = Variable()
1345 Case DIMFLTID
1346 answer = Dimvariable()
1347 Case E
1348 answer = Exp(1.0)
1349 Match(E)
1350 Case PI
1351 answer = Acos(0.0) * 2.0
1352 Match(PI)
1353 Case kSIN
1354 Match(kSIN)
1355 Match(OPAREN)
1356 answer = Expr()
1357 Match(CPAREN)
1358 answer = Sin(answer)
1359 Case kCOS
1360 Match(kCOS)
1361 Match(OPAREN)
1362 answer = Expr()
1363 Match(CPAREN)
1364 answer = Cos(answer)
1365 Case kTAN
1366 Match(TAN)
1367 Match(OPAREN)
1368 answer = Expr()
1369 Match(CPAREN)
1370 answer = Tan(answer)
1371 Case LN
1372 Match(LN)
1373 Match(OPAREN)
1374 answer = Expr()
1375 Match(CPAREN)
1376 If (answer > 0) Then
1377 answer = Log(answer)
1378 Else
1379 Seterror(ERR_NEGLOG)
1380 End If
1381 Case POW
1382 Match(POW)
1383 Match(OPAREN)
1384 answer = Expr()
1385 Match(COMMA)
1386 answer = Pow(answer, Expr())
1387 Match(CPAREN)
1388 Case SQRT
1389 Match(SQRT)
1390 Match(OPAREN)
1391 answer = Expr()
1392 Match(CPAREN)
1393 If (answer >= 0.0) Then
1394 answer = Sqrt(answer)
1395 Else
1396 Seterror(ERR_NEGSQRT)
1397 End If
1398 Case kABS
1399 Match(kABS)
1400 Match(OPAREN)
1401 answer = Expr()
1402 Match(CPAREN)
1403 answer = Fabs(answer)
1404 Case kLEN
1405 Match(kLEN)
1406 Match(OPAREN)
1407 str_ = Stringexpr()
1408 Match(CPAREN)
1409 If (str_) Then
1410 answer = Strlen(str_)
1411 Free(str_)
1412 Else
1413 answer = 0
1414 End If
1415 Case ASCII
1416 Match(ASCII)
1417 Match(OPAREN)
1418 str_ = Stringexpr()
1419 Match(CPAREN)
1420 If (str_) Then
1421 answer = *str
1422 Free(str_)
1423 Else
1424 answer = 0
1425 End If
1426 Case kASIN
1427 Match(kASIN)
1428 Match(OPAREN)
1429 answer = Expr()
1430 Match(CPAREN)
1431 If (answer >= -1 And answer <= 1) Then
1432 answer = Asin(answer)
1433 Else
1434 Seterror(ERR_BADSINCOS)
1435 End If
1436 Case kACOS
1437 Match(kACOS)
1438 Match(OPAREN)
1439 answer = Expr()
1440 Match(CPAREN)
1441 If (answer >= -1 And answer <= 1) Then
1442 answer = Acos(answer)
1443 Else
1444 Seterror(ERR_BADSINCOS)
1445 End If
1446 Case kATAN
1447 Match(ATAN)
1448 Match(OPAREN)
1449 answer = Expr()
1450 Match(CPAREN)
1451 answer = Atan(answer)
1452 Case kINT
1453 Match(kINT)
1454 Match(OPAREN)
1455 answer = Expr()
1456 Match(CPAREN)
1457 answer = Floor(answer)
1458 Case kRND
1459 Match(kRND)
1460 Match(OPAREN)
1461 answer = Expr()
1462 Match(CPAREN)
1463 answer = _integer(answer)
1464 If (answer > 1) Then
1465 answer = Floor(Rand()/(RAND_MAX + 1.0) * answer)
1466 Elseif (answer = 1) Then
1467 answer = Rand()/(RAND_MAX + 1.0)
1468 Else
1469 If (answer < 0) Then
1470 Srand( Cast(unsigned, -answer))
1471 End If
1472 answer = 0
1473 End If
1474 Case kVAL
1475 Match(kVAL)
1476 Match(OPAREN)
1477 str_ = Stringexpr()
1478 Match(CPAREN)
1479 If (str_) Then
1480 answer = Strtod(str, 0)
1481 Free(str_)
1482 Else
1483 answer = 0
1484 End If
1485 Case VALLEN:
1486 Match(VALLEN)
1487 Match(OPAREN)
1488 str_ = Stringexpr()
1489 Match(CPAREN)
1490 If (str_) Then
1491 Strtod(str_, &end_)
1492 answer = end_ - str_
1493 Free(str)
1494 Else
1495 answer = 0.0
1496 End If
1497
1498 Case kINSTR
1499 answer = _instr()
1500 Case Else
1501 If (Isstring(token)) Then
1502 Seterror(ERR_TYPEMISMATCH)
1503 Else
1504 Seterror(ERR_SYNTAX)
1505 End If
1506 End Select
1507
1508 While (token = SHRIEK)
1509 Match(SHRIEK)
1510 answer = Factorial(answer)
1511 Wend
1512
1513 Return answer
1514 End Function
1515
1516 /'
1517 calculate the Instr() Function.
1518 '/
1519 Private Function _instr() As Double
1520 Dim str_ As ZString Ptr
1521 Dim substr As ZString Ptr
1522 Dim end_ As ZString Ptr
1523 Dim answer As Double = 0
1524 Dim offset As Integer
1525
1526 Match(kINSTR)
1527 Match(OPAREN)
1528 str_ = Stringexpr()
1529 Match(COMMA)
1530 substr = Stringexpr()
1531 Match(COMMA)
1532 offset = _integer( Expr() )
1533 offset--
1534 Match(CPAREN)
1535
1536 If (Not(str_) Or Not(substr)) Then
1537 If (str_) Then
1538 Free(str_)
1539 End If
1540 If (substr) Then
1541 Free(substr)
1542 End If
1543 Return 0
1544 End If
1545
1546 If (offset >= 0 And offset < Cast(Integer,Strlen(str_)) Then
1547 end_ = Strstr(str_ + offset, substr)
1548 If (end_) Then
1549 answer = end_ - str_ + 1.0
1550 End If
1551 End If
1552
1553 Free(str_)
1554 Free(substr)
1555
1556 Return answer
1557 End Function
1558
1559 /'
1560 Get the value of a scalar variable from String
1561 matches FLTID
1562 '/
1563
1564 Private Function Variable() As Double
1565 Dim var As VARIABLE Ptr
1566 Dim id As ZString * 34
1567 Dim len_ As Integer
1568
1569 Getid(string_, id, &len_)
1570 Match(FLTID)
1571 var = Findvariable(id)
1572 If (var) Then
1573 Return var->dval
1574 Else
1575 Seterror(ERR_NOSUCHVARIABLE)
1576 Return 0.0
1577 End If
1578 End Function
1579
1580 /'
1581 Get value of a dimensioned variable from String.
1582 matches DIMFLTID
1583 '/
1584 Private Function Dimvariable() As Double
1585 Dim dimvar_ As DIMVAR Ptr
1586 Dim id As ZString * 34
1587 Dim len_ As Integer
1588 Dim Index(5) As Integer
1589 Dim answer As Double Ptr
1590
1591 Getid(string_, id, &len_)
1592 Match(DIMFLTID)
1593 dimvar_ = Finddimvar(id)
1594 If (Not(dimvar_)) Then
1595 Seterror(ERR_NOSUCHVARIABLE)
1596 Return 0.0
1597 End If
1598
1599 If (dimvar_) Then
1600 Select Case dimvar_->ndims
1601 Case 1
1602 Index(0) = _integer( Expr() )
1603 answer = Getdimvar(dimvar_, Index(0))
1604 Case 2
1605 Index(0) = _integer( Expr() )
1606 Match(COMMA)
1607 Index(1) = _integer( Expr() )
1608 answer = Getdimvar(dimvar_, Index(0), Index(1))
1609 Case 3
1610 Index(0) = _integer( Expr() )
1611 Match(COMMA)
1612 Index(1) = _integer( Expr() )
1613 Match(COMMA)
1614 Index(2) = _integer( Expr() )
1615 answer = Getdimvar(dimvar_, Index(0), Index(1), Index(2))
1616 Case 4
1617 Index(0) = _integer( Expr() )
1618 Match(COMMA)
1619 Index(1) = _integer( Expr() )
1620 Match(COMMA)
1621 Index(2) = _integer( Expr() )
1622 Match(COMMA)
1623 Index(3) = _integer( Expr() )
1624 answer = Getdimvar(dimvar_, Index(0), Index(1), Index(2), Index(3))
1625 Case 5
1626 Index(0) = _integer( Expr() )
1627 Match(COMMA)
1628 Index(1) = _integer( Expr() )
1629 Match(COMMA)
1630 Index(2) = _integer( Expr() )
1631 Match(COMMA)
1632 Index(3) = _integer( Expr() )
1633 Match(COMMA)
1634 Index(4) = _integer( Expr() )
1635 answer = Getdimvar(dimvar_, Index(0), Index(1), Index(2), Index(3), Index(4))
1636 End Select
1637 Match(CPAREN)
1638 End If
1639
1640 If (answer) Then
1641 Return *answer
1642 End If
1643
1644 Return 0.0
1645 End Function
1646
1647 /'
1648 find a scalar variable invariables list
1649 Params: id - id To Get
1650 Returns: pointer To that entry, 0 On fail
1651 '/
1652 Private Function Findvariable(Dim id As ZString Ptr) As VARIABLE Ptr
1653 Dim i As Integer
1654
1655 For i = 0 To nvariables - 1
1656 If (Not(Strcmp(variables[i].id, id)) Then
1657 Return &variables[i]
1658 Next i
1659 Return 0
1660 End Function
1661
1662
1663 /'
1664 Get a dimensioned array by name
1665 Params: Id (includes opening parenthesis)
1666 Returns: pointer To array entry Or 0 On fail
1667 '/
1668 Private Function Finddimvar(Byval id As ZString Ptr) As DIMVAR Ptr
1669 Dim i As Integer
1670
1671 For i = 0 To ndimvariables - 1
1672 If (Not(Strcmp(dimvariables[i].id, id)) Then
1673 Return &dimvariables[i]
1674 Next i
1675 Return 0
1676 End Function
1677
1678 /'
1679 dimension an array.
1680 Params: id - the id of the Array (include Leading ()
1681 ndims - number of Dimension (1-5)
1682 ... - integers giving dimension size,
1683 '/
1684 Private Function Dimension(Byval id As ZString Ptr, Byval ndims As Integer, ...) As DIMVAR Ptr
1685
1686 Dim dv As DIMVAR Ptr
1687 Dim vargs As Any Ptr
1688 Dim size As Integer = 1
1689 Dim oldsize As Integer = 1
1690 Dim i As Integer
1691 Dim Dimensions(5) As Integer
1692 Dim dtemp As Double Ptr
1693 Dim stem As ZString Ptr Ptr
1694
1695 Assert(ndims <= 5)
1696 If (ndims > 5) Then
1697 Return 0
1698 End If
1699
1700 dv = Finddimvar(id)
1701 If (Not(dv)) Then
1702 dv = Adddimvar(id)
1703 End If
1704 If (Not(dv)) Then
1705 Seterror(ERR_OUTOFMEMORY)
1706 Return 0
1707 End If
1708
1709 If (dv->ndims) Then
1710 For i = 0 To dv->ndims - 1
1711 oldsize *= dv->Dim[i]
1712 End If
1713 Else
1714 oldsize = 0
1715 End If
1716
1717 vargs = va_first
1718 For i = 0 ndims - 1
1719 dimensions[i] = Va_arg(vargs, Integer)
1720 vargs = Va_next(vargs, Integer)
1721 size *= dimensions[i]
1722 Next i
1723
1724 Select Case dv->type_
1725 Case FLTID
1726 dtemp = Realloc(dv->dval, size * Sizeof(Double))
1727 If (dtemp) Then
1728 dv->dval = dtemp
1729 Else
1730 Seterror(ERR_OUTOFMEMORY)
1731 Return 0
1732 End If
1733 Case STRID
1734 If (dv->str_) Then
1735 For i = size To oldsize - 1
1736 If (dv->str_[i]) Then
1737 Free(dv->str_[i])
1738 dv->str_[i] = 0
1739 End If
1740 Next i
1741 End If
1742 stemp = Realloc(dv->str_, size * Sizeof(char *))
1743 If (stemp) Then
1744 dv->str_ = stemp
1745 For i = oldsize To size - 1
1746 dv->str_[i] = 0
1747 Next i
1748 Else
1749 For i = 0 To oldsize - 1
1750 If (dv->str_[i]) Then
1751 Free(dv->str_[i])
1752 dv->str_[i] = 0
1753 End If
1754 Seterror(ERR_OUTOFMEMORY)
1755 Return 0
1756 End If
1757 Case Else
1758 Assert(0)
1759 End Select
1760
1761 For i = 0 To 4
1762 dv->dim_[i] = dimensions[i]
1763 Next i
1764 dv->ndims = ndims
1765 Return dv
1766 End Function
Code: Select all
1767
1768 /'
1769 Get the address of a dimensioned array element.
1770 works For both String And real arrays.
1771 Params: dv - the array's entry in variable list
1772 ... - integers telling which array element To Get
1773 Returns: the address of that element, 0 On fail
1774 '/
1775
1776 Private Function Getdimvar(Byval dv As DIMVAR Ptr, ...) As Any Ptr
1777 Dim vargs As Any Ptr
1778 Dim Index(5) As Integer
1779 Dim i As Integer
1780 Dim answer As Any Ptr = 0
1781
1782 vargs = va_first
1783 For i = 0 To dv->ndims - 1
1784 Index(i) = Va_arg(vargs, Integer)
1785 vargs = Va_next(vargs, Integer)
1786 Index(i) -= 1
1787 Next i
1788 For i = 0 To dv->ndims - 1
1789 If (Index(i) >= dv->Dim_(i) Or Index(i) < 0) Then
1790 Seterror(ERR_BADSUBSCRIPT)
1791 Return 0
1792 End If
1793 Next i
1794 If (dv->Type = FLTID) Then
1795 Select Case dv->ndims)
1796 Case 1
1797 answer = &dv->Dval( Index(0) )
1798 Case 2
1799 answer = &dv->Dval( Index(1) * dv->Dim_(0) + Index(0) )
1800 Case 3
1801 answer = &dv->Dval( Index(2) * (dv->Dim_(0) * dv->dim_[1]) + _
1802 Index(1) * dv->Dim_(0) + Index(0) )
1803 Case 4
1804 answer = &dv->Dval( Index(3) * (dv->Dim_(0) + dv->Dim_(1) + dv->Dim_(2)) + _
1805 Index(2) * (dv->Dim_(0) * dv->dim_[1]) + Index(1) * dv->Dim_(0) + Index(0))
1806 Case 5
1807 answer = &dv->Dval( Index(4) * (dv->Dim_(0) + dv->Dim_(1) + dv->Dim_(2) + dv->Dim_(3)) + _
1808 Index(3) * (dv->Dim_(0) + dv->Dim_(1) + dv->dim_[2]) + Index(2) * (dv->Dim_(0) + _
1809 dv->dim_[1]) + Index(1) * dv->Dim_(0) + Index(0))
1810 End Select
1811 Elseif (dv->type_ = STRID) Then
1812 Select Case dv->ndims
1813 Case 1
1814 answer = &dv->Str_(Index(0))
1815 Case 2
1816 answer = &dv->Str_(Index(1) * dv->Dim_(0) + Index(0))
1817 Case 3
1818 answer = &dv->Str_(Index(2) * (dv->Dim_(0) * dv->Dim_(1)) + Index(1) * dv->Dim_(0) + _
1819 Index(0))
1820 Case 4
1821 answer = &dv->Str_(Index(3) * (dv->Dim_(0) + dv->Dim_(1) + dv->Dim_(2)) + _
1822 Index(2) * (dv->Dim_(0) * dv->Dim_(1)) + Index(1) * dv->Dim_(0) + _
1823 Index(0))
1824 Case 5
1825 answer = &dv->Str_(Index(4) * (dv->Dim_(0) + dv->Dim_(1) + dv->Dim_(2) + dv->Dim_(3)) + _
1826 Index(3) * (dv->Dim_(0) + dv->Dim_(1) + dv->Dim_(2)) + Index(2) * (dv->Dim_(0) + _
1827 dv->Dim_(1)) + Index(1) * dv->Dim_(0) + Index(0))
1828 End Select
1829 End If
1830 Return answer
1831 End Function
1832
1833 /'
1834 add a real varaible To our variable list
1835 Params: id - id of varaible To add.
1836 Returns: pointer To New entry In table
1837 '/
1838 Private Function Addfloat(Byval id As ZString Ptr) As VARIABLE Ptr
1839 Dim vars As VARIABLE Ptr
1840
1841 vars = Realloc(variables, (nvariables + 1) * Sizeof(VARIABLE))
1842 If (vars) Then
1843 variables = vars
1844 Strcpy(variables[nvariables].id, id)
1845 variables[nvariables].dval = 0
1846 variables[nvariables].sval = 0
1847 nvariables += 1
1848 Return &variables[nvariables-1]
1849 Else
1850 Seterror(ERR_OUTOFMEMORY)
1851 End If
1852 Return 0
1853 End Function
1854
1855 /'
1856 add a String variable To table.
1857 Params: id - id of variable To Get (including trailing $)
1858 Retruns: pointer To New entry In table, 0 On fail.
1859 '/
1860 Private Function Addstring(Dim id As ZString Ptr) As VARIABLE Ptr
1861 Dim vars As VARIABLE Ptr
1862
1863 vars = Realloc(variables, (nvariables + 1) * Sizeof(VARIABLE))
1864 If (vars) Then
1865 variables = vars
1866 Strcpy(variables[nvariables].id, id)
1867 variables[nvariables].sval = 0
1868 variables[nvariables].dval = 0
1869 nvariables += 1
1870 Return &variables[nvariables-1]
1871 Else
1872 Seterror(ERR_OUTOFMEMORY)
1873 End If
1874
1875 Return 0
1876 End Function
1877
1878 /'
1879 add a New array To our symbol table.
1880 Params: id - id of Array (include Leading ()
1881 Returns: pointer To New entry, 0 On fail.
1882 '/
1883 Private Function Adddimvar(Byval id As ZString Ptr) As DIMVAR Ptr
1884 Dim vars As DIMVAR Ptr
1885
1886 vars = Realloc(dimvariables, (ndimvariables + 1) * Sizeof(DIMVAR))
1887 If (vars) Then
1888 dimvariables = vars
1889 Strcpy(dimvariables[ndimvariables].id, id)
1890 dimvariables[ndimvariables].dval = 0
1891 dimvariables[ndimvariables].str_ = 0
1892 dimvariables[ndimvariables].ndims = 0
1893 If (Strchr(id,"$")) Then
1894 dimvariables[ndimvariables].type_ = STRID
1895 Else
1896 dimvariables[ndimvariables].type_ = FLTID
1897 ndimvariables +=1
1898 Return &dimvariables[ndimvariables-1]
1899 Else
1900 seterror(ERR_OUTOFMEMORY)
1901 End If
1902
1903 Return 0
1904 End Function
1905
1906 /'
1907 high level string parsing function.
1908 Returns: a malloced pointer, or 0 on error condition.
1909 caller must free!
1910 '/
1911 Private Function stringexpr() As ZString Ptr
1912 Dim left_ As ZString Ptr
1913 Dim right_ As ZString Ptr
1914 Dim temp As ZString Ptr
1915
1916 Select Case token
1917 Case DIMSTRID
1918 left_ = mystrdup(stringdimvar())
1919 Case STRID
1920 left_ = mystrdup(stringvar())
1921 Case QUOTE:
1922 left_ = stringliteral()
1923 Case CHRSTRING
1924 left_ = chrstring()
1925 Case STRSTRING
1926 left_ = strstring()
1927 Case LEFTSTRING
1928 left_ = leftstring()
1929 Case RIGHTSTRING
1930 left_ = rightstring()
1931 Case MIDSTRING
1932 left_ = midstring()
1933 Case STRINGSTRING:
1934 left_ = stringstring()
1935 Case Else
1936 If (Not(isstring(token)) Then
1937 seterror(ERR_TYPEMISMATCH)
1938 Else
1939 seterror(ERR_SYNTAX)
1940 End If
1941 Return mystrdup("")
1942 End Select
1943
1944 If (Not(left)) Then
1945 seterror(ERR_OUTOFMEMORY)
1946 Return 0
1947 End If
1948
1949 Select Case token
1950 Case PLUS
1951 match(PLUS)
1952 right_ = stringexpr()
1953 If (right_) Then
1954 temp = mystrconcat(left_, right_)
1955 free(right_)
1956 If (temp) Then
1957 free(left_)
1958 left_ = temp
1959 Else
1960 seterror(ERR_OUTOFMEMORY)
1961 End If
1962 Else
1963 seterror(ERR_OUTOFMEMORY)
1964 End If
1965 Case Else
1966 Return left_
1967 End Select
1968
1969 Return left_
1970 End Function
1971
1972 /'
1973 parse the CHR$ token
1974 '/
1975 Private Function chrstring() As ZString Ptr
1976 Dim x As
1977 Dim buf As ZString * 8
1978 Dim answer As ZString
1979
1980 match(CHRSTRING)
1981 match(OPAREN)
1982 x = _integer( expr() )
1983 match(CPAREN)
1984
1985 buff[0] = Cast(UByte,x)
1986 buff[1] = 0
1987 answer = mystrdup(buff)
1988
1989 If (Not(answer)) Then
1990 seterror(ERR_OUTOFMEMORY)
1991 End If
1992
1993 Return answer
1994 End Function
1995
1996 /'
1997 parse the STR$ token
1998 '/
1999 Private Function strstring() As ZString Ptr
2000 Dim x As double
2001 Dim buf As ZString * 64
2002 Dim answer As ZString Ptr
2003
2004 match(STRSTRING)
2005 match(OPAREN)
2006 x = expr()
2007 match(CPAREN)
2008 sprintf(buff, "%g", x)
2009 answer = mystrdup(buff)
2010 If (Not(answer)) Then
2011 seterror(ERR_OUTOFMEMORY)
2012 End If
2013 Return answer
2014 End Function
2015
2016 /'
2017 parse the LEFT$ token
2018 '/
2019 Private Function leftstring(void) As ZString Ptr
2020 Dim str_ As ZString Ptr
2021 Dim x As Integer
2022 Dim char As ZString Ptr
2023
2024 match(LEFTSTRING)
2025 match(OPAREN)
2026 str_ = stringexpr()
2027 If (Not(str)) Then
2028 Return 0
2029 End If
2030 match(COMMA)
2031 x = _integer( expr() )
2032 match(CPAREN)
2033
2034 If (x > Cast(Integer, strlen(str_))) Then
2035 Return str_
2036 End If
2037 If (x < 0) Then
2038 seterror(ERR_ILLEGALOFFSET)
2039 Return str_
2040 End If
2041 str_[x] = 0
2042 answer = mystrdup(str_)
2043 free(str_)
2044 If (Not(answer)) Then
2045 seterror(ERR_OUTOFMEMORY)
2046 End If
2047 Return answer
2048 End Function
2049
2050 /'
2051 parse the RIGHT$ token
2052 '/
2053 Private Function rightstring() As ZString Ptr
2054 Dim x As Integer
2055 Dim str_ As ZString Ptr
2056 Dim answer As ZString Ptr
2057
2058 match(RIGHTSTRING)
2059 match(OPAREN)
2060 str_ = stringexpr()
2061 If (Not(str_)) Then
2062 Return 0
2063 End If
2064 match(COMMA)
2065 x = _integer( expr() )
2066 match(CPAREN)
2067
2068 If( x > Cast((Integer,strlen(str_))) Then
2069 Return str_
2070 End If
2071
2072 If (x < 0) Then
2073 seterror(ERR_ILLEGALOFFSET)
2074 Return str_
2075 End If
2076
2077 answer = mystrdup( &str_[strlen(str_) - x] )
2078 free(str_)
2079 If (Not(answer)) Then
2080 seterror(ERR_OUTOFMEMORY)
2081 End If
2082 Return answer
2083 End Function
2084
2085 /'
2086 parse the MID$ token
2087 '/
2088 Private Function midstring() As ZString Ptr
2089 Dim str_ As ZString Ptr
2090 Dim x As Integer
2091 Dim len_ As Integer
2092 Dim answer As ZString Ptr
2093 Dim temp As ZString Ptr
2094
2095 match(MIDSTRING)
2096 match(OPAREN)
2097 str_ = stringexpr()
2098 match(COMMA)
2099 x = _integer( expr() )
2100 match(COMMA)
2101 len_ = _integer( expr() )
2102 match(CPAREN)
2103
2104 If (Not(str_)) Then
2105 Return 0
2106 End If
2107
2108 If (len_ = -1) Then
2109 len_ = strlen(str_) - x + 1
2110 End If
2111
2112 If ( x > (Cast(Integer,strlen(str_)) Or len_ < 1) Then
2113 free(str_)
2114 answer = mystrdup("")
2115 If (Not(answer))
2116 seterror(ERR_OUTOFMEMORY)
2117 Return answer
2118 End If
2119
2120 If (x < 1.0) Then
2121 seterror(ERR_ILLEGALOFFSET)
2122 Return str_
2123 End If
2124
2125 temp = &str_[x-1]
2126
2127 answer = malloc(len_ + 1)
2128 If (Not(answer)) Then
2129 seterror(ERR_OUTOFMEMORY)
2130 Return str_
2131 End If
2132 strncpy(answer, temp, len_)
2133 answer[len_] = 0
2134 free(str_)
2135
2136 Return answer
2137 End Function
2138
2139 /'
2140 parse the string$ token
2141 '/
2142 Private Function stringstring(void) As ZString Ptr
2143 Dim x As Integer
2144 Dim str_ As ZString Ptr
2145 Dim answer As ZString Ptr
2146 Dim len_ As Integer
2147 Dim N As Integer
2148 Dim i As Integer
2149
2150 match(STRINGSTRING)
2151 match(OPAREN)
2152 x = _integer( expr() )
2153 match(COMMA)
2154 str_ = stringexpr()
2155 match(CPAREN)
2156
2157 If (Not(str)) Then
2158 Return 0
2159 End If
2160
2161 N = x
2162
2163 If (N < 1) Then
2164 free(str_)
2165 answer = mystrdup("")
2166 If (Not(answer)) Then
2167 seterror(ERR_OUTOFMEMORY)
2168 End If
2169 Return answer
2170 End If
2171
2172 len_ = strlen(str_)
2173 answer = malloc( N * len_ + 1 )
2174 If (Not(answer)) Then
2175 free(str)
2176 seterror(ERR_OUTOFMEMORY)
2177 Return 0
2178 End If
2179 For i = 0 To N - 1
2180 strcpy(answer + len_ * i, str_)
2181 Next i
2182
2183 free(str_)
2184
2185 Return answer
2186 End Function
2187
2188 /'
2189 read a dimensioned string variable from input.
2190 Returns: pointer to string (not malloced)
2191 '/
2192 Private Function stringdimvar() As ZString Ptr
2193 Dim id As ZString * 34
2194 Dim len_ As Integer
2195 Dim dimvar As DIMVAR Ptr
2196 Dim answer As ZString Ptr Ptr
2197 Dim index(5) As Integer
2198
2199 getid(string_, id, &len_)
2200 match(DIMSTRID)
2201 dimvar = finddimvar(id)
2202
2203 If (dimvar) Then
2204 Select Case dimvar->ndims
2205 Case 1
2206 index(0) = _integer( expr() )
2207 answer = getdimvar(dimvar, index(0))
2208 Case 2
2209 index(0) = _integer( expr() )
2210 match(COMMA)
2211 index(1) = _integer( expr() )
2212 answer = getdimvar(dimvar, index(0), index(1))
2213 Case 3
2214 index(0) = _integer( expr() )
2215 match(COMMA)
2216 index(1) = _integer( expr() )
2217 match(COMMA)
2218 index(2) = _integer( expr() )
2219 answer = getdimvar(dimvar, index(0), index(1), index(2))
2220 Case 4
2221 index(0) = _integer( expr() )
2222 match(COMMA)
2223 index(1) = _integer( expr() )
2224 match(COMMA)
2225 index(2) = _integer( expr() )
2226 match(COMMA)
2227 index(3) = _integer( expr() )
2228 answer = getdimvar(dimvar, index(0), index(1), index(2), index(3))
2229 Case 5
2230 index(0) = _integer( expr() )
2231 match(COMMA)
2232 index(1) = _integer( expr() )
2233 match(COMMA)
2234 index(2) = _integer( expr() )
2235 match(COMMA)
2236 index(3) = _integer( expr() )
2237 match(COMMA)
2238 index(4) = integer( expr() )
2239 answer = getdimvar(dimvar, index(0), index(1), index(2), index(3), index(4))
2240 End Select
2241 match(CPAREN)
2242 Else
2243 seterror(ERR_NOSUCHVARIABLE)
2244 End If
2245
2246 If (Not(errorflag)) Then
2247 If (*answer) Then
2248 Return *answer
2249 End If
2250 End If
2251 Return ""
2252 End Function
2253
2254 /'
2255 parse a string variable.
2256 Returns: pointer to string (not malloced)
2257 '/
2258 Private Function stringvar() As ZString Ptr
2259 Dim id As ZString * 34
2260 Dim len_ As Integer
2261 Dim var As VARIABLE Ptr
2262
2263 getid(string_, id, &len_)
2264 match(STRID)
2265 var = findvariable(id)
2266 If (var) Then
2267 If(var->sval) Then
2268 Return var->sval
2269 End If
2270 Return ""
2271 End If
2272 seterror(ERR_NOSUCHVARIABLE)
2273 Return ""
2274 End Function
Code: Select all
2275
2276 /'
2277 parse a string literal
2278 Returns: malloced string literal
2279 Notes: newlines aren't allwed in literals, but blind
2280 concatenation across newlines is.
2281 '/
2282 Private Function stringliteral() As ZString Ptr
2283 Dim len_ As Integer = 1
2284 Dim answer As ZString Ptr = 0
2285 Dim temp As ZString Ptr
2286 Dim substr As ZString Ptr
2287 Dim end_ As ZString Ptr
2288
2289 While (token = QUOTE)
2290 While (isspace(*string_))
2291 string_ += 1
2292 Wend
2293 end_ = mystrend(string_, '"')
2294 If (end_) Then
2295 len_ = end_ - string_
2296 substr = Malloc(len_)
2297 If (Not(substr)) Then
2298 Seterror(ERR_OUTOFMEMORY)
2299 Return answer
2300 End If
2301 Mystrgrablit(substr, string_)
2302 If (answer) Then
2303 temp = Mystrconcat(answer, substr)
2304 Free(substr)
2305 Free(answer)
2306 answer = temp
2307 If (Not(answer)) Then
2308 Seterror(ERR_OUTOFMEMORY)
2309 Return answer
2310 End If
2311 Else
2312 answer = substr
2313 End If
2314 string_ = end_
2315 Else
2316 Seterror(ERR_SYNTAX)
2317 Return answer
2318 End If
2319
2320 Match(QUOTE)
2321 Wend
2322
2323 Return answer
2324 End Function
2325
2326 /'
2327 cast a Double To an Integer, triggering errors If out of range
2328 '/
2329 Private Function _integer(Byval x As Double) As Integer
2330 If ( x < INT_MIN Or x > INT_MAX ) Then
2331 Seterror( ERR_BADVALUE )
2332 End If
2333 If ( x <> Floor(x) ) Then
2334 Seterror( ERR_NOTINT )
2335 End If
2336 Return Cast(Integer,x)
2337 End Function
2338
2339 /'
2340 check that we have a token of the passed Type
2341 (If Not Set the errorflag)
2342 Move parser On To Next token. Sets token And String.
2343 '/
2344 Private Sub Match(Byval tok As Integer)
2345 If (token <> tok) Then
2346 Seterror(ERR_SYNTAX)
2347 Return
2348 End If
2349
2350 While (Isspace(*string_))
2351 string_ += 1
2352 Wend
2353
2354 string_ += Tokenlen(string_, token)
2355 token = Gettoken(string_)
2356 If (token = Error) Then
2357 Seterror(ERR_SYNTAX)
2358 End If
2359 End Sub
2360
2361 /'
2362 Set the errorflag.
2363 Params: errorcode - the Error.
2364 Notes: ignores Error cascades
2365 '/
2366 Private Sub Seterror(Byval errorcode As Integer)
2367 If (errorflag = 0 Or errorcode = 0) Then
2368 errorflag = errorcode
2369 End If
2370 End Sub
2371
2372 /'
2373 Get the Next line number
2374 Params: str - pointer To parse String
2375 Returns: line no of Next line, 0 If End
2376 Notes: goes To newline, Then finds
2377 first line starting With a digit.
2378 '/
2379 Private Function Getnextline(Byval str_ As ZString Ptr) As Integer
2380
2381 While (*str_)
2382 While (*str_ And *str_ != "\n")
2383 str_ += 1
2384 Wend
2385 If (*str_ = 0) Then
2386 Return 0
2387 End If
2388 str_ += 1
2389 If (Isdigit(*str_)) Then
2390 Return Atoi(str_)
2391 End If
2392 Wend
2393 Return 0
2394 End Function
2395
2396 /'
2397 Get a token from the String
2398 Params: str - String To read token from
2399 Notes: ignores white space between tokens
2400 '/
2401
2402 Private Function Gettoken(Byval str_ As ZString Ptr) As Integer
2403 While (Isspace(*str_))
2404 str_ += 1
2405 Wend
2406
2407 If (Isdigit(*str_)) Then
2408 Return VALUE
2409 End If
2410
2411 Case Select *str_
2412 Case 0
2413 Return EOS
2414 Case "\n"
2415 Return EOL
2416 Case "/"
2417 Return DIV
2418 Case "*"
2419 Return MULT
2420 Case "("
2421 Return OPAREN
2422 Case ")"
2423 Return CPAREN
2424 Case "+"
2425 Return PLUS
2426 Case "-"
2427 Return MINUS
2428 Case "!"
2429 Return SHRIEK
2430 Case ","
2431 Return COMMA
2432 Case "'"
2433 Return SEMICOLON
2434 Case """"
2435 Return QUOTE
2436 Case "="
2437 Return EQUALS
2438 Case "<"
2439 Return LESS
2440 Case ">"
2441 Return GREATER
2442 Case Else
2443 If (Not(Strncmp(str_, "e", 1)) And Not(Isalnum(str_[1]))) Then
2444 Return E
2445 End If
2446 If (Isupper(*str_)) Then
2447 If (Not(Strncmp(str_, "kSIN", 3)) And Not(Isalnum(str_[3]))) Then
2448 Return kSIN
2449 If (Not(Strncmp(str_, "kCOS", 3)) And Not(Isalnum(str_[3]))) Then
2450 Return kCOS
2451 If (Not(Strncmp(str_, "kTAN", 3)) And Not(Isalnum(str_[3]))) Then
2452 Return kTAN
2453 If (Not(Strncmp(str_, "LN", 2)) And Not(Isalnum(str_[2]))) Then
2454 Return LN
2455 If (Not(Strncmp(str_, "kPOW", 3)) And Not(Isalnum(str_[3]))) Then
2456 Return POW
2457 If (Not(Strncmp(str_, "PI", 2)) And Not(Isalnum(str_[2]))) Then
2458 Return PI
2459 If (Not(Strncmp(str_, "kSQRT", 4)) And Not(Isalnum(str_[4]))) Then
2460 Return SQRT
2461 If (Not(Strncmp(str_, "kPRINT", 5)) And Not(Isalnum(str_[5]))) Then
2462 Return kPRINT
2463 If (Not(Strncmp(str_, "kLET", 3)) And Not(Isalnum(str_[3]))) Then
2464 Return kLET
2465 If (Not(Strncmp(str_, "kDIM", 3)) And Not(Isalnum(str_[3]))) Then
2466 Return kDIM
2467 If (Not(Strncmp(str_, "kIF", 2)) And Not(Isalnum(str_[2]))) Then
2468 Return kIF
2469 If (Not(Strncmp(str_, "kTHEN", 4)) And Not(Isalnum(str_[4]))) Then
2470 Return kTHEN
2471 If (Not(Strncmp(str_, "kAND", 3)) And Not(Isalnum(str_[3]))) Then
2472 Return kAND
2473 If (Not(Strncmp(str_, "kOR", 2)) And Not(Isalnum(str_[2]))) Then
2474 Return kOR
2475 If (Not(Strncmp(str_, "kGOTO", 4)) And Not(Isalnum(str_[4]))) Then
2476 Return kGOTO
2477 If (Not(Strncmp(str_, "kINPUT", 5)) And Not(Isalnum(str_[5]))) Then
2478 Return kINPUT
2479 If (Not(Strncmp(str_, "kREM", 3)) And Not(Isalnum(str_[3]))) Then
2480 Return kREM
2481 If (Not(Strncmp(str_, "kFOR", 3)) And Not(Isalnum(str_[3]))) Then
2482 Return kFOR
2483 If (Not(Strncmp(str_, "kTO", 2)) And Not(Isalnum(str_[2]))) Then
2484 Return kTO
2485 If (Not(Strncmp(str_, "kNEXT", 4)) And Not(Isalnum(str_[4]))) Then
2486 Return kNEXT
2487 If (Not(Strncmp(str_, "kSTEP", 4)) And Not(Isalnum(str_[4]))) Then
2488 Return kSTEP
2489
2490 If (Not(Strncmp(str_, "kMOD", 3)) And Not(Isalnum(str_[3]))) Then
2491 Return kMOD
2492 If (Not(Strncmp(str_, "kABS", 3)) And Not(Isalnum(str_[3]))) Then
2493 Return kABS
2494 If (Not(Strncmp(str_, "kLEN", 3)) And Not(Isalnum(str_[3]))) Then
2495 Return kLEN
2496 If (Not(Strncmp(str_, "ASCII", 5)) And Not(Isalnum(str_[5]))) Then
2497 Return ASCII
2498 If (Not(Strncmp(str_, "kASIN", 4)) And Not(Isalnum(str_[4]))) Then
2499 Return ASIN
2500 If (Not(Strncmp(str_, "kACOS", 4)) And Not(Isalnum(str_[4]))) Then
2501 Return ACOS
2502 If (Not(Strncmp(str_, "kATAN", 4)) And Not(Isalnum(str_[4]))) Then
2503 Return ATAN
2504 If (Not(Strncmp(str_, "kINT", 3)) And Not(Isalnum(str_[3]))) Then
2505 Return kINT
2506 If (Not(Strncmp(str_, "kRND", 3)) And Not(Isalnum(str_[3]))) Then
2507 Return kRND
2508 If (Not(Strncmp(str_, "kVAL", 3)) And Not(Isalnum(str_[3]))) Then
2509 Return kVAL
2510 If (Not(Strncmp(str_, "VALLEN", 6)) And Not(Isalnum(str_[6]))) Then
2511 Return VALLEN
2512 If (Not(Strncmp(str_, "kINSTR", 5)) And Not(Isalnum(str_[5]))) Then
2513 Return kINSTR
2514
2515 If (Not(Strncmp(str_, "CHR$", 4))) Then
2516 Return CHRSTRING
2517 If (Not(strncmp(str_, "STR$", 4))) Then
2518 Return STRSTRING
2519 If (Not(Strncmp(str_, "LEFT$", 5))) Then
2520 Return LEFTSTRING
2521 If (Not(strncmp(str_, "RIGHT$", 6))) Then
2522 Return RIGHTSTRING
2523 If (Not(Strncmp(str_, "MID$", 4))) Then
2524 Return MIDSTRING
2525 If (Not(strncmp(str_, "String$", 7))) Then
2526 Return STRINGSTRING
2527 End If
2528 /' end isupper() '/
2529
2530 If (Isalpha(*str_)) Then
2531 While (Isalnum(*str_))
2532 str_ += 1
2533 Wend
2534 Select Case (*str_)
2535 Case "$"
2536 If (str_[1] = "(") Then
2537 Return DIMSTRID
2538 Else
2539 Return STRID
2540 End If
2541 Case "("
2542 Return DIMFLTID
2543 Case Else
2544 Return FLTID
2545 End Select
2546 End If
2547
2548 Return ERROR
2549 End Select
2550 End Function
2551
2552 /'
2553 get the length of a token.
2554 Params: str - pointer to the string containing the token
2555 token - the type of the token read
2556 Returns: length of the token, or 0 for EOL to prevent
2557 it being read past.
2558 '/
2559 Private Function tokenlen(ByVal str_ As ZString Ptr, _
2560 Byval token As Integer) As Integer
2561
2562 Dim len_ As Integer = 0
2563 Dim buff As ZString * 34
2564
2565 Select Case token
2566 Case EOS
2567 Return 0
2568 Case EOL
2569 Return 1
2570 Case VALUE
2571 getvalue(str_, &len_)
2572 Return len_
2573 Case DIMSTRID
2574 Case DIMFLTID
2575 Case STRID
2576 getid(str_, buff, &len_)
2577 Return len_
2578 Case FLTID
2579 getid(str_, buff, &len_)
2580 Return len_
2581 Case PI
2582 Return 2
2583 Case E
2584 Return 1
2585 Case kSIN
2586 Return 3
2587 Case kCOS
2588 Return 3
2589 Case kTAN
2590 Return 3
2591 Case LN
2592 Return 2
2593 Case POW
2594 Return 3
2595 Case SQRT
2596 Return 4
2597 Case DIV
2598 Return 1
2599 Case MULT
2600 Return 1
2601 Case OPAREN
2602 Return 1
2603 Case CPAREN
2604 Return 1
2605 Case PLUS
2606 Return 1
2607 Case MINUS
2608 Return 1
2609 Case SHRIEK
2610 Return 1
2611 Case COMMA
2612 Return 1
2613 Case QUOTE
2614 Return 1
2615 Case EQUALS
2616 Return 1
2617 Case LESS
2618 Return 1
2619 Case GREATER
2620 Return 1
2621 Case SEMICOLON
2622 Return 1
2623 Case kERROR
2624 Return 0
2625 Case kPRINT
2626 Return 5
2627 Case kLET
2628 Return 3
2629 Case kDIM
2630 Return 3
2631 Case kIF
2632 Return 2
2633 Case kTHEN
2634 Return 4
2635 Case kAND
2636 Return 3
2637 Case kOR
2638 Return 2
2639 Case kGOTO
2640 Return 4
2641 Case kINPUT
2642 Return 5
2643 Case kREM
2644 Return 3
2645 Case kFOR
2646 Return 3
2647 Case kTO
2648 Return 2
2649 Case kNEXT
2650 Return 4
2651 Case kSTEP
2652 Return 4
2653 Case kMOD
2654 Return 3
2655 Case kABS
2656 Return 3
2657 Case kLEN
2658 Return 3
2659 Case ASCII
2660 Return 5
2661 Case ASIN
2662 Return 4
2663 Case ACOS
2664 Return 4
2665 Case ATAN
2666 Return 4
2667 Case kINT
2668 Return 3
2669 Case kRND
2670 Return 3
2671 Case kVAL
2672 Return 3
2673 Case VALLEN
2674 Return 6
2675 Case kINSTR
2676 Return 5
2677 Case CHRSTRING
2678 Return 4
2679 Case STRSTRING
2680 Return 4
2681 Case LEFTSTRING
2682 Return 5
2683 Case RIGHTSTRING
2684 Return 6
2685 Case MIDSTRING
2686 Return 4
2687 Case STRINGSTRING
2688 Return 7
2689 Case Else
2690 Assert(0)
2691 Return 0
2692 End Select
2693 End Function
2694
2695 /'
2696 test if a token represents a string expression
2697 Params token - token to test
2698 Returns 1 if a string, else 0
2699 '/
2700 Private isstring(ByVal token As Integer) As Integer
2701 If (token = STRID Or token = QUOTE Or token == DIMSTRID Or
2702 token = CHRSTRING Or token = STRSTRING Or
2703 token = LEFTSTRING Or token = RIGHTSTRING Or _
2704 token = MIDSTRING Or token = STRINGSTRING) Then
2705 Return 1
2706 End If
2707 Return 0
2708 End Function
2709
2710 /'
2711 get a numerical value from the parse string
2712 Params str - the string to search
2713 len - return pinter for no chars read
2714 Retuns the value of the string.
2715 '/
2716 Private getvalue(ByVal str_ As ZString Ptr, ByVal len_ As Integer Ptr) As Double
2717 Dim answer As Double
2718 Dim end_ As ZString Ptr
2719
2720 answer = strtod(str_, &end_)
2721 Assert(end_ <> str_)
2722 *len_ = end_ - str_
2723 Return answer
2724 End Function
2725
2726 /'
2727 getid - get an id from the parse string
2728 Params str - string to search
2729 out - id output [32 chars max ]
2730 len - return pointer for id length
2731 Notes triggers an error if id > 31 chars
2732 the id includes the $ and ( qualifiers.
2733 '/
2734 Private Sub getid(ByVal str_ As ZString Ptr, ByVal out_ As ZString Ptr, _
2735 ByVal len_ As Integer Ptr)
2736
2737 Dim nread As Integer = 0
2738
2739 While (isspace(*str_))
2740 str_ += 1
2741 Wend
2742 Assert(isalpha(*str_))
2743 While (isalnum(*str_))
2744 If (nread < 31) Then
2745 out_[nread] = *str_
2746 nread += 1
2747 str_ += 1
2748 Else
2749 seterror(ERR_IDTOOLONG)
2750 Exit While
2751 End If
2752 Wend
2753 If (*str_ = '$')
2754 If (nread < 31) Then
2755 out_[nread] = *str_
2756 nraed += 1
2757 str_ += 1
2758 End If
2759 Else
2760 seterror(ERR_IDTOOLONG)
2761 End If
2762 If (*str_ = '(') Then
2763 If (nread < 31) Then
2764 out_[nread] = *str_
2765 nread += 1
2766 str_ += 1
2767 End If
2768 Else
2769 seterror(ERR_IDTOOLONG)
2770 End If
2771 out_[nread] = 0
2772 *len_ = nread
2773 End Sub
2774
2775 /'
2776 grab a literal from the parse string.
2777 Params: dest - destination string
2778 src - source string
2779 Notes: strings are in quotes, double quotes the escape
2780 '/
2781 Private Sub mystrgrablit(ByVal dest As ZString Ptr, ByVal src As ZString Ptr)
2782 Assert(*src = '"')
2783 src += 1
2784
2785 While(*src)
2786 If (*src = '"') Then
2787 If (src[1] = '"') Then
2788 *dest = *src
2789 dest += 1
2790 src += 1
2791 src += 1
2792 Else
2793 Exit While
2794 End If
2795 Else
2796 *dest = *src
2797 dest += 1
2798 src += 1
2799 End If
2800 Wend
2801
2802 *dest = 0
2803 dest += 1
2804 End Sub
2805
2806 /'
2807 find where a source String literal ends
2808 Params: src - String To Check (must point To quote)
2809 quote - character To use For quotation
2810 Returns: pointer To quote which ends String
2811 Notes: quotes escape quotes
2812 '/
2813 Private Function Mystrend(Byval str_ As ZString Ptr, Byval quote As UByte) As ZString Ptr
2814 Assert(*str_ = quote)
2815 str += 1
2816
2817 While (*str_)
2818 While (*str_ <> quote)
2819 If (*str_ = '\n' Or *str = 0) Then
2820 Return 0
2821 End If
2822 str_ += 1
2823 Wend
2824 If (str_[1] = quote) Then
2825 str_ += 2
2826 Else
2827 Exit While
2828 End If
2829 Wend
2830 If (*str_) Then
2831 Return Cptr(ZString Ptr,str_)
2832 Else
2833 Return Cptr(ZString Ptr,0)
2834 End If
2835 End Function
2836
2837 /'
2838 Count the instances of ch In str
2839 Params: str - String To check
2840 ch - character To count
2841 Returns: no time chs occurs In str.
2842 '/
2843 Private Function Mystrcount(Byval str_ As ZString Ptr, Byval ch As UByte) As Integer
2844 Dim answer As Integer = 0
2845
2846 While (*str_)
2847 If (*str_ = ch) Then
2848 answer += 1
2849 End If
2850 str_ += 1
2851 Wend
2852
2853 Return answer
2854 End Function
2855
2856 /'
2857 duplicate a String:
2858 Params: str - String To duplicate
2859 Returns: malloced duplicate.
2860 '/
2861 Private Function Mystrdup(Dim str_ As ZString Ptr) As ZString Ptr
2862 Dim answer As ZString Ptr
2863
2864 answer = Malloc(Strlen(str_) + 1)
2865 If (answer) Then
2866 Strcpy(answer, str_)
2867 End If
2868
2869 Return answer
2870 End Function
2871
2872 /'
2873 concatenate two strings
2874 Params: str - firsts String
2875 cat - second String
2876 Returns: malloced String.
2877 '/
2878 Private Function Mystrconcat(Byval str_ As ZString Ptr, Byval cat As ZString Ptr) As ZString Ptr
2879 Dim len_ As Integer
2880 Dim answer As ZString Ptr
2881
2882 len_ = Strlen(str_) + Strlen(cat)
2883 answer = Malloc(len_ + 1)
2884 If (answer) Then
2885 Strcpy(answer, str_)
2886 Strcat(answer, cat)
2887 End If
2888 Return answer
2889 End Function
2890
2891 /'
2892 compute x!
2893 '/
2894 Private Function Factorial(Byval x As Double) As Double
2895 Dim answer As Double = 1.0
2896 Dim t As Double
2897
2898 If ( x > 1000.0) Then
2899 x = 1000.0
2900 End If
2901
2902 For t = 1 To x
2903 answer *= t
2904 Next x
2905 Return answer
2906 End Function