dws2comp.pas

script language

begin
  if Count > 0 then
  begin
    Result := Items[0].GetDisplayName;
    for i := 1 to Count - 1 do
      Result := Result + '; ' + Items[i].GetDisplayName;
  end
  else
    Result := '';
end;

class function Tdws2Variables.GetSymbolClass: Tdws2SymbolClass;
begin
  result := Tdws2Global;
end;

{ Tdws2Global }

function Tdws2Global.DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil):
  TSymbol;
var
  typSym: TTypeSymbol;
  readEventFunc: TReadVarEventFunc;
  writeEventFunc: TWriteVarEventFunc;
  readFunc: TReadVarFunc;
  funcSym: TFuncSymbol;
begin
  FIsGenerating := True;
  CheckName(Table, Name);

  // Get the type symbol of this variable
  typSym := GetDataType(Table, DataType);

  if (Assigned(FOnReadVar) or Assigned(FOnWriteVar)) then
  begin
    Result := TExternalVarSymbol.Create(Name, typSym);

    if Assigned(FOnReadVar) then
    begin
      funcSym := TFuncSymbol.Create('', fkFunction, 1);
      funcSym.Typ := typSym;

      readEventFunc := TReadVarEventFunc.Create(funcSym);
      readEventFunc.OnReadVar := FOnReadVar;

      funcSym.Executable := ICallable(readEventFunc);

      TExternalVarSymbol(Result).ReadFunc := funcSym;
    end;

    if Assigned(FOnWriteVar) then
    begin
      funcSym := TFuncSymbol.Create('', fkProcedure, 1);
      funcSym.AddParam(TParamSymbol.Create('Value', typSym));

      writeEventFunc := TWriteVarEventFunc.Create(funcSym);
      writeEventFunc.OnWriteVar := FOnWriteVar;

      funcSym.Executable := ICallable(writeEventFunc);

      TExternalVarSymbol(Result).WriteFunc := funcSym;
    end;
  end
  else
  begin
    Result := TExternalVarSymbol.Create(Name, typSym);

    funcSym := TFuncSymbol.Create('', fkFunction, 1);
    funcSym.Typ := typSym;

    readFunc := TReadVarFunc.Create(funcSym);
    TExternalVarSymbol(Result).ReadFunc := funcSym;

    funcSym := TFuncSymbol.Create('', fkProcedure, 1);
    funcSym.AddParam(TParamSymbol.Create('Value', typSym));
    TWriteVarFunc.Create(funcSym, readFunc);
    TExternalVarSymbol(Result).WriteFunc := funcSym;
  end;

  GetUnit.Table.AddSymbol(Result);
end;

procedure Tdws2Global.Assign(Source: TPersistent);
begin
  inherited;
  if Source is Tdws2Global then
  begin
    FOnReadVar := Tdws2Global(Source).OnReadVar;
    FOnWriteVar := Tdws2Global(Source).OnWriteVar;
  end;
end;

{ TInstantiateFunc }

procedure TInstantiateFunc.Execute;
var
  scriptObj: TScriptObj;
  extObj: TObject;
begin
  if Assigned(FScriptObj) then
    // Instance was already created
    Info.Result := FScriptObj
  else
  begin
    // First access to this variable. Create object instance!
    scriptObj := TScriptObj.Create(FClassSym{, Info.Caller});
    scriptObj.OnObjectDestroy := FOnObjectDestroy;
    FScriptObj := scriptObj;

    FOnInstantiate(extObj);
    FScriptObj.ExternalObject := extObj;

    Info.Result := FScriptObj;
  end;
end;

procedure TInstantiateFunc.Initialize;
begin
  inherited;
  if Assigned(FOnInitialize) then
    FOnInitialize(Self);
end;

function TInstantiateFunc.Optimize(FuncExpr: TExprBase): TExprBase;
begin
  if Assigned(FOnOptimize) then
    result := FOnOptimize(Self,FuncExpr)
  else
    result := inherited Optimize(FuncExpr);
end;

procedure TInstantiateFunc.ReleaseObject;
begin
  FScriptObj := nil;
end;

{ Tdws2Parameter }

procedure Tdws2Parameter.Assign(Source: TPersistent);
begin
  inherited;
  if Source is Tdws2Parameter then
  begin
    FIsVarParam := Tdws2Parameter(Source).IsVarParam;
    FIsWritable := Tdws2Parameter(Source).IsWritable;
  end;
end;

constructor Tdws2Parameter.Create(Collection: TCollection);
begin
  inherited;
  FIsWritable := True;
  FIsVarParam := False;
  FDefaultValue := Unassigned;
  FHasDefaultValue := False;
end;

function Tdws2Parameter.DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil):
  TSymbol;
var ParamSym : TParamSymbol;
begin
  FIsGenerating := True;
  if IsVarParam then
    ParamSym := TVarParamSymbol.Create(Name, GetDataType(Table, DataType),IsWritable)
  else
    ParamSym := TParamSymbol.Create(Name, GetDataType(Table, DataType));
  if HasDefaultValue then
    ParamSym.SetDefaultValue(DefaultValue);
  Result := ParamSym;
end;

function Tdws2Parameter.GetDisplayName: string;
begin
  if IsVarParam then
    if IsWritable then
      Result := 'var ' + inherited GetDisplayName
    else
      Result := 'const ' + inherited GetDisplayName
  else
    Result := inherited GetDisplayName;
  if HasDefaultValue then
    Result := Result + Format(' = %s',[ValueToString(DefaultValue)]);
end;

procedure Tdws2Parameter.SetDefaultValue(const Value: Variant);
begin
  FDefaultValue := Value;
  FHasDefaultValue := not (FIsVarParam and FIsWritable);
end;

procedure Tdws2Parameter.SetHasDefaultValue(const Value: Boolean);
begin
  FHasDefaultValue := Value and not (FIsVarParam and FIsWritable);
end;

procedure Tdws2Parameter.SetIsVarParam(const Value: Boolean);
begin
  FIsVarParam := Value;
  if FIsVarParam and FIsWritable then
    FHasDefaultValue := False;
end;

procedure Tdws2Parameter.SetIsWritable(const Value: Boolean);
begin
  FIsWritable := Value;
  if FIsVarParam and FIsWritable then
    FHasDefaultValue := False;
end;

{ Tdws2Function }

constructor Tdws2Function.Create;
begin
  inherited;
  FParameters := Tdws2Parameters.Create(Self);
end;

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

procedure Tdws2Function.Call(Caller: TProgram; Func: TFuncSymbol);
var
  info: TProgramInfo;
begin
  if Assigned(FOnEval) then
  begin
    info := TProgramInfo.Create(Func.Params, Caller);
    try
      info.FuncSym := Func;
      FOnEval(info);
    finally
      info.Free;
    end;
  end;
end;

function Tdws2Function._AddRef: Integer;
begin
  Result := -1;
end;

function Tdws2Function._Release: Integer;
begin
  Result := -1;
end;

function Tdws2Function.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  Result := 0;
end;

function Tdws2Function.DoGenerate(Table: TSymbolTable; ParentSym: TSymbol = nil):
  TSymbol;
begin
  FIsGenerating := True;
  CheckName(Table, Name);

  if ResultType <> '' then
    GetDataType(Table, ResultType);

  Result := TFuncSymbol.Generate(Table, Name, GetParameters(Table), ResultType);
  try
    TFuncSymbol(Result).Params.AddParent(Table);

    // Connect Tdws2Function to TFuncSymbol
    TFuncSymbol(Result).Executable := ICallable(Self);
    GetUnit.Table.AddSymbol(Result);
  except
    Result.Free;
    raise;
  end;
end;

function GetParameters(Symbol: Tdws2Symbol;
  Parameters: Tdws2Parameters; Table: TSymbolTable): TParamList;
var
  x, y: Integer;
  name: string;
begin
  SetLength(Result, Parameters.Count);
  for x := 0 to Parameters.Count - 1 do
  begin
    name := Parameters.Items[x].Name;

    // Check wether parameter name is unique
    for y := x - 1 downto 0 do
    begin
      if SameText(Result[y].ParamName, name) then
        raise Exception.CreateFmt(UNT_ParameterNameAlreadyExists, [name]);
    end;

    Result[x].IsVarParam := Tdws2Parameter(Parameters.Items[x]).IsVarParam;
    Result[x].IsWritable := Tdws2Parameter(Parameters.Items[x]).IsWritable;
    Result[x].ParamName := name;
    Result[x].ParamType := Tdws2Parameter(Parameters.Items[x]).DataType;
    Result[x].HasDefaultValue := Tdws2Parameter(Parameters.Items[x]).HasDefaultValue;
    if Result[x].HasDefaultValue then
    begin
      SetLength(Result[x].DefaultValue,1);
      Result[x].DefaultValue[0] := Tdws2Parameter(Parameters.Items[x]).DefaultValue;
    end
    else
      Result[x].DefaultValue := nil;

    Symbol.GetUnit.GetSymbol(Table, Result[x].ParamType);
  end;
end;


function Tdws2Function.GetParameters(Table: TSymbolTable): TParamList;
begin
  result := dws2Comp.GetParameters(Self,Parameters,Table);
end;

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

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

  if ResultType = '' then
    Result := Format('procedure %s%s;', [Name, Result])
  else
    Result := Format('function %s%s : %s;', [Name, Result, ResultType]);
end;

procedure Tdws2Function.Initialize;
begin
  if Assigned(FOnInitialize) then
    FOnInitialize(Self);
end;

function Tdws2Function.Optimize(FuncExpr: TExprBase): TExprBase;
begin
  if Assigned(FOnOptimize) then
    result := FOnOptimize(Self,FuncExpr)
  else
    Result := FuncExpr;
end;

procedure Tdws2Function.Assign(Source: TPersistent);
begin
  inherited;
  if Source is Tdws2Function then
  begin
    FFuncType := Tdws2Function(Source).ResultType;
    FParameters.Assign(Tdws2Function(Source).Parameters);
  end;
end;

{ Tdws2Field }

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

{ Tdws2Method }

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

  if ResultType <> '' then
    GetUnit.GetSymbol(Table, ResultType);

  Result := TMethodSymbol.Generate(Table, Kind, Attributes, Name,
    GetParameters(Table), ResultType, TClassSymbol(ParentSym));
  try
    TFuncSymbol(Result).Params.AddParent(Table);

    TMethodSymbol(Result).Executable := ICallable(Self);
  except
    Result.Free;
    raise;
  end;
end;

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

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

  case FKind of
    mkProcedure:
      Result := Format('procedure %s%s;', [Name, Result]);
    mkFunction:
      Result := Format('function %s%s : %s;', [Name, Result, ResultType]);
    mkConstructor:
      Result := Format('constructor %s%s;', [Name, Result]);
    mkDestructor:
      Result := Format('destructor %s%s;', [Name, Result]);
    mkClassProcedure:
      Result := Format('class procedure %s%s;', [Name, Result]);
    mkClassFunction:
      Result := Format('class function %s%s : %s;', [Name, Result, ResultType]);
  else
    Assert(false); // if triggered, this func needs upgrade !
  end;
end;

procedure Tdws2Method.SetResultType(const Value: TDataType);
begin
  FResultType := Value;
  if Value <> '' then
    case FKind of
      mkProcedure:
        FKind := mkFunction;
      mkClassProcedure:
        FKind := mkClassFunction;
    end
  else
    case FKind of
      mkFunction:
        FKind := mkProcedure;
      mkClassFunction:
        FKind := mkClassProcedure;
    end;
end;

procedure Tdws2Method.Call(Caller: TProgram; Func: TFuncSymbol);
var
  info: TProgramInfo;
  scriptObj: IScriptObj;
begin
  if Assigned(FOnEval) then
  begin
    info := TProgramInfo.Create(Func.Params, Caller);
    try
      info.FuncSym := Func;