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.

Máte otázky, připomínky?