base_code.pas

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

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


{$I PaxScript.def}
{$O-}
unit BASE_CODE;

interface

uses
{$IFDEF VARIANTS}
  Variants,
{$ENDIF}
  SysUtils, Classes, Math, TypInfo,
  BASE_CONSTS,
  BASE_SYNC, BASE_CONV,
  BASE_SYS, BASE_SYMBOL, BASE_CLASS, BASE_EXTERN, BASE_CALL;

const
  MaxTryStack = 100;
type
  TProc = procedure of object;

  TPAXDebugInfo = class(TPAXStack)
    procedure PopProc;
  end;

  TPAXTryStackRec = record
    B1, B2: Integer;
  end;

  TPAXTryStack = class
  public
    A: array[1..MaxTryStack] of TPAXTryStackRec;
    Card: Integer;
    constructor Create;
    procedure Clear;
    procedure Push(N1, N2: Integer);
    procedure Pop;
    function Legal(N: Integer): boolean;
  end;

  TPAXBreakpoint = class
  public
    LineNumber: Integer;
    Condition: String;
    PassCount: Integer;
    CurrPassCount: Integer;
    constructor Create(LineNumber: Integer;
                       const Condition: String;
                       PassCount: Integer);
  end;

 TPAXBreakpointList = class(TPAXIndexedList)
 private
   function GetBreakpoint(I: Integer): TPAXBreakpoint;
 public
   procedure InitCurrPassCounts;
   procedure AddBreakpoint(LineNumber: Integer;
                           const Condition: String;
                           PassCount: Integer);
   function RemoveBreakpoint(LineNumber: Integer): Boolean;
   property Breakpoints[I: Integer]: TPAXBreakpoint read GetBreakpoint; default;
 end;

  TPAXCodeRec = record
    Op, Arg1, Arg2, Res, Vars: Integer;
    PP_Res, PP_Arg1, PP_Arg2: Pointer;
    _Entry, _SubID, SaveOP, AltArg1, LinePos: Integer;
    IsExecutable: Boolean;
  end;

  TPAXCode = class
  private
    Base: Variant;
  public
    Scripter: Pointer;
    SymbolTable: TPAXSymbolTable;
    ClassList: TPAXClassList;
    Stack: TPAXFastStack;

    Prog: array of TPAXCodeRec;
    Card: Integer;

    ArrProc: array[- 350..BOUND_OPER] of TProc;

    N, ErrorN: Integer;
    SubRunCount: Integer;

    UsingList: TPAXUsingList;
    WithStack: TPAXWithStack;
    LevelStack: TPAXFastStack;
    TryStack: TPAXTryStack;

    BreakPointList: TPAXBreakpointList;

    DebugState: Boolean;
    DebugInfo: TPAXDebugInfo;

    StateStack: TPAXStack;
    RefStack: TPAXFastStack;

    SignFOP, fTerminated, DeclareON, SignRETURN, SignInitStage: Boolean;

    ResultValue: Variant;
    _ParamCount: Integer;

    CurrRunMode: Integer;

    _This: Variant;

    InitializationList, FinalizationList: TPaxIds;

    UpcaseOn: Boolean;

    SignVBARRAYS: Boolean;
    SignZERO_BASED_STRINGS: Boolean;

    Undefined2: Variant;

    SignHaltGlobal: Boolean;

    AssignedUndeclaredList: TPAXIds;

    IsAborted: Boolean;

    VV: Variant;

    constructor Create(AScripter: Pointer);
    destructor Destroy; override;
    function  GetUpcase(I: Integer): Boolean;
    procedure SetRef(ID: Integer; const V: Variant; ma: TPAXMemberAccess);
    procedure SaveOP;
    function CurrArg1ID: Integer;
    function CurrArg2ID: Integer;
    function CurrResID: Integer;
    function CurrOP: Integer;
    function IsExecutableSourceLine(const ModuleName: String; L: Integer): Boolean;
    procedure SaveToStream(S: TStream; P1, P2: Integer);
    procedure LoadFromStream(S: TStream;
                             DS: Integer = 0; DP: Integer = 0);
    procedure CheckLength;
    procedure Add(InitOp, InitArg1, InitArg2, InitRes: Integer; IsExecutable: Boolean = false);
    procedure GenAt(P: Integer; InitOp, InitArg1, InitArg2, InitRes: Integer; IsExecutable: Boolean = false);
    procedure SetFOP(FOP: Integer; Ex: Boolean = false);
    procedure SaveState;
    procedure RestoreState;
    function FindCreateObjectStmt(TypeID: Integer): Integer;
    function GetLanguageNamespaceID: Integer;
    function GetModuleID(J: Integer): Integer;
    function ModuleID: Integer;
    function LineID: Integer;
    function NextLineID: Integer;
    function IsExecutableLine(I: Integer): Boolean;
    function IsBreakpoint(L: Integer): Boolean;
    procedure Dump(const FileName: String);
    procedure Run(RunMode: Integer = _rmRun; DestLine: Integer = 0);
    function EvalGetFunction(SubID, NParams: Integer): Integer;
    procedure EvalSetProcedure(SubID, NParams: Integer; AValue: Variant);
    procedure CallSub(SubID, ParamCount: Integer; PThis: PVariant; ResultID: Integer; MakeFOP: Boolean = false);
    procedure CallHostSub(D: TPAXMethodDefinition; PThis, PResult: PVariant; ParamCount: Integer);
    function PopVariant: Variant;
    function PopAddress: Pointer;
    function PopInteger: Integer;
    procedure RaiseException;
    procedure Optimization(StartPos, EndPos: Integer);
    procedure LinkGoTo(StartPos, EndPos: Integer);
    procedure RemoveNops;
    procedure ReplaceID(ID1, ID2: Integer);
    procedure InvokeOnChangedVariable;
    function NextOp(var NewN: Integer): Integer;
    function CurrMethodID: Integer;

    procedure InitRunStage;
    procedure ResetRunStage;

    procedure ResetCompileStage;

    procedure OperBinaryOperator;
    procedure OperUnaryOperator;
    procedure OperPrint;

    procedure OperHalt;
    procedure OperHaltGlobal;
    procedure OperHaltOrNop;
    procedure OperNop;
    procedure OperSkip;

    procedure OperPutProperty;
    procedure OperCall;
    procedure OperTypeCast;
    procedure OperPush;
    procedure OperRet;
    procedure OperExit0;
    procedure OperExit;
    procedure OperReturn;
    procedure OperSetLabel;
    procedure OperGetParamCount;
    procedure OperGetParam;
    procedure OperGetPublishedProperty;
    procedure OperPutPublishedProperty;
    procedure OperRetOperator;

    procedure OperExitOnError;
    procedure OperDiscardError;
    procedure OperFinally;
    procedure OperCatch;
    procedure OperTryOn;
    procedure OperTryOff;
    procedure OperThrow;

    procedure OperCreateArray;
    procedure OperDoNotDestroy;
    procedure OperGetItem;
    procedure OperPutItem;
    procedure OperGetItemEx;
    procedure OperPutItemEx;

    procedure OperCreateShortString;

    procedure OperGetField;

    procedure OperGetStringElement;
    procedure OperPutStringElement;

    procedure OperCreateObject;
    procedure OperDestroyHost;
    procedure OperDestroyObject;
    procedure OperDestroyLocalVar;
    procedure OperDestroyIntf;
    procedure OperRelease;
    procedure OperCreateRef;
    procedure OperUseNamespace;
    procedure OperEndOfNamespace;
    procedure OperBeginWith;
    procedure OperEndWith;
    procedure OperEvalWith;
    procedure OperIn;
    procedure OperInSet;
    procedure OperInstanceOf;
    procedure OperTypeOf;
    procedure OperGetNextProp;
    procedure OperSaveResult;
    procedure OperGetAncestorName;

    procedure OperGo;
    procedure OperGoFalse;
    procedure OperGoFalseEx;
    procedure OperGoTrue;
    procedure OperGoTrueEx;

    procedure OperAssign;
    procedure OperSetOwner;
    procedure OperAssignResult;

    procedure OperAssignAddress;
    procedure OperGetTerminal;

    procedure OperAnd;
    procedure OperOr;
    procedure OperXor;
    procedure OperNot;

    procedure OperLeftShift;
    procedure OperLeftShift_Ex;

    procedure OperRightShift;
    procedure OperRightShift_Ex;

    procedure OperUnsignedRightShift;
    procedure OperUnsignedRightShift_Ex;

    procedure OperPlus;
    procedure OperPlus_Ex;

    procedure OperMinus;
    procedure OperMinus_Ex;

    procedure OperUnaryPlus;

    procedure OperUnaryMinus;
    procedure OperUnaryMinusEx;

    procedure OperMult;
    procedure OperMult_Ex;

    procedure OperDiv;
    procedure OperDiv_Ex;

    procedure OperIntDiv;

    procedure OperMod;
    procedure OperMod_Ex;

    procedure OperPower;

    procedure OperLT;
    procedure OperLT_Ex;

    procedure OperGT;
    procedure OperGT_Ex;

    procedure OperLE;
    procedure OperLE_Ex;

    procedure OperGE;
    procedure OperGE_Ex;

    procedure OperEQ;
    procedure OperEQ_Ex;

    procedure OperNE;
    procedure OperNE_Ex;

    procedure OperID;
    procedure OperID_Ex;

    procedure OperNI;
    procedure OperNI_Ex;

    procedure OperIS;
    procedure OperAS;

    procedure OperToInteger;
    procedure OperToString;
    procedure OperToBoolean;

    procedure OperDefine;

    procedure OperDeclareOn;
    procedure OperDeclareOff;

    procedure OperUpcaseOn;
    procedure OperUpcaseOff;

    procedure OperOptimizationOn;
    procedure OperOptimizationOff;

    procedure OperVBArraysOff;
    procedure OperVBArraysOn;

    procedure OperZeroBasedStringsOn;
    procedure OperZeroBasedStringsOff;

    procedure FindUnaryOperator(const Name: String; const V2: Variant);
    procedure FindBinaryOperator(const Name: String; const V1, V2: Variant);

//------------------------------------------

    procedure FOperGoFalse1;
    procedure FOperGoFalse2;
    procedure FOperGoTrue1;
    procedure FOperGoTrue2;
    procedure FOperAssign;

    procedure FOperINC1;
    procedure FOperINC2;

    procedure FOperPlusInteger1;
    procedure FOperPlusInteger2;
    procedure FOperPlusDouble1;
    procedure FOperPlusDouble2;
    procedure FOperPlusString1;
    procedure FOperPlusString2;

    procedure FOperMinusInteger1;
    procedure FOperMinusInteger2;
    procedure FOperMinusDouble1;
    procedure FOperMinusDouble2;

    procedure FOperMultInteger1;
    procedure FOperMultInteger2;
    procedure FOperMultDouble1;
    procedure FOperMultDouble2;

    procedure FOperDivInteger1;
    procedure FOperDivInteger2;
    procedure FOperDivDouble1;
    procedure FOperDivDouble2;

    procedure FOperMod1;
    procedure FOperMod2;

    procedure FOperLTInteger1;
    procedure FOperLTInteger2;
    procedure FOperLTDouble1;
    procedure FOperLTDouble2;

    procedure FOperLEInteger1;
    procedure FOperLEInteger2;
    procedure FOperLEDouble1;
    procedure FOperLEDouble2;

    procedure FOperGTInteger1;
    procedure FOperGTInteger2;
    procedure FOperGTDouble1;
    procedure FOperGTDouble2;

    procedure FOperGEInteger1;
    procedure FOperGEInteger2;
    procedure FOperGEDouble1;
    procedure FOperGEDouble2;

    procedure FOperEQInteger1;
    procedure FOperEQInteger2;
    procedure FOperEQDouble1;
    procedure FOperEQDouble2;

    procedure FOperNEInteger1;
    procedure FOperNEInteger2;
    procedure FOperNEDouble1;
    procedure FOperNEDouble2;

    procedure FOperBitwiseAND1;
    procedure FOperBitwiseAND2;

    procedure FOperBitwiseOR1;
    procedure FOperBitwiseOR2;

    procedure FOperBitwiseXOR1;
    procedure FOperBitwiseXOR2;

    procedure FOperLogicalAND1;
    procedure FOperLogicalAND2;

    procedure FOperLogicalOR1;
    procedure FOperLogicalOR2;

    procedure FOperLogicalXOR1;
    procedure FOperLogicalXOR2;

    procedure FOperBitwiseNOT1;
    procedure FOperBitwiseNOT2;

    procedure FOperLogicalNOT1;
    procedure FOperLogicalNOT2;

    procedure FOperUnaryMinusInteger1;
    procedure FOperUnaryMinusInteger2;
    procedure FOperUnaryMinusDouble1;
    procedure FOperUnaryMinusDouble2;

    procedure FOperSHL1;
    procedure FOperSHL2;

    procedure FOperSHR1;
    procedure FOperSHR2;

    procedure FOperUSHR1;
    procedure FOperUSHR2;

//======================================================================
    procedure FOperPush;

    procedure FOperPlus1;
    procedure FOperPlus2;

    procedure FOperMinus1;
    procedure FOperMinus2;

    procedure FOperMult1;
    procedure FOperMult2;

    procedure FOperDiv1;
    procedure FOperDiv2;

    procedure FOperGT1;
    procedure FOperGT2;

    procedure FOperGE1;
    procedure FOperGE2;

    procedure FOperLT1;
    procedure FOperLT2;

    procedure FOperLE1;
    procedure FOperLE2;

    procedure FOperEQ1;
    procedure FOperEQ2;

    procedure FOperNE1;