base_sys.pas

来自「Delphi脚本控件」· PAS 代码 · 共 3,083 行 · 第 1/5 页

////////////////////////////////////////////////////////////////////////////
// PAXScript Interpreter
// Author: Alexander Baranovsky ([e-mail])
// ========================================================================
// Copyright (c) Alexander Baranovsky, 2003-2005. All rights reserved.
// Code Version: 3.0
// ========================================================================
// Unit: BASE_SYS.pas
// ========================================================================
////////////////////////////////////////////////////////////////////////////

{$I PaxScript.def}
unit BASE_SYS;

interface

uses
{$IFDEF VARIANTS}
  Variants,
{$ENDIF}
{$IFDEF WIN32}
  Windows,

{$ifndef FP}
  syncobjs,
{$ENDIF}

{$ENDIF}
{$IFDEF LINUX}
{$IFDEF CONSOLE}
  SyncObjs,
{$ELSE}
  QForms,
  SyncObjs,
{$ENDIF}
{$ENDIF}

  TypInfo,
  SysUtils,
  Classes,
  BASE_CONSTS,
  BASE_SYNC;
const
{$IFDEF TRIAL}
  _IsTrial = true;
{$ELSE}
  _IsTrial = false;
{$ENDIF}

{$IFDEF DUMP}
  _IsDump: Boolean = true;
{$ELSE}
  _IsDump: Boolean = false;
{$ENDIF}

  RootNamespaceName = 'NonameNamespace';

  SignLoadOnDemand = true;

  PathDelim  = {$IFDEF WIN32} '\'; {$endif}{$IFDEF LINUX} '/';{$ENDIF}
  DriveDelim = {$IFDEF WIN32} ':'; {$endif}{$IFDEF LINUX} '';{$ENDIF}
  PathSep    = {$IFDEF WIN32} ';'; {$endif}{$IFDEF LINUX} ':';{$ENDIF}

  _rmRun = 0;
  _rmStepOver = 1;
  _rmTraceInto = 2;
  _rmRunToCursor = 3;
  _rmTraceToNextSourceLine = 4;

  _ccRegister = 0;
  _ccPascal = 1;
  _ccCDecl = 2;
  _ccStdCall = 3;
  _ccSafeCall = 4;

  _CompiledModuleVersion = 2;

  MaxParams = 20; // max number of parameters of imported routine
  MaxHash = 97;

  _ssInit = 0; // component was created, no modules and code
  _ssReadyToCompile = 1; // modules and code were added
  _ssCompiling = 2; // compiles script
  _ssCompiled = 3; // all modules were compiled
  _ssLinking = 4;  // links modules in a script
  _ssReadyToRun = 5; // script was linked and it is ready to run now
  _ssRunning = 6; // runs script
  _ssPaused = 7; // script was paused
  _ssTerminated = 8; // script was terminated

{$IFDEF LINUX}
  varScriptObject = varError;
  varAlias        = $15;
{$ELSE}
  varScriptObject = $0E;
  varAlias        = $15;
{$ENDIF}
  varUndefined = varEmpty;

  FirstSymbolCard = 46;
  DeltaSymbolCard = 64;

  DefaultStackSize = 16000;
  FirstMemSize =  3200;
  DeltaMemSize = 32000;

  FirstProgCard = 64;
  DeltaProgCard = 256;

  FirstStackSize = 128;
  DeltaStackSize = 1024;

//  BOUND_OPER  = -100;
  BOUND_OPER  = 0;
  BOUND_LINES = -30000;
  BOUND_FILES = -50000;

  SP_ROUND_BRACKET_L = -901;
  SP_ROUND_BRACKET_R = -902;

  SP_BRACKET_L = -903;
  SP_BRACKET_R = -904;

  SP_BRACE_L = -905;
  SP_BRACE_R = -906;

  SP_SEMICOLON = -907;
  SP_POINT     = -908;
  SP_COLON     = -909;
  SP_COMMA     = -910;
  SP_EOF       = -911;
  SP_BACKSLASH = -912;

  MAX_VALUE:double=1.7E307;
  MIN_VALUE:double=4.0E-324;
  NEGATIVE_INFINITY:double=-1.7E308;
  POSITIVE_INFINITY:double=1.7E308;
  NaN:double=1.71E308;
  INFINITY:double=1.7E308;

  BR = #13#10;

  typeVOID = 0;
  typeVARIANT = 1;
  typeOLEVARIANT = 2;
  typeBYTE = 3;
  typeCHAR = 4;
  typeBOOLEAN = 5;
  typeWORDBOOL = 6;
  typeLONGBOOL = 7;
  typeINTEGER = 8;
  typeCARDINAL = 9;
  typePOINTER = 10;
  typeDOUBLE = 11;
  typeSTRING = 12;
  typeENUM = 13;
  typeRECORD = 14;
  typeARRAY = 15;
  typeSHORTSTRING = 16;
  typeTEXT = 17;
  typeSUBRANGE = 18;
  typeSET = 19;
  typeCLASS = 20;
  typeCLASSREF = 21;
  typeDYNAMICARRAY = 22;
  typePCHAR = 23;
  typeWORD = 24;
  typeSHORTINT = 25;
  typeSMALLINT = 26;
  typeINT64 = 27;
  typeSINGLE = 28;
  typeCURRENCY = 29;
  typeCOMP = 30;
  typeREAL48 = 31;
  typeEXTENDED = 32;
  typeINTERFACE = 33;
  typeMETHOD = 34;
  typeFILE = 35;
  typeWIDECHAR = 36;
  typeWIDESTRING = 37;
  typePWIDECHAR = 38;
  typeTVarRec = 39;

  IntegerPaxTypes: TIntegerSet = [typeINTEGER,
                                  typeINT64, typeCARDINAL,
                                  typeBYTE, typeWORD, typeSMALLINT,
                                  typeSHORTINT];

  BooleanPaxTypes: TIntegerSet = [typeBOOLEAN];

  StringPaxTypes: TIntegerSet = [typeSTRING];

  RealPaxTypes: TIntegerSet = [typeDOUBLE, typeSINGLE, typeCURRENCY];

  VariantPaxTypes: TIntegerSet = [typeVARIANT];

  KindNONE = 0;
  KindVAR = 1;
  KindTYPE = 2;
  KindCONST = 3;
  KindSUB = 4;
  KindREF = 5;
  KindPROP = 6;
  KindLABEL = 7;
  KindHOSTVAR = 8;
  KindHOSTCONST = 9;
  KindHOSTOBJECT = 10;
  KindHOSTINTERFACEVAR = 11;
  KindVIRTUALOBJECT = 12;
const
  SecsPerHour   = 60 * 60;
  SecsPerDay    = SecsPerHour * 24;
  MSecsPerDay   = SecsPerDay * 1000;
  MSecsPerHour  = SecsPerHour * 1000;
type
  TIntegerMethodNoParam = function(): Integer of Object;
  TIntegerMethodOneParam = function(I: Integer): Integer of Object;

  TPAXClassKind = (ckNone, ckClass, ckStructure, ckEnum, ckInterface, ckArray,
                   ckDynamicArray);

  TPAXMemberAccess = (maAny, maMyBase, maMyClass);

  TPAXModifier = (modDEFAULT, modPUBLIC, modPRIVATE, modSTATIC, modPROTECTED, modVIRTUAL);
  TPAXModifierList = set of TPAXModifier;

  PVariant = ^Variant;
  PInteger = ^TInteger;

  PUnknown = ^IUnknown;
  PPointer = ^Pointer;

  TByteInt = (bb00,bb01,bb02,bb03,bb04,bb05,bb06,bb07,bb08,bb09,
              bb10,bb11,bb12,bb13,bb14,bb15,bb16,bb17,bb18,bb19,
              bb20,bb21,bb22,bb23,bb24,bb25,bb26,bb27,bb28,bb29);

  TByteSet = set of TByteInt;

  TFile = file;
  TTextFile = TextFile;
  TInteger = Integer;
  TReal = Double;
  TSingle  = Single;
  TCurrency = Currency;
  TDouble = Double;
  TReal48 = Double;
  TComp = Double;
  TExtended = Extended;
  TString  = String;
  TShortString = ShortString;
  TByte = Byte;
  TChar = Char;
  TWideChar = WideChar;
  TWideString = WideString;
  TBoolean = Boolean;
  TWordBool = WordBool;
  TLongBool = LongBool;
  TPointer = Pointer;
  TCardinal = Cardinal;
  TWord = Word;
  TShortInt = ShortInt;
  TSmallInt = SmallInt;
  TInt64 = Int64;
  PInt64 = ^TInt64;
  TOleVariant = OleVariant;

  PBoolean = ^TBoolean;
  PDouble = ^TDouble;

  TPAXTypeSub = (tsNone, tsMethod, tsConstructor, tsDestructor, tsGlobal, tsFunction, tsProcedure);

  TPAXScripterState = Integer;

  TPAXTokenClass = (tcNone, tcKeyword, tcId, tcSpecial, tcSeparator, tcIntegerConst,
                    tcFloatConst, tcStringConst, tcHtmlStringConst);

  TCharSet = set of Char;

  TPAXToken = record
    Text: String;
    ID: Integer;
    TokenClass: TPAXTokenClass;
    Value: Variant;
    Position: Integer;
  end;

  TPAXKinds = TStringList;
  TPAXOperators = TStringList;

  TPAXTypes = class(TStringList)
    function AddType(const TypeName: String; TypeSize: Integer): Integer;
    function GetSize(TypeID: Integer): Integer;
    function GetTypeID(const TypeName: String): Integer;
  end;

  TPAXScriptFailure = class(Exception);

  TPAXStack = class
  private
    L: Integer;
    function GetItem(I: Integer): Integer;
  public
    Card: Integer;
    fItems: array of Integer;
    constructor Create;
    function Push(I: Integer): Integer; overload;
    procedure Push(P: Pointer); overload;
    function Pop: Integer;
    function PopPointer: Pointer;
    function Top: Integer;
    procedure SaveToStream(f: TStream);
    procedure LoadFromStream(f: TStream);
    procedure Clear;
    function StackPtr: Pointer;
    procedure CopyFrom(S: TPAXStack);

    function IndexOf(I: Integer): Integer;
    function PushUnique(I: Integer): Integer;
    procedure Delete(I: Integer);

    property Items[I: Integer]: Integer read GetItem; default;
  end;

  TPAXFastStack = class
  private
    function GetItem(I: Integer): Integer;
  public
    Card: Integer;
    fItems: array [0..1024] of Integer;
    constructor Create;
    function Push(I: Integer): Integer; overload;
    procedure Push(P: Pointer); overload;
    procedure Clear;
    function Pop: Integer;
    function PopPointer: Pointer;
    function Top: Integer;

    function IndexOf(I: Integer): Integer;
    function PushUnique(I: Integer): Integer;
    procedure Delete(I: Integer);

    property Items[I: Integer]: Integer read GetItem; default;
  end;

  TPAXCallStack = TPAXStack;
  TPAXUsingList = TPAXStack;
  TPAXWithStack = TPAXStack;

  TPAXIndexedList = class
  private
    fItems: TList;
    function GetNameID(I: Integer): Integer;
    procedure SetNameID(I: Integer; Value: Integer);
  public
    Objects: TList;
    constructor Create;
    procedure Clear;
    destructor Destroy; override;
    function Count: Integer;
    procedure Delete(I: Integer);
    function AddObject(ID: Integer; AnObject: TObject): Integer;
    function GetObject(ID: Integer): TObject;
    function IndexOf(I: Integer): Integer;
    procedure DeleteObject(Index: Integer);
    property NameID[I: Integer]: Integer read GetNameID write SetNameID; default;
  end;

  TPAXHashArray = class
  public
    A: array[0..MaxHash] of TList;
    constructor Create;
    destructor Destroy; override;
    procedure AddName(const Name: String; NameIndex, _HashNumber: Integer);
    procedure Clear;
  end;

  TPAXHashTable = class
  private
    Keys: array[0..MaxHash] of TList;
    Values: array[0..MaxHash] of TList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(Key: Integer; Value: Integer);
    function FindValue(Key: Integer; var found: Boolean): Integer;
    procedure DeleteValue(Value: Integer);
    procedure Clear;
  end;

  TPAXHashedIndexedList = class(TPAXIndexedList)
    HashTable: TPAXHashTable;
    constructor Create;
    destructor Destroy; override;
    function IndexOf(ID: Integer): Integer;
    function AddObject(ID: Integer; AnObject: TObject): Integer;
    function GetObject(ID: Integer): TObject;
    procedure DeleteObject(Index: Integer);
    procedure Clear;
  end;

  TPAXEntryRec = class
  public
    BreakLabel, ContinueLabel: Integer;
    StringLabel: String;
  end;

  TPAXEntryStack = class(TList)
    procedure Push(ABreakLabel, AContinueLabel: Integer;
                  var AStringLabel: String);
    procedure Pop;
    function TopBreakLabel(const AStringLabel: String = ''): Integer;
    function TopContinueLabel(const AStringLabel: String = ''): Integer;
  end;

  TPAXIniFile = class
  private
    L: TStringList;
    FileName: String;
    function IndexOf(const Key: String): Integer;
    function GetValue(const Key: String): String;
    procedure SetValue(const Key, Value: String);
  public
    constructor Create(const FileName: String);
    destructor Destroy; override;
    property Values[const Key: String]: String read GetValue write SetValue; default;
  end;

  TPAXNameList = class(TStringList)
  public
    HashArray: TPAXHashArray;
    constructor Create;
    destructor Destroy; override;
    function Add(const S: string): Integer; override;
    function GetSize: Integer;
  end;

  TPAXCodeRec = class
  public
    Key: String;
    LanguageName: String;
    Code: String;
  end;

  TPAXCodeList = class(TList)
  private
    function GetRecord(Index: Integer): TPAXCodeRec;
  public
    procedure Clear; override;
    function IndexOfKey(const Key: String): Integer;
    function AddCode(const Key, LanguageName, Code: String): TPAXCodeRec;
    function GetCode(LanguageName: String): String;
    property Records[Index: Integer]: TPAXCodeRec read GetRecord; default;
  end;

  TPAXParamList = class
  private
    L: TStringList;
  public
    function GetParam(const ParamName: String): Variant;
    procedure SetParam(const ParamName: String; const Value: Variant);
    function GetAddress(const ParamName: String): Pointer;
    function HasAddress(P: Pointer): Boolean;
    constructor Create;
    destructor Destroy; override;
  end;

  TPAXIds = class(TList)
  private
    function GetID(Index: Integer): Integer;
    procedure PutID(Index: Integer; Value: Integer);
  public
    DupYes: Boolean;
    constructor Create(DupYes: Boolean);
    function Add(ID: Integer): Integer;
    function IndexOf(ID: Integer): Integer;
    procedure SaveToStream(S: TStream);
    procedure LoadFromStream(S: TStream);
    property Ids[Index: Integer]: Integer read GetID write PutID; default;
  end;

  TPAXVariantStack = class
  private
    L: Integer;
    A: array of Variant;
  public
    Card: Integer;
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    function Push(const V: Variant): PVariant;
    procedure Pop;
    function Top: Variant;
  end;

  TPAXVarList = class
  private
    fItems: TList;
    function GetCount: Integer;
    function Get(Index: Integer): Variant;
  public
    constructor Create;
    destructor Destroy; override;
    function GetAddress(Index: Integer): PVariant;
    function Add(const Value: Variant): Integer;
    function IndexOf(const Value: Variant): Integer;
    procedure Delete(Index: Integer);
    property Count: Integer read GetCount;
    property Items[I: Integer]: Variant read Get; default;
  end;

  TPAXAssocRec = class
  public
    Data: TVarRec;
    Obj: TObject;
  end;

  TPAXAssocList = class
  private
    fItems: TList;
    function GetItem(I: Integer): TPAXAssocRec;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    function Add(const Data: TVarRec; Obj: TObject): Integer;
    function FindObject(const Data: TVarRec): TObject;
    property Items[I: Integer]: TPAXAssocRec read GetItem;
  end;

  TDefaultParameterRec = class
  public
    SubID: Integer;
    ID: Integer;
    Value: Variant;
    procedure SaveToStream(S: TStream);
    procedure LoadFromStream(S: TStream);
  end;

  TDefaultParameterList = class(TList)
  private
    function GetRecord(I: Integer): TDefaultParameterRec;
  public
    destructor Destroy; override;
    procedure AddParameter(SubID, ID: Integer; const Value: Variant);
    function FindFirst(SubID: Integer): Integer;
    function FindNext(I, SubID: Integer): Integer;
    procedure SaveToStream(S: TStream);
    procedure LoadFromStream(S: TStream);
    property Records[I: Integer]: TDefaultParameterRec read GetRecord; default;
  end;

  TPaxIDRec = class
  public
    ID, N, Pos: Integer;
    constructor Create(ID, N, Pos: Integer);
  end;

  TPaxIDRecList = class(TPaxIndexedList)
  private
    function GetRecord(I: Integer): TPaxIDRec;
  public
    property Records[I: Integer]: TPaxIDRec read GetRecord; default;
  end;

  TPaxCallRec = class
  public
    CallN, CallP: Integer;
    ArgsN, ArgsP: TPaxIds;
    constructor Create;
    destructor Destroy; override;
  end;

  TPaxCallRecList = class(TPaxIndexedList)
  private
    function GetRecord(I: Integer): TPaxCallRec;
  public
    procedure AddObject(N: Integer; X: TPaxCallRec);
    function Top: TPaxCallRec;
    property Records[I: Integer]: TPaxCallRec read GetRecord; default;
  end;

  TPaxAssociativeList = class
  private
    L1, L2: TPaxIds;
    function GetFirst(I: Integer): Integer;
    function GetSecond(I: Integer): Integer;
  public
    constructor Create(DupYes: Boolean);
    destructor Destroy; override;
    function Add(I1, I2: Integer): Integer;
    function Count: Integer;
    procedure Clear;
    function Convert(ID: Integer): Integer;
    property First[I: Integer]: Integer read GetFirst;
    property Second[I: Integer]: Integer read GetSecond;
  end;

  TOperatorList = class
  public
     fItems: TStringList;
     constructor Create;
     destructor Destroy; override;
     procedure Add(const Name: String; Op: Integer);
     function GetName(Op: Integer): String;
     function IndexOf(const Name: String): Integer;
   end;

  TPaxObjectList = class
  private
    fItems: TList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(X: TObject);
    procedure Clear;
    procedure Delete(I: Integer);
    function Count: Integer;