Tento zdrojový kód je k dispozici ke stažení zde: cmd_v12_2004_09_27.zip(~1 MB)
1: | { KEYWORDS: VERSION } |
2: | { VERSION: 1.8 } |
3: | { 1.8 / 20.8.2002 |
4: | - TBasic.Destroy cleans up variables |
5: | - fixed varptr matching in token parser. variable names are case-insensitive now |
6: | - fixed uninitialized memory blocks obtained by New() |
7: | - fixed power operator (^) to work correctly with 0 |
8: | - default extension for LOAD/SAVE command's argument is .BAS |
9: | 1.7 / 6.8.2002 |
10: | - LOAD command supports unix text files (only LF terminated) |
11: | - function LEFT$ added |
12: | - DEF FN added |
13: | 1.6 / 2.8.2002 |
14: | - varrec internal structures reworked. new 'valref' structure included. |
15: | as a side effect, array and simple variable can share name. eg. A$ and A$(2) |
16: | are two distinct memory areas bound together in the varrec associated with |
17: | name 'A$' |
18: | 1.5 |
19: | - DECLARE statement extended with mapping function calls to program calls. |
20: | function parameters are passed as program arguments in a format declared by |
21: | the statement |
22: | 1.4 |
23: | - DECLARE statement allowing dynamic function mapping (from external libraries) |
24: | 1.3 |
25: | - support for plug-in external functions with stdcall, fastcall and cdecl |
26: | calling conventions. core functions were taken from Alexander Baranovsky's |
27: | PasScript interpreter |
28: | 1.2 |
29: | - basic interpreter wrapped up into a class, thus allowing co-existence of |
30: | multiple interpreters at the same time |
31: | 1.1 |
32: | - Chipmunk BASIC 1.0 by David Gillespie made Delphi compatible. |
33: | char* management converted to strings and escape() converted to classic |
34: | exceptions |
35: | } |
36: | unit Chip; |
37: | |
38: | interface |
39: | uses Windows,SysUtils,Classes; |
40: | |
41: | { TUNE: } |
42: | |
43: | const |
44: | vkNone =0; |
45: | |
46: | vkFastCall =0 shl 5; |
47: | vkStdCall =1 shl 5; |
48: | |
49: | vkMaskCall =1 shl 5; |
50: | |
51: | vkByVal =0 shl 7; |
52: | vkByRef =1 shl 7; |
53: | vkMaskBy =1 shl 7; |
54: | |
55: | vkConst =1 shl 6; |
56: | vkOptional =1 shl 4; |
57: | |
58: | vkMaskType =$FF and not (vkMaskCall or vkOptional); |
59: | |
60: | vkString =1; |
61: | vkInteger =2; |
62: | vkPChar =3; |
63: | |
64: | vkHandle =vkInteger; |
65: | |
66: | type |
67: | TValueKind=integer; |
68: | ArrayOfValueKind=string; // chr()+chr().. |
69: | TFuncDef=class |
70: | descriptor:string; |
71: | obj:TObject; |
72: | offset:pointer; |
73: | cmdFormat:string; |
74: | end; |
75: | TInterpreter=class |
76: | protected |
77: | FLibs:TList; |
78: | FFuncs:TStrings; |
79: | |
80: | function FindFunc(const preview:string; const buffer:string; var start:integer):integer; |
81: | procedure InternalMap(const symbolName:string; outValue:TValueKind; const inValue:ArrayOfValueKind; obj:TObject; offset:pointer; const cmdFormat:string); |
82: | procedure NewFunction(const symbolName:string; index:integer);virtual; |
83: | public |
84: | constructor Create;virtual; |
85: | destructor Destroy;override; |
86: | |
87: | procedure MapShell(const symbolName:string; outValue:TValueKind; const inValue:ArrayOfValueKind; const cmdFormat:string); |
88: | procedure MapLib(const symbolName:string; outValue:TValueKind; const inValue:ArrayOfValueKind; const libName:string; const entryPoint:string); |
89: | procedure Map(const symbolName:string; outValue:TValueKind; const inValue:ArrayOfValueKind; offset:pointer); |
90: | procedure MapMethod(const symbolName:string; outValue:TValueKind; const inValue:ArrayOfValueKind; obj:TObject; offset:pointer); |
91: | procedure Run(ACommand:string);virtual;abstract; |
92: | procedure Chat;virtual;abstract; |
93: | end; |
94: | |
95: | const |
96: | checking = true; |
97: | |
98: | varnamelen = 20; |
99: | maxdims = 4; |
100: | |
101: | type |
102: | varnamestring = string[varnamelen]; |
103: | |
104: | tokenkinds = (tokvar, toknum, tokstr, tokfunc, toksnerr, |
105: | |
106: | tokplus, tokminus, toktimes, tokdiv, tokup, toklp, tokrp, |
107: | tokcomma, toksemi, tokcolon, tokeq, toklt, tokgt, |
108: | tokle, tokge, tokne, |
109: | |
110: | tokand, tokor, tokxor, tokmod, toknot, toksqr, toksqrt, toksin, |
111: | tokcos, toktan, tokarctan, toklog, tokexp, tokabs, toksgn, |
112: | tokstr_, tokval, tokchr_, tokasc, toklen, tokmid_, tokleft, tokint, tokrnd, |
113: | |
114: | tokrem, toklet, tokprint, tokinput, tokgoto, tokif, tokend, |
115: | tokstop, tokfor, toknext, tokwhile, tokwend, tokgosub, |
116: | tokreturn, tokread, tokdata, tokrestore, tokon, |
117: | tokcommon,tokdim,tokdef, |
118: | |
119: | toklist, tokrun, toknew, tokload, tokmerge, toksave, tokbye, |
120: | tokdel, tokdeclare, tokrenum, |
121: | |
122: | tokthen, tokelse, tokto, tokstep); |
123: | |
124: | float = double; // TUNE: TODO: |
125: | numptr = ^float; |
126: | basicstring = packed record |
127: | size:integer; |
128: | data:pointer |
129: | end; |
130: | stringptr=^basicstring; |
131: | numarray = array[0..(maxint div sizeof(float))-1] of float; |
132: | numarrayptr = ^numarray; |
133: | strarray = array[0..(maxint div sizeof(basicstring))-1] of basicstring; |
134: | strarrayptr = ^strarray; |
135: | |
136: | strref=packed record base:strarrayptr; index:integer end; |
137: | numref=packed record base:numarrayptr; index:integer end; |
138: | |
139: | tokenptr = ^tokenrec; |
140: | lineptr = ^linerec; |
141: | varptr = ^varrec; |
142: | loopptr = ^looprec; |
143: | |
144: | tokenrec = |
145: | packed record |
146: | next : tokenptr; |
147: | case kind : tokenkinds of |
148: | tokvar : (vp : varptr); |
149: | toknum : (num : float); |
150: | tokstr, tokrem : (sptr2 : PChar); |
151: | tokfunc: ( fi: integer ); |
152: | toksnerr : (snch : char); |
153: | end; |
154: | |
155: | linerec = |
156: | packed record |
157: | num, num2 : integer; |
158: | txt : tokenptr; |
159: | next : lineptr; |
160: | end; |
161: | |
162: | vartype=(vNumber,vString); |
163: | |
164: | numvarrec=packed record |
165: | value:float; |
166: | ref:numref; |
167: | base:numarrayptr; |
168: | end; |
169: | |
170: | strvarrec=packed record |
171: | value:basicstring; |
172: | ref:strref; |
173: | base:strarrayptr; |
174: | end; |
175: | |
176: | funcrecptr = ^funcrec; |
177: | |
178: | varrec = |
179: | packed record |
180: | name : varnamestring; |
181: | next : varptr; |
182: | dims : array [1..maxdims] of integer; |
183: | numdims : 0..maxdims; |
184: | |
185: | func: funcrecptr; |
186: | |
187: | case kind:vartype of |
188: | vNumber: ( num:numvarrec ); |
189: | vString: ( str:strvarrec ); |
190: | end; |
191: | |
192: | numvalrec=packed record |
193: | value:float |
194: | end; |
195: | strvalrec=packed record |
196: | value:string |
197: | end; |
198: | valrec =packed record |
199: | kind:vartype; |
200: | num:numvalrec; |
201: | str:strvalrec; |
202: | end; |
203: | valref=packed record |
204: | case kind:vartype of |
205: | vNumber: ( num:numref ); |
206: | vString: ( str:strref ) |
207: | end; |
208: | |
209: | funcrec = packed record |
210: | tok: tokenptr; |
211: | dims : array [1..maxdims] of valref; |
212: | numdims : 0..maxdims; |
213: | end; |
214: | |
215: | loopkind = (forloop, whileloop, gosubloop); |
216: | looprec = |
217: | packed record |
218: | next : loopptr; |
219: | homeline : lineptr; |
220: | hometok : tokenptr; |
221: | case kind : loopkind of |
222: | forloop : |
223: | ( ref : valref; |
224: | max, step : float ); |
225: | end; |
226: | |
227: | |
228: | type |
229: | EBasic=class(Exception) |
230: | public |
231: | escapecode:integer; |
232: | constructor Create(AnEscapeCode:integer; const msg:string); |
233: | end; |
234: | |
235: | PStream=^TextFile; |
236: | TGetFileNameEvent=function(Sender:TObject; const fileName:string; new:boolean):string of object; |
237: | TBasicClass=class of TBasic; |
238: | TBasic=class(TInterpreter) |
239: | protected |
240: | inbuf : string; |
241: | |
242: | linebase : lineptr; |
243: | varbase : varptr; |
244: | loopbase : loopptr; |
245: | |
246: | curline : integer; |
247: | stmtline, dataline : lineptr; |
248: | stmttok, datatok, buf : tokenptr; |
249: | |
250: | exitflag : boolean; |
251: | t : tokenptr; |
252: | protected |
253: | FOnGetFileName:TGetFileNameEvent; |
254: | procedure cmdend; |
255: | procedure cmdnew; |
256: | procedure cmdload(merging : boolean; name : string); |
257: | procedure cmdsave(const name:string); |
258: | protected |
259: | procedure restoredata; |
260: | procedure clearloops; |
261: | procedure clearvars; |
262: | procedure listtokens(var f : text; buf : tokenptr); |
263: | procedure parseinput(var buf : tokenptr); |
264: | procedure exec; |
265: | procedure parse(const inbuf :string; var buf : tokenptr); |
266: | procedure NewFunction(const symbolName:string; index:integer);override; |
267: | public |
268: | function ExpandFileName(const fileName:string; new:boolean):string; |
269: | protected |
270: | procedure CallShellSub(const cmd:string);virtual; |
271: | function CallShellFunction(const cmd:string):string;virtual; |
272: | protected |
273: | Commons:TStrings; |
274: | procedure initvarfromenv(v:varptr); |
275: | public |
276: | constructor Create;override; |
277: | destructor Destroy;override; |
278: | |
279: | procedure LoadFromFile(const fileName:string); |
280: | procedure SaveToFile(const fileName:string); |
281: | procedure Run(ACommand:string);override; |
282: | procedure Chat;override; |
283: | protected |
284: | BreakFlag: Boolean; |
285: | procedure CheckBreak; |
286: | public |
287: | procedure SetBreak; virtual; |
288: | public |
289: | Environment:TStrings; |
290: | input,output:PStream; |
291: | procedure ExportCommons(Env:TStrings); |
292: | property OnGetFileName:TGetFileNameEvent read FOnGetFileName write FOnGetFileName; |
293: | end; |
294: | |
295: | implementation |
296: | (* |
297: | X |
298: | X Chipmunk BASIC 1.0 |
299: | X David Gillespie |
300: | X |
301: | X |
302: | X -------------------------------------------------------------- |
303: | X |
304: | X |
305: | X |
306: | X |
307: | X COMMANDS |
308: | X |
309: | X |
310: | X LIST line(s) |
311: | X |
312: | X List the specified program lines. For example, |
313: | X |
314: | X LIST 10, 100-200 |
315: | X |
316: | X lists line 10, and lines 100 through 200, inclusive. |
317: | X |
318: | X |
319: | X RUN [line] |
320: | X |
321: | X Begin execution of the program at the first line, or at the |
322: | X specified line. All variables are cleared. |
323: | X |
324: | X |
325: | X RUN file[,line] |
326: | X |
327: | X Load and run a program. For example, |
328: | X |
329: | X RUN "FOO", 30 |
330: | X |
331: | X loads a program from the file FOO.TEXT and begins execution at |
332: | X line 30. |
333: | X |
334: | X |
335: | X NEW |
336: | X |
337: | X Erase the program in memory. |
338: | X |
339: | X |
340: | X LOAD file |
341: | X |
342: | X Load a program into memory. The program previously in memory is |
343: | X erased. The file name should be in quotes; a .TEXT extension is |
344: | X automatically added. Files contain ASCII listings of the programs. |
345: | X All lines in the file must begin with a line number, but line |
346: | X numbers do not need to be in increasing order. |
347: | X |
348: | X |
349: | X MERGE file |
350: | X |
351: | X Load a program into memory. The previous program remains in |
352: | X memory; if a line exists in both programs, the newly loaded |
353: | X line is kept. |
354: | X |
355: | X |
356: | X SAVE file |
357: | X |
358: | X Save the program in memory to a file. |
359: | X |
360: | X |
361: | X BYE |
362: | X |
363: | X Return to the operating system. |
364: | X |
365: | X |
366: | X DEL line(s) |
367: | X |
368: | X Delete the specified program lines. Line numbers may be |
369: | X separated by commas and dashes as in LIST. If used inside |
370: | X a program, DEL will terminate execution only if it deletes |
371: | X the line on which it appears. |
372: | X |
373: | X |
374: | X RENUM [start[,inc]] |
375: | X |
376: | X Renumber program lines. By default, the new sequence is 10,20,30,... |
377: | X The first argument is a new initial line number; the second argument |
378: | X is the increment between line numbers. |
379: | X |
380: | X |
381: | X |
382: | X |
383: | X STATEMENTS |
384: | X |
385: | X REM comment |
386: | X |
387: | X A remark; ignored. Comments may contain any characters except |
388: | X that REM can not be immediately followed by an alphanumeric |
389: | X character. |
390: | X |
391: | X |
392: | X [LET] var = expr |
393: | X |
394: | X Assign a value to a variable. Variable names contain up to 20 |
395: | X significant characters, consisting of upper- and lower-case |
396: | X letters, digits, underscores, and dollar signs. Variable names |
397: | X are case-sensitive. Variables hold real numbers normally, or |
398: | X strings of up to 255 characters if their names end with $. |
399: | X |
400: | X Examples: |
401: | X |
402: | X LET X=20 |
403: | X X$="FOO" |
404: | X X$=X$+"BAR" |
405: | X |
406: | X |
407: | X DIM var(dimensions), ... |
408: | X |
409: | X Allocate memory for arrays. Arrays may have up to 4 dimensions, |
410: | X ranging from 0 to the value specified in the DIM statement. |
411: | X The same name must not be used for both a simple variable and |
412: | X an array. |
413: | X |
414: | X If an array is used before it is dimensioned, each dimension |
415: | X is set to 10. |
416: | X |
417: | X Example: |
418: | X |
419: | X INPUT "How many elements? "; x |
420: | X DIM array(x,1) |
421: | X FOR i=1 TO x : INPUT array(i,0), array(i,1) : NEXT |
422: | X |
423: | X |
424: | X PRINT items |
425: | X |
426: | X Print the items on the screen. Items may be either numeric |
427: | X or string expressions, and may be separated by commas, semicolons, |
428: | X or nothing. |
429: | X |
430: | X Numbers are normally terminated by spaces. To avoid this space, |
431: | X convert the number to a string with STR$. |
432: | X |
433: | X The line is terminated by a CR/LF, unless the item list ends |
434: | X with a comma or semicolon. |
435: | X |
436: | X The word PRINT may be abbreviated as a question mark. |
437: | X |
438: | X Examples: |
439: | X |
440: | X PRINT "1+2=", 1+2 |
441: | X PRINT X$ "=" Z$; |
442: | X ? x; y+z |
443: | X |
444: | X |
445: | X INPUT [prompt;] vars |
446: | X |
447: | X If a prompt string is given, it is printed. Otherwise, a |
448: | X question mark is printed. The computer then waits for values |
449: | X for each variable to be entered. If several variables are |
450: | X listed, their names must be separated by commas. |
451: | X |
452: | X If the variables are numeric, their values may be entered |
453: | X on separate lines, or combined with commas. Any numeric expression |
454: | X is a valid response. |
455: | X |
456: | X If the variables are strings, each string is typed on a separate |
457: | X line. The characters typed are copied verbatim into the string. |
458: | X |
459: | X String and numeric variables may be not mixed in a single |
460: | X INPUT statement. |
461: | X |
462: | X Examples: |
463: | X |
464: | X INPUT X$ |
465: | X INPUT "Type 3 numbers: "; X, Y, Z |
466: | X |
467: | X |
468: | X GOTO line |
469: | X |
470: | X Begin executing statements at the specified line. The line |
471: | X number may be any numeric expression. |
472: | X |
473: | X The word GO TO may be used instead of GOTO if preferable. |
474: | X |
475: | X |
476: | X IF condition THEN line/statements ELSE line/statements |
477: | X |
478: | X If the condition is true (i.e., the numeric expression has a |
479: | X non-zero value), the statements following the word THEN are |
480: | X executed. Otherwise, the statements following ELSE are |
481: | X executed. If there is no ELSE clause, execution proceeds |
482: | X to the next line in the program. |
483: | X |
484: | X A line number may be used after either THEN or ELSE, for an |
485: | X implied GOTO statement. |
486: | X |
487: | X |
488: | X END |
489: | X |
490: | X Terminate the program. An END statement is not required. |
491: | X |
492: | X |
493: | X STOP |
494: | X |
495: | X Terminate the program with an identifying "Break" message. |
496: | X |
497: | X |
498: | X FOR var = first TO last [STEP inc] |
499: | X {statements} |
500: | X NEXT [var] |
501: | X |
502: | X Execute {statements} repeatedly while the variable counts from |
503: | X "first" to "last," incrementing by 1, or by the STEP value if |
504: | X given. If the STEP value is negative, the variable counts |
505: | X downward. |
506: | X |
507: | X If "first" is greater than "last" (or less than if STEP is |
508: | X negative), execution proceeds directly to the NEXT statement, |
509: | X without executing the body of the loop at all. |
510: | X |
511: | X The variable name is optional on the NEXT statement. |
512: | X |
513: | X |
514: | X WHILE [condition] |
515: | X {statements} |
516: | X WEND [condition] |
517: | X |
518: | X Execute {statements} repeatedly until the WHILE condition (if |
519: | X given) becomes false, or until the WEND condition becomes true. |
520: | X This structure can emulate Pascal's WHILE-DO and REPEAT-UNTIL, |
521: | X or even both at once. If no conditions are given, the loop will |
522: | X never terminate unless the Evil GOTO is used. |
523: | X |
524: | X |
525: | X GOSUB line |
526: | X RETURN |
527: | X |
528: | X Execute the statements beginning at the specified line, then |
529: | X when RETURN is reached, return to the statement following the |
530: | X GOSUB. |
531: | X |
532: | X |
533: | X READ vars |
534: | X DATA values |
535: | X RESTORE line |
536: | X |
537: | X Read numeric or string values from the DATA statements. Reading |
538: | X begins at the first DATA statement in the program and proceeds |
539: | X to the last. Reading past the end the last DATA statement |
540: | X generates an error. |
541: | X |
542: | X The DATA values must be either numeric or string expressions, |
543: | X according to the type of variable being read. Reading the wrong |
544: | X kind of expression produces a Syntax Error. |
545: | X |
546: | X The RESTORE statement causes the next READ to re-use the first |
547: | X DATA statement in the program, or the first DATA statement on |
548: | X or after a particular line. |
549: | X |
550: | X |
551: | X ON expr GOTO line, line, ... |
552: | X ON expr GOSUB line, line, ... |
553: | X |
554: | X If the expression's value, rounded to an integer, is N, go to |
555: | X the Nth line number in the list. If N is less than one or is |
556: | X too large, execution continues at the next statement after |
557: | X the ON-GOTO or ON-GOSUB. |
558: | X |
559: | X |
560: | X |
561: | X NUMERIC EXPRESSIONS |
562: | X |
563: | X x AND y |
564: | X |
565: | X Logical AND of two integers. |
566: | X |
567: | X |
568: | X x OR y |
569: | X |
570: | X Logical OR of two integers. |
571: | X |
572: | X |
573: | X x XOR y |
574: | X |
575: | X Logical XOR of two integers. |
576: | X |
577: | X |
578: | X NOT x |
579: | X |
580: | X Logical complement of an integer. |
581: | X |
582: | X |
583: | X INT x |
584: | X |
585: | X |
586: | X x+y, x-y, x*y, x/y, x^y, -x |
587: | X |
588: | X Typical floating-point arithmetic operations. |
589: | X |
590: | X |
591: | X x=y, x<y, x>y, x<=y, x>=y, x<>y |
592: | X |
593: | X Comparisons; result is 1 if true, 0 if false. |
594: | X |
595: | X |
596: | X x MOD y |
597: | X |
598: | X Modulo of two integers. |
599: | X |
600: | X |
601: | X SQR x |
602: | X |
603: | X Square of X. Note that parentheses are not required if a function's |
604: | X argument is a single entitity; for example, SQR SIN X needs no |
605: | X parentheses, but SQR(1+X) does. |
606: | X |
607: | X |
608: | X SQRT x |
609: | X |
610: | X Square root of X. |
611: | X |
612: | X |
613: | X SIN x, COS x, TAN x, ARCTAN x |
614: | X |
615: | X Typical trig functions, in radians. |
616: | X |
617: | X |
618: | X LOG x, EXP x |
619: | X |
620: | X Natural logarithm, and e the power X. |
621: | X |
622: | X |
623: | X ABS x |
624: | X |
625: | X Absolute value of X. |
626: | X |
627: | X |
628: | X SGN x |
629: | X |
630: | X Sign of X: 1 if X is positive, 0 if zero, -1 if negative. |
631: | X |
632: | X |
633: | X VAL x$ |
634: | X |
635: | X Value of the expression contained in the string X$. For example, |
636: | X VAL "1+2" yields 3. X$ may be a single string literal, variable, |
637: | X or function, or a string expression in parentheses. |
638: | X |
639: | X |
640: | X ASC x$ |
641: | X |
642: | X ASCII code of the first character in X$, or 0 if X$ is null. |
643: | X |
644: | X |
645: | X LEN x$ |
646: | X |
647: | X Number of characters in X$. |
648: | X |
649: | X |
650: | X Precedence: Parentheses |
651: | X Functions (incl. NOT and unary minus) |
652: | X ^ |
653: | X *, /, MOD |
654: | X +, - |
655: | X =, <, >, <=, >=, <> |
656: | X AND |
657: | X OR, XOR |
658: | X |
659: | X |
660: | X |
661: | X STRING EXPRESSIONS |
662: | X |
663: | X "string" or 'string' |
664: | X |
665: | X String literal. Single quotes are converted to double quotes |
666: | X internally. |
667: | X |
668: | X |
669: | X x$+y$ |
670: | X |
671: | X Concatenation. Result must be 255 characters or less. |
672: | X |
673: | X |
674: | X x$=y$, x$<y$, x$>y$, x$<=y$, x$>=y$, x$<>y$ |
675: | X |
676: | X String comparisons; result is 1 if true, 0 if false. |
677: | X |
678: | X |
679: | X STR$(x) |
680: | X |
681: | X The number X expressed as a string of digits. No leading or |
682: | X trailing spaces are included; scientific notation is used |
683: | X if the absolute values is greater than 1E12 or less than 1E-2. |
684: | X |
685: | X |
686: | X CHR$(x) |
687: | X |
688: | X The character whose ASCII code is X. |
689: | X |
690: | X |
691: | X MID$(x$, y) |
692: | X MID$(x$, y, z) |
693: | X |
694: | X (Parentheses required.) The substring consisting of the first |
695: | X Z characters starting at position Y of string X$. Position 1 |
696: | X is the first character of the string. If Z is omitted, 255 |
697: | X is used, i.e., the entire right part of the string. |
698: | X |
699: | X |
700: | X LEFT$(x$, y) |
701: | X |
702: | X same as MID$(x$, 1, y) |
703: | X |
704: | X CONVENTIONS |
705: | X |
706: | X Multiple statements may be written on a line, separated by colons: |
707: | X |
708: | X 10 INPUT X : PRINT X : STOP |
709: | X |
710: | X |
711: | X There is actually no difference between commands and statements; |
712: | X both can be used in or out of programs at will. Certain commands, |
713: | X such as NEW, will, of course, halt program execution. |
714: | X |
715: | X |
716: | X Line numbers may be any integer from 1 to MAXINT. |
717: | X |
718: | X |
719: | X To delete a line use DEL, or type its line number alone: |
720: | X |
721: | X 10 |
722: | X |
723: | X |
724: | X Press CLR I/O to halt program execution. [This is not supported |
725: | X by p2c's translation!] To leave BASIC, use the BYE command. |
726: | X |
727: | X |
728: | X Keywords must be written in all upper- or all lower-case; they are |
729: | X always converted to upper-case internally. Spaces are ignored in |
730: | X the input except between quotes. Square brackets are converted to |
731: | X parentheses. Missing closing quotes at the end of the line are |
732: | X added, as in the command: |
733: | X |
734: | X SAVE "PROGRAM |
735: | X |
736: | X |
737: | X |
738: | X |
739: | *) |
740: | |
741: | procedure string2basicstring(var v:basicstring; const value:string); |
742: | var n:integer; |
743: | begin |
744: | if v.data<>nil then begin |
745: | FreeMem(v.data); |
746: | v.data:=nil |
747: | end; |
748: | n:=Length(value); |
749: | v.size:=n; |
750: | if n<>0 then begin |
751: | GetMem(v.data,n); |
752: | Move(value[1],v.data^,n) |
753: | end |
754: | end; |
755: | |
756: | function basicstring2string(var v:basicstring):string; |
757: | begin |
758: | if v.size=0 then |
759: | Result:='' |
760: | else begin |
761: | SetLength(Result,v.size); |
762: | Move(v.data^,Result[1],v.size) |
763: | end |
764: | end; |
765: | |
766: | procedure _setvarrec2string(var v:varrec; const value:string); |
767: | begin |
768: | v.str.ref.base:=nil; |
769: | string2basicstring(v.str.value,value) |
770: | end; |
771: | |
772: | procedure _setvarrec2float(var v:varrec; value:float); |
773: | begin |
774: | v.num.ref.base:=nil; |
775: | v.num.value:=value |
776: | end; |
777: | |
778: | function _varrec2string(var v:varrec):string; |
779: | var p:stringptr; |
780: | begin |
781: | if v.str.ref.base<>nil then |
782: | p:=@v.str.ref.base^[v.str.ref.index] |
783: | else |
784: | p:=@v.str.value; |
785: | |
786: | Result:=basicstring2string(p^) |
787: | end; |
788: | |
789: | function _valref2string(var ref:valref):string; |
790: | begin |
791: | Result:=basicstring2string(ref.str.base^[ref.str.index]) |
792: | end; |
793: | |
794: | function valrefMaps(var ref:valref; var v:varrec):boolean; |
795: | begin |
796: | Result:=ref.kind=v.kind; |
797: | if not Result then exit; |
798: | case ref.kind of |
799: | vNumber: |
800: | Result:=(ref.num.index=0) and (ref.num.base=@v.num.value); |
801: | |
802: | vString: |
803: | Result:=(ref.str.index=0) and (ref.str.base=@v.str.value); |
804: | |
805: | else assert(false) |
806: | end |
807: | end; |
808: | |
809: | procedure varrec2valref(var v:varrec; var ref:valref); |
810: | begin |
811: | case v.kind of |
812: | vNumber: |
813: | begin |
814: | ref.kind:=vNumber; |
815: | if v.num.ref.base=nil then begin |
816: | ref.num.base:=@v.num.value; |
817: | ref.num.index:=0 |
818: | end else begin |
819: | ref.num:=v.num.ref |
820: | end |
821: | end; |
822: | |
823: | vString: |
824: | begin |
825: | ref.kind:=vString; |
826: | if v.str.ref.base=nil then begin |
827: | ref.str.base:=@v.str.value; |
828: | ref.str.index:=0 |
829: | end else begin |
830: | ref.str:=v.str.ref |
831: | end |
832: | end; |
833: | |
834: | else assert(false) |
835: | end; |
836: | end; |
837: | |
838: | procedure _assignstring2varrec(var v:varrec; const value:string); |
839: | var p:stringptr; |
840: | begin |
841: | if v.str.ref.base<>nil then |
842: | p:=@v.str.ref.base^[v.str.ref.index] |
843: | else |
844: | p:=@v.str.value; |
845: | |
846: | string2basicstring(p^,value) |
847: | end; |
848: | |
849: | procedure _assignstring2valref(var ref:valref; const value:string); |
850: | begin |
851: | string2basicstring(ref.str.base^[ref.str.index],value) |
852: | end; |
853: | |
854: | procedure _assignfloat2varrec(var v:varrec; value:float); |
855: | var p:numptr; |
856: | begin |
857: | if v.num.ref.base<>nil then |
858: | p:=@v.num.ref.base^[v.num.ref.index] |
859: | else |
860: | p:=@v.num.value; |
861: | |
862: | p^:=value |
863: | end; |
864: | |
865: | procedure _assignfloat2valref(var ref:valref; value:float); |
866: | begin |
867: | ref.num.base^[ref.num.index]:=value |
868: | end; |
869: | |
870: | function _varrec2float(var v:varrec):float; |
871: | var p:numptr; |
872: | begin |
873: | if v.num.ref.base<>nil then |
874: | p:=@v.num.ref.base^[v.num.ref.index] |
875: | else |
876: | p:=@v.num.value; |
877: | |
878: | Result:=p^ |
879: | end; |
880: | |
881: | function _valref2float(var ref:valref):float; |
882: | begin |
883: | Result:=ref.num.base^[ref.num.index] |
884: | end; |
885: | |
886: | procedure valref2valrec(var ref:valref; var n:valrec); |
887: | begin |
888: | n.kind:=ref.kind; |
889: | case n.kind of |
890: | vNumber: |
891: | n.num.value:=_valref2float(ref); |
892: | |
893: | vString: |
894: | n.str.value:=_valref2string(ref); |
895: | |
896: | else assert(false) |
897: | end |
898: | end; |
899: | |
900: | procedure valrec2valref(var ref:valref; var n:valrec); |
901: | begin |
902: | assert(n.kind=ref.kind); |
903: | case n.kind of |
904: | vNumber: |
905: | _assignfloat2valref(ref,n.num.value); |
906: | |
907: | vString: |
908: | _assignstring2valref(ref,n.str.value); |
909: | |
910: | else assert(false) |
911: | end |
912: | end; |
913: | |
914: | procedure clearvar(var v:varrec); |
915: | var dim:integer; |
916: | var i:integer; |
917: | begin |
918: | if v.numdims<>0 then begin |
919: | dim:=1; |
920: | for i:=1 to v.numdims do dim:=dim*v.dims[i]; |
921: | |
922: | case v.kind of |
923: | vNumber: |
924: | begin |
925: | FreeMem(v.num.base); |
926: | v.num.base:=nil |
927: | end; |
928: | |
929: | vString: |
930: | begin |
931: | for i:=dim-1 downto 0 do |
932: | string2basicstring(v.str.base^[i],''); |
933: | |
934: | FreeMem(v.str.base); |
935: | v.str.base:=nil |
936: | end; |
937: | |
938: | else assert(false) |
939: | end; |
940: | |
941: | v.numdims:=0 |
942: | end; |
943: | |
944: | case v.kind of |
945: | vNumber: _setvarrec2float(v,0); |
946: | vString: _setvarrec2string(v,''); |
947: | else assert(false) |
948: | end; |
949: | |
950: | if v.func<>nil then begin |
951: | FreeMem(v.func); |
952: | v.func:=nil |
953: | end |
954: | end; |
955: | |
956: | type |
957: | TFuncDefs=class(TList) |
958: | protected |
959: | function GetItem(index:integer):TFuncDef; |
960: | public |
961: | destructor Destroy;override; |
962: | property Items[index:integer]:TFuncDef read GetItem; |
963: | end; |
964: | |
965: | function TFuncDefs.GetItem; |
966: | begin |
967: | Result:=TFuncDef(inherited Get(index)) |
968: | end; |
969: | |
970: | destructor TFuncDefs.Destroy; |
971: | var i:integer; |
972: | begin |
973: | for i:=Count-1 downto 0 do |
974: | Items[i].Free; |
975: | inherited |
976: | end; |
977: | |
978: | constructor TInterpreter.Create; |
979: | begin |
980: | inherited Create; |
981: | FFuncs:=TStringList.Create; |
982: | TStringList(FFuncs).Sorted:=true; |
983: | FLibs:=TList.Create |
984: | end; |
985: | |
986: | function TInterpreter.FindFunc; |
987: | var buf:string; |
988: | var n:integer; |
989: | var ln:integer; |
990: | begin |
991: | if TStringList(FFuncs).Find(preview,Result) then exit; |
992: | |
993: | n:=FFuncs.Count; |
994: | ln:=length(preview); |
995: | while Result<n do begin |
996: | buf:=FFuncs[Result]; |
997: | |
998: | if CompareText(preview,Copy(buf,1,ln))<>0 then break; |
999: | |
1000: | if CompareText(buf,Copy(buffer,start-ln,length(buf)))=0 then begin |
1001: | inc(start,length(buf)-ln); |
1002: | exit |
1003: | end; |
1004: | |
1005: | inc(Result) |
1006: | end; |
1007: | Result:=-1 |
1008: | end; |
1009: | |
1010: | procedure TInterpreter.MapMethod; |
1011: | begin |
1012: | InternalMap(symbolName,outValue,inValue,obj,offset,'') |
1013: | end; |
1014: | |
1015: | procedure TInterpreter.Map; |
1016: | begin |
1017: | InternalMap(symbolName,outValue,inValue,nil,offset,'') |
1018: | end; |
1019: | |
1020: | procedure escape(code:integer; const msg:string); |
1021: | begin |
1022: | raise EBasic.Create(code,msg) |
1023: | end; |
1024: | |
1025: | procedure errormsg(s : string); |
1026: | begin |
1027: | escape(42,s); |
1028: | end; |
1029: | |
1030: | procedure TInterpreter.MapShell; |
1031: | begin |
1032: | InternalMap(symbolName,outValue,inValue,nil,nil,cmdFormat) |
1033: | end; |
1034: | |
1035: | procedure TInterpreter.MapLib; |
1036: | var lib:THandle; |
1037: | var offset:pointer; |
1038: | begin |
1039: | lib:=LoadLibrary(PChar(libName)); |
1040: | if lib=0 then |
1041: | offset:=nil |
1042: | else |
1043: | offset:=GetProcAddress(lib,PChar(entryPoint)); |
1044: | if lib<>0 then FLibs.Add(pointer(lib)); |
1045: | InternalMap(symbolName,outValue,inValue,nil,offset,'') |
1046: | end; |
1047: | |
1048: | procedure TInterpreter.NewFunction; |
1049: | begin |
1050: | end; |
1051: | |
1052: | procedure TInterpreter.InternalMap; |
1053: | var descriptor:string; |
1054: | var i:integer; |
1055: | var flag:integer; |
1056: | var size:integer; |
1057: | var fd:TFuncDef; |
1058: | var fl:TFuncDefs; |
1059: | begin |
1060: | size:=Length(inValue); |
1061: | flag:=outValue and (not vkConst); |
1062: | if size=0 then |
1063: | descriptor:=chr(flag) |
1064: | else begin |
1065: | SetLength(descriptor,1+size); |
1066: | descriptor[1]:=chr(flag); |
1067: | for i:=1 to size do begin |
1068: | flag:=ord(inValue[i]); |
1069: | |
1070: | if (flag and vkByRef)<>0 then flag:=flag and (not vkConst); |
1071: | |
1072: | descriptor[1+i]:=chr(flag) |
1073: | end |
1074: | end; |
1075: | |
1076: | fd:=TFuncDef.Create; |
1077: | fd.descriptor:=descriptor; |
1078: | fd.obj:=obj; |
1079: | fd.offset:=offset; |
1080: | fd.cmdFormat:=cmdFormat; |
1081: | |
1082: | i:=FFuncs.IndexOf(symbolName); |
1083: | if i<0 then begin |
1084: | fl:=TFuncDefs.Create; |
1085: | FFuncs.AddObject(symbolName,fl); |
1086: | fl.Add(fd); |
1087: | NewFunction(UpperCase(symbolName),integer(fl)) |
1088: | end else begin |
1089: | fl:=TFuncDefs(FFuncs.Objects[i]); |
1090: | for i:=fl.Count-1 downto 0 do |
1091: | if fl.Items[i].descriptor=descriptor then begin |
1092: | fl.Items[i].Free; |
1093: | fl.Delete(i); |
1094: | break |
1095: | end; |
1096: | fl.Add(fd); |
1097: | end; |
1098: | |
1099: | end; |
1100: | |
1101: | destructor TInterpreter.Destroy; |
1102: | var i:integer; |
1103: | begin |
1104: | for i:=FFuncs.Count-1 downto 0 do |
1105: | FFuncs.Objects[i].Free; |
1106: | FFuncs.Free; |
1107: | for i:=FLibs.Count-1 downto 0 do FreeLibrary(THandle(FLibs[i])); |
1108: | FLibs.Free; |
1109: | inherited; |
1110: | end; |
1111: | |
1112: | constructor EBasic.Create; |
1113: | begin |
1114: | inherited Create(msg); |
1115: | escapecode:=AnEscapeCode |
1116: | end; |
1117: | |
1118: | const ts=#1; |
1119: | const tokenNames:array [tokenkinds] of string=( |
1120: | '', // tokvar |
1121: | '', // toknum |
1122: | '', // tokstr |
1123: | '', // tokfunc |
1124: | '', // toksnerr |
1125: | |
1126: | '+', // tokplus |
1127: | '-', // tokminus |
1128: | '*', // toktimes |
1129: | '/', // tokdiv |
1130: | '^', // tokup |
1131: | '('+ts+'[', // toklp |
1132: | ')'+ts+']', // tokrp |
1133: | ',', // tokcomma |
1134: | ';', // toksemi |
1135: | ':', // tokcolon |
1136: | '=', // tokeq |
1137: | '<', // toklt |
1138: | '>', // tokgt, |
1139: | '<=', // tokle |
1140: | '>=', // tokge |
1141: | '<>', // tokne |
1142: | |
1143: | 'AND', // tokand |
1144: | 'OR', // tokor |
1145: | 'XOR', // tokxor |
1146: | 'MOD', // tokmod |
1147: | 'NOT', // toknot |
1148: | 'SQR', // toksqr |
1149: | 'SQRT', // toksqrt |
1150: | 'SIN', // toksin |
1151: | 'COS', // tokcos |
1152: | 'TAN', // toktan |
1153: | 'ARCTAN', // tokarctan |
1154: | 'LOG', // toklog |
1155: | 'EXP', // tokexp |
1156: | 'ABS', // tokabs |
1157: | 'SGN', // toksgn, |
1158: | 'STR$', // tokstr_ |
1159: | 'VAL', // tokval |
1160: | 'CHR$', // tokchr_ |
1161: | 'ASC', // tokasc |
1162: | 'LEN', // toklen |
1163: | 'MID$', // tokmid_ |
1164: | 'LEFT$', // tokleft |
1165: | 'INT', // tokint |
1166: | 'RND', // tokrnd |
1167: | |
1168: | 'REM', // tokrem |
1169: | 'LET', // toklet |
1170: | 'PRINT', // tokprint |
1171: | 'INPUT', // tokinput |
1172: | 'GOTO'+ts+'GO TO', // tokgoto |
1173: | 'IF', // tokif |
1174: | 'END', // tokend |
1175: | 'STOP', // tokstop |
1176: | 'FOR', // tokfor |
1177: | 'NEXT', // toknext |
1178: | 'WHILE', // tokwhile |
1179: | 'WEND', // tokwend |
1180: | 'GOSUB', // tokgosub |
1181: | 'RETURN', // tokreturn |
1182: | 'READ', // tokread |
1183: | 'DATA', // tokdata |
1184: | 'RESTORE', // tokrestore |
1185: | 'ON', // tokon |
1186: | 'COMMON', // tokcommon |
1187: | 'DIM', // tokdim |
1188: | 'DEF', // tokdef |
1189: | |
1190: | 'LIST', // toklist |
1191: | 'RUN', // tokrun |
1192: | 'NEW', // toknew |
1193: | 'LOAD', // tokload |
1194: | 'MERGE', // tokmerge |
1195: | 'SAVE', // toksave |
1196: | 'BYE'+ts+'QUIT', // tokbye |
1197: | 'DEL', // tokdel |
1198: | 'DECLARE', // tokdeclare |
1199: | 'RENUM', // tokrenum |
1200: | |
1201: | 'THEN', // tokthen |
1202: | 'ELSE', // tokelse |
1203: | 'TO', // tokto |
1204: | 'STEP' // tokstep |
1205: | ); |
1206: | |
1207: | |
1208: | procedure snerr; |
1209: | begin |
1210: | errormsg('Syntax error'); |
1211: | end; |
1212: | |
1213: | procedure tmerr; |
1214: | begin |
1215: | errormsg('Type mismatch error'); |
1216: | end; |
1217: | |
1218: | procedure badsubscr; |
1219: | begin |
1220: | errormsg('Bad subscript'); |
1221: | end; |
1222: | |
1223: | function strltrim(const s:string):string; |
1224: | var i:integer; |
1225: | begin |
1226: | for i:=1 to length(s) do |
1227: | if s[i]<>' ' then begin |
1228: | strltrim:=Copy(s,i,maxint); |
1229: | exit |
1230: | end; |
1231: | strltrim:='' |
1232: | end; |
1233: | |
1234: | // TODO: use numtostr(,false) where appropriate |
1235: | |
1236: | function numtostr(n : float; trim:boolean) : string; |
1237: | var |
1238: | s : string; |
1239: | i : integer; |
1240: | begin |
1241: | if (n <> 0) and (abs(n) < 1e-2) or (abs(n) >= 1e12) then |
1242: | begin |
1243: | Str(n,s); |
1244: | |
1245: | if trim or (n<0) then |
1246: | numtostr := s |
1247: | else |
1248: | numtostr := ' '+s |
1249: | end |
1250: | else |
1251: | begin |
1252: | Str(n:30:10,s); |
1253: | i:=Length(s)+1; |
1254: | repeat |
1255: | i := i - 1; |
1256: | until s[i] <> '0'; |
1257: | if s[i] = '.' then |
1258: | i := i - 1; |
1259: | SetLength(s,i); |
1260: | |
1261: | if trim or (n<0) then |
1262: | numtostr := strltrim(s) |
1263: | else |
1264: | numtostr := ' '+strltrim(s) |
1265: | end; |
1266: | end; |
1267: | |
1268: | procedure NewPChar(var p:PChar; const s:string); |
1269: | begin |
1270: | GetMem(p,length(s)+1); |
1271: | if length(s)>0 then Move(s[1],p^,length(s)); |
1272: | p[length(s)]:=#0 |
1273: | end; |
1274: | |
1275: | procedure disposetokens(var tok : tokenptr); |
1276: | var |
1277: | tok1 : tokenptr; |
1278: | begin |
1279: | while tok <> nil do |
1280: | begin |
1281: | tok1 := tok^.next; |
1282: | if tok^.kind in [tokstr, tokrem] then |
1283: | FreeMem(tok^.sptr2); |
1284: | dispose(tok); |
1285: | tok := tok1; |
1286: | end; |
1287: | end; |
1288: | |
1289: | //-------------------------------------------------------------------- |
1290: | constructor TBasic.Create; |
1291: | begin |
1292: | inherited Create; |
1293: | Environment:=TStringList.Create; |
1294: | Commons:=TStringList.Create; |
1295: | TStringList(Commons).Sorted:=true |
1296: | end; |
1297: | |
1298: | destructor TBasic.Destroy; |
1299: | begin |
1300: | cmdnew; // dispose tokens, variables |
1301: | inherited; |
1302: | Environment.Free; |
1303: | Commons.Free |
1304: | end; |
1305: | |
1306: | procedure TBasic.CallShellSub; |
1307: | begin |
1308: | snerr |
1309: | end; |
1310: | |
1311: | function TBasic.CallShellFunction; |
1312: | begin |
1313: | snerr |
1314: | end; |
1315: | |
1316: | //-------------------------------------------------------------------- |
1317: | procedure TBasic.ExportCommons; |
1318: | var i:integer; |
1319: | var key:string; |
1320: | var v:varptr; |
1321: | var line:string; |
1322: | begin |
1323: | for i:=Commons.Count-1 downto 0 do begin |
1324: | key:=Commons[i]; |
1325: | v:=varbase; |
1326: | while v<>nil do |
1327: | if CompareText(v^.name,key)=0 then |
1328: | break |
1329: | else |
1330: | v:=v^.next; |
1331: | |
1332: | if key[length(key)]='$' then SetLength(key,length(key)-1); |
1333: | if v=nil then |
1334: | Env.Values[key]:='' |
1335: | else begin |
1336: | { TODO: handle arrays } |
1337: | case v^.kind of |
1338: | vString: |
1339: | Env.Values[key]:=_varrec2string(v^); |
1340: | |
1341: | vNumber: |
1342: | begin |
1343: | Str(_varrec2float(v^),line); |
1344: | Env.Values[key]:=Trim(line) |
1345: | end; |
1346: | |
1347: | else assert(false) |
1348: | end |
1349: | end |
1350: | end |
1351: | end; |
1352: | |
1353: | procedure TBasic.initvarfromenv(v:varptr); |
1354: | var value:string; |
1355: | var num:float; |
1356: | var code:integer; |
1357: | var key:string; |
1358: | begin |
1359: | { TODO: handle arrays ? } |
1360: | key:=v^.name; |
1361: | if key[length(key)]='$' then SetLength(key,length(key)-1); |
1362: | value:=Environment.Values[key]; |
1363: | |
1364: | case v^.kind of |
1365: | vString: |
1366: | _setvarrec2string(v^,value); |
1367: | |
1368: | vNumber: |
1369: | begin |
1370: | Val(value,num,code); |
1371: | if code<>0 then num:=0; |
1372: | _setvarrec2float(v^,num) |
1373: | end; |
1374: | |
1375: | else assert(false) |
1376: | end; |
1377: | end; |
1378: | |
1379: | procedure TBasic.listtokens(var f : text; buf : tokenptr); |
1380: | var |
1381: | ltr : boolean; |
1382: | wasSpace:boolean; |
1383: | |
1384: | procedure Put(const s:string); |
1385: | begin |
1386: | if (s[1]=' ') and wasSpace then |
1387: | Write(f,Copy(s,2,maxint)) |
1388: | else |
1389: | Write(f,s); |
1390: | wasSpace:=s[length(s)]=' ' |
1391: | end; |
1392: | |
1393: | function TN:string; |
1394: | var i:integer; |
1395: | begin |
1396: | Result:=tokenNames[buf^.kind]; |
1397: | i:=Pos(ts,Result); |
1398: | if i<>0 then SetLength(Result,i-1) |
1399: | end; |
1400: | |
1401: | procedure PT; |
1402: | begin |
1403: | Put(TN) |
1404: | end; |
1405: | |
1406: | procedure PS; |
1407: | begin |
1408: | Put(' '+TN+' ') |
1409: | end; |
1410: | |
1411: | procedure PU; |
1412: | begin |
1413: | Put(TN+' ') |
1414: | end; |
1415: | |
1416: | function s2p(const s:string):string; |
1417: | var i:integer; |
1418: | begin |
1419: | Result:=''; |
1420: | for i:=1 to length(s) do |
1421: | if s[i]='"' then |
1422: | Result:=Result+'""' |
1423: | else |
1424: | Result:=Result+s[i] |
1425: | end; |
1426: | |
1427: | begin |
1428: | ltr := false; |
1429: | wasSpace:=false; |
1430: | while buf <> nil do |
1431: | begin |
1432: | if buf^.kind in [tokvar, tokFunc, toknum, toknot..tokrenum] then |
1433: | begin |
1434: | if ltr then Put(' '); |
1435: | ltr := (buf^.kind <> toknot); |
1436: | end |
1437: | else |
1438: | ltr := false; |
1439: | case buf^.kind of |
1440: | tokvar : Put(buf^.vp^.name); |
1441: | toknum : Put(numtostr(buf^.num,true)); |
1442: | tokstr : Put('"'+ s2p(buf^.sptr2) +'"'); |
1443: | tokFunc : Put(FFuncs[FFuncs.IndexOfObject(TObject(buf^.fi))]); |
1444: | toksnerr : Put('{'+ buf^.snch +'}'); |
1445: | tokplus , |
1446: | tokminus , |
1447: | toktimes , |
1448: | tokdiv , |
1449: | tokup , |
1450: | toklp , |
1451: | tokrp , |
1452: | tokcomma , |
1453: | toksemi : PT; |
1454: | tokcolon , |
1455: | tokeq , |
1456: | toklt , |
1457: | tokgt , |
1458: | tokle , |
1459: | tokge , |
1460: | tokne , |
1461: | tokand , |
1462: | tokor , |
1463: | tokxor , |
1464: | tokmod : PS; |
1465: | toknot : PU; |
1466: | toksqr , |
1467: | toksqrt , |
1468: | toksin , |
1469: | tokcos , |
1470: | toktan , |
1471: | tokarctan , |
1472: | toklog , |
1473: | tokexp , |
1474: | tokabs , |
1475: | toksgn , |
1476: | tokstr_ , |
1477: | tokval , |
1478: | tokchr_ , |
1479: | tokasc , |
1480: | toklen , |
1481: | tokmid_ , |
1482: | tokleft , |
1483: | tokint , |
1484: | tokrnd , |
1485: | toklet , |
1486: | tokprint , |
1487: | tokinput , |
1488: | tokgoto , |
1489: | tokif , |
1490: | tokend , |
1491: | tokstop , |
1492: | tokfor , |
1493: | toknext , |
1494: | tokwhile , |
1495: | tokwend , |
1496: | tokgosub , |
1497: | tokreturn , |
1498: | tokread , |
1499: | tokdata , |
1500: | tokrestore , |
1501: | tokon , |
1502: | tokcommon , |
1503: | tokdim , |
1504: | tokdef , |
1505: | toklist , |
1506: | tokrun , |
1507: | toknew , |
1508: | tokload , |
1509: | tokmerge , |
1510: | toksave , |
1511: | tokdel , |
1512: | tokbye , |
1513: | tokrenum , |
1514: | tokdeclare : PT; |
1515: | tokthen , |
1516: | tokelse , |
1517: | tokto , |
1518: | tokstep : PS; |
1519: | tokrem : Put(TN+buf^.sptr2); |
1520: | end; |
1521: | buf := buf^.next; |
1522: | end; |
1523: | end; |
1524: | |
1525: | //-------------------------------------------------------------------- |
1526: | procedure TBasic.clearvars; |
1527: | var |
1528: | v : varptr; |
1529: | begin |
1530: | v := varbase; |
1531: | while v <> nil do |
1532: | begin |
1533: | clearvar(v^); |
1534: | v := v^.next; |
1535: | end; |
1536: | end; |
1537: | //-------------------------------------------------------------------- |
1538: | procedure TBasic.clearloops; |
1539: | var |
1540: | l : loopptr; |
1541: | begin |
1542: | while loopbase <> nil do |
1543: | begin |
1544: | l := loopbase^.next; |
1545: | dispose(loopbase); |
1546: | loopbase := l; |
1547: | end; |
1548: | end; |
1549: | //-------------------------------------------------------------------- |
1550: | procedure TBasic.parseinput(var buf : tokenptr); |
1551: | var |
1552: | l, l0, l1 : lineptr; |
1553: | begin |
1554: | inbuf := strltrim(inbuf); |
1555: | curline := 0; |
1556: | while (length(inbuf) <> 0) and (inbuf[1] in ['0'..'9']) do |
1557: | begin |
1558: | curline := curline * 10 + ord(inbuf[1]) - ord('0'); |
1559: | Delete(inbuf,1,1) |
1560: | end; |
1561: | parse(inbuf, buf); |
1562: | if curline <> 0 then |
1563: | begin |
1564: | l := linebase; |
1565: | l0 := nil; |
1566: | while (l <> nil) and (l^.num < curline) do |
1567: | begin |
1568: | l0 := l; |
1569: | l := l^.next; |
1570: | end; |
1571: | if (l <> nil) and (l^.num = curline) then |
1572: | begin |
1573: | l1 := l; |
1574: | l := l^.next; |
1575: | if l0 = nil then |
1576: | linebase := l |
1577: | else |
1578: | l0^.next := l; |
1579: | disposetokens(l1^.txt); |
1580: | dispose(l1); |
1581: | end; |
1582: | if buf <> nil then |
1583: | begin |
1584: | new(l1); |
1585: | FillChar(l1^,sizeof(l1^),0); |
1586: | l1^.next := l; |
1587: | if l0 = nil then |
1588: | linebase := l1 |
1589: | else |
1590: | l0^.next := l1; |
1591: | l1^.num := curline; |
1592: | l1^.txt := buf; |
1593: | end; |
1594: | clearloops; |
1595: | restoredata; |
1596: | end; |
1597: | end; |
1598: | |
1599: | |
1600: | //-------------------------------------------------------------------- |
1601: | procedure TBasic.restoredata; |
1602: | begin |
1603: | dataline := nil; |
1604: | datatok := nil; |
1605: | end; |
1606: | //-------------------------------------------------------------------- |
1607: | procedure TBasic.parse(const inbuf :string; var buf : tokenptr); |
1608: | |
1609: | const |
1610: | toklength = 20; |
1611: | |
1612: | type |
1613: | chset = set of char; |
1614: | |
1615: | const |
1616: | idchars = ['A'..'Z','a'..'z','0'..'9','_','$',{ TODO: }'%']; |
1617: | |
1618: | var |
1619: | i, j, k, i2 : integer; |
1620: | token : string[toklength]; |
1621: | t, tptr : tokenptr; |
1622: | v : varptr; |
1623: | ch : char; |
1624: | n, d, d1 : float; |
1625: | |
1626: | // TODO: support "GO TO" |
1627: | |
1628: | function IsA(const key:string):boolean; |
1629: | var i:integer; |
1630: | begin |
1631: | IsA:=false; |
1632: | if length(key)<>length(token) then exit; |
1633: | for i:=1 to length(key) do |
1634: | if UpCase(token[i])<>UpCase(key[i]) then exit; |
1635: | IsA:=true |
1636: | end; |
1637: | |
1638: | function MatchTokens(toks:array of tokenkinds):boolean; |
1639: | var i:integer; |
1640: | var keys:string; |
1641: | var p:integer; |
1642: | label loop; |
1643: | begin |
1644: | Result:=false; |
1645: | for i:=Low(toks) to High(toks) do begin |
1646: | keys:=tokenNames[toks[i]]; |
1647: | loop: |
1648: | p:=Pos(ts,keys); |
1649: | if p=0 then p:=length(keys)+1; |
1650: | if IsA(Copy(keys,1,p-1)) then begin |
1651: | t^.kind:=toks[i]; |
1652: | Result:=true; |
1653: | exit |
1654: | end; |
1655: | Delete(keys,1,p); |
1656: | if keys<>'' then goto loop |
1657: | end |
1658: | end; |
1659: | |
1660: | var tmp:string; |
1661: | begin |
1662: | tptr := nil; |
1663: | buf := nil; |
1664: | i := 1; |
1665: | repeat |
1666: | ch := ' '; |
1667: | while (i <= length(inbuf)) and (ch = ' ') do |
1668: | begin |
1669: | ch := inbuf[i]; |
1670: | i := i + 1; |
1671: | end; |
1672: | if ch <> ' ' then |
1673: | begin |
1674: | new(t); |
1675: | FillChar(t^,sizeof(t^),0); |
1676: | if tptr = nil then |
1677: | buf := t |
1678: | else |
1679: | tptr^.next := t; |
1680: | tptr := t; |
1681: | t^.next := nil; |
1682: | case ch of |
1683: | 'A'..'Z', 'a'..'z', '_' : |
1684: | begin |
1685: | i := i - 1; |
1686: | j := 0; |
1687: | SetLength(token,toklength); |
1688: | while (i <= Length(inbuf)) and (inbuf[i] in idchars) do |
1689: | begin |
1690: | if j < toklength then |
1691: | begin |
1692: | j := j + 1; |
1693: | token[j] := inbuf[i]; |
1694: | end; |
1695: | i := i + 1; |
1696: | end; |
1697: | SetLength(token,j); |
1698: | |
1699: | |
1700: | i2:=FindFunc(token,inbuf,i); |
1701: | if i2>=0 then begin |
1702: | t^.kind:=tokFunc; |
1703: | t^.fi:=integer(FFuncs.Objects[i2]) |
1704: | end else |
1705: | |
1706: | if MatchTokens([ |
1707: | tokand, |
1708: | tokor, |
1709: | tokxor, |
1710: | toknot, |
1711: | tokmod, |
1712: | toksqr, |
1713: | toksqrt, |
1714: | toksin, |
1715: | tokcos, |
1716: | toktan, |
1717: | tokarctan, |
1718: | toklog, |
1719: | tokexp, |
1720: | tokabs, |
1721: | toksgn, |
1722: | tokstr_, |
1723: | tokval, |
1724: | tokchr_, |
1725: | tokasc, |
1726: | toklen, |
1727: | tokmid_, |
1728: | tokleft, |
1729: | tokint, |
1730: | tokrnd, |
1731: | toklet, |
1732: | tokprint, |
1733: | tokinput, |
1734: | tokgoto, |
1735: | tokif, |
1736: | tokend, |
1737: | tokstop, |
1738: | tokfor, |
1739: | toknext, |
1740: | tokwhile, |
1741: | tokwend, |
1742: | tokgosub, |
1743: | tokreturn, |
1744: | tokread, |
1745: | tokdata, |
1746: | tokrestore, |
1747: | tokon, |
1748: | tokcommon, |
1749: | tokdim, |
1750: | tokdef, |
1751: | toklist, |
1752: | tokrun, |
1753: | toknew, |
1754: | tokload, |
1755: | tokmerge, |
1756: | toksave, |
1757: | tokbye, |
1758: | tokdel, |
1759: | tokrenum, |
1760: | tokdeclare, |
1761: | tokthen, |
1762: | tokelse, |
1763: | tokto, |
1764: | tokstep |
1765: | ]) then |
1766: | else if IsA(tokenNames[tokrem]) then |
1767: | begin |
1768: | t^.kind := tokrem; |
1769: | NewPChar(t^.sptr2,Copy(inbuf,i,maxint)); |
1770: | i := length(inbuf)+1; |
1771: | end |
1772: | else |
1773: | begin |
1774: | t^.kind := tokvar; |
1775: | v := varbase; |
1776: | while (v <> nil) and (not IsA(v^.name)) do |
1777: | v := v^.next; |
1778: | if v = nil then |
1779: | begin |
1780: | new(v); |
1781: | FillChar(v^,sizeof(v^),0); |
1782: | |
1783: | v^.next := varbase; |
1784: | varbase := v; |
1785: | v^.name := token; |
1786: | v^.numdims := 0; |
1787: | if token[length(token)] = '$' then |
1788: | v^.kind:=vString |
1789: | else |
1790: | v^.kind:=vNumber |
1791: | end; |
1792: | t^.vp := v; |
1793: | end; |
1794: | end; |
1795: | '"' : |
1796: | begin |
1797: | t^.kind := tokstr; |
1798: | tmp:=''; |
1799: | while true do begin |
1800: | if i>length(inbuf) then break; |
1801: | if inbuf[i]=ch then begin |
1802: | if (i<length(inbuf)) and (inbuf[i+1]=ch) then begin |
1803: | tmp:=tmp+ch; |
1804: | inc(i,2) |
1805: | end else begin |
1806: | inc(i); |
1807: | break |
1808: | end |
1809: | end else begin |
1810: | tmp:=tmp+inbuf[i]; |
1811: | inc(i) |
1812: | end |
1813: | end; |
1814: | NewPChar(t^.sptr2,tmp); |
1815: | end; |
1816: | '0'..'9', '.' : |
1817: | begin |
1818: | t^.kind := toknum; |
1819: | n := 0; |
1820: | d := 1; |
1821: | d1 := 1; |
1822: | i := i - 1; |
1823: | while (i <= length(inbuf)) and ((inbuf[i] in ['0'..'9']) |
1824: | or ((inbuf[i] = '.') and (d1 = 1))) do |
1825: | begin |
1826: | if inbuf[i] = '.' then |
1827: | d1 := 10 |
1828: | else |
1829: | begin |
1830: | n := n * 10 + ord(inbuf[i]) - ord('0'); |
1831: | d := d * d1; |
1832: | end; |
1833: | i := i + 1; |
1834: | end; |
1835: | n := n / d; |
1836: | if (i <= length(inbuf)) and (inbuf[i] in ['e','E']) then |
1837: | begin |
1838: | i := i + 1; |
1839: | d1 := 10; |
1840: | if (i <= length(inbuf)) and (inbuf[i] in ['+','-']) then |
1841: | begin |
1842: | if inbuf[i] = '-' then |
1843: | d1 := 0.1; |
1844: | i := i + 1; |
1845: | end; |
1846: | j := 0; |
1847: | while (i <= length(inbuf)) and (inbuf[i] in ['0'..'9']) do |
1848: | begin |
1849: | j := j * 10 + ord(inbuf[i]) - ord('0'); |
1850: | i := i + 1; |
1851: | end; |
1852: | for k := 1 to j do |
1853: | n := n * d1; |
1854: | end; |
1855: | t^.num := n; |
1856: | end; |
1857: | '+' : t^.kind := tokplus; |
1858: | '-' : t^.kind := tokminus; |
1859: | '*' : t^.kind := toktimes; |
1860: | '/' : t^.kind := tokdiv; |
1861: | '^' : t^.kind := tokup; |
1862: | '(', '[' : t^.kind := toklp; |
1863: | ')', ']' : t^.kind := tokrp; |
1864: | ',' : t^.kind := tokcomma; |
1865: | ';' : t^.kind := toksemi; |
1866: | ':' : t^.kind := tokcolon; |
1867: | '?' : t^.kind := tokprint; |
1868: | '=' : t^.kind := tokeq; |
1869: | '<' : |
1870: | begin |
1871: | if (i <= length(inbuf)) and (inbuf[i] = '=') then |
1872: | begin |
1873: | t^.kind := tokle; |
1874: | i := i + 1; |
1875: | end |
1876: | else if (i <= length(inbuf)) and (inbuf[i] = '>') then |
1877: | begin |
1878: | t^.kind := tokne; |
1879: | i := i + 1; |
1880: | end |
1881: | else |
1882: | t^.kind := toklt; |
1883: | end; |
1884: | '>' : |
1885: | begin |
1886: | if (i <= length(inbuf)) and (inbuf[i] = '=') then |
1887: | begin |
1888: | t^.kind := tokge; |
1889: | i := i + 1; |
1890: | end |
1891: | else |
1892: | t^.kind := tokgt; |
1893: | end; |
1894: | else |
1895: | begin |
1896: | t^.kind := toksnerr; |
1897: | t^.snch := ch; |
1898: | end; |
1899: | end; |
1900: | end; |
1901: | until i > length(inbuf); |
1902: | end; |
1903: | //-------------------------------------------------------------------- |
1904: | const |
1905: | MaxArgs=6; // TUNE: |
1906: | type |
1907: | TArg=packed record |
1908: | sbuf:string; |
1909: | val:valrec; |
1910: | ref:valref; |
1911: | isRef:boolean |
1912: | end; |
1913: | TArgs=packed record |
1914: | count:integer; |
1915: | outVal:TArg; |
1916: | inVal:array [1..MaxArgs] of TArg; |
1917: | end; |
1918: | |
1919: | procedure TBasic.cmdend; |
1920: | begin |
1921: | stmtline := nil; |
1922: | t := nil; |
1923: | end; |
1924: | |
1925: | |
1926: | procedure TBasic.cmdnew; |
1927: | var |
1928: | p : pointer; |
1929: | begin |
1930: | cmdend; |
1931: | clearloops; |
1932: | restoredata; |
1933: | while linebase <> nil do |
1934: | begin |
1935: | p := linebase^.next; |
1936: | disposetokens(linebase^.txt); |
1937: | dispose(linebase); |
1938: | linebase := p; |
1939: | end; |
1940: | while varbase <> nil do |
1941: | begin |
1942: | p := varbase^.next; |
1943: | clearvar(varbase^); |
1944: | dispose(varbase); |
1945: | varbase := p; |
1946: | end; |
1947: | end; |
1948: | |
1949: | |
1950: | procedure TBasic.cmdload(merging : boolean; name : string); |
1951: | var |
1952: | f : file; |
1953: | buf : tokenptr; |
1954: | ch:char; |
1955: | block:array [0..8 { TUNE: }*1024-1] of char; |
1956: | blockSize:integer; |
1957: | blockHead:integer; |
1958: | eof:boolean; |
1959: | |
1960: | function Get:boolean; |
1961: | begin |
1962: | if blockHead=blockSize then begin |
1963: | blockHead:=0; |
1964: | blockread(f,block,sizeof(block),blockSize); |
1965: | if blockSize=0 then begin |
1966: | Result:=false; |
1967: | eof:=true; |
1968: | exit |
1969: | end |
1970: | end; |
1971: | ch:=block[blockHead]; |
1972: | inc(blockHead); |
1973: | Result:=true |
1974: | end; |
1975: | |
1976: | begin |
1977: | if not merging then |
1978: | cmdnew; |
1979: | assign(f,ExpandFileName(name,false)); // TODO: shared |
1980: | reset(f,sizeof(ch)); |
1981: | |
1982: | blockSize:=0; |
1983: | blockHead:=0; |
1984: | |
1985: | eof:=false; |
1986: | while not eof do |
1987: | begin |
1988: | inbuf:=''; |
1989: | while not eof do begin |
1990: | if not Get then break; |
1991: | case ch of |
1992: | #$0A: break; |
1993: | #$0D: ; |
1994: | else inbuf:=inbuf+ch |
1995: | end |
1996: | end; |
1997: | // readln(f, inbuf); |
1998: | if inbuf='' then continue; |
1999: | parseinput(buf); |
2000: | if curline = 0 then |
2001: | begin |
2002: | writeln(output^,'Bad line in file'); |
2003: | disposetokens(buf); |
2004: | end; |
2005: | end; |
2006: | close(f); |
2007: | end; |
2008: | |
2009: | procedure TBasic.cmdsave; |
2010: | var |
2011: | f : text; |
2012: | l : lineptr; |
2013: | begin |
2014: | rewrite(f, ExpandFileName(name,true)); |
2015: | l := linebase; |
2016: | while l <> nil do |
2017: | begin |
2018: | write(f, l^.num:1, ' '); |
2019: | listtokens(f, l^.txt); |
2020: | writeln(f); |
2021: | l := l^.next; |
2022: | end; |
2023: | close(f); |
2024: | end; |
2025: | |
2026: | procedure TBasic.NewFunction; |
2027: | var lin:lineptr; |
2028: | |
2029: | procedure Replace(t:tokenptr); |
2030: | begin |
2031: | while t<>nil do begin |
2032: | if (t^.kind=tokvar) and (UpperCase(t^.vp^.name)=symbolName) then begin |
2033: | t^.kind:=tokfunc; |
2034: | t^.fi:=index |
2035: | end; |
2036: | t:=t^.next |
2037: | end; |
2038: | end; |
2039: | |
2040: | begin |
2041: | { replace tokvar with tokfunc } |
2042: | Replace(t); |
2043: | lin:=linebase; |
2044: | while lin<>nil do begin |
2045: | Replace(lin^.txt); |
2046: | lin:=lin^.next |
2047: | end |
2048: | end; |
2049: | |
2050: | procedure TBasic.SetBreak; |
2051: | begin |
2052: | BreakFlag := True |
2053: | end; |
2054: | |
2055: | procedure TBasic.CheckBreak; |
2056: | begin |
2057: | if BreakFlag then begin |
2058: | BreakFlag := False; |
2059: | escape(-20,'Break'); |
2060: | end |
2061: | end; |
2062: | |
2063: | procedure TBasic.exec; |
2064: | |
2065: | var |
2066: | gotoflag, elseflag : boolean; |
2067: | |
2068: | procedure factor(var n:valrec);forward; |
2069: | |
2070: | procedure expr(var n:valrec);forward; |
2071: | |
2072: | function realfactor:float; |
2073: | var n:valrec; |
2074: | begin |
2075: | factor(n); |
2076: | if n.kind<>vNumber then tmerr; |
2077: | Result:=n.num.value |
2078: | end; |
2079: | |
2080: | function strfactor:string; |
2081: | var n:valrec; |
2082: | begin |
2083: | factor(n); |
2084: | if n.kind<>vString then tmerr; |
2085: | Result:=n.str.value |
2086: | end; |
2087: | |
2088: | function intfactor:integer; |
2089: | begin |
2090: | Result:=round(realfactor); |
2091: | end; |
2092: | |
2093: | function realexpr:float; |
2094: | var n:valrec; |
2095: | begin |
2096: | expr(n); |
2097: | if n.kind<>vNumber then tmerr; |
2098: | Result:=n.num.value |
2099: | end; |
2100: | |
2101: | function strexpr:string; |
2102: | var n:valrec; |
2103: | begin |
2104: | expr(n); |
2105: | if n.kind<>vString then tmerr; |
2106: | Result:=n.str.value |
2107: | end; |
2108: | |
2109: | function intexpr:integer; |
2110: | begin |
2111: | Result:=round(realexpr); |
2112: | end; |
2113: | |
2114: | procedure require(k : tokenkinds); |
2115: | begin |
2116: | if (t = nil) or (t^.kind <> k) then |
2117: | snerr; |
2118: | t := t^.next; |
2119: | end; |
2120: | |
2121: | function keyword(const name:string):boolean; |
2122: | begin |
2123: | if t=nil then |
2124: | Result:=false |
2125: | else begin |
2126: | Result:=((t^.kind=tokvar) and (UpperCase(t^.vp^.name)=name)) or |
2127: | (tokenNames[t^.kind]=name) or |
2128: | ((t^.kind=tokfunc) and (UpperCase(FFuncs[FFuncs.IndexOfObject(TObject(t^.fi))])=name)); |
2129: | if Result then t:=t^.next |
2130: | end |
2131: | end; |
2132: | |
2133: | procedure requireKeyword(const name:string); |
2134: | begin |
2135: | if not keyword(name) then snerr |
2136: | end; |
2137: | |
2138: | procedure skipparen; |
2139: | label 1; |
2140: | begin |
2141: | repeat |
2142: | if t = nil then snerr; |
2143: | if (t^.kind = tokrp) or (t^.kind = tokcomma) then |
2144: | goto 1; |
2145: | if t^.kind = toklp then |
2146: | begin |
2147: | t := t^.next; |
2148: | skipparen; |
2149: | end; |
2150: | t := t^.next; |
2151: | until false; |
2152: | 1 : |
2153: | end; |
2154: | |
2155: | function iseos : boolean;forward; |
2156: | |
2157: | procedure skipoptionalparenexpr; |
2158: | var level:integer; |
2159: | begin |
2160: | if (t<>nil) and (t^.kind=toklp) then begin |
2161: | t:=t^.next; |
2162: | level:=1; |
2163: | while level<>0 do begin |
2164: | if iseos then snerr; |
2165: | if t^.kind=toklp then |
2166: | inc(level) |
2167: | else |
2168: | if t^.kind=tokrp then |
2169: | dec(level); |
2170: | t:=t^.next |
2171: | end |
2172: | end; |
2173: | end; |
2174: | |
2175: | function findvar : varptr; |
2176: | var |
2177: | v : varptr; |
2178: | i, j, k : integer; |
2179: | tok : tokenptr; |
2180: | begin |
2181: | if (t = nil) or (t^.kind <> tokvar) then snerr; |
2182: | v := t^.vp; |
2183: | t := t^.next; |
2184: | if (t <> nil) and (t^.kind = toklp) then |
2185: | with v^ do |
2186: | begin |
2187: | if numdims = 0 then |
2188: | begin |
2189: | tok := t; |
2190: | i := 0; |
2191: | j := 1; |
2192: | repeat |
2193: | if i >= maxdims then badsubscr; |
2194: | t := t^.next; |
2195: | skipparen; |
2196: | j := j * 11; |
2197: | i := i + 1; |
2198: | dims[i] := 11; |
2199: | until t^.kind = tokrp; |
2200: | numdims := i; |
2201: | case kind of |
2202: | vNumber: |
2203: | begin |
2204: | GetMem(num.base,j*sizeof(float)); |
2205: | FillChar(num.base^,j*sizeof(float),0) |
2206: | end; |
2207: | |
2208: | vString: |
2209: | begin |
2210: | GetMem(str.base,j*sizeof(basicstring)); |
2211: | FillChar(str.base^,j*sizeof(basicstring),0) |
2212: | end; |
2213: | |
2214: | else assert(false) |
2215: | end; |
2216: | t := tok; |
2217: | end; |
2218: | k := 0; |
2219: | t := t^.next; |
2220: | for i := 1 to numdims do |
2221: | begin |
2222: | j := intexpr; |
2223: | if (j < 0) or (j >= dims[i]) then |
2224: | badsubscr; |
2225: | k := k * dims[i] + j; |
2226: | if i < numdims then |
2227: | require(tokcomma); |
2228: | end; |
2229: | require(tokrp); |
2230: | |
2231: | case kind of |
2232: | vNumber: |
2233: | begin |
2234: | num.ref.base:=num.base; |
2235: | num.ref.index:=k |
2236: | end; |
2237: | |
2238: | vString: |
2239: | begin |
2240: | str.ref.base:=str.base; |
2241: | str.ref.index:=k |
2242: | end; |
2243: | |
2244: | else assert(false) |
2245: | end; |
2246: | end |
2247: | else |
2248: | begin |
2249: | { TODO: |
2250: | if v^.numdims <> 0 then |
2251: | badsubscr; |
2252: | } |
2253: | case v^.kind of |
2254: | vNumber: v^.num.ref.base:=nil; |
2255: | vString: v^.str.ref.base:=nil; |
2256: | else assert(false) |
2257: | end |
2258: | end; |
2259: | if v^.func<>nil then snerr; |
2260: | findvar := v; |
2261: | end; |
2262: | |
2263: | procedure getvar(var ref:valref); |
2264: | begin |
2265: | varrec2valref(findvar^,ref) |
2266: | end; |
2267: | |
2268: | function inot(i : integer) : integer; |
2269: | begin |
2270: | inot := -1 - i; |
2271: | end; |
2272: | |
2273: | function ixor(a, b : integer) : integer; |
2274: | begin |
2275: | ixor := a xor b; |
2276: | end; |
2277: | |
2278: | procedure CallFunction(var n:valrec; fi:integer; needResult:boolean); |
2279: | var arity:integer; |
2280: | var descriptors:string; |
2281: | var args:TArgs; |
2282: | var flag:integer; |
2283: | var needBraces:boolean; |
2284: | var i:integer; |
2285: | var missing:boolean; |
2286: | |
2287: | var stack:array [0..30 { TUNE: }] of integer; |
2288: | var sp:integer; |
2289: | var _eax,_edx,_ecx:integer; |
2290: | var regcount:integer; |
2291: | var ltr:boolean; |
2292: | |
2293: | procedure PushInt(n:integer); |
2294: | begin |
2295: | case regcount of |
2296: | 0: begin inc(regcount); _eax:=n end; |
2297: | 1: begin inc(regcount); _edx:=n end; |
2298: | 2: begin inc(regcount); _ecx:=n end; |
2299: | else |
2300: | stack[sp]:=n; |
2301: | if ltr then dec(sp) else inc(sp) |
2302: | end |
2303: | end; |
2304: | |
2305: | procedure PushPtr(n:pointer); |
2306: | begin |
2307: | PushInt(integer(n)) |
2308: | end; |
2309: | |
2310: | function AsInt(var a:TArg):integer; |
2311: | begin |
2312: | with a do |
2313: | if isRef then begin |
2314: | if (ref.kind<>vNumber) or (ref.num.base=nil) then tmerr; |
2315: | Result:=Trunc(ref.num.base^[ref.num.index]) |
2316: | end else begin |
2317: | if val.kind<>vNumber then tmerr; |
2318: | Result:=Trunc(val.num.value) |
2319: | end |
2320: | end; |
2321: | |
2322: | procedure AsStr(var a:TArg); |
2323: | begin |
2324: | with a do |
2325: | if isRef then begin |
2326: | if (ref.kind<>vString) or (ref.str.base=nil) then tmerr; |
2327: | a.sbuf:=basicstring2string(ref.str.base^[ref.str.index]) |
2328: | end else begin |
2329: | if val.kind<>vString then tmerr; |
2330: | a.sbuf:=val.str.value |
2331: | end; |
2332: | end; |
2333: | |
2334: | var stkusage:integer; |
2335: | var stkadr:integer; |
2336: | var regcall:boolean; |
2337: | var adr:pointer; |
2338: | var resadr:pointer; |
2339: | var resvalue:integer; |
2340: | var needsExtraParam:boolean; |
2341: | var isMethod:boolean; |
2342: | var obj:TObject; |
2343: | var fd:TFuncDef; |
2344: | var fl:TFuncDefs; |
2345: | |
2346: | function ShellCommand(const cmdFormat:string):string; |
2347: | var i:integer; |
2348: | var ch:char; |
2349: | var ai:integer; |
2350: | var flag:integer; |
2351: | var missing:boolean; |
2352: | begin |
2353: | Result:=''; |
2354: | i:=1; |
2355: | while i<=length(cmdFormat) do begin |
2356: | ch:=cmdFormat[i]; |
2357: | if ch='%' then begin |
2358: | if (i=length(cmdFormat)) or (cmdFormat[i+1]='%') then begin |
2359: | Result:=Result+ch; |
2360: | inc(i,2) |
2361: | end else begin |
2362: | ai:=ord(cmdFormat[i+1])-ord('0'); |
2363: | |
2364: | if (ai<1) or (ai>arity) then snerr; |
2365: | |
2366: | flag:=ord(descriptors[ai+1]); |
2367: | missing:=args.count<ai; |
2368: | |
2369: | case flag and vkMaskType of |
2370: | vkByVal or vkInteger, |
2371: | vkByVal or vkInteger or vkConst: |
2372: | if missing then |
2373: | Result:=Result+'0' |
2374: | else |
2375: | Result:=Result+IntToStr(AsInt(args.inVal[ai])); |
2376: | |
2377: | vkByVal or vkString, |
2378: | vkByVal or vkString or vkConst, |
2379: | vkByVal or vkPChar, |
2380: | vkByVal or vkPChar or vkConst: |
2381: | begin |
2382: | if not missing then begin |
2383: | AsStr(args.inVal[ai]); |
2384: | Result:=Result+args.inVal[ai].sbuf |
2385: | end |
2386: | end; |
2387: | |
2388: | else snerr |
2389: | end; |
2390: | |
2391: | inc(i,2) |
2392: | end |
2393: | end else begin |
2394: | Result:=Result+ch; |
2395: | inc(i) |
2396: | end |
2397: | end |
2398: | end; |
2399: | |
2400: | begin |
2401: | fl:=TFuncDefs(fi); |
2402: | fd:=fl.Items[0]; |
2403: | |
2404: | descriptors:=fd.descriptor; |
2405: | adr:=fd.offset; |
2406: | arity:=length(descriptors)-1; |
2407: | FillChar(args,sizeof(args),0); |
2408: | |
2409: | flag:=ord(descriptors[1]); |
2410: | if needResult and ((flag and vkMaskType)=vkNone) then tmerr; |
2411: | obj:=fd.obj; |
2412: | isMethod:=obj<>nil; |
2413: | |
2414: | if arity>0 then begin |
2415: | if t<>nil then begin |
2416: | if t^.kind=toklp then begin |
2417: | needBraces:=true; |
2418: | t:=t^.next |
2419: | end else |
2420: | needBraces:=false; |
2421: | |
2422: | while true do begin |
2423: | if iseos then begin |
2424: | if needBraces then snerr else break |
2425: | end; |
2426: | |
2427: | if needBraces and (t^.kind=tokrp) then begin |
2428: | t:=t^.next; |
2429: | break |
2430: | end; |
2431: | |
2432: | flag:=ord(descriptors[args.count+1]); |
2433: | if (flag and vkByRef)<>0 then begin |
2434: | with args.inVal[args.count+1] do begin |
2435: | isRef:=true; |
2436: | getvar(ref) |
2437: | end |
2438: | end else begin |
2439: | with args.inVal[args.count+1] do begin |
2440: | isRef:=false; |
2441: | if needBraces then |
2442: | expr(val) |
2443: | else |
2444: | factor(val) |
2445: | end |
2446: | end; |
2447: | inc(args.count); |
2448: | |
2449: | dec(arity); |
2450: | |
2451: | if (iseos or (arity=0)) and (not needBraces) then break; |
2452: | |
2453: | if t=nil then snerr; |
2454: | |
2455: | case t^.kind of |
2456: | tokcomma: t:=t^.next; |
2457: | tokrp: if needBraces then begin t:=t^.next; break end; |
2458: | else |
2459: | if needBraces then snerr else break |
2460: | end; |
2461: | |
2462: | if arity=0 then snerr; |
2463: | |
2464: | end |
2465: | end |
2466: | end else begin |
2467: | if (t<>nil) and (t^.kind=toklp) then begin |
2468: | t:=t^.next; |
2469: | require(tokrp) |
2470: | end |
2471: | end; |
2472: | |
2473: | arity:=length(descriptors)-1; |
2474: | for i:=args.count+1 to arity do begin |
2475: | flag:=ord(descriptors[i+1]); |
2476: | if (flag and vkOptional)=0 then snerr |
2477: | end; |
2478: | |
2479: | if fd.cmdFormat='' then begin |
2480: | case ord(descriptors[1]) and vkMaskCall of |
2481: | vkFastCall: |
2482: | begin |
2483: | ltr:=true; |
2484: | regcall:=true; |
2485: | regcount:=0 |
2486: | end; |
2487: | else |
2488: | // vkStdCall |
2489: | ltr:=false; |
2490: | regcall:=false; |
2491: | regcount:=3 // don't use registers |
2492: | end; |
2493: | |
2494: | if ltr then begin |
2495: | sp:=High(stack); |
2496: | end else begin |
2497: | sp:=Low(stack); |
2498: | end; |
2499: | |
2500: | flag:=ord(descriptors[1]) and vkMaskType; |
2501: | case flag of |
2502: | vkString: |
2503: | begin |
2504: | needsExtraParam:=true |
2505: | end; |
2506: | else |
2507: | needsExtraParam:=false; |
2508: | end; |
2509: | |
2510: | resadr:=@resvalue; |
2511: | resvalue:=0; |
2512: | |
2513: | if needsExtraParam and (not ltr) then |
2514: | PushInt(integer(resadr)); |
2515: | if isMethod { TODO: ? and (not ltr)} then |
2516: | PushInt(integer(obj)); |
2517: | |
2518: | for i:=1 to arity do begin |
2519: | flag:=ord(descriptors[i+1]); |
2520: | missing:=args.count<i; |
2521: | |
2522: | case flag and vkMaskType of |
2523: | vkByVal or vkInteger, |
2524: | vkByVal or vkInteger or vkConst: |
2525: | if missing then |
2526: | PushInt(0) |
2527: | else |
2528: | PushInt(AsInt(args.inVal[i])); |
2529: | |
2530: | vkByVal or vkString, |
2531: | vkByVal or vkString or vkConst: |
2532: | begin |
2533: | if missing then |
2534: | args.inVal[i].sbuf:='' |
2535: | else |
2536: | AsStr(args.inVal[i]); |
2537: | |
2538: | PushPtr(pointer(args.inVal[i].sbuf)) |
2539: | end; |
2540: | |
2541: | vkByVal or vkPChar, |
2542: | vkByVal or vkPChar or vkConst: |
2543: | begin |
2544: | if missing then |
2545: | args.inVal[i].sbuf:='' |
2546: | else |
2547: | AsStr(args.inVal[i]); |
2548: | |
2549: | if args.inVal[i].sbuf='' then |
2550: | PushInt(0) |
2551: | else with args.inVal[i] do begin |
2552: | sbuf:=sbuf+#0; |
2553: | PushPtr(@sbuf[1]) |
2554: | end |
2555: | end |
2556: | |
2557: | else snerr; |
2558: | |
2559: | // TODO: |
2560: | { vkByRef or vkInteger: |
2561: | ; |
2562: | |
2563: | vkByVal or vkString: |
2564: | ; |
2565: | |
2566: | vkByVal or vkString or vkConst: |
2567: | ; |
2568: | |
2569: | vkByRef or vkString: |
2570: | ; |
2571: | |
2572: | ;} |
2573: | |
2574: | |
2575: | end |
2576: | end; |
2577: | |
2578: | if Adr=nil then errormsg('external function missing'); |
2579: | |
2580: | { TODO: if isMethod and ltr then |
2581: | PushInt(integer(obj)); } |
2582: | if needsExtraParam and ltr then |
2583: | PushInt(integer(resadr)); |
2584: | |
2585: | if ltr then begin |
2586: | stkadr:=integer(@stack[sp])+sizeof(stack[0]); |
2587: | stkusage:=integer(@stack[High(stack)])+sizeof(stack[0])-integer(stkadr) |
2588: | end else begin |
2589: | stkadr:=integer(@stack); |
2590: | stkusage:=integer(@stack[sp])-integer(stkadr); |
2591: | end; |
2592: | |
2593: | asm |
2594: | push esi // esi, edi, ebp and ebx must be kept |
2595: | push edi // (we use only esi and edi here). |
2596: | sub esp, StkUsage // make room on stack |
2597: | mov edi, esp // set destination of mem copy, it is the stack |
2598: | mov esi, StkAdr // set source of mem copy, it is Addr(ExtStk) |
2599: | mov ecx, StkUsage // prepare ecx to copy StkUsage bytes |
2600: | shr ecx, 2 // divide by 4 to perform DWORD-copy (is faster) |
2601: | |
2602: | //add edi, StkUsage; |
2603: | //sub edi,4 |
2604: | //add esi, StkUsage; |
2605: | //sub esi,4 |
2606: | cld // choose copy direction |
2607: | rep movsd // do DWORD-copy |
2608: | |
2609: | cmp RegCall, true |
2610: | jnz @@EXEC |
2611: | mov EAX, _EAX |
2612: | mov EDX, _EDX |
2613: | mov ECX, _ECX |
2614: | |
2615: | @@EXEC: |
2616: | call Adr // execute the external function |
2617: | // esp is restored by the external function |
2618: | // (except for cdecl-convention) |
2619: | pop edi // restore edi... |
2620: | pop esi // ...and esi |
2621: | mov _EAX,eax |
2622: | end; // asm |
2623: | |
2624: | |
2625: | // TODO: convert references back |
2626: | |
2627: | if needsExtraParam then begin |
2628: | args.outVal.val.kind:=vString; |
2629: | args.outVal.val.str.value:=string(resvalue); |
2630: | string(resvalue):='' |
2631: | end else begin |
2632: | args.outVal.val.kind:=vNumber; |
2633: | args.outVal.val.num.value:=_EAX; |
2634: | end |
2635: | end else begin |
2636: | { this is a shell call } |
2637: | { TODO: use shell func and convert back the output } |
2638: | case ord(descriptors[1]) and vkMaskType of |
2639: | vkNone: |
2640: | CallShellSub(ShellCommand(fd.cmdFormat)); |
2641: | |
2642: | vkString,vkPChar: |
2643: | begin |
2644: | args.outVal.val.kind:=vString; |
2645: | args.outVal.val.str.value:=CallShellFunction(ShellCommand(fd.cmdFormat)) |
2646: | end; |
2647: | |
2648: | vkInteger: |
2649: | begin |
2650: | { TODO: } |
2651: | args.outVal.val.kind:=vNumber; |
2652: | args.outVal.val.num.value:=StrToIntDef(CallShellFunction(ShellCommand(fd.cmdFormat)),0) |
2653: | end; |
2654: | |
2655: | else snerr |
2656: | end |
2657: | end; |
2658: | |
2659: | n:=args.outVal.val |
2660: | end; |
2661: | |
2662: | procedure CallProcedure(fi:integer); |
2663: | var n:valrec; |
2664: | begin |
2665: | CallFunction(n,fi,false) |
2666: | end; |
2667: | |
2668: | procedure factor(var n:valrec); |
2669: | var |
2670: | v : valref; |
2671: | facttok : tokenptr; |
2672: | i, j : integer; |
2673: | tok, tok1 : tokenptr; |
2674: | s : string; |
2675: | |
2676: | procedure CallDefFn(var func:funcrec); |
2677: | var args:array [1..maxdims] of valrec; |
2678: | var i:integer; |
2679: | var tmp:valrec; |
2680: | var oldtok:tokenptr; |
2681: | begin |
2682: | { push local variables } |
2683: | for i:=1 to func.numdims do |
2684: | valref2valrec(func.dims[i],args[i]); |
2685: | try |
2686: | require(toklp); |
2687: | |
2688: | { bind arguments } |
2689: | for i:=1 to func.numdims do begin |
2690: | expr(tmp); |
2691: | valrec2valref(func.dims[i],tmp); |
2692: | if i<func.numdims then require(tokcomma) |
2693: | end; |
2694: | |
2695: | require(tokrp); |
2696: | |
2697: | oldtok:=t; |
2698: | try |
2699: | t:=func.tok; |
2700: | expr(n) |
2701: | finally |
2702: | t:=oldtok |
2703: | end |
2704: | finally |
2705: | { pop local variables } |
2706: | for i:=1 to func.numdims do |
2707: | valrec2valref(func.dims[i],args[i]) |
2708: | end |
2709: | end; |
2710: | |
2711: | begin |
2712: | if t = nil then snerr; |
2713: | facttok := t; |
2714: | t := t^.next; |
2715: | n.kind:=vNumber; |
2716: | case facttok^.kind of |
2717: | toknum : |
2718: | n.num.value:=facttok^.num; |
2719: | |
2720: | tokstr : |
2721: | begin |
2722: | n.kind:=vString; |
2723: | n.str.value:=facttok^.sptr2; |
2724: | end; |
2725: | |
2726: | tokfunc: |
2727: | begin |
2728: | CallFunction(n,facttok^.fi,true) |
2729: | end; |
2730: | |
2731: | tokvar : |
2732: | begin |
2733: | if facttok^.vp^.func<>nil then begin |
2734: | { DEF FN invocation } |
2735: | CallDefFn(facttok^.vp^.func^) |
2736: | end else begin |
2737: | t := facttok; |
2738: | |
2739: | getvar(v); |
2740: | case v.kind of |
2741: | vNumber: |
2742: | begin |
2743: | n.kind:=vNumber; |
2744: | n.num.value:=_valref2float(v) |
2745: | end; |
2746: | |
2747: | vString: |
2748: | begin |
2749: | n.kind:=vString; |
2750: | n.str.value:=_valref2string(v) |
2751: | end; |
2752: | else assert(false) |
2753: | end |
2754: | end |
2755: | end; |
2756: | |
2757: | toklp : |
2758: | begin |
2759: | expr(n); |
2760: | require(tokrp); |
2761: | end; |
2762: | |
2763: | tokminus : |
2764: | n.num.value:=-realfactor; |
2765: | |
2766: | tokplus : |
2767: | n.num.value:=realfactor; |
2768: | |
2769: | toknot : |
2770: | n.num.value:=inot(intfactor); |
2771: | |
2772: | toksqr : |
2773: | n.num.value:=sqr(realfactor); |
2774: | |
2775: | toksqrt : |
2776: | n.num.value:=sqrt(realfactor); |
2777: | |
2778: | toksin : |
2779: | n.num.value:=sin(realfactor); |
2780: | |
2781: | tokcos : |
2782: | n.num.value:=cos(realfactor); |
2783: | |
2784: | toktan : |
2785: | begin |
2786: | n.num.value:=realfactor; |
2787: | n.num.value:=sin(n.num.value)/cos(n.num.value); |
2788: | end; |
2789: | |
2790: | tokarctan : |
2791: | n.num.value:=arctan(realfactor); |
2792: | |
2793: | toklog: |
2794: | n.num.value:=ln(realfactor); |
2795: | |
2796: | tokexp : |
2797: | n.num.value:=exp(realfactor); |
2798: | |
2799: | tokabs : |
2800: | n.num.value:=abs(realfactor); |
2801: | |
2802: | toksgn : |
2803: | begin |
2804: | n.num.value:=realfactor; |
2805: | n.num.value:=ord(n.num.value>0)-ord(n.num.value<0); |
2806: | end; |
2807: | |
2808: | tokstr_ : |
2809: | begin |
2810: | n.kind:=vString; |
2811: | n.str.value:=numtostr(realfactor,true); |
2812: | end; |
2813: | |
2814: | tokval : |
2815: | begin |
2816: | s := strfactor; |
2817: | tok1 := t; |
2818: | parse(s, t); |
2819: | tok := t; |
2820: | if tok = nil then |
2821: | n.num.value:=0 |
2822: | else |
2823: | expr(n); |
2824: | disposetokens(tok); |
2825: | t := tok1; |
2826: | end; |
2827: | |
2828: | tokchr_ : |
2829: | begin |
2830: | n.kind:=vString; |
2831: | n.str.value:=chr(intfactor); |
2832: | end; |
2833: | |
2834: | tokasc : |
2835: | begin |
2836: | s := strfactor; |
2837: | if s='' then |
2838: | n.num.value:=0 |
2839: | else |
2840: | n.num.value:=ord(s[1]); |
2841: | end; |
2842: | |
2843: | tokmid_ : |
2844: | begin |
2845: | require(toklp); |
2846: | n.kind:=vString; |
2847: | n.str.value:=strexpr; |
2848: | require(tokcomma); |
2849: | i := intexpr; |
2850: | if i < 1 then i := 1; |
2851: | j := maxint; |
2852: | if (t <> nil) and (t^.kind = tokcomma) then |
2853: | begin |
2854: | t := t^.next; |
2855: | j := intexpr; |
2856: | end; |
2857: | if j > length(n.str.value)-i+1 then |
2858: | j := length(n.str.value)-i+1; |
2859: | if i > length(n.str.value) then |
2860: | n.str.value:='' |
2861: | else |
2862: | n.str.value:=Copy(n.str.value, i, j); |
2863: | require(tokrp); |
2864: | end; |
2865: | |
2866: | tokleft: |
2867: | begin |
2868: | require(toklp); |
2869: | n.kind:=vString; |
2870: | n.str.value:=strexpr; |
2871: | require(tokcomma); |
2872: | i := intexpr; |
2873: | if i < 1 then i := 0; |
2874: | n.str.value:=Copy(n.str.value, 1, i); |
2875: | require(tokrp); |
2876: | end; |
2877: | |
2878: | toklen : |
2879: | begin |
2880: | s := strfactor; |
2881: | n.num.value:=length(s); |
2882: | end; |
2883: | |
2884: | tokint : |
2885: | begin |
2886: | n.num.value:=trunc(realfactor); |
2887: | end; |
2888: | |
2889: | tokrnd: |
2890: | begin |
2891: | skipoptionalparenexpr; |
2892: | n.num.value:=random(1000)/1000 { TUNE: TODO: } |
2893: | end |
2894: | else |
2895: | snerr; |
2896: | end; |
2897: | end; |
2898: | |
2899: | procedure upexpr(var n:valrec); |
2900: | var n2 : valrec; |
2901: | begin |
2902: | factor(n); |
2903: | while (t <> nil) and (t^.kind = tokup) do |
2904: | begin |
2905: | if n.kind<>vNumber then tmerr; |
2906: | t := t^.next; |
2907: | upexpr(n2); |
2908: | if n2.kind<>vNumber then tmerr; |
2909: | if n.num.value<0 then |
2910: | begin |
2911: | if n2.num.value<>trunc(n2.num.value) then n.num.value:=ln(n.num.value); |
2912: | n.num.value:=exp(n2.num.value*ln(-n.num.value)); |
2913: | if odd(trunc(n2.num.value)) then |
2914: | n.num.value:=-n.num.value; |
2915: | end |
2916: | else if n.num.value<>0 then |
2917: | n.num.value:=exp(n2.num.value*ln(n.num.value)); |
2918: | end; |
2919: | end; |
2920: | |
2921: | procedure term(var n:valrec); |
2922: | var |
2923: | n2 : valrec; |
2924: | k : tokenkinds; |
2925: | begin |
2926: | upexpr(n); |
2927: | while (t <> nil) and (t^.kind in [toktimes, tokdiv, tokmod]) do |
2928: | begin |
2929: | k := t^.kind; |
2930: | t := t^.next; |
2931: | upexpr(n2); |
2932: | if (n.kind<>vNumber) or (n2.kind<>vNumber) then tmerr; |
2933: | if k = tokmod then |
2934: | n.num.value:=round(n.num.value) mod round(n2.num.value) |
2935: | else if k = toktimes then |
2936: | n.num.value:=n.num.value*n2.num.value |
2937: | else |
2938: | n.num.value:=n.num.value/n2.num.value; |
2939: | end; |
2940: | end; |
2941: | |
2942: | procedure sexpr(var n:valrec); |
2943: | var |
2944: | n2 : valrec; |
2945: | k : tokenkinds; |
2946: | begin |
2947: | term(n); |
2948: | while (t <> nil) and (t^.kind in [tokplus, tokminus]) do |
2949: | begin |
2950: | k := t^.kind; |
2951: | t := t^.next; |
2952: | term(n2); |
2953: | if n.kind<>n2.kind then tmerr; |
2954: | if k = tokplus then begin |
2955: | case n.kind of |
2956: | vNumber: |
2957: | n.num.value:=n.num.value+n2.num.value; |
2958: | |
2959: | vString: |
2960: | n.str.value:=n.str.value+n2.str.value; |
2961: | |
2962: | else assert(false) |
2963: | end |
2964: | end else |
2965: | case n.kind of |
2966: | vNumber: |
2967: | n.num.value:=n.num.value-n2.num.value; |
2968: | |
2969: | vString: |
2970: | tmerr; |
2971: | |
2972: | else assert(false) |
2973: | end |
2974: | end; |
2975: | end; |
2976: | |
2977: | procedure relexpr(var n:valrec); |
2978: | var |
2979: | n2 : valrec; |
2980: | f : boolean; |
2981: | k : tokenkinds; |
2982: | begin |
2983: | sexpr(n); |
2984: | while (t <> nil) and (t^.kind in [tokeq..tokne]) do |
2985: | begin |
2986: | k := t^.kind; |
2987: | t := t^.next; |
2988: | sexpr(n2); |
2989: | if n.kind<>n2.kind then tmerr; |
2990: | |
2991: | case n.kind of |
2992: | vString: |
2993: | begin |
2994: | f := ((n.str.value=n2.str.value) and (k in [tokeq, tokge, tokle]) or |
2995: | (n.str.value<n2.str.value) and (k in [toklt, tokle, tokne]) or |
2996: | (n.str.value>n2.str.value) and (k in [tokgt, tokge, tokne])); |
2997: | end; |
2998: | |
2999: | vNumber: |
3000: | begin |
3001: | f := ((n.num.value=n2.num.value) and (k in [tokeq, tokge, tokle]) or |
3002: | (n.num.value<n2.num.value) and (k in [toklt, tokle, tokne]) or |
3003: | (n.num.value>n2.num.value) and (k in [tokgt, tokge, tokne])); |
3004: | end; |
3005: | |
3006: | else assert(false) |
3007: | end; |
3008: | |
3009: | n.kind:=vNumber; |
3010: | n.num.value:=ord(f); |
3011: | end; |
3012: | end; |
3013: | |
3014: | procedure andexpr(var n:valrec); |
3015: | var |
3016: | n2 : valrec; |
3017: | begin |
3018: | relexpr(n); |
3019: | while (t <> nil) and (t^.kind = tokand) do |
3020: | begin |
3021: | t := t^.next; |
3022: | relexpr(n2); |
3023: | if (n.kind<>vNumber) or (n2.kind<>vNumber) then tmerr; |
3024: | n.num.value:=trunc(n.num.value) and trunc(n2.num.value); |
3025: | end; |
3026: | end; |
3027: | |
3028: | procedure expr(var n:valrec); |
3029: | var |
3030: | n2 : valrec; |
3031: | k : tokenkinds; |
3032: | begin |
3033: | andexpr(n); |
3034: | while (t <> nil) and (t^.kind in [tokor, tokxor]) do |
3035: | begin |
3036: | k := t^.kind; |
3037: | t := t^.next; |
3038: | andexpr(n2); |
3039: | if (n.kind<>vNumber) or (n2.kind<>vNumber) then tmerr; |
3040: | if k = tokor then |
3041: | n.num.value:=trunc(n.num.value) or trunc(n2.num.value) |
3042: | else |
3043: | n.num.value:=trunc(n.num.value) xor trunc(n2.num.value); |
3044: | end; |
3045: | end; |
3046: | |
3047: | |
3048: | procedure checkextra; |
3049: | begin |
3050: | if t <> nil then |
3051: | errormsg('Extra information on line'); |
3052: | end; |
3053: | |
3054: | |
3055: | function iseos : boolean; |
3056: | begin |
3057: | iseos := (t = nil) or (t^.kind in [tokcolon, tokelse]); |
3058: | end; |
3059: | |
3060: | |
3061: | procedure skiptoeos; |
3062: | begin |
3063: | while not iseos do |
3064: | t := t^.next; |
3065: | end; |
3066: | |
3067: | |
3068: | function findline(n : integer) : lineptr; |
3069: | var |
3070: | l : lineptr; |
3071: | begin |
3072: | l := linebase; |
3073: | while (l <> nil) and (l^.num <> n) do |
3074: | l := l^.next; |
3075: | findline := l; |
3076: | end; |
3077: | |
3078: | |
3079: | function mustfindline(n : integer) : lineptr; |
3080: | var |
3081: | l : lineptr; |
3082: | begin |
3083: | l := findline(n); |
3084: | if l = nil then |
3085: | errormsg('Undefined line'); |
3086: | mustfindline := l; |
3087: | end; |
3088: | |
3089: | |
3090: | procedure cmdlist; |
3091: | var |
3092: | l : lineptr; |
3093: | n1, n2 : integer; |
3094: | begin |
3095: | repeat |
3096: | n1 := 0; |
3097: | n2 := maxint; |
3098: | if (t <> nil) and (t^.kind = toknum) then |
3099: | begin |
3100: | n1 := trunc(t^.num); |
3101: | t := t^.next; |
3102: | if (t = nil) or (t^.kind <> tokminus) then |
3103: | n2 := n1; |
3104: | end; |
3105: | if (t <> nil) and (t^.kind = tokminus) then |
3106: | begin |
3107: | t := t^.next; |
3108: | if (t <> nil) and (t^.kind = toknum) then |
3109: | begin |
3110: | n2 := trunc(t^.num); |
3111: | t := t^.next; |
3112: | end |
3113: | else |
3114: | n2 := maxint; |
3115: | end; |
3116: | l := linebase; |
3117: | while (l <> nil) and (l^.num <= n2) do |
3118: | begin |
3119: | if (l^.num >= n1) then |
3120: | begin |
3121: | write(output^,l^.num:1, ' '); |
3122: | listtokens(output^, l^.txt); |
3123: | writeln(output^); |
3124: | end; |
3125: | l := l^.next; |
3126: | end; |
3127: | if not iseos then |
3128: | require(tokcomma); |
3129: | until iseos; |
3130: | end; |
3131: | |
3132: | |
3133: | procedure cmdrun; |
3134: | var |
3135: | l : lineptr; |
3136: | i : integer; |
3137: | s : string; |
3138: | begin |
3139: | l := linebase; |
3140: | if not iseos then |
3141: | begin |
3142: | if t^.kind = toknum then |
3143: | l := mustfindline(intexpr) |
3144: | else |
3145: | begin |
3146: | s := strexpr; |
3147: | i := 0; |
3148: | if not iseos then |
3149: | begin |
3150: | require(tokcomma); |
3151: | i := intexpr; |
3152: | end; |
3153: | checkextra; |
3154: | cmdload(false, s); |
3155: | if i = 0 then |
3156: | l := linebase |
3157: | else |
3158: | l := mustfindline(i) |
3159: | end |
3160: | end; |
3161: | stmtline := l; |
3162: | gotoflag := true; |
3163: | clearvars; |
3164: | clearloops; |
3165: | restoredata; |
3166: | end; |
3167: | |
3168: | |
3169: | procedure cmdbye; |
3170: | begin |
3171: | exitflag := true; |
3172: | end; |
3173: | |
3174: | |
3175: | procedure cmddel; |
3176: | var |
3177: | l, l0, l1 : lineptr; |
3178: | n1, n2 : integer; |
3179: | begin |
3180: | repeat |
3181: | if iseos then snerr; |
3182: | n1 := 0; |
3183: | n2 := maxint; |
3184: | if (t <> nil) and (t^.kind = toknum) then |
3185: | begin |
3186: | n1 := trunc(t^.num); |
3187: | t := t^.next; |
3188: | if (t = nil) or (t^.kind <> tokminus) then |
3189: | n2 := n1; |
3190: | end; |
3191: | if (t <> nil) and (t^.kind = tokminus) then |
3192: | begin |
3193: | t := t^.next; |
3194: | if (t <> nil) and (t^.kind = toknum) then |
3195: | begin |
3196: | n2 := trunc(t^.num); |
3197: | t := t^.next; |
3198: | end |
3199: | else |
3200: | n2 := maxint; |
3201: | end; |
3202: | l := linebase; |
3203: | l0 := nil; |
3204: | while (l <> nil) and (l^.num <= n2) do |
3205: | begin |
3206: | l1 := l^.next; |
3207: | if (l^.num >= n1) then |
3208: | begin |
3209: | if l = stmtline then |
3210: | begin |
3211: | cmdend; |
3212: | clearloops; |
3213: | restoredata; |
3214: | end; |
3215: | if l0 = nil then |
3216: | linebase := l^.next |
3217: | else |
3218: | l0^.next := l^.next; |
3219: | disposetokens(l^.txt); |
3220: | dispose(l); |
3221: | end |
3222: | else |
3223: | l0 := l; |
3224: | l := l1; |
3225: | end; |
3226: | if not iseos then |
3227: | require(tokcomma); |
3228: | until iseos; |
3229: | end; |
3230: | |
3231: | |
3232: | procedure cmdrenum; |
3233: | var |
3234: | l, l1 : lineptr; |
3235: | tok : tokenptr; |
3236: | lnum, step : integer; |
3237: | begin |
3238: | lnum := 10; |
3239: | step := 10; |
3240: | if not iseos then |
3241: | begin |
3242: | lnum := intexpr; |
3243: | if not iseos then |
3244: | begin |
3245: | require(tokcomma); |
3246: | step := intexpr; |
3247: | end; |
3248: | end; |
3249: | l := linebase; |
3250: | if l <> nil then |
3251: | begin |
3252: | while l <> nil do |
3253: | begin |
3254: | l^.num2 := lnum; |
3255: | lnum := lnum + step; |
3256: | l := l^.next; |
3257: | end; |
3258: | l := linebase; |
3259: | repeat |
3260: | tok := l^.txt; |
3261: | repeat |
3262: | if tok^.kind in [tokgoto, tokgosub, tokthen, tokelse, |
3263: | tokrun, toklist, tokrestore, tokdel] then |
3264: | while (tok^.next <> nil) and (tok^.next^.kind = toknum) do |
3265: | begin |
3266: | tok := tok^.next; |
3267: | lnum := round(tok^.num); |
3268: | l1 := linebase; |
3269: | while (l1 <> nil) and (l1^.num <> lnum) do |
3270: | l1 := l1^.next; |
3271: | if l1 = nil then |
3272: | writeln(output^,'Undefined line ', lnum:1, ' in line ', l^.num2:1) |
3273: | else |
3274: | tok^.num := l1^.num2; |
3275: | if (tok^.next <> nil) and (tok^.next^.kind = tokcomma) then |
3276: | tok := tok^.next; |
3277: | end; |
3278: | tok := tok^.next; |
3279: | until tok = nil; |
3280: | l := l^.next; |
3281: | until l = nil; |
3282: | l := linebase; |
3283: | while l <> nil do |
3284: | begin |
3285: | l^.num := l^.num2; |
3286: | l := l^.next; |
3287: | end; |
3288: | end; |
3289: | end; |
3290: | |
3291: | |
3292: | procedure cmdprint; |
3293: | var |
3294: | semiflag : boolean; |
3295: | n : valrec; |
3296: | begin |
3297: | semiflag := false; |
3298: | while not iseos do |
3299: | begin |
3300: | semiflag := false; |
3301: | if t^.kind in [toksemi, tokcomma] then |
3302: | begin |
3303: | semiflag := true; |
3304: | t := t^.next; |
3305: | end |
3306: | else if keyword('TAB') then begin |
3307: | n.kind:=vNumber; |
3308: | n.num.value:=intfactor; |
3309: | { TODO: tabulate to position } |
3310: | write(output^,' ') |
3311: | end else |
3312: | begin |
3313: | expr(n); |
3314: | case n.kind of |
3315: | vString: |
3316: | write(output^,n.str.value); |
3317: | |
3318: | vNumber: |
3319: | write(output^,numtostr(n.num.value,true),' '); |
3320: | |
3321: | else assert(false) |
3322: | end |
3323: | end; |
3324: | end; |
3325: | if not semiflag then |
3326: | writeln(output^); |
3327: | end; |
3328: | |
3329: | |
3330: | procedure cmdinput; |
3331: | var |
3332: | v : valref; |
3333: | s : string; |
3334: | tok, tok0, tok1 : tokenptr; |
3335: | strflag : vartype; |
3336: | begin |
3337: | if (t <> nil) and (t^.kind = tokstr) then |
3338: | begin |
3339: | write(output^,t^.sptr2); |
3340: | t := t^.next; |
3341: | if (t<>nil) and (t^.kind=tokcomma) then begin |
3342: | t:=t^.next; |
3343: | write(output^,'? ') |
3344: | end else |
3345: | require(toksemi); |
3346: | end |
3347: | else |
3348: | begin |
3349: | write(output^,'? '); |
3350: | end; |
3351: | tok := t; |
3352: | if (t = nil) or (t^.kind <> tokvar) then snerr; |
3353: | strflag := t^.vp^.kind; |
3354: | repeat |
3355: | if (t <> nil) and (t^.kind = tokvar) then |
3356: | if t^.vp^.kind <> strflag then snerr; |
3357: | t := t^.next; |
3358: | until iseos; |
3359: | t := tok; |
3360: | case strflag of |
3361: | vString: |
3362: | begin |
3363: | repeat |
3364: | readln(input^,s); |
3365: | getvar(v); |
3366: | _assignstring2valref(v,s); |
3367: | if not iseos then |
3368: | begin |
3369: | require(tokcomma); |
3370: | write(output^,'?? '); |
3371: | end; |
3372: | until iseos; |
3373: | end; |
3374: | |
3375: | vNumber: |
3376: | begin |
3377: | readln(input^,s); |
3378: | parse(s, tok); |
3379: | tok0 := tok; |
3380: | repeat |
3381: | getvar(v); |
3382: | while tok = nil do |
3383: | begin |
3384: | write(output^,'?? '); |
3385: | readln(input^,s); |
3386: | disposetokens(tok0); |
3387: | parse(s, tok); |
3388: | tok0 := tok; |
3389: | end; |
3390: | tok1 := t; |
3391: | t := tok; |
3392: | _assignfloat2valref(v,realexpr); |
3393: | if t <> nil then |
3394: | if t^.kind = tokcomma then |
3395: | t := t^.next |
3396: | else |
3397: | snerr; |
3398: | tok := t; |
3399: | t := tok1; |
3400: | if not iseos then |
3401: | require(tokcomma); |
3402: | until iseos; |
3403: | disposetokens(tok0); |
3404: | end; |
3405: | |
3406: | else assert(false) |
3407: | end |
3408: | end; |
3409: | |
3410: | |
3411: | procedure cmdlet(implied : boolean); |
3412: | var |
3413: | v : valref; |
3414: | begin |
3415: | if implied then |
3416: | t := stmttok; |
3417: | getvar(v); |
3418: | require(tokeq); |
3419: | |
3420: | case v.kind of |
3421: | vNumber: _assignfloat2valref(v,realexpr); |
3422: | vString: _assignstring2valref(v,strexpr); |
3423: | else assert(false) |
3424: | end; |
3425: | end; |
3426: | |
3427: | |
3428: | procedure cmdgoto; |
3429: | begin |
3430: | stmtline := mustfindline(intexpr); |
3431: | t := nil; |
3432: | gotoflag := true; |
3433: | end; |
3434: | |
3435: | |
3436: | procedure cmdif; |
3437: | var |
3438: | n : float; |
3439: | i : integer; |
3440: | begin |
3441: | n := realexpr; |
3442: | require(tokthen); |
3443: | if n = 0 then |
3444: | begin |
3445: | i := 0; |
3446: | repeat |
3447: | if t <> nil then |
3448: | begin |
3449: | if t^.kind = tokif then |
3450: | i := i + 1; |
3451: | if t^.kind = tokelse then |
3452: | i := i - 1; |
3453: | t := t^.next; |
3454: | end; |
3455: | until (t = nil) or (i < 0); |
3456: | end; |
3457: | if (t <> nil) and (t^.kind = toknum) then |
3458: | cmdgoto |
3459: | else |
3460: | elseflag := true; |
3461: | end; |
3462: | |
3463: | |
3464: | procedure cmdelse; |
3465: | begin |
3466: | t := nil; |
3467: | end; |
3468: | |
3469: | |
3470: | function skiploop(up, dn : tokenkinds) : boolean; |
3471: | label 1; |
3472: | var |
3473: | i : integer; |
3474: | saveline : lineptr; |
3475: | begin |
3476: | saveline := stmtline; |
3477: | i := 0; |
3478: | repeat |
3479: | while t = nil do |
3480: | begin |
3481: | if (stmtline = nil) or (stmtline^.next = nil) then |
3482: | begin |
3483: | skiploop := false; |
3484: | stmtline := saveline; |
3485: | goto 1; |
3486: | end; |
3487: | stmtline := stmtline^.next; |
3488: | t := stmtline^.txt; |
3489: | end; |
3490: | if t^.kind = up then |
3491: | i := i + 1; |
3492: | if t^.kind = dn then |
3493: | i := i - 1; |
3494: | t := t^.next; |
3495: | until i < 0; |
3496: | skiploop := true; |
3497: | 1 : |
3498: | end; |
3499: | |
3500: | |
3501: | procedure cmdfor; |
3502: | var |
3503: | l : loopptr; |
3504: | lr : looprec; |
3505: | saveline : lineptr; |
3506: | i, j : integer; |
3507: | begin |
3508: | getvar(lr.ref); |
3509: | if lr.ref.kind<>vNumber then snerr; |
3510: | require(tokeq); |
3511: | _assignfloat2valref(lr.ref,realexpr); |
3512: | require(tokto); |
3513: | lr.max := realexpr; |
3514: | if (t <> nil) and (t^.kind = tokstep) then |
3515: | begin |
3516: | t := t^.next; |
3517: | lr.step := realexpr; |
3518: | end |
3519: | else |
3520: | lr.step := 1; |
3521: | lr.homeline := stmtline; |
3522: | lr.hometok := t; |
3523: | lr.kind := forloop; |
3524: | lr.next := loopbase; |
3525: | with lr do |
3526: | if ((step >= 0) and (_valref2float(ref) > max)) or ((step <= 0) and (_valref2float(ref) < max)) then |
3527: | begin |
3528: | saveline := stmtline; |
3529: | i := 0; |
3530: | j := 0; |
3531: | repeat |
3532: | while t = nil do |
3533: | begin |
3534: | if (stmtline = nil) or (stmtline^.next = nil) then |
3535: | begin |
3536: | stmtline := saveline; |
3537: | errormsg('FOR without NEXT'); |
3538: | end; |
3539: | stmtline := stmtline^.next; |
3540: | t := stmtline^.txt; |
3541: | end; |
3542: | if t^.kind = tokfor then |
3543: | if (t^.next <> nil) and (t^.next^.kind = tokvar) and valrefMaps(ref,t^.next^.vp^) then |
3544: | j := j + 1 |
3545: | else |
3546: | i := i + 1; |
3547: | if (t^.kind = toknext) then |
3548: | if (t^.next <> nil) and (t^.next^.kind = tokvar) and valrefMaps(ref,t^.next^.vp^) then |
3549: | j := j - 1 |
3550: | else |
3551: | i := i - 1; |
3552: | t := t^.next; |
3553: | until (i < 0) or (j < 0); |
3554: | skiptoeos; |
3555: | end |
3556: | else |
3557: | begin |
3558: | new(l); |
3559: | FillChar(l^,sizeof(l^),0); |
3560: | l^ := lr; |
3561: | loopbase := l; |
3562: | end; |
3563: | end; |
3564: | |
3565: | |
3566: | procedure cmdnext; |
3567: | var |
3568: | v : varptr; |
3569: | found : boolean; |
3570: | l : loopptr; |
3571: | begin |
3572: | if not iseos then |
3573: | v := findvar |
3574: | else |
3575: | v := nil; |
3576: | repeat |
3577: | if (loopbase = nil) or (loopbase^.kind = gosubloop) then |
3578: | errormsg('NEXT without FOR'); |
3579: | found := (loopbase^.kind = forloop) and |
3580: | ((v = nil) or valrefMaps(loopbase^.ref,v^)); |
3581: | if not found then |
3582: | begin |
3583: | l := loopbase^.next; |
3584: | dispose(loopbase); |
3585: | loopbase := l; |
3586: | end; |
3587: | until found; |
3588: | with loopbase^ do |
3589: | begin |
3590: | _assignfloat2valref(ref,_valref2float(ref) + step); |
3591: | if ((step >= 0) and (_valref2float(ref) > max)) or ((step <= 0) and (_valref2float(ref) < max)) then |
3592: | begin |
3593: | l := loopbase^.next; |
3594: | dispose(loopbase); |
3595: | loopbase := l; |
3596: | end |
3597: | else |
3598: | begin |
3599: | stmtline := homeline; |
3600: | t := hometok; |
3601: | end; |
3602: | end; |
3603: | end; |
3604: | |
3605: | |
3606: | procedure cmdwhile; |
3607: | var |
3608: | l : loopptr; |
3609: | begin |
3610: | new(l); |
3611: | FillChar(l^,sizeof(l^),0); |
3612: | l^.next := loopbase; |
3613: | loopbase := l; |
3614: | l^.kind := whileloop; |
3615: | l^.homeline := stmtline; |
3616: | l^.hometok := t; |
3617: | if not iseos then |
3618: | if realexpr = 0 then |
3619: | begin |
3620: | if not skiploop(tokwhile, tokwend) then |
3621: | errormsg('WHILE without WEND'); |
3622: | l := loopbase^.next; |
3623: | dispose(loopbase); |
3624: | loopbase := l; |
3625: | skiptoeos; |
3626: | end; |
3627: | end; |
3628: | |
3629: | |
3630: | procedure cmdwend; |
3631: | var |
3632: | tok : tokenptr; |
3633: | tokline : lineptr; |
3634: | l : loopptr; |
3635: | found : boolean; |
3636: | begin |
3637: | repeat |
3638: | if (loopbase = nil) or (loopbase^.kind = gosubloop) then |
3639: | errormsg('WEND without WHILE'); |
3640: | found := (loopbase^.kind = whileloop); |
3641: | if not found then |
3642: | begin |
3643: | l := loopbase^.next; |
3644: | dispose(loopbase); |
3645: | loopbase := l; |
3646: | end; |
3647: | until found; |
3648: | if not iseos then |
3649: | if realexpr <> 0 then |
3650: | found := false; |
3651: | tok := t; |
3652: | tokline := stmtline; |
3653: | if found then |
3654: | begin |
3655: | stmtline := loopbase^.homeline; |
3656: | t := loopbase^.hometok; |
3657: | if not iseos then |
3658: | if realexpr = 0 then |
3659: | found := false; |
3660: | end; |
3661: | if not found then |
3662: | begin |
3663: | t := tok; |
3664: | stmtline := tokline; |
3665: | l := loopbase^.next; |
3666: | dispose(loopbase); |
3667: | loopbase := l; |
3668: | end; |
3669: | end; |
3670: | |
3671: | |
3672: | procedure cmdgosub; |
3673: | var |
3674: | l : loopptr; |
3675: | begin |
3676: | new(l); |
3677: | FillChar(l^,sizeof(l^),0); |
3678: | l^.next := loopbase; |
3679: | loopbase := l; |
3680: | l^.kind := gosubloop; |
3681: | l^.homeline := stmtline; |
3682: | l^.hometok := t; |
3683: | cmdgoto; |
3684: | end; |
3685: | |
3686: | |
3687: | procedure cmdreturn; |
3688: | var |
3689: | l : loopptr; |
3690: | found : boolean; |
3691: | begin |
3692: | repeat |
3693: | if loopbase = nil then |
3694: | errormsg('RETURN without GOSUB'); |
3695: | found := (loopbase^.kind = gosubloop); |
3696: | if not found then |
3697: | begin |
3698: | l := loopbase^.next; |
3699: | dispose(loopbase); |
3700: | loopbase := l; |
3701: | end; |
3702: | until found; |
3703: | stmtline := loopbase^.homeline; |
3704: | t := loopbase^.hometok; |
3705: | l := loopbase^.next; |
3706: | dispose(loopbase); |
3707: | loopbase := l; |
3708: | skiptoeos; |
3709: | end; |
3710: | |
3711: | |
3712: | procedure cmdread; |
3713: | var |
3714: | v : valref; |
3715: | tok : tokenptr; |
3716: | found : boolean; |
3717: | begin |
3718: | repeat |
3719: | getvar(v); |
3720: | tok := t; |
3721: | t := datatok; |
3722: | if dataline = nil then |
3723: | begin |
3724: | dataline := linebase; |
3725: | t := dataline^.txt; |
3726: | end; |
3727: | if (t = nil) or (t^.kind <> tokcomma) then |
3728: | repeat |
3729: | while t = nil do |
3730: | begin |
3731: | if (dataline = nil) or (dataline^.next = nil) then |
3732: | errormsg('Out of Data'); |
3733: | dataline := dataline^.next; |
3734: | t := dataline^.txt; |
3735: | end; |
3736: | found := (t^.kind = tokdata); |
3737: | t := t^.next; |
3738: | until found and not iseos |
3739: | else |
3740: | t := t^.next; |
3741: | |
3742: | case v.kind of |
3743: | vString: _assignstring2valref(v,strexpr); |
3744: | vNumber: _assignfloat2valref(v,realexpr); |
3745: | else assert(false) |
3746: | end; |
3747: | datatok := t; |
3748: | t := tok; |
3749: | if not iseos then |
3750: | require(tokcomma); |
3751: | until iseos; |
3752: | end; |
3753: | |
3754: | |
3755: | procedure cmddata; |
3756: | begin |
3757: | skiptoeos; |
3758: | end; |
3759: | |
3760: | |
3761: | procedure cmdrestore; |
3762: | begin |
3763: | if iseos then |
3764: | restoredata |
3765: | else |
3766: | begin |
3767: | dataline := mustfindline(intexpr); |
3768: | datatok := dataline^.txt; |
3769: | end; |
3770: | end; |
3771: | |
3772: | |
3773: | procedure cmdon; |
3774: | var |
3775: | i : integer; |
3776: | l : loopptr; |
3777: | begin |
3778: | i := intexpr; |
3779: | if (t <> nil) and (t^.kind = tokgosub) then |
3780: | begin |
3781: | new(l); |
3782: | FillChar(l^,sizeof(l^),0); |
3783: | l^.next := loopbase; |
3784: | loopbase := l; |
3785: | l^.kind := gosubloop; |
3786: | l^.homeline := stmtline; |
3787: | l^.hometok := t; |
3788: | t := t^.next; |
3789: | end |
3790: | else |
3791: | require(tokgoto); |
3792: | if i < 1 then |
3793: | skiptoeos |
3794: | else |
3795: | begin |
3796: | while (i > 1) and not iseos do |
3797: | begin |
3798: | require(toknum); |
3799: | if not iseos then |
3800: | require(tokcomma); |
3801: | i := i - 1; |
3802: | end; |
3803: | if not iseos then |
3804: | cmdgoto; |
3805: | end; |
3806: | end; |
3807: | |
3808: | |
3809: | procedure cmddim; |
3810: | var |
3811: | i, j, k : integer; |
3812: | v : varptr; |
3813: | done : boolean; |
3814: | begin |
3815: | repeat |
3816: | if (t = nil) or (t^.kind <> tokvar) then snerr; |
3817: | v := t^.vp; |
3818: | t := t^.next; |
3819: | with v^ do |
3820: | begin |
3821: | if numdims <> 0 then |
3822: | errormsg('Array already dimensioned'); |
3823: | j := 1; |
3824: | i := 0; |
3825: | require(toklp); |
3826: | repeat |
3827: | k := intexpr + 1; |
3828: | if k < 1 then badsubscr; |
3829: | if i >= maxdims then badsubscr; |
3830: | i := i + 1; |
3831: | dims[i] := k; |
3832: | j := j * k; |
3833: | done := (t <> nil) and (t^.kind = tokrp); |
3834: | if not done then |
3835: | require(tokcomma); |
3836: | until done; |
3837: | t := t^.next; |
3838: | numdims := i; |
3839: | |
3840: | case kind of |
3841: | vNumber: |
3842: | begin |
3843: | GetMem(num.base,j*sizeof(float)); |
3844: | FillChar(num.base^,j*sizeof(float),0) |
3845: | end; |
3846: | |
3847: | vString: |
3848: | begin |
3849: | GetMem(str.base,j*sizeof(basicstring)); |
3850: | FillChar(str.base^,j*sizeof(basicstring),0) |
3851: | end; |
3852: | |
3853: | else assert(false) |
3854: | end; |
3855: | end; |
3856: | if not iseos then |
3857: | require(tokcomma); |
3858: | until iseos; |
3859: | end; |
3860: | |
3861: | procedure cmddef; |
3862: | var func:funcrecptr; |
3863: | var tok:tokenptr; |
3864: | begin |
3865: | if (t=nil) or (t^.kind<>tokvar) then snerr; |
3866: | |
3867: | tok:=t; |
3868: | t:=t^.next; |
3869: | |
3870: | require(toklp); |
3871: | |
3872: | GetMem(func,sizeof(funcrec)); |
3873: | FillChar(func^,sizeof(funcrec),0); |
3874: | try |
3875: | if (t<>nil) and (t^.kind=tokrp) then |
3876: | t:=t^.next |
3877: | else begin |
3878: | while true do begin |
3879: | inc(func^.numdims); |
3880: | getvar(func^.dims[func^.numdims]); |
3881: | if (t<>nil) and (t^.kind=tokrp) then begin |
3882: | t:=t^.next; |
3883: | break |
3884: | end; |
3885: | require(tokcomma) |
3886: | end |
3887: | end; |
3888: | |
3889: | require(tokeq); |
3890: | |
3891: | func^.tok:=t; |
3892: | if tok^.vp^.func<>nil then |
3893: | FreeMem(tok^.vp^.func); |
3894: | tok^.vp^.func:=func |
3895: | except |
3896: | FreeMem(func); |
3897: | raise |
3898: | end; |
3899: | |
3900: | skiptoeos |
3901: | end; |
3902: | |
3903: | procedure cmdcommon; |
3904: | var v:varptr; |
3905: | var i:integer; |
3906: | begin |
3907: | repeat |
3908: | if (t = nil) or (t^.kind <> tokvar) then snerr; |
3909: | v := t^.vp; |
3910: | t := t^.next; |
3911: | |
3912: | i:=Commons.IndexOf(v^.name); |
3913: | if i<0 then |
3914: | Commons.Add(UpperCase(v^.name)); |
3915: | initvarfromenv(v); |
3916: | |
3917: | if not iseos then |
3918: | require(tokcomma); |
3919: | until iseos |
3920: | end; |
3921: | |
3922: | procedure cmddeclare; |
3923: | { Declare Sub name <Lib "libname" [Alias "aliasname"]|Shell "command"> [([arglist])] |
3924: | |
3925: | Declare Function name <Lib "libname" [Alias "aliasname"]|Shell "command"> [([arglist])] [As type] |
3926: | } |
3927: | var funcName:string; |
3928: | var libName:string; |
3929: | var aliasName:string; |
3930: | var isFunc:boolean; |
3931: | var descriptor:ArrayOfValueKind; |
3932: | |
3933: | var ref:integer; |
3934: | var kind:integer; |
3935: | |
3936: | function Ident:string; |
3937: | begin |
3938: | if (t<>nil) and (t^.kind=tokvar) then begin |
3939: | Result:=t^.vp^.name; |
3940: | t:=t^.next |
3941: | end else if (t<>nil) and (t^.kind=tokfunc) then begin |
3942: | Result:=FFuncs[FFuncs.IndexOfObject(TObject(t^.fi))]; |
3943: | t:=t^.next |
3944: | end else begin |
3945: | Result:=''; |
3946: | snerr |
3947: | end |
3948: | end; |
3949: | |
3950: | procedure FetchAs; |
3951: | begin |
3952: | requireKeyword('AS'); |
3953: | |
3954: | if keyword('STRING') then |
3955: | kind:=vkString |
3956: | else |
3957: | if keyword('LONG') or keyword('INTEGER') then |
3958: | kind:=vkInteger |
3959: | else |
3960: | snerr; |
3961: | end; |
3962: | |
3963: | var isShell:boolean; |
3964: | var cmdFormat:string; |
3965: | begin |
3966: | isFunc:=keyword('FUNCTION'); |
3967: | if not isFunc then requireKeyword('SUB'); |
3968: | |
3969: | funcName:=Ident; |
3970: | |
3971: | if keyword('SHELL') then begin |
3972: | isShell:=true; |
3973: | cmdFormat:=strexpr |
3974: | end else begin |
3975: | isShell:=false; |
3976: | requireKeyword('LIB'); |
3977: | |
3978: | libName:=strexpr; |
3979: | |
3980: | if keyword('ALIAS') then |
3981: | aliasName:=strexpr |
3982: | else |
3983: | aliasName:=funcName; |
3984: | end; |
3985: | |
3986: | descriptor:=''; |
3987: | |
3988: | if (t<>nil) and (t^.kind=toklp) then begin |
3989: | t:=t^.next; |
3990: | while (t<>nil) and (t^.kind<>tokrp) do begin |
3991: | if descriptor<>'' then require(tokcomma); |
3992: | |
3993: | { [BYREF|BYVAL] Ident AS String|Long } |
3994: | if keyword('BYVAL') then |
3995: | ref:=vkByVal |
3996: | else |
3997: | if keyword('BYREF') then |
3998: | ref:=vkByRef |
3999: | else |
4000: | ref:=vkByVal; // TODO: default parameter passing |
4001: | |
4002: | Ident; |
4003: | FetchAs; |
4004: | |
4005: | if (ref=vkByVal) and (kind=vkString) then |
4006: | kind:=vkPChar; |
4007: | |
4008: | descriptor:=descriptor+chr(kind or ref) |
4009: | end; |
4010: | if t<>nil then t:=t^.next |
4011: | end; |
4012: | |
4013: | if isFunc then |
4014: | FetchAs |
4015: | else |
4016: | kind:=vkNone; |
4017: | |
4018: | if not iseos then snerr; |
4019: | |
4020: | if isShell then |
4021: | MapShell(funcName,kind,descriptor,cmdFormat) |
4022: | else |
4023: | MapLib(funcName,kind or vkStdCall,descriptor,libName,aliasName) |
4024: | end; |
4025: | |
4026: | procedure finalerror; |
4027: | begin |
4028: | if stmtline <> nil then |
4029: | write(output^,' in ', stmtline^.num:1); |
4030: | writeln(output^); |
4031: | end; |
4032: | |
4033: | begin {exec} |
4034: | try |
4035: | repeat |
4036: | repeat |
4037: | gotoflag := false; |
4038: | elseflag := false; |
4039: | while (stmttok <> nil) and (stmttok^.kind = tokcolon) do |
4040: | stmttok := stmttok^.next; |
4041: | t := stmttok; |
4042: | if t <> nil then |
4043: | begin |
4044: | CheckBreak; |
4045: | t := t^.next; |
4046: | case stmttok^.kind of |
4047: | tokrem : ; |
4048: | tokfunc : CallProcedure(stmttok^.fi); |
4049: | toklist : cmdlist; |
4050: | tokrun : cmdrun; |
4051: | toknew : cmdnew; |
4052: | tokload : cmdload(false, strexpr); |
4053: | tokmerge : cmdload(true, strexpr); |
4054: | toksave : cmdsave(strexpr); |
4055: | tokbye : cmdbye; |
4056: | tokdel : cmddel; |
4057: | tokrenum : cmdrenum; |
4058: | tokdeclare : cmddeclare; |
4059: | toklet : cmdlet(false); |
4060: | tokvar : cmdlet(true); |
4061: | tokprint : cmdprint; |
4062: | tokinput : cmdinput; |
4063: | tokgoto : cmdgoto; |
4064: | tokif : cmdif; |
4065: | tokelse : cmdelse; |
4066: | tokend : cmdend; |
4067: | tokstop : escape(-20,'Break'); |
4068: | tokfor : cmdfor; |
4069: | toknext : cmdnext; |
4070: | tokwhile : cmdwhile; |
4071: | tokwend : cmdwend; |
4072: | tokgosub : cmdgosub; |
4073: | tokreturn : cmdreturn; |
4074: | tokread : cmdread; |
4075: | tokdata : cmddata; |
4076: | tokrestore : cmdrestore; |
4077: | tokon : cmdon; |
4078: | tokcommon : cmdcommon; |
4079: | tokdim : cmddim; |
4080: | tokdef : cmddef; |
4081: | else |
4082: | errormsg('Illegal command'); |
4083: | end; |
4084: | end; |
4085: | if not elseflag and not iseos then |
4086: | checkextra; |
4087: | stmttok := t; |
4088: | until t = nil; |
4089: | if stmtline <> nil then |
4090: | begin |
4091: | if not gotoflag then |
4092: | stmtline := stmtline^.next; |
4093: | if stmtline <> nil then |
4094: | stmttok := stmtline^.txt; |
4095: | end; |
4096: | until stmtline = nil; |
4097: | except |
4098: | on EAbort do raise; |
4099: | on e:EBasic do begin |
4100: | Write(output^,#7,'(',e.escapecode,') ',e.Message); |
4101: | { TODO: -20 - break, 42 = handled error } |
4102: | finalerror |
4103: | end; |
4104: | |
4105: | on e:Exception do begin |
4106: | write(output^,#7,e.Message); |
4107: | finalerror |
4108: | end; |
4109: | |
4110: | end |
4111: | end; {exec} |
4112: | //-------------------------------------------------------------------- |
4113: | const CRLF=#13#10; |
4114: | const prompt='READY'; //'Ok' |
4115: | |
4116: | procedure TBasic.Run; |
4117: | var noinput:boolean; |
4118: | var p:integer; |
4119: | var cmd:string; |
4120: | |
4121: | function Cut:string; |
4122: | label loop; |
4123: | begin |
4124: | loop: |
4125: | p:=Pos(CRLF,cmd); |
4126: | if p=0 then begin |
4127: | Result:=cmd; |
4128: | cmd:='' |
4129: | end else begin |
4130: | Result:=Copy(cmd,1,p-1); |
4131: | Delete(cmd,1,p+length(CRLF)-1) |
4132: | end; |
4133: | if Result='' then if cmd<>'' then goto loop |
4134: | end; |
4135: | |
4136: | begin {main} |
4137: | if output <> nil then |
4138: | with TTextRec(output^) do |
4139: | Flags := Flags or tfCRLF; |
4140: | |
4141: | cmd:=ACommand; |
4142: | inbuf:=Cut; |
4143: | noinput:=inbuf<>''; |
4144: | clearloops; |
4145: | clearvars; |
4146: | exitflag := false; |
4147: | repeat |
4148: | try |
4149: | repeat |
4150: | if inbuf='' then begin |
4151: | inbuf:=Cut; |
4152: | if inbuf='' then begin |
4153: | if noinput then begin |
4154: | exitflag:=true; |
4155: | break |
4156: | end; |
4157: | writeln(output^,prompt); |
4158: | if eof(input^) then begin |
4159: | exitflag:=true; |
4160: | break; |
4161: | end; |
4162: | readln(input^,inbuf); |
4163: | end |
4164: | end; |
4165: | parseinput(buf); |
4166: | if curline = 0 then |
4167: | begin |
4168: | stmtline := nil; |
4169: | stmttok := buf; |
4170: | if stmttok <> nil then |
4171: | exec; |
4172: | disposetokens(buf); |
4173: | end; |
4174: | inbuf:='' |
4175: | until exitflag; |
4176: | except |
4177: | on EAbort do raise; |
4178: | on e:Exception do begin |
4179: | { TODO: |
4180: | if escapecode <> -20 then |
4181: | misc_printerror(escapecode, ioresult) |
4182: | else } |
4183: | writeln(output^,#7,e.Message); |
4184: | end |
4185: | end; |
4186: | inbuf:='' |
4187: | until exitflag; |
4188: | end; |
4189: | |
4190: | procedure TBasic.Chat; |
4191: | begin {main} |
4192: | exitflag := false; |
4193: | repeat |
4194: | try |
4195: | repeat |
4196: | writeln(output^,prompt); |
4197: | if eof(input^) then break; |
4198: | readln(input^,inbuf); |
4199: | parseinput(buf); |
4200: | if curline = 0 then |
4201: | begin |
4202: | stmtline := nil; |
4203: | stmttok := buf; |
4204: | if stmttok <> nil then |
4205: | exec; |
4206: | disposetokens(buf); |
4207: | end; |
4208: | until exitflag; |
4209: | except |
4210: | on EAbort do raise; |
4211: | on e:Exception do begin |
4212: | { TODO: |
4213: | if escapecode <> -20 then |
4214: | misc_printerror(escapecode, ioresult) |
4215: | else } |
4216: | writeln(output^,#7,e.Message); |
4217: | end |
4218: | end; |
4219: | until exitflag; |
4220: | end; |
4221: | |
4222: | function TBasic.ExpandFileName; |
4223: | begin |
4224: | if Assigned(FOnGetFileName) then |
4225: | Result:=FOnGetFileName(Self,fileName,new) |
4226: | else |
4227: | if ExtractFileExt(fileName)='' then |
4228: | Result:=fileName+'.BAS' |
4229: | else |
4230: | Result:=fileName |
4231: | end; |
4232: | |
4233: | procedure TBasic.LoadFromFile; |
4234: | begin |
4235: | cmdload(false,fileName) |
4236: | end; |
4237: | |
4238: | procedure TBasic.SaveToFile; |
4239: | begin |
4240: | cmdsave(fileName) |
4241: | end; |
4242: | |
4243: | end. |