base_symbol.pas

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

    Module := -1;
    Position := -1;
  end;
  result := Card;
end;

destructor TPAXSymbolTable.Destroy;
begin
  EraseTail(0);

  FreeMem(Mem, MemSize);
  StateStack.Free;

  inherited;
end;

procedure TPAXSymbolTable.SetName(I: Integer; const Name: String);
begin
  A[I].PName := TPaxBaseScripter(Scripter).NameList.Add(Name);
end;


function TPAXSymbolTable.GetName(I: Integer): String;
var
  Index: Integer;
begin
  if I < 0 then
  begin
    result := DefinitionList.GetName(-I);
    Exit;
  end;

  if I > Card then
  begin
    result := '';
    Exit;
  end;

  Index := A[I].PName;
  if Index > 0 then
  begin
    if Index < NameList.Count then
      result := NameList[Index]
    else
      result := '';
  end
  else
    result := '';
end;

function TPAXSymbolTable.GetFullName(I: Integer): String;
var
  L: Integer;
begin
  if I < 0 then
  begin
    result := DefinitionList.GetFullName(-I);
    Exit;
  end;
  result := GetName(I);
  L := GetLevel(I);
  if (L > 0) and (L < Card) and (L <> RootNamespaceID) then
    result := GetName(L) + '.' + result; 
end;


procedure TPAXSymbolTable.SetLocal(ID: Integer);
begin
  A[ID].Local := 1;
end;

function TPAXSymbolTable.IsLocal(ID: Integer): Boolean;
begin
  result := A[ID].Local > 0;
end;

procedure TPAXSymbolTable.SetNameIndex(I, Value: Integer);
begin
  A[I].PName := Value;
end;

function TPAXSymbolTable.GetNameIndex(I: Integer): Integer;
begin
  if I > 0 then
    result := A[I].PName
  else
  begin
    result := DefinitionList.GetNameIndex(-I, Scripter);
  end;
end;

procedure TPAXSymbolTable.SetKind(I, AKind: Integer);
begin
  if I > 0 then
    A[I].Kind := AKind;
end;

function TPAXSymbolTable.GetKind(I: Integer): Integer;
begin
  if I > 0 then
    result := A[I].Kind
  else
    result := DefinitionList.GetKind(-I);
end;

procedure TPAXSymbolTable.SetImported(I: Integer; Value: Boolean);
begin
  if I > 0 then
    A[I].Imported := Value;
end;

function TPAXSymbolTable.GetImported(I: Integer): Boolean;
begin
  if I > 0 then
    result := A[I].Imported
  else
    result := false;
end;

procedure TPAXSymbolTable.SetGlobal(I: Integer; Value: Boolean);
begin
  if I > 0 then
    A[I].Global := Value;
end;

function TPAXSymbolTable.GetGlobal(I: Integer): Boolean;
begin
  if I > 0 then
    result := A[I].Global
  else
    result := false;
end;


function TPAXSymbolTable.GetStrKind(I: Integer): String;
var
  J: Integer;
begin
  J := GetKind(I);
  if (J >= 1) and (J <= PAXKinds.Count - 1) then
    result := PAXKinds[J]
  else
    result := ' ';
end;

procedure TPAXSymbolTable.SetCount(I, ACount: Integer);
begin
  A[I].Count := ACount;
end;

function TPAXSymbolTable.GetCount(I: Integer): Integer;
begin
  if I > 0 then
    result := A[I].Count
  else
    result := DefinitionList.GetCount(-I);
end;

function TPAXSymbolTable.GetParamTypeName(SubID, ParamIndex: Integer): String;
var
  ParamID, TypeID: Integer;
begin
  if SubID > 0 then
  begin
    ParamID := GetParamID(SubID, ParamIndex);
    TypeID := GetType(ParamID);
    result := GetName(TypeID);
  end
  else
  begin
    result := DefinitionList.GetParamTypeName(-SubID, ParamIndex);
  end;
end;

function TPAXSymbolTable.GetParamName(SubID, ParamIndex: Integer): String;
var
  ParamID: Integer;
begin
  if SubID > 0 then
  begin
    ParamID := GetParamID(SubID, ParamIndex);
    result := GetName(ParamID);
  end
  else
  begin
    result := DefinitionList.GetParamName(-SubID, ParamIndex);
  end;
end;

function TPAXSymbolTable.GetTypeName(ID: Integer): String;
var
  TypeID: Integer;
begin
  if ID > 0 then
  begin
    TypeID := GetType(ID);
    result := GetName(TypeID);
  end
  else
  begin
    result := DefinitionList.GetTypeName(-ID);
  end;
end;

procedure TPAXSymbolTable.SetRank(I, ARank: Integer);
begin
  if I > 0 then
    A[I].Rank := ARank;
end;

function TPAXSymbolTable.GetRank(I: Integer): Integer;
begin
  if I > 0 then
    result := A[I].Rank
  else
    result := 0;
end;

procedure TPAXSymbolTable.SetNext(I, Value: Integer);
begin
  A[I].Next := Value;
end;

function TPAXSymbolTable.GetNext(I: Integer): Integer;
begin
  result := A[I].Next;
end;

procedure TPAXSymbolTable.SetModule(I, Value: Integer);
begin
  A[I].Module := Value;
end;

function TPAXSymbolTable.GetModule(I: Integer): Integer;
begin
  result := A[I].Module;
end;

procedure TPAXSymbolTable.SetPosition(I, Value: Integer);
begin
  A[I].Position := Value;
end;

function TPAXSymbolTable.GetPosition(I: Integer): Integer;
begin
  result := A[I].Position;
end;

procedure TPAXSymbolTable.SetStartPosition(I, Value: Integer);
begin
  A[I].StartPosition := Value;
end;

function TPAXSymbolTable.GetStartPosition(I: Integer): Integer;
begin
  result := A[I].StartPosition;
end;

procedure TPAXSymbolTable.SetLevel(I: Integer; Value: Integer);
begin
  if I > 0 then
    A[I].Level := Value;
end;

function TPAXSymbolTable.GetLevel(I: Integer): Integer;
begin
  if I > 0 then
    result := A[I].Level
  else if I < 0 then
    result := -1
  else
    result := 0;
end;

procedure TPAXSymbolTable.SetCallConv(I, Value: Integer);
begin
  A[I].CallConv := Value;
end;

function TPAXSymbolTable.GetCallConv(I: Integer): Integer;
begin
  result := A[I].CallConv;
end;

procedure TPAXSymbolTable.SetTypeNameIndex(I, Value: Integer);
begin
  A[I].TypeNameIndex := Value;
end;

function TPAXSymbolTable.GetTypeNameIndex(I: Integer): Integer;
begin
  result := A[I].TypeNameIndex;
end;

procedure TPAXSymbolTable.SetType(I, AType: Integer);
begin
  if I > 0 then
  A[I].PType := AType;
end;

function TPAXSymbolTable.GetType(I: Integer): Integer;
begin
  if I > 0 then
    result := A[I].PType
  else
    result := typeVARIANT;
end;

procedure TPAXSymbolTable.SetAddr(I: Integer; Address: Pointer);
begin
  A[I].Address := Address;
end;

function TPAXSymbolTable.GetAddr(I: Integer): Pointer;
begin
  if I > 0 then
    result := A[I].Address
  else if I = 0 then
    result := @Undefined
  else
    result := DefinitionList.GetAddress(Scripter, -I);
end;

procedure TPAXSymbolTable.SetByRef(ParamID: Integer; Value: Integer);
begin
  A[ParamID].Misc := Value;
end;

function TPAXSymbolTable.GetByRef(ParamID: Integer): Integer;
begin
  result := A[ParamID].Misc;
end;

procedure TPAXSymbolTable.SetTypeSub(SubID: Integer; Value: TPAXTypeSub);
begin
  A[SubID].Misc := Ord(Value);
end;

function TPAXSymbolTable.GetTypeSub(SubID: Integer): TPAXTypeSub;
var
  D: TPaxDefinition;
begin
  result := tsNone;
  if SubID > 0 then
    result := TPAXTypeSub(A[SubID].Misc)
  else
  begin
    D := DefinitionList[-SubID];
    if D.DefKind = dkMethod then
      result := TPaxMethodDefinition(D).TypeSub;
  end;
end;

function TPAXSymbolTable.GetStrType(I: Integer): String;
var
  J: Integer;
begin
  J := GetType(I);
  if (J >= 1) and (J <= Card) then
    result := GetName(J)
  else if J < 0 then
    result := '-' + DefinitionList.GetName(-J)
  else
    result := ' ';
end;

function TPAXSymbolTable.GetStrVal(I: Integer): String;
begin
  if not IsInsideMemAddress(GetAddr(I)) then
    result := '***'
  else if GetType(I) > 0 then
    result := ToStr(Scripter, GetVariant(I))
  else
    result := '';
end;

function TPAXSymbolTable.GetSizeOf(I: Integer): Integer;
begin
  result := _SizeVariant;
end;

function TPAXSymbolTable.AppLabel: Integer;
begin
  result := AppVariant(Undefined);
  A[result].Kind := KindLABEL;
end;

function TPAXSymbolTable.GetAlias(ID: Integer): Variant;
begin
  result := CreateAlias(GetAddr(ID));
end;

function TPAXSymbolTable.GetVariant(ID: Integer): Variant;
begin
  if ID > 0 then
    result := GetTerminal(GetAddr(ID))^
  else if ID = 0 then
  begin
  end
  else
    result := DefinitionList.GetVariant(Scripter, -ID);
end;

procedure TPAXSymbolTable.ClearVariant(ID: Integer);
begin
  VarClear(Variant(GetAddr(ID)^));
end;

procedure TPAXSymbolTable.ClearVariantValue(ID: Integer);
var
  Base: Variant;
  SO: TPAXScriptObject;
begin
  if GetKind(ID) <> kindREF then
  begin
    VarClear(Variant(GetAddr(ID)^));
    Exit;
  end;

  Base := GetVariant(ID);
  if VarIsNull(Base) or VarIsEmpty(Base) then
    raise TPAXScriptFailure.Create(errIncompatibleTypes);

  SO := VariantToScriptObject(Base);
  SO.ClearProperty(NameIndex[ID]);
end;

procedure TPAXSymbolTable.PutVariant(ID: Integer; const Val: Variant);
begin
  if ID > 0 then
    GetTerminal(GetAddr(ID))^ := Val
  else if ID = 0 then
  begin
  end
  else
    DefinitionList.PutVariant(Scripter, -ID, Val);
end;

function TPAXSymbolTable.AppVariant(const Val: Variant; HasAddress: Boolean = true): Integer;
begin
  CheckMem;

  IncCard;

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

    if HasAddress then
    begin
      Address := Pointer(Integer(Mem) + MemBoundVar);
      Inc(MemBoundVar, SizeOf(Variant));
      FillChar(Address^, SizeOf(Variant), 0);
      Variant(Address^) := Val;
    end
    else
      Address := @Undefined;

    Module := -1;
    Position := -1;
  end;
  result := Card;
end;

function TPAXSymbolTable.AppVariantConst(const Val: Variant; Dup: Boolean = false): Integer;
var
  R: Double;
  I: Integer;
begin
  if Dup = false then
  begin
    result := LookupConstID(Val);
    if result > 0 then
      Exit;
  end;

  CheckMem;

  if VarType(Val) = varByte then
  begin
    I := Val;
    result := AppVariant(I);
  end
  else
    result := AppVariant(Val);

  SetKind(result, KindCONST);
  SetName(result, VarToStr(Val));

  if GetType(result) = typeDOUBLE then
  begin
    R := Frac(Val);
    if R = 0 then
      SetType(result, typeInt64);
  end;
end;

function TPAXSymbolTable.AllocateVar(I: Integer): Pointer;
var
  MemCnt: Integer;
begin
  CheckMem;

  result := ShiftPointer(Mem, MemBoundVar);
  A[I].Address := result;
  MemCnt := GetSizeOf(I);
  Inc(MemBoundVar, MemCnt);

  FillChar(result^, MemCnt, 0);
end;

procedure TPAXSymbolTable.CheckMem;
begin
  if MemBoundVar > MemSize - 256 then
    ReallocateMem(MemSize + DeltaMemSize);
end;

procedure TPAXSymbolTable.ReallocateMem(NewSize: Integer);
var
  I: Integer;
  P, Q, Adr: Pointer;
  V: Variant;
  K: Integer;
begin
  if NewSize = MemSize then
    Exit
  else if NewSize < MemSize then
  begin
//    ReallocMem(Mem, NewSize);
//    MemSize := NewSize;
    Exit;
  end;

  P := AllocMem(NewSize);
  Q := P;

  K := 0;
  for I:=1 to Card do
  begin
    Adr := A[I].Address;
    if (Adr <> nil) and (Adr <> @Undefined)
        and (not TPaxBaseScripter(Scripter).ParamList.HasAddress(Adr)) then
    begin
      V := Variant(Adr^);
      VarClear(Variant(Adr^));
      A[I].Address := Q;
      if not IsUndefined(V) then
        Variant(A[I].Address^) := V;

      Inc(Integer(Q), _SizeVariant);

      Inc(K, _SizeVariant);
    end;
  end;

  if K > MemBoundVar then
    MemBoundVar := K;

  FreeMem(Mem, MemSize);
  Mem := P;
  MemSize := NewSize;
end;

function TPAXSymbolTable.CodeNumberConst(Val: Variant): Integer;
var
  I, VT: Integer;
  TempVal: Variant;
begin
  VT := VarType(Val);
  for I:=PAXTypes.Count + 1 to Card do
    if GetType(I) > 0 then
    if GetKind(I) = kindCONST then
    begin
      TempVal := GetVariant(I);
      if VT = VarType(TempVal) then
        if Val = TempVal then
        begin
          result := I;
          Exit;
        end;
    end;

  result := AppVariantConst(Val);
  SetName(result, GetStrVal(result));
end;

function TPAXSymbolTable.LookUpID(const Name: String; aLevel: Integer; UpCase: Boolean = true): Integer;
var
  I, K: Integer;
  S: String;
  B: Boolean;
  SymbolRec: TPAXSymbolRec;
begin
  result := 0;
  for I:=Card downto 1 do
  begin
    SymbolRec := A[I];
    if SymbolRec.PName <> 0 then
    begin
      K := SymbolRec.Kind;
      if (K = KindVAR) or (K = KindSUB) or (K = KindTYPE) or 
         (K = KindLABEL) or