dws2comp.pas

script language

      if not (Func as TMethodSymbol).IsClassMethod then
        scriptObj := info.Vars['Self'].ScriptObj;

      info.ScriptObj := scriptObj;

      if Assigned(scriptObj) then
        FOnEval(info, scriptObj.ExternalObject)
      else
        FOnEval(info, nil);

    finally
      info.Free;
    end;
  end;
end;

procedure Tdws2Method.Assign(Source: TPersistent);
begin
  inherited;
  if Source is Tdws2Method then
  begin
    FAttributes := Tdws2Method(Source).Attributes;
    FKind := Tdws2Method(Source).Kind;
    FResultType := Tdws2Method(Source).ResultType;
  end;
end;

{ Tdws2Constructor }

procedure Tdws2Constructor.Assign(Source: TPersistent);
begin
  inherited;
  if Source is Tdws2Method then
    FAttributes := Tdws2Method(Source).Attributes;
end;

procedure Tdws2Constructor.Call(Caller: TProgram; Func: TFuncSymbol);
var
  info: TProgramInfo;
  extObj: TObject;
  scriptObj: IScriptObj;
begin
  info := TProgramInfo.Create(Func.Params, Caller);
  try
    info.FuncSym := Func;

    scriptObj := info.Vars['Self'].ScriptObj;
    info.ScriptObj := scriptObj;

    if Assigned(FOnAssignExternalObject) then
      if Assigned(scriptObj) then
      begin
        extObj := scriptObj.ExternalObject; // may assigned by Info.GetConstructor()
        FOnAssignExternalObject(info, extObj);
        scriptObj.ExternalObject := extObj;
      end;

    if Assigned(FOnEval) then
    begin
      if Assigned(scriptObj) then
        FOnEval(info, scriptObj.ExternalObject)
      else
        FOnEval(info, nil);
    end
  finally
    info.Free;
  end;
end;

constructor Tdws2Constructor.Create(Collection: TCollection);
begin
  inherited;
  // Name the first constructor "Create" by default
  if Collection.Count = 1 then
    FName := 'Create';
end;

function Tdws2Constructor.DoGenerate(Table: TSymbolTable;
  ParentSym: TSymbol): TSymbol;
begin
  FIsGenerating := True;
  CheckName(TClassSymbol(ParentSym).Members, Name);

  Result := TMethodSymbol.Generate(Table, mkConstructor, Attributes, Name,
    GetParameters(Table), '', TClassSymbol(ParentSym));
  try
    TFuncSymbol(Result).Params.AddParent(Table);
    TMethodSymbol(Result).Executable := ICallable(Self);
  except
    Result.Free;
    raise;
  end;
end;

function Tdws2Constructor.GetDisplayName: string;
begin
  Result := Parameters.GetDisplayName;

  if Result <> '' then
    Result := '(' + Result + ')';

  Result := Format('constructor %s%s;', [Name, Result]);
end;

function Tdws2Constructor.GetResultType: string;
begin
  // Hides the property "ResultType" in the object inspector
  Result := '';
end;

{ Tdws2Class }

procedure Tdws2Class.Assign(Source: TPersistent);
begin
  inherited;
  if Source is Tdws2Class then
  begin
    FAncestor := Tdws2Class(Source).Ancestor;
    FFields.Assign(Tdws2Class(Source).Fields);
    FMethods.Assign(Tdws2Class(Source).Methods);
    FProperties.Assign(Tdws2Class(Source).Properties);
  end;
end;

constructor Tdws2Class.Create(Collection: TCollection);
begin
  inherited;
  FFields := Tdws2Fields.Create(Self);
  FConstructors := Tdws2Constructors.Create(Self);
  FMethods := Tdws2Methods.Create(Self);
  FProperties := Tdws2Properties.Create(Self);
end;

destructor Tdws2Class.Destroy;
begin
  FFields.Free;
  FConstructors.Free;
  FMethods.Free;
  FProperties.Free;
  inherited;
end;

function Tdws2Class.DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil):
  TSymbol;
var
  x: Integer;
  ancestorSym: TClassSymbol;
begin
  FIsGenerating := True;

  Result := GetUnit.Table.FindSymbol(Name);

  if Assigned(Result) then
  begin
    if Result is TClassSymbol then
    begin
      if not TClassSymbol(Result).IsForward then
        raise Exception.Create(UNT_ClassAlreadyDefined);
    end
    else
      raise Exception.CreateFmt(UNT_ClassNameAlreadyDefined, [Name,
        Result.Caption]);
  end;

  try

    if not Assigned(Result) then
      Result := TClassSymbol.Create(Name);

    TClassSymbol(Result).OnObjectDestroy := FOnObjectDestroy;

    if FAncestor = '' then
      FAncestor := SYS_TOBJECT;

    ancestorSym := TClassSymbol(GetUnit.GetSymbol(Table, FAncestor));
    if ancestorSym = nil then
      raise Exception.CreateFmt(UNT_SuperClassUnknwon, [FAncestor]);

    TClassSymbol(Result).InheritFrom(ancestorSym);

    for x := 0 to FFields.Count - 1 do
      TClassSymbol(Result).AddField(TFieldSymbol(Tdws2Field(FFields.Items[x]).Generate(Table, Result)));

    for x := 0 to FConstructors.Count - 1 do
      TClassSymbol(Result).AddMethod(TMethodSymbol(Tdws2Constructor(FConstructors.Items[x]).Generate(Table, Result)));

    for x := 0 to FMethods.Count - 1 do
      TClassSymbol(Result).AddMethod(TMethodSymbol(Tdws2Method(FMethods.Items[x]).Generate(Table, Result)));

    for x := 0 to FProperties.Count - 1 do
      TClassSymbol(Result).AddProperty(TPropertySymbol(Tdws2Property(FProperties.Items[x]).Generate(Table, Result)));

  except
    if not TClassSymbol(Result).IsForward then
      Result.Free;
    raise;
  end;

  if TClassSymbol(Result).IsForward then
    TClassSymbol(Result).IsForward := false
      // The symbol is already in the symbol table
  else
    GetUnit.Table.AddSymbol(Result);
end;

function Tdws2Class.GetDisplayName: string;
begin
  if Ancestor <> '' then
    Result := Name + ' (' + Ancestor + ')'
  else
    Result := Name + ' (TObject)';
end;

{ Tdws2Member }

function Tdws2Member.DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil):
  TSymbol;
begin
  FIsGenerating := True;
  CheckName(TRecordSymbol(ParentSym).Members, Name);
  Result := TMemberSymbol.Create(Name, GetDataType(Table, DataType));
end;

{ Tdws2Record }

procedure Tdws2Record.Assign(Source: TPersistent);
begin
  inherited;
  if Source is Tdws2Record then
    FMembers := Tdws2Record(Source).Members;
end;

constructor Tdws2Record.Create;
begin
  inherited;
  FMembers := Tdws2Members.Create(Self);
end;

destructor Tdws2Record.Destroy;
begin
  FMembers.Free;
  inherited;
end;

function Tdws2Record.DoGenerate;
var
  x: Integer;
begin
  FIsGenerating := True;
  CheckName(Table, Name);

  Result := TRecordSymbol.Create(Name);
  try
    for x := 0 to FMembers.Count - 1 do
      TRecordSymbol(Result).AddMember(TMemberSymbol(Tdws2Member(FMembers.Items[x]).Generate(Table, Result)));
    GetUnit.Table.AddSymbol(Result);
  except
    Result.Free;
    raise;
  end;
end;

function Tdws2Record.GetDisplayName: string;
begin
  Result := 'Record ' + Name;
end;

{ Tdws2Array }

procedure Tdws2Array.Assign(Source: TPersistent);
begin
  inherited;
  if Source is Tdws2Array then
  begin
    FDataType := Tdws2Array(Source).DataType;
    FLowBound :=  Tdws2Array(Source).LowBound;
    FHighBound :=  Tdws2Array(Source).HighBound;
  end;
end;

function Tdws2Array.DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil):
  TSymbol;
begin
  FIsGenerating := True;
  CheckName(Table, Name);
  if IsDynamic then
    Result := TDynamicArraySymbol.Create(Name, GetDataType(Table, DataType))
  else
  begin
    if LowBound > HighBound then
      raise Exception.Create(UNT_InvalidArrayBounds);
    Result := TArraySymbol.Create(Name, LowBound, HighBound, GetDataType(Table,
      DataType));
  end;
  GetUnit.Table.AddSymbol(Result);
end;

function Tdws2Array.GetBoundStored: Boolean;
begin
  result := not IsDynamic;
end;

function Tdws2Array.GetDisplayName: string;
begin
  if IsDynamic then
    Result := Format('%s = array of %s', [Name, DataType])
  else
    Result := Format('%s = array [%d .. %d] of %s', [Name, LowBound, HighBound,
      DataType]);
end;

function Tdws2Array.GetIsDynamic: Boolean;
begin
  result := (FLowBound = 0) and (FHighBound = -1);
end;

procedure Tdws2Array.SetIsDynamic(const Value: Boolean);
begin
  if Value then
  begin
    FLowBound := 0;
    FHighBound := -1;
  end
  else if IsDynamic then
    FHighBound := 0;
end;

{ Tdws2Property }

procedure Tdws2Property.Assign(Source: TPersistent);
begin
  inherited;
  if Source is Tdws2Property then
  begin
    FDataType := Tdws2Property(Source).DataType;
    FReadAccess := Tdws2Property(Source).ReadAccess;
    FWriteAccess := Tdws2Property(Source).WriteAccess;
    FParameters.Assign(Tdws2Property(Source).Parameters);
    FIsDefault := Tdws2Property(Source).IsDefault;
  end;
end;

constructor Tdws2Property.Create(Collection: TCollection);
begin
  inherited;
  FParameters := Tdws2Parameters.Create(Self);
end;

destructor Tdws2Property.Destroy;
begin
  FParameters.Free;
  inherited;
end;

function Tdws2Property.DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil):
  TSymbol;
var
  sym: TSymbol;
  propSym: TPropertySymbol;
  indexData: TData;
begin
  FIsGenerating := True;

  propSym := TPropertySymbol.Create(Name, GetDataType(Table, DataType));
  Result := PropSym;

  propSym.GenerateParams(Table,GetParameters(Self, Parameters, Table));

  if FReadAccess <> '' then
  begin
    // ReadAccess
    sym := TClassSymbol(ParentSym).Members.FindLocal(FReadAccess);

    if not Assigned(sym) then
      raise Exception.CreateFmt(UNT_ReadAccessNotFound, [ReadAccess]);

    propSym.ReadSym := sym;
  end;

  if FWriteAccess <> '' then
  begin
    // WriteAccess
    sym := TClassSymbol(ParentSym).Members.FindLocal(FWriteAccess);

    if not Assigned(sym) then
      raise Exception.CreateFmt(UNT_WriteAccessNotFound, [WriteAccess]);

    propSym.WriteSym := sym;
  end;

  if FIndexType <> '' then
  begin
    SetLength(indexData,1);
    indexData[0] := FIndexValue;
    propSym.SetIndex(indexData,0,GetDataType(Table, IndexType));
  end;

  if IsDefault then
    TClassSymbol(ParentSym).DefaultProperty := propSym;
end;

function Tdws2Property.GetDisplayName: string;
var
  Params: string;
  Index : String;
begin
  if FParameters.Count > 0 then
    Params := '[' + FParameters.GetDisplayName + ']';
  if IndexType <> '' then
    Index := Format(' index %s',[ValueToString(IndexValue)]);
  if (ReadAccess = '') and (WriteAccess = '') then
    Result := Format('property %s%s: %s%s;', [Name, Params, DataType, Index])
  else if (ReadAccess = '') and (WriteAccess <> '') then
    Result := Format('property %s%s: %s%s write %s;', [Name, Params, DataType, Index, WriteAccess])
  else if (ReadAccess <> '') and (WriteAccess = '') then
    Result := Format('property %s%s: %s%s read %s;', [Name, Params, DataType, Index, ReadAccess])
  else
    Result := Format('property %s%s: %s%s read %s write %s;', [Name, Params, DataType, Index,
      ReadAccess, WriteAccess]);
  if IsDefault then
    Result := Result + ' default;';
end;

function Tdws2Property.GetIsDefault: Boolean;
begin
  result := FIsDefault and (Parameters.Count > 0);
end;

procedure Tdws2Property.SetIsDefault(Value: Boolean);
var
  i: Integer;
  properties: Tdws2Properties;
begin
  Value := Value and (Parameters.Count > 0);
  if IsDefault <> Value then
  begin
    FIsDefault := Value;
    if FIsDefault then
    begin
      properties :