dws2symbols.pas

script language

  ClassSym: TSymbol; FuncLevel: Integer);
begin
  inherited Create(Name, FuncKind, FuncLevel);
  if ClassSym is TClassSymbol then
  begin
    // Method
    FClassSymbol := TClassSymbol(ClassSym);
    FSelfSym := TDataSymbol.Create(SYS_SELF, ClassSym);
    FInternalParams.AddSymbol(FSelfSym);
    FSize := 2; // code + data
  end
  else
    // Class function -> self is "class of"
    FClassSymbol := TClassSymbol(ClassSym.Typ);
  FParams.AddParent(FClassSymbol.Members);
end;

constructor TMethodSymbol.Generate(Table: TSymbolTable; MethKind: TMethodKind;
  Attributes: TMethodAttributes; MethName: string; MethParams: TParamList;
  MethType: string; Cls: TClassSymbol);
var
  typSym: TSymbol;
  meth: TSymbol;
begin
  // Check if name is already used
  meth := Cls.Members.FindSymbol(MethName);
  if meth is TFieldSymbol then
    raise Exception.CreateFmt(CPE_FieldExists, [MethName])
  else if meth is TPropertySymbol then
    raise Exception.CreateFmt(CPE_PropertyExists, [MethName])
  else if meth is TMethodSymbol then
  begin
    if TMethodSymbol(meth).ClassSymbol = Cls then
      raise Exception.CreateFmt(CPE_MethodExsists, [MethName]);
  end;

  // Initialize MethodSymbol
  case MethKind of
    mkConstructor:
      Create(MethName, fkConstructor, Cls);
    mkDestructor:
      Create(MethName, fkDestructor, Cls);
    mkProcedure:
      Create(MethName, fkProcedure, Cls);
    mkFunction:
      Create(MethName, fkFunction, Cls);
    mkClassProcedure:
      Create(MethName, fkProcedure, Cls.ClassOf);
    mkClassFunction:
      Create(MethName, fkFunction, Cls.ClassOf);
  end;

  // Set Resulttype
  if MethType <> '' then
  begin
    if Kind <> fkFunction then
      raise Exception.Create(CPE_NoResultTypeRequired);

    typSym := Table.FindSymbol(MethType);
    if not Assigned(typSym) then
      raise Exception.CreateFmt(CPE_TypeIsUnknown, [MethType]);
    SetType(typSym);
  end;

  if (Kind = fkFunction) and (MethType = '') then
    raise Exception.Create(CPE_ResultTypeExpected);

  GenerateParams(Table, MethParams);

  if Assigned(meth) then
    SetOverlap(TMethodSymbol(meth));

  if Attributes = [maVirtual] then
    FIsVirtual := True
  else if Attributes = [maVirtual, maAbstract] then
  begin
    FIsVirtual := True;
    FIsAbstract := True;
  end
  else if Attributes = [maOverride] then
  begin
    if FIsOverlap then
      SetOverride(TMethodSymbol(meth))
    else
      raise Exception.CreateFmt(CPE_CanNotOverride, [Name]);
  end
  else if Attributes = [maReintroduce] then
  else if Attributes = [] then
  else
    raise Exception.Create(CPE_InvalidArgCombination);
end;

function TMethodSymbol.GetIsClassMethod: Boolean;
begin
  result := not Assigned(FSelfSym);
end;

procedure TMethodSymbol.InitData(Dat: TData; Offset: Integer);
const
  nilIntf: IUnknown = nil;
begin
  inherited;
  if Size = 2 then
    Dat[Offset + 1] := nilIntf;
end;

function TMethodSymbol.IsCompatible(typSym: TSymbol): Boolean;
begin
  result := inherited IsCompatible(typSym);
end;

procedure TMethodSymbol.SetOverlap(meth: TMethodSymbol);
begin
  FParentMeth := meth;
  FIsOverride := False;
  FIsOverlap := True;
end;

procedure TMethodSymbol.SetOverride(meth: TMethodSymbol);
begin
  FParentMeth := meth;
  FIsOverride := True;
  FIsVirtual := True;
  FIsOverlap := False;
end;

{ TPropertySymbol }

procedure TPropertySymbol.AddParam(Param: TParamSymbol);
begin
  ArrayIndices.AddSymbol(Param);
end;

constructor TPropertySymbol.Create(Name: string; Typ: TSymbol);
begin
  inherited;
  FArrayIndices := TSymbolTable.Create;
  FIndexValue := nil;
end;

destructor TPropertySymbol.Destroy;
begin
  FArrayIndices.Free;
  inherited;
end;

procedure TPropertySymbol.GenerateParams(Table: TSymbolTable; FuncParams: TParamList);
begin
  dws2Symbols.GenerateParams(Name,Table,FuncParams,AddParam);
end;

function TPropertySymbol.GetCaption: string;
begin
  Result := GetDescription;
end;

function TPropertySymbol.GetDescription: string;
var
  x: Integer;
  indexDesc: string;
begin
  if ArrayIndices.Count > 0 then
  begin
    indexDesc := '';
    for x := 0 to ArrayIndices.Count - 1 do
    begin
      if x = 0 then
        indexDesc := Format('%s: %s', [ArrayIndices[x].Name, ArrayIndices[x].Typ.Name])
      else
        indexDesc := Format('%s, %s: %s', [indexDesc, ArrayIndices[x].Name, ArrayIndices[x].Typ.Name]);
    end;
    Result := Format('property %s[%s]: %s', [Name, indexDesc, Typ.Name])
  end
  else
    Result := Format('property %s: %s', [Name, Typ.Name]);

  if Assigned(FReadSym) then
    Result := Result + ' read ' + FReadSym.Name;

  if Assigned(FWriteSym) then
    Result := Result + ' write ' + FWriteSym.Name;

  if ClassSymbol.DefaultProperty = Self then
    Result := Result + '; default';
end;

function TPropertySymbol.GetIsDefault: Boolean;
begin
  Result := ClassSymbol.DefaultProperty = Self;
end;

function TPropertySymbol.GetReadSym: TSymbol;
begin
  result := FReadSym;
end;

function TPropertySymbol.GetWriteSym: TSymbol;
begin
  result := FWriteSym;
end;

procedure TPropertySymbol.SetIndex(Data: TData; Addr: Integer; Sym: TSymbol);
begin
  FIndexSym := Sym;
  SetLength(FIndexValue,FIndexSym.Size);
  FIndexSym.CopyData(Data,Addr,FIndexValue,0);
end;

{ TClassSymbol }

constructor TClassSymbol.Create;
begin
  inherited Create(Name, nil);
  FSize := 1;
  FMembers := CreateMembersTable;
  FClassOfSymbol := TClassOfSymbol.Create('class of ' + Name, Self);
  FMembers.AddSymbol(TAliasSymbol.Create('Self',Self)); // private member ?!
end;

destructor TClassSymbol.Destroy;
begin
  FMembers.Free;
  FClassOfSymbol.Free;
  inherited;
end;

function TClassSymbol.CreateMembersTable: TSymbolTable;
begin
  result := TSymbolTable.Create(nil);
end;

procedure TClassSymbol.AddField(Sym: TFieldSymbol);
begin
  FMembers.AddSymbol(Sym);
  Sym.FClassSymbol := Self;

  Sym.FOffset := FInstanceSize;
  FInstanceSize := FInstanceSize + Sym.Typ.Size;
end;

procedure TClassSymbol.AddMethod(Sym: TMethodSymbol);
var
  x: Integer;
begin
  FMembers.AddSymbol(Sym);
  sym.FClassSymbol := Self;

  // Check if class is abstract or not
  if Sym.IsAbstract then
    FIsAbstract := True
  else if Sym.IsOverride and Sym.FParentMeth.IsAbstract then
  begin
    FIsAbstract := False;
    for x := 0 to FMembers.Count - 1 do
      if (FMembers[x] is TMethodSymbol) and (TMethodSymbol(FMembers[x]).IsAbstract) then
      begin
        FIsAbstract := True;
        break;
      end;
  end;
end;

procedure TClassSymbol.AddProperty(Sym: TPropertySymbol);
begin
  FMembers.AddSymbol(Sym);
  sym.FClassSymbol := Self;
end;

procedure TClassSymbol.InitData(Dat: TData; Offset: Integer);
const
  nilIntf: IUnknown = nil;
begin
  Dat[Offset] := IUnknown(nilIntf);
end;

procedure TClassSymbol.Initialize;
var
  x: Integer;
  Err: EClassMethodImplIncompleteError;
begin
  // Check validity of the class declaration

  if FIsForward then
    raise Exception.CreateFmt(CPE_ClassNotCompletelyDefined, [Caption]);

  for x := 0 to FMembers.Count - 1 do
    if FMembers[x] is TMethodSymbol then
    begin
      if not TMethodSymbol(FMembers[x]).IsAbstract then
      begin
        if Assigned(TMethodSymbol(FMembers[x]).FExecutable) then
          TMethodSymbol(FMembers[x]).FExecutable.Initialize
        else
        begin
          Err := EClassMethodImplIncompleteError.CreateFmt(CPE_MethodNotImplemented,
            [FMembers[x].Caption, TMethodSymbol(FMembers[x]).ClassSymbol.Caption]);
          Err.ClassSymObj := Self;
          raise Err;
        end;
      end;
    end;
end;

procedure TClassSymbol.InheritFrom(Typ: TClassSymbol);
begin
  FMembers.AddParent(Typ.Members);
  FInstanceSize := Typ.InstanceSize;
  FParent := Typ;
end;

function TClassSymbol.IsCompatible(typSym: TSymbol): Boolean;
var
  csym: TClassSymbol;
begin
  Result := False;
  typSym := typSym.BaseType;
  if typSym is TNilSymbol then
    Result := True
  else if typSym is TClassSymbol then
  begin
    csym := TClassSymbol(typSym);
    while csym <> nil do
    begin
      if csym = Self then
      begin
        Result := True;
        exit;
      end;
      csym := csym.Parent;
    end;
  end;
end;

function TClassSymbol.GetDescription: string;
var
  i: Integer;
begin
  if FParent <> nil then
    Result := Name + ' = class (' + FParent.Name + ')'#13#10
  else
    Result := Name + ' = class'#13#10;

  for i := 0 to Members.Count - 1 do
    Result := Result + '   ' + Members.Symbols[i].Description + ';'#13#10;

  Result := Result + 'end';
end;

function TClassSymbol.InstanceSize: Integer;
begin
  result := FInstanceSize;
end;

{ TNilSymbol }

constructor TNilSymbol.Create;
begin
  inherited Create('', nil);
  FSize := 1;
end;

function TNilSymbol.GetCaption: string;
begin
  Result := 'nil';
end;

function TNilSymbol.IsCompatible(TypSym: TSymbol): Boolean;
begin
  typSym := typSym.BaseType;
  Result := (TypSym is TClassSymbol) or (TypSym is TNilSymbol);
end;

{ TClassOfSymbol }

constructor TClassOfSymbol.Create;
begin
  inherited Create(Name, Typ);
end;

function TClassOfSymbol.GetCaption: string;
begin
  if Typ <> nil then
    Result := 'class of ' + Typ.Name
  else
    Result := 'class of ???';
end;

procedure TClassOfSymbol.InitData(Dat: TData; Offset: Integer);
begin
  Dat[Offset] := '';
end;

function TClassOfSymbol.IsCompatible(typSym: TSymbol): Boolean;
begin
  typSym := typSym.BaseType;
  Result := (typSym is TClassOfSymbol) and Typ.IsCompatible(typSym.Typ);
end;

function IsBaseTypeCompatible(AType, BType: TBaseTypeId): Boolean;
const
{(*}
  compatiblityMask: array[1..7, 1..7] of Boolean =
  (
   //int    flt    str    bool   dt     var   conn
    (true,  false, false, false, false, true, true), // int
    (false, true,  false, false, false, true, true), // flt
    (false, false, true,  false, false, true, true), // str
    (false, false, false, true,  false, true, true), // bool
    (false, false, false, false, true,  true, true), // dt
    (true,  true,  true,  true,  true,  true, true), // var
    (true,  true,  true,  true,  true,  true, true)  // conn
  );
{*)}
begin
  Result := compatiblityMask[AType, BType];
end;

{ TBaseSymbol }

constructor TBaseSymbol.Create(Name: string; Id: Integer; Default: Variant);
begin
  inherited Create(Name, nil);
  FId := Id;
  FDefault := Default;
  FSize := 1;
end;

procedure TBaseSymbol.InitData(Dat: TData; Offset: Integer);
begin
  VarCopy(Dat[Offset], FDefault);
end;

function TBaseSymbol.IsCompatible(typSym: TSymbol): Boolean;
begin
  typSym := typSym.BaseType;
  if typSym is TEnumerationSymbol then
    typSym := TEnumerationSymbol(typSym).Typ.BaseType;
  Result := (typSym is TBaseSymbol) and
    IsBaseTypeCompatible(Self.FId, TBaseSymbol(typSym).FId);
end;

{ TConnectorSymbol }

constructor TConnectorSymbol.Create(Name: string; ConnectorType: IConnectorType);
begin
  inherited Create(Name, typConnectorID, Null);
  FConnectorType := ConnectorType;
end;

procedure TConnectorSymbol.InitData(Dat: TData; Offset: Integer);
begin
  VarClear(Dat[Offset]);
end;

{ TValueSymbol }

function TValueSymbol.GetCaption: string;
begin
  Result := FName + ': ' + FTyp.Caption;
end;

function TValueSymbol.GetDescription: string;
begin
  Result := FName + ': ' + FTyp.Description;
end;

{ TConstSymbol }

constructor TConstSymbol.Create(Name: string; Typ: TSymbol; const Value: Variant);
begin
  inherited Create(Name, Typ);
  SetLength(FData, 1);
  VarCopy(FData[0], Value);
end;

constructor TConstSymbol.Create(Name: string; Typ: TSymbol; Data: TData;
  Addr: Integer);
begin
  inherited Create(Name, Typ);
  SetLength(FData, Typ.Size);
  Typ.CopyData(Data,Addr,FData,0);
end;

function TConstSymbol.GetCaption: string;
begin
  Result := 'const ' + inherited GetCaption;
end;

function TConstSymbol.GetDescription: string;
begin
  if VarType(FData[0]) = varError then
    Result := 'const ' + inherited GetDescription + ' = [varError]'
  else
    Result := 'const ' + inherited GetDescription + ' = ' + VarToStr(FData[0]);
end;

procedure TConstSymbol.Initialize;
begin
end;

{ TMemberSymbol }

procedure TMemberSymbol.InitData(Dat: TData; Offset: Integer);
begin
  Typ.InitData(Dat, Offset);
end;

{ TDataSymbol }

function TDataSymbol.GetDescription: string;
begin
  if Assigned(FTyp) then
    Result := FName + ': ' + FTyp.Name
  else
    Result := FName;
end;

procedure TDataSymbol.InitData(Dat: TData; Offset: Integer);
begin
  Typ.InitData(Dat, Offset);
end;

{ TParamSymbol }

function TParamSymbol.GetDescription: string;
begin
  if Typ <> nil then
    Result := Name + ': ' + Typ.Name
  else
    Result := Name + ': ???';

  // Has a default parameter. Format display of param to show it.
  if Length(FDefaultValue) > 0 then
    if VarType(FDefaultValue[0]) = varString then    // does not support OLE types
      Result := Result + ' = ''' + VarToStr(FDefaultValue[0]) + ''''  // put quotes around value
    else
      Result := Result + ' = ' + VarToStr(FDefaultValue[0]);
end;

procedure TParamSymbol.SetDefaultValue(Data: TData; Addr: Integer);
begin
  SetLength(FDefaultValue,Typ.Size);
  Typ.CopyData(Data,Addr,FDefaultValue,0);
end;

procedure TParamSymbol.SetDefaultValue(const Value: Variant);