dws2compiler.pas.bak

script language

  i: Integer;
begin

  if not IsType then
  begin
    // Find Symbol for Functionname
    if not FTok.TestName then
      FMsgs.AddCompilerStop(FTok.HotPos, CPE_NameExpected);
    Name := FTok.GetToken.FString;
    funcPos := FTok.HotPos;
    FTok.KillToken;

    sym := FProg.Table.FindSymbol(Name);

    // Open context for procedure declaration. Closed in ReadProcBody.
    if coContextMap in FCompilerOptions then
      FProg.ContextMap.OpenContext(funcPos, sym);
  end
  else begin
    sym := nil;
    Name := '';
  end;

  // Name is the name of class -> Method
  if sym is TClassSymbol then
  begin
    // Store reference to class in dictionary
    if coSymbolDictionary in FCompilerOptions then
      FProg.SymbolDictionary.Add(sym, funcPos);
    Result := ReadMethodImpl(TClassSymbol(sym), FuncKind, IsClassMethod);
  end
  else
  begin
    // Read normal procedure/function declaration
    if IsClassMethod or (FuncKind = fkConstructor) or (FuncKind = fkDestructor) then
      FMsgs.AddCompilerStop(FTok.HotPos, CPE_ImplClassNameExpected);

    if (sym is TFuncSymbol) and TFuncSymbol(sym).IsForwarded then
      // There was already a (forward) declaration
      forwardedSym := TFuncSymbol(sym)
    else
      forwardedSym := nil;

    if not Assigned(forwardedSym) then
      CheckName(Name);

    if IsType then
      Result := TFuncSymbol.Create('', FuncKind, -1)
    else
      Result := TFuncSymbol.Create(Name, FuncKind,
        FProg.Stack.NextLevel(FProg.Level));
    try
      ReadParams(Result, forwardedSym=nil);  // Don't add params to dictionary when function is forwarded. It is already declared.

      if FuncKind = fkFunction then
      begin
        if not FTok.TestDelete(ttCOLON) then
          FMsgs.AddCompilerStop(FTok.HotPos, CPE_FunctionTypeExpected);
        Result.Typ := ReadType('');
      end;

      if not IsType then
      begin
        if Assigned(forwardedSym) then
          CompareFuncSymbols(forwardedSym, Result, True);

        // forward declarations
        if not Assigned(forwardedSym) then
        begin
          if FTok.Test(ttSEMI) then
          begin
            FTok.KillToken; // SEMI
            if FTok.Test(ttFORWARD) then
            begin
              Result.IsForwarded := True;
              FTok.TestDelete(ttFORWARD);
            end;
          end;
        end
        else if not FTok.TestDelete(ttSEMI) then
          FMsgs.AddCompilerStop(FTok.HotPos, CPE_SemiExpected);


        if Assigned(forwardedSym) then
        begin
          // Get forwarded position in script. If compiled without symbols it will just return from empty list (could optimize here to prevent the push/pop of call stack
          forwardedSymPos := FProg.SymbolDictionary.FindSymbolUsage(forwardedSym, suDeclaration);  // may be nil
          // Adapt dictionary entry to reflect that it was a forward
          // If the record is in the SymbolDictionary (disabled dictionary would leave pointer nil)
          if Assigned(forwardedSymPos) then
            forwardedSymPos.SymbolUsages := [suForward];  // update old postion to reflect that the type was forwarded

          Result.Free;
          Result := forwardedSym;
          Result.IsForwarded := False;
        end
        else
          FProg.Table.AddSymbol(Result);
      end
      else if FTok.TestDelete(ttOF) then
      begin
        if not FTok.TestDelete(ttOBJECT) then
          FMsgs.AddCompilerStop(FTok.HotPos, CPE_ObjectExpected);
        methSym := TMethodSymbol.Create('',FuncKind, FProg.TypObject,-1);
        methSym.Typ := Result.Typ;
        for i := 0 to Result.Params.Count - 1 do
          methSym.Params.AddSymbol(Result.Params[i]);
        Result.Params.Clear;
        Result.Free;
        Result := methSym;
      end;

      // Procedure is both Declared and Implemented here
      if coSymbolDictionary in FCompilerOptions then
        FProg.SymbolDictionary.Add(Result, funcPos, [suDeclaration, suImplementation]);
    except
      // Remove reference to symbol (gets freed)
      if coSymbolDictionary in FCompilerOptions then
        FProg.SymbolDictionary.Remove(Result);
      Result.Free;
      raise;
    end;
  end;
end;

function Tdws2Compiler.ReadMethodDecl(ClassSym: TClassSymbol; FuncKind: TFuncKind;
  IsClassMethod: Boolean): TMethodSymbol;

  function ParamsCheck(newMeth, oldMeth: TMethodSymbol): Boolean;
  var
    x: Integer;
  begin
    Result := False;
    if newMeth.Params.Count = oldMeth.Params.Count then
    begin
      for x := 0 to newMeth.Params.Count - 1 do
        if not newMeth.Params[x].Typ.IsCompatible(oldMeth.Params[x].Typ) then
          exit;
      Result := True;
    end;
  end;
var
  Name: string;
  meth: TSymbol;
  IsReintroduced: Boolean;
  methPos: TScriptPos;
begin
  // Find Symbol for Functionname
  if not FTok.TestName then
    FMsgs.AddCompilerStop(FTok.HotPos, CPE_NameExpected);
  Name := FTok.GetToken.FString;
  FTok.KillToken;

  methPos := FTok.HotPos;

  // Check if name is already used
  meth := ClassSym.Members.FindSymbol(Name);
  if meth is TFieldSymbol then
    FMsgs.AddCompilerStop(FTok.HotPos, Format(CPE_FieldRedefined, [Name]))
  else if meth is TPropertySymbol then
    FMsgs.AddCompilerStop(FTok.HotPos, Format(CPE_PropertyRedefined, [Name]))
  else if meth is TMethodSymbol then
  begin
    if TMethodSymbol(meth).ClassSymbol = ClassSym then
      FMsgs.AddCompilerStop(FTok.HotPos, Format(CPE_MethodRedefined, [Name]));
  end;

  // Read declaration of method implementation
  if IsClassMethod then
    Result := TMethodSymbol.Create(Name, FuncKind, ClassSym.ClassOf)
  else
    Result := TMethodSymbol.Create(Name, FuncKind, ClassSym);

  try
    if meth is TMethodSymbol then
    begin
      Result.SetOverlap(TMethodSymbol(meth));
      IsReintroduced := TMethodSymbol(meth).IsVirtual;
    end
    else
      IsReintroduced := False;

    ReadParams(Result);

    if FuncKind = fkFunction then
    begin
      if not FTok.TestDelete(ttCOLON) then
        FMsgs.AddCompilerStop(methPos, CPE_FunctionTypeExpected);
      Result.Typ := ReadType('');
    end
    else if FuncKind = fkConstructor then
      Result.Typ := ClassSym;

    if not FTok.TestDelete(ttSEMI) then
      FMsgs.AddCompilerStop(methPos, CPE_SemiExpected);

    if FTok.Test(ttVIRTUAL) or FTok.Test(ttOVERRIDE) or FTok.Test(ttREINTRODUCE) then
    begin
      if FTok.TestDelete(ttVIRTUAL) then
      begin
        TMethodSymbol(Result).IsVirtual := True;
        if FTok.Test(ttSEMI) and FTok.NextTest(ttABSTRACT) then
        begin
          FTok.KillToken;
          FTok.TestDelete(ttABSTRACT);
          TMethodSymbol(Result).IsAbstract := True;
        end;
      end
      else if FTok.TestDelete(ttOVERRIDE) then
      begin
        if not Assigned(meth) or not (meth is TMethodSymbol) then
          FMsgs.AddCompilerStop(methPos, Format(CPE_CantOverrideNotInherited, [Name]))
        else if not TMethodSymbol(meth).IsVirtual then
          FMsgs.AddCompilerStop(methPos, Format(CPE_CantOverrideNotVirtual, [Name]))
        else
        begin
          if not ParamsCheck(TMethodSymbol(Result), TMethodSymbol(meth)) then
            FMsgs.AddCompilerStop(FTok.HotPos, CPE_CantOverrideWrongParameterList);
          TMethodSymbol(Result).SetOverride(TMethodSymbol(meth));
          IsReintroduced := False;
        end;
      end
      else if FTok.TestDelete(ttREINTRODUCE) then
      begin
        if not IsReintroduced then
          FMsgs.AddCompilerStop(methPos, Format(CPE_CantReintroduce, [Name]));
        IsReintroduced := False;
      end;

      if not FTok.TestDelete(ttSEMI) then
        FMsgs.AddCompilerStop(FTok.HotPos, CPE_SemiExpected);
    end;

    if IsReintroduced then
      FMsgs.AddCompilerWarning(methPos, Format(CPE_ReintroduceWarning, [Name]));

    // Added as last step. OnExcept, won't need to be freed.
    if coSymbolDictionary in FCompilerOptions then
      FProg.SymbolDictionary.Add(Result, methPos, [suDeclaration]);
  except
    Result.Free;
    raise;
  end;
end;

function Tdws2Compiler.ReadMethodImpl(ClassSym: TClassSymbol;
  FuncKind: TFuncKind; IsClassMethod: Boolean): TMethodSymbol;
var
  methName: string;
  meth: TSymbol;
  methPos: TScriptPos;
begin
  if not (FTok.TestDelete(ttDOT) and FTok.TestName) then
    FMsgs.AddCompilerStop(FTok.HotPos, CPE_NameExpected);

  methName := FTok.GetToken.FString;
  methPos := FTok.HotPos;
  FTok.KillToken;
  FTok.Test(ttBLEFT);

  meth := ClassSym.Members.FindSymbol(methName);

  if not (meth is TMethodSymbol) then
    FMsgs.AddCompilerStop(methPos, CPE_ImplNotAMethod);

  if TMethodSymbol(meth).ClassSymbol <> ClassSym then
    FMsgs.AddCompilerStop(methPos, Format(CPE_ImplInvalidClass, [methName,
      ClassName]));

  if TMethodSymbol(meth).IsAbstract then
    FMsgs.AddCompilerError(methPos, Format(CPE_ImplAbstract, [ClassName, methName]));

  if TMethodSymbol(meth).IsClassMethod and not IsClassMethod then
    FMsgs.AddCompilerStop(methPos, CPE_ImplClassExpected)
  else if not TMethodSymbol(meth).IsClassMethod and IsClassMethod then
    FMsgs.AddCompilerStop(methPos, CPE_ImplNotClassExpected);

  Result := TMethodSymbol.Create(methName, FuncKind, ClassSym);
  try
    if not FTok.TestDelete(ttSEMI) then
    begin
      ReadParams(Result, False);  // Don't store these params to Dictionary. They will become invalid when the method is freed.

      if FuncKind = fkFunction then
      begin
        if not FTok.TestDelete(ttCOLON) then
          FMsgs.AddCompilerStop(FTok.HotPos, CPE_FunctionTypeExpected);
        Result.Typ := ReadType('');
      end;

      if not FTok.TestDelete(ttSEMI) then
        FMsgs.AddCompilerStop(FTok.HotPos, CPE_SemiExpected);

      CompareFuncSymbols(TMethodSymbol(meth), Result, True);
    end
    else
      CompareFuncSymbols(TMethodSymbol(meth), Result, False);
  finally
    Result.Free;
    Result := TMethodSymbol(meth);
    if coSymbolDictionary in FCompilerOptions then
      FProg.SymbolDictionary.Add(Result, methPos, [suImplementation]);
  end;
end;

procedure Tdws2Compiler.ReadProcBody(Proc: TFuncSymbol);
var
  x: Integer;
  oldprog: TProgram;
  stmt: TExpr;
  names: TStringList;
  typ: TSymbol;
  dataSym: TDataSymbol;
  initData: TData;
  pos: TScriptPos;
  PosArray: TScriptPosArray;
begin
  // Stop if declaration was forwarded or external
  if (TFuncSymbol(Proc).IsForwarded) then
  begin
    // Closed context of procedure (was only a forward)
    if coContextMap in FCompilerOptions then
      FProg.ContextMap.CloseContext(FTok.HotPos);
    Exit;
  end;

  // Open context of full procedure body (may include a 'var' section)
  if coContextMap in FCompilerOptions then
    FProg.ContextMap.OpenContext(FTok.CurrentPos, Proc);   // attach to symbol that it belongs to (perhaps a class)

  try
    // Funktion Body
    oldprog := FProg;
    FProg := TProcedure.Create(FProg);
    try
      TProcedure(FProg).AssignTo(Proc);
      // Set the current context's LocalTable to be the table of the new procedure
      if coContextMap in FCompilerOptions then
        FProg.ContextMap.Current.LocalTable := FProg.Table;

      // Read local variable declarations
      if FTok.TestDelete(ttVAR) then
      begin
        names := TStringList.Create;
        try
          // Read names of local variable
          repeat
            // Track Procedure local variables positions
            if coSymbolDictionary in FCompilerOptions then
              ReadNameList(names, PosArray)
            else
              ReadNameList(names);
            if not FTok.TestDelete(ttCOLON) then
              FMsgs.AddCompilerStop(FTok.HotPos, CPE_ColonExpected);

            // Read type of local variables
            pos := FTok.HotPos;
            typ := ReadType('');
            for x := 0 to names.Count - 1 do
            begin
              CheckName(names[x]);
              dataSym := TDataSymbol.Create(names[x], typ);
              FProg.Table.AddSymbol(dataSym);
              // Add local proc variable declarations
              if coSymbolDictionary in FCompilerOptions then
                FProg.SymbolDictionary.Add(dataSym, PosArray[x], [suDeclaration]);

              // Initialize with default value
              initData := nil;
              SetLength(initData, typ.Size);
              dataSym.initData(initData, 0);

              TBlockExpr(FProg.InitExpr).AddStatement(
                TAssignDataExpr.Create(FProg, pos,
                GetVarExpr(dataSym),
                TConstExpr.Create(FProg, pos, typ, initData)))
            end;

            if not FTok.TestDelete(ttSEMI) then
              FMsgs.AddCompilerStop(FTok.HotPos, CPE_SemiExpected);

          until FTok.Test(ttBEGIN);
        finally
          names.Free;
        end;
      end;

      if coContextMap in FCompilerOptions then