base_symbol.pas

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

PAS
2,415 行
字号
1234
////////////////////////////////////////////////////////////////////////////
// PAXScript Interpreter
// Author: Alexander Baranovsky (ab@cable.netlux.org)
// ========================================================================
// Copyright (c) Alexander Baranovsky, 2003-2005. All rights reserved.
// Code Version: 3.0
// ========================================================================
// Unit: BASE_SYMBOL.pas
// ========================================================================
////////////////////////////////////////////////////////////////////////////


{$I PaxScript.def}

unit BASE_SYMBOL;

interface

uses
{$IFDEF VARIANTS}
  Variants,
{$ENDIF}
  SysUtils, Classes,

  BASE_CONSTS,
  BASE_SYS, BASE_CLASS;

type
  TPAXSymbolRec = packed record
    Address: Pointer;
    Position: Integer;
    StartPosition: Integer;
    Next: Integer;
    Level: Integer;
    PName: Integer;
    PType: Integer;
    Count: Integer;
    Local: Integer;
    Kind: Integer;
    Module: Integer;
    CallConv: Integer;
    Misc: Integer;
    Owner: Integer;
    TypeNameIndex: Integer;
    Imported: Boolean;
    Rank: ShortInt;
    Global: Boolean;
    JSIndex: Boolean;
    IsVirtual: Boolean;
  end;

  TPAXSymbolTable = class
  private
    Scripter: Pointer;
    Mem: Pointer;
    fCard: Integer;
    StateStack: TPAXStack;
    procedure SetName(I: Integer; const Name: String);
    function GetName(I: Integer): String;
    function GetFullName(I: Integer): String;
    procedure SetNameIndex(I, Value: Integer);
    function GetNameIndex(I: Integer): Integer;
    procedure SetKind(I, AKind: Integer);
    function GetKind(I: Integer): Integer;
    procedure SetCount(I, ACount: Integer);
    function GetCount(I: Integer): Integer;
    procedure SetRank(I, ARank: Integer);
    function GetRank(I: Integer): Integer;
    procedure SetNext(I, Value: Integer);
    function GetNext(I: Integer): Integer;
    procedure SetModule(I, Value: Integer);
    function GetModule(I: Integer): Integer;
    procedure SetPosition(I, Value: Integer);
    function GetStartPosition(I: Integer): Integer;
    procedure SetStartPosition(I, Value: Integer);
    function GetPosition(I: Integer): Integer;
    procedure SetLevel(I: Integer; Value: Integer);
    function GetLevel(I: Integer): Integer;
    procedure SetType(I, AType: Integer);
    function GetType(I: Integer): Integer;
    procedure SetImported(I: Integer; Value: Boolean);
    function GetImported(I: Integer): Boolean;
    procedure SetGlobal(I: Integer; Value: Boolean);
    function GetGlobal(I: Integer): Boolean;
    procedure SetAddr(I: Integer; Address: Pointer);
    function GetAddr(I: Integer): Pointer;
    function GetStrKind(I: Integer): String;
    procedure SetByRef(ParamID: Integer; Value: Integer);
    function GetByRef(ParamID: Integer): Integer;
    function GetStrType(I: Integer): String;
    procedure SetTypeSub(SubID: Integer; Value: TPAXTypeSub);
    function GetTypeSub(SubID: Integer): TPAXTypeSub;
    function GetMemberAccess(RefID: Integer): TPAXMemberAccess;
    procedure SetMemberAccess(RefID: Integer; Value: TPAXMemberAccess);
    procedure SetCallConv(I, Value: Integer);
    function GetCallConv(I: Integer): Integer;
    procedure SetTypeNameIndex(I, Value: Integer);
    function GetTypeNameIndex(I: Integer): Integer;
    procedure SetCard(Value: Integer);
    procedure CheckMem;
    function NameList: TPaxNameList;
    function GetJSIndex(I: Integer): Boolean;
    procedure SetJSIndex(I: Integer; Value: Boolean);
  public
    A: array of TPAXSymbolRec;
    RootNamespaceID: Integer;

    MemBoundVar: Integer;
    MemSize: Integer;
    CreateCard: Integer;
    CreateMemBoundVar: Integer;
    MaxLocalVars: Integer;

    IDfalse: Integer;
    IDtrue: Integer;
    IDundefined: Integer;

    constructor Create(AScripter: Pointer);
    destructor Destroy; override;
    procedure SaveToStream(S: TStream; I1, I2: Integer);
    procedure LoadFromStream(S: TStream;
                             DS: Integer = 0; DP: Integer = 0);
    procedure Reset;
    procedure ResetCompileStage;
    procedure EraseTail(K: Integer);

    procedure InitRunStage;
    procedure ResetRunStage;

    function AllocateVar(I: Integer): Pointer;
    function GetSizeOf(I: Integer): Integer;

    function AppLabel: Integer;

    procedure LinkVariables(SubID: Integer; HasResult: Boolean);
    function GetParamID(SubID: Integer; N: Integer): Integer;
    function GetResultID(SubID: Integer): Integer;
    function GetThisID(SubID: Integer): Integer;
    function GetDllID(SubID: Integer): Integer;
    function GetDllProcID(SubID: Integer): Integer;
    procedure AllocateSub(SubID: Integer);
    function GetSubCount: Integer;
    procedure AllocateSubroutines;
    procedure DeallocateSub(SubID: Integer);
    function IsLocalVar(SubID, ID: Integer): Boolean;
    procedure SetLocal(ID: Integer);
    function IsLocal(ID: Integer): Boolean;
    procedure Erase(I: Integer);
    procedure SaveState;
    procedure RestoreState;
    procedure ReallocateMem(NewSize: Integer);

    function GetStrVal(I: Integer): String;

    function GetAlias(ID: Integer): Variant;
    function GetParamTypeName(SubID, ParamIndex: Integer): String;
    function GetParamName(SubID, ParamIndex: Integer): String;
    function GetTypeName(ID: Integer): String;

    function GetVariant(ID: Integer): Variant;
    procedure ClearVariant(ID: Integer);
    procedure ClearVariantValue(ID: Integer);

    procedure PutVariant(ID: Integer; const Val: Variant);
    function AppVariant(const Val: Variant; HasAddress: Boolean = true): Integer;
    function AppVariantConst(const Val: Variant; Dup: Boolean = false): Integer;
    function GetUserData(ID: Integer): Integer;

    function CodeNumberConst(Val: Variant): Integer;
    function CodeStringConst(const Val: String): Integer;

    function GetMemberRec(RefID: Integer; ma: TPAXMemberAccess): TPAXMemberRec;
    function GetMemberRecEx(RefID: Integer; ma: TPAXMemberAccess;
                            var FoundInBaseClass: Boolean;
                            var SO: TPaxScriptObject): TPAXMemberRec;
    function IsFormalParamID(ID: Integer): Boolean;

    function GetOverloadedSubID(RefID: Integer; ma: TPAXMemberAccess;
                        ParamCount: Integer): Integer;

    procedure SetReference(RefID: Integer; const Base: Variant; ma: TPAXMemberAccess);
    function AppReference(const Base: Variant; ANameIndex: Integer; ma: TPAXMemberAccess): Integer;
    function GetValue(ID: Integer): Variant;
    procedure PutValue(ID: Integer; const Val: Variant);

    function LookUpID(const Name: String; aLevel: Integer; UpCase: Boolean = true): Integer;
    function LookUpSubID(const Name: String; aLevel: Integer; UpCase: Boolean = true): Integer;
    function LookupConstID(const Value: Variant): Integer;

    function IsOutsideMemAddress(A: Pointer): boolean;
    function IsInsideMemAddress(A: Pointer): boolean;
    function IsExternalAddress(A: Pointer): boolean;
    function IsInternalAddress(A: Pointer): boolean;

    procedure IncCard;
    procedure DecCard;
    procedure CheckLength; overload;
    procedure CheckLength(Value: Integer); overload;

    procedure Dump(const FileName: String);
    procedure SetupSubs(StartRecNo: Integer);
    function TypeCast(TypeID: Integer; const Value: Variant): Variant;
    function IsVirtual(SubId: Integer): Boolean;

    function GetAddressEx(ID: Integer): Pointer;
    procedure InitGlobalVars;

    property Name[I: Integer]: String read GetName write SetName;
    property FullName[I: Integer]: String read GetFullName;
    property Kind[I: Integer]: Integer read GetKind write SetKind;
    property Count[I: Integer]: Integer read GetCount write SetCount;
    property Rank[I: Integer]: Integer read GetRank write SetRank;
    property Next[I: Integer]: Integer read GetNext write SetNext;
    property Module[I: Integer]: Integer read GetModule write SetModule;
    property Position[I: Integer]: Integer read GetPosition write SetPosition;
    property StartPosition[I: Integer]: Integer read GetStartPosition write SetStartPosition;
    property Level[I: Integer]: Integer read GetLevel write SetLevel;
    property PType[I: Integer]: Integer read GetType write SetType;
    property Address[I: Integer]: Pointer read GetAddr write SetAddr;
    property ByRef[I: Integer]: Integer read GetByRef write SetByRef;
    property TypeSub[I: Integer]: TPAXTypeSub read GetTypeSub write SetTypeSub;
    property NameIndex[I: Integer]: Integer read GetNameIndex write SetNameIndex;
    property VariantValue[I: Integer]: Variant read GetValue write PutValue;
    property MemberAccess[RefID: Integer]: TPAXMemberAccess read GetMemberAccess write SetMemberAccess;
    property CallConv[SubID: Integer]: Integer read GetCallConv write SetCallConv;
    property TypeNameIndex[ID: Integer]: Integer read GetTypeNameIndex write SetTypeNameIndex;
    property Imported[I: Integer]: Boolean read GetImported write SetImported;
    property Global[I: Integer]: Boolean read GetGlobal write SetGlobal;
    property JSIndex[I: Integer]: Boolean read GetJSIndex write SetJSIndex;
    property Card: Integer read fCard write SetCard;
  end;

function _GetName(NameIndex: Integer; Scripter: Pointer): String;

implementation

uses
  BASE_SCRIPTER, BASE_CODE, BASE_EXTERN;

constructor TPAXSymbolTable.Create(AScripter: Pointer);
var
  I: Integer;
begin
  StateStack := TPAXStack.Create;

  Scripter := AScripter;

  MemSize := FirstMemSize;

  Mem := AllocMem(MemSize);
  MemBoundVar  := 0;

  SetLength(A, FirstSymbolCard);
  for I:=0 to FirstSymbolCard - 1 do
    FillChar(A[I], SizeOf(TPAXSymbolRec), 0);

  fCard := -1;

  for I:=0 to PAXTypes.Count - 1 do
  begin
    AppVariant(Undefined, true);
    SetName(I, PAXTypes[I]);
    SetKind(I, kindTYPE);
  end;

  SetName(AppVariantConst(ord(maAny)), '_maAny_');
  SetName(AppVariantConst(ord(maMyBase)), '_maMyBase_');
  SetName(AppVariantConst(ord(maMyClass)), '_maMyClass_');

  IDtrue := AppVariant(true);
  SetName(IDtrue, 'true');

  IDfalse := AppVariant(false);
  SetName(IDfalse, 'false');

  IDundefined := AppVariant(undefined);

  RootNameSpaceID := AppVariant(Undefined);
  Name[RootNameSpaceID] := RootNamespaceName;
  Kind[RootNameSpaceID] := KindTYPE;

  CreateCard := Card;
  CreateMemBoundVar := MemBoundVar;

  MaxLocalVars := 0;
end;

procedure TPAXSymbolTable.SetCard(Value: Integer);
begin
  fCard := Value;
  CheckLength;
end;

procedure TPAXSymbolTable.IncCard;
begin
  Inc(fCard);
  CheckLength;
end;

procedure TPAXSymbolTable.DecCard;
begin
  Dec(fCard);
end;

procedure TPAXSymbolTable.CheckLength;
var
  L, I: Integer;
begin
  L := Length(A);
  if L < Card + 10 then
  begin
    SetLength(A, Card + DeltaSymbolCard);
    for I:=fCard + 1 to Length(A) - 1 do
      FillChar(A[I], SizeOf(TPAXSymbolRec), 0);
  end;
end;

procedure TPAXSymbolTable.CheckLength(Value: Integer);
var
  L, I: Integer;
begin
  L := Length(A);
  if value >= L then
  begin
    SetLength(A, value + DeltaSymbolCard);
    for I:=fCard + 1 to Length(A) - 1 do
      FillChar(A[I], SizeOf(TPAXSymbolRec), 0);
  end;
end;

procedure TPAXSymbolTable.SaveToStream(S: TStream; I1, I2: Integer);
var
  I, J, K, L: Integer;
  ClassRec: TPAXClassRec;
  ClassList: TPAXClassList;
  MemberRec: TPAXMemberRec;
  SO: TPAXScriptObject;
  FInstance: TPAXDelegate;
  ClassRecList: TPaxIds;
begin
  ClassList := TPAXBaseScripter(Scripter).ClassList;

  ClassRecList := TPaxIds.Create(false);

  SaveInteger(I1, S);
  SaveInteger(I2, S);
  SaveInteger(MaxLocalVars, S);

  for I:=I1 to I2 do
    if Kind[I] = KindTYPE then
    begin
      ClassRec := ClassList.FindClass(I);
      if ClassRec <> nil then
        ClassRecList.Add(I);
    end;

  for I:=I1 to I2 do
  begin
    S.WriteBuffer(A[I], SizeOF(A[I]));
    SaveString(Name[I], S);
  end;

  SaveInteger(ClassRecList.Count, S);
  for J:=0 to ClassRecList.Count - 1 do
  begin
    I := ClassRecList[J];
    L := Level[I];

    ClassRec := ClassList.FindClass(I);
    ClassRec.SaveToStream(S);
    if Kind[L] = KindTYPE then
    begin
      ClassRec := ClassList.FindClass(L);
      MemberRec := ClassRec.GetMember(NameIndex[I]);
      MemberRec.SaveToStream(S);
    end;
  end;

  ClassRecList.Free;

  for I:=I1 to I2 do
  begin
    K := Kind[I];
    L := Level[I];

    if K = KindVAR then
    begin
      if L = RootNamespaceID then
      begin
        ClassRec := ClassList[0];
        MemberRec := ClassRec.GetMember(NameIndex[I]);
        if MemberRec = nil then
          SaveInteger(0, S)
        else
        begin
          if MemberRec.IsSource then
          begin
            SaveInteger(1, S);
            MemberRec.SaveToStream(S);
          end
          else
            SaveInteger(0, S);
        end;
      end;
    end
    else if K = KindCONST then
    begin
      SaveVariant(GetVariant(I), S);
    end
    else if K = KindSUB then
    begin
      SO := VariantToScriptObject(GetVariant(I));
      FInstance := TPAXDelegate(SO.Instance);
      SaveInteger(FInstance.N, S);

      if L = RootNamespaceID then
      begin
        ClassRec := ClassList[0];
        MemberRec := ClassRec.GetMember(NameIndex[I]);
        MemberRec.SaveToStream(S);
      end;
    end;
  end;
end;

procedure TPAXSymbolTable.LoadFromStream(S: TStream;
                                         DS: Integer = 0; DP: Integer = 0);
var
  I1, I2, I, J, K, L, Temp: Integer;
  St: String;
  ClassRec: TPAXClassRec;
  ClassList: TPAXClassList;
  MemberRec: TPAXMemberRec;

  Shift: Boolean;
begin
  Shift := (DS <> 0) or (DP <> 0);

  ClassList := TPAXBaseScripter(Scripter).ClassList;

  I1 := LoadInteger(S);
  I2 := LoadInteger(S);
  MaxLocalVars := LoadInteger(S);

  ReallocateMem((I2 + MaxLocalVars * 2) * _SizeVariant + DeltaMemSize);

  for I:=I1 to I2 do
  begin
    IncCard;
    S.ReadBuffer(A[Card], SizeOf(A[Card]));
    St := LoadString(S);
    Name[Card] := St;

    AllocateVar(Card);

    if Shift then
    begin
      if A[Card].Level > RootNamespaceID then
        Inc(A[Card].Level, DS);
      if A[Card].Next > RootNamespaceID then
        Inc(A[Card].Next, DS);
      if A[Card].PType > RootNamespaceID then
        Inc(A[Card].PType, DS);
    end;
  end;

  K := LoadInteger(S);
  for J:=1 to K do
  begin
    ClassRec := TPAXClassRec.Create(Scripter, ckClass);
    ClassRec.LoadFromStream(S, DS, DP);
    ClassList.AddObject(ClassRec.ClassID, ClassRec);

    I := ClassRec.ClassID;
    L := Level[I];

    if Kind[L] = KindTYPE then
    begin
      ClassRec := ClassList.FindClass(L);
      MemberRec := TPAXMemberRec.Create(I, ClassRec);
      MemberRec.LoadFromStream(S, DS, DP);

      ClassRec.MemberList.AddObject(NameIndex[I], MemberRec);
    end;
  end;

  for I:=I1 + DS to I2 + DS do
  begin
    K := Kind[I];
    L := Level[I];

    if K = KindVAR then
    begin
      if L = RootNamespaceID then
      begin
        Temp := LoadInteger(S);
        if Temp <> 0 then
        begin
          ClassRec := ClassList[0];
          MemberRec := TPAXMemberRec.Create(I, ClassRec);
          MemberRec.LoadFromStream(S, DS, DP);
          ClassRec.MemberList.AddObject(NameIndex[I], MemberRec);
        end;
      end;
    end
    else if K = KindCONST then
    begin
      PutVariant(I, LoadVariant(S));
    end
    else if K = KindSUB then
    begin
      Temp := LoadInteger(S);
      if Temp > 0 then
        Inc(Temp, DP);

      PutVariant(I, Temp);

      if L = RootNamespaceID then
      begin
        ClassRec := ClassList[0];
        MemberRec := TPAXMemberRec.Create(I, ClassRec);
        MemberRec.LoadFromStream(S, DS, DP);
        ClassRec.MemberList.AddObject(NameIndex[I], MemberRec);
      end;
    end;
  end;
end;

procedure TPAXSymbolTable.Reset;
begin
  FillChar(Mem^, MemSize, 0);
  MemBoundVar := CreateMemBoundVar;

  EraseTail(CreateCard);
  StateStack.Clear;
end;

procedure TPAXSymbolTable.EraseTail(K: Integer);
var
  I: Integer;
  P: Pointer;
begin
  for I:=Card downto K + 1 do
  if Level[I] >= 0 then
  begin
    P := A[I].Address;

    if P <> nil then
    begin
      try
        if IsInsideMemAddress(P) then
           ClearVariant(I);
      finally
        FillChar(A[I], SizeOf(TPAXSymbolRec), 0);
      end;
    end;
  end;
  Card := K;
end;

function TPAXSymbolTable.IsFormalParamID(ID: Integer): Boolean;
var
  I, SubID: Integer;
begin
  result := false;
  if ID <= 0 then
    Exit;
  SubID := GetLevel(ID);
  if GetKind(SubID) <> KindSUB then
    Exit;
  for I:=1 to GetCount(SubID) do
    if GetParamID(SubID, I) = ID then
      result := true;
end;

function TPAXSymbolTable.CodeStringConst(const Val: String): Integer;
var
  I: Integer;
begin
  for I:=PAXTypes.Count + 1 to Card do
    if GetType(I) > 0 then
    if GetKind(I) = kindCONST then
      if VarType(Variant(GetAddr(I)^)) = varString then
        if Val = Variant(GetAddr(I)^) then
        begin
          result := I;
          Exit;
        end;

//  result := AppVariantConst(Val);

  IncCard;

  with A[Card] do
  begin
    PName := 0;
    PType := GetPAXtype(Val);
    Kind := kindCONST;

    Address := Pointer(Integer(Mem) + MemBoundVar);
    Inc(MemBoundVar, SizeOf(Variant));
    FillChar(Address^, SizeOf(Variant), 0);
    Variant(Address^) := Val;// StrPas(PChar(Val));
1234

base_symbol.pas - 源码说明

本页面展示了「Delphi脚本控件」中的 base_symbol.pas 源码文件，采用 PAS 编程语言编写，共 2,415 行代码。您可以在线阅读完整代码内容，也可以返回资源详情页下载完整源码包进行本地学习和开发。

虫虫下载站收录了大量与Delphi相关的技术资源，包括源代码、技术文档、电路图等，是电子工程师和嵌入式开发者的专业学习平台。

⌨️ 快捷键说明

复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?