dws2compiler.pas.bak

script language

        FProg.ContextMap.OpenContext(FTok.CurrentPos, nil);
      try
        // Read procedure body
        if not FTok.TestDelete(ttBEGIN) then
          FMsgs.AddCompilerStop(FTok.HotPos, CPE_BeginExpected);

        // Read Statements enclosed in "begin" and "end"
        FProg.Expr := TBlockExpr.Create(FProg, FTok.HotPos);
        while not FTok.TestDelete(ttEND) do
        begin
          stmt := ReadRootStatement;
          if Assigned(stmt) then
            TBlockExpr(FProg.Expr).AddStatement(Stmt);
          if not FTok.TestDelete(ttSEMI) then
          begin
            if not FTok.Test(ttEND) then
              FMsgs.AddCompilerStop(FTok.HotPos, CPE_SemiExpected);
          end;
        end;
      finally
        if coContextMap in FCompilerOptions then
          FProg.ContextMap.CloseContext(FTok.HotPos);  // close with inside procedure end
      end;

      // Optimize procedure
      // ALu: TODO Optimize fails if procs called inside only declared and not defined yet  
      if coOptimize in FCompilerOptions then
        FProg.Expr := FProg.Expr.Optimize;

    finally
      FProg := oldprog;
    end;
  finally
    // Closed procedure body and procedure implementation (from declaration to body)
    if coContextMap in FCompilerOptions then
    begin
      FProg.ContextMap.CloseContext(FTok.CurrentPos);  // closed begin..end body (may include 'var' section)
      FProg.ContextMap.CloseContext(FTok.CurrentPos);  // closed from declaration through implementation
    end;
  end;
end;

function Tdws2Compiler.ReadBlocks(EndTokens: TTokenTypes; var FinalToken: TTokenType): TExpr;
var
  blk: TExpr;
  oldTable: TSymbolTable;
  x: Integer;
  closePos: TScriptPos; // Position at which the ending token was found (for context)
begin

  // Read a block of instructions enclosed in "begin" and "end"
  Result := TBlockExpr.Create(FProg, FTok.HotPos);
  try
    if coContextMap in FCompilerOptions then
    begin
      FProg.ContextMap.OpenContext(FTok.CurrentPos, nil);
      closePos := FTok.CurrentPos;     // default to close context where it openned (used on errors)
    end;
    oldTable := FProg.Table;
    FProg.Table := TBlockExpr(Result).Table;
    try
      // Add local table to context for the new block
      if coContextMap in FCompilerOptions then
        FProg.ContextMap.Current.LocalTable := FProg.Table;

      while True do
      begin

        if FTok.HasTokens then
        begin
          if FTok.GetToken.FTyp in EndTokens then
          begin
            FinalToken := FTok.GetToken.FTyp;
            closePos := FTok.GetToken.FPos;    // get start position of ending token
            FTok.KillToken;
            exit;
          end;
        end
        else
          FMsgs.AddCompilerStop(FTok.HotPos, CPE_EndOfBlockExpected);

        blk := ReadStatement;
        if Assigned(blk) then
          TBlockExpr(Result).AddStatement(blk);
        if not FTok.TestDelete(ttSEMI) then
        begin
          if not (FTok.GetToken.FTyp in EndTokens) then
            FMsgs.AddCompilerStop(FTok.HotPos, CPE_SemiExpected);
        end;
      end;
    finally
      FProg.Table := oldTable;
      if coContextMap in FCompilerOptions then
        FProg.ContextMap.CloseContext(closePos);   // get to end of block
    end;
  except
    // Remove any symbols in the expression's table. Table will be freed.
    if coSymbolDictionary in FCompilerOptions then
      for x := 0 to TBlockExpr(Result).Table.Count - 1 do
        FProg.SymbolDictionary.Remove(TBlockExpr(Result).Table[x]);
    Result.Free;
    raise;
  end;
end;

function Tdws2Compiler.ReadBlock: TExpr;
var
  tt: TTokenType;
begin
  Result := nil;
  if FTok.TestDelete(ttBEGIN) then
    Result := ReadBlocks([ttEND], tt)
  else if FTok.HasTokens then
    // Read a single instruction
    Result := ReadInstr;
end;

function Tdws2Compiler.ReadInstr: TExpr;
begin
  // Decide which instruction to read
  if FTok.TestDelete(ttIF) then
    Result := ReadIf
  else if FTok.TestDelete(ttCASE) then
    Result := ReadCase
  else if FTok.TestDelete(ttFOR) then
    Result := ReadFor
  else if FTok.TestDelete(ttWHILE) then
    Result := ReadWhile
  else if FTok.TestDelete(ttREPEAT) then
    Result := ReadRepeat
  else if FTok.TestDelete(ttTRY) then
    Result := ReadTry
  else if FTok.TestDelete(ttRAISE) then
    Result := ReadRaise
  else if FTok.TestDelete(ttBREAK) then
    Result := TBreakExpr.Create(FProg, FTok.HotPos)
  else if FTok.TestDelete(ttEXIT) then
    Result := TExitExpr.Create(FProg, FTok.HotPos)
  else if FTok.TestDelete(ttCONTINUE) then
    Result := TContinueExpr.Create(FProg, FTok.HotPos)
      // Try to read a function call, method call or an assignment
  else if FTok.Test(ttSWITCH) then
    Result := ReadInstrSwitch
  else if FTok.Test(ttBLEFT) or FTok.Test(ttINHERITED) or FTok.TestName  then // !! TestName must be the last !!
  begin
    if FTok.Test(ttBLEFT) then // (X as TY)
      Result := ReadSymbol(ReadTerm)
    else
      Result := ReadName(True);
    try
      if FTok.TestDelete(ttASSIGN) then
      begin
        if not (Result is TDataExpr) or not TDataExpr(Result).IsWritable then
          FMsgs.AddCompilerStop(FTok.HotPos, CPE_CantWriteToLeftSide);
        Result := ReadAssign(Result);
      end
      else if not (Result is TFuncExpr)
        and not (Result is TAssignExpr)
        and not (Result is TConnectorCallExpr)
        and not (Result is TConnectorWriteExpr)
        and not (Result is TStringArraySetExpr) then
        FMsgs.AddCompilerStop(FTok.HotPos, CPE_InvalidInstruction)
    except
      Result.Free;
      raise;
    end;
  end
  else
    Result := TNullExpr.Create(FProg, FTok.HotPos);

  if Assigned(Result) then
  try
    Result.TypeCheck;
  except
    Result.Free;
    raise;
  end;
end;

function Tdws2Compiler.ReadInherited(IsWrite: Boolean): TExpr;
var
  name: string;
  sym: TSymbol;
  methSym: TMethodSymbol;
  classSym, parentSym: TClassSymbol;
  varExpr: TDataExpr;
begin
  Result := nil;
  if not ((FProg is TProcedure) and (TProcedure(FProg).Func is TMethodSymbol)) then
    FMsgs.AddCompilerStop(FTok.HotPos, CPE_InheritedOnlyInMethodsAllowed);

  methSym := TMethodSymbol(TProcedure(FProg).Func);
  classSym := methSym.ClassSymbol;
  parentSym := ClassSym.Parent;
  sym := nil;

  if FTok.TestName then
  begin
    name := FTok.GetToken.FString;
    FTok.KillToken;

    sym := ParentSym.Members.FindSymbol(name);
  end
  else if not methSym.IsOverride then
    FMsgs.AddCompilerStop(FTok.HotPos, CPE_InheritedWithoutName)
  else
    sym := methSym.ParentMeth;

  if Assigned(sym) then
  begin
    if sym is TMethodSymbol then
    begin
      if methSym.IsClassMethod then
        varExpr := TConstExpr.Create(FProg, FTok.HotPos, parentSym.ClassOf, parentSym.Name)
      else
        varExpr := TVarExpr.Create(FProg, FTok.HotPos, parentSym, methSym.SelfSym);
      try
        if methSym.IsClassMethod then
          Result := GetMethodExpr(TMethodSymbol(sym),varExpr,rkClassOfRef,FTok.HotPos,True,True)
        else
          Result := GetMethodExpr(TMethodSymbol(sym),varExpr,rkObjRef,FTok.HotPos,True,True);
      except
        varExpr.Free;
        raise;
      end;
      try
        ReadFuncArgs(TFuncExpr(Result).AddArg);
        if TMethodSymbol(sym).Kind = fkConstructor then
          Result.Typ := methSym.ClassSymbol.Parent;
      except
        Result.Free;
        raise;
      end;
    end
    else if sym is TPropertySymbol then
    begin
      varExpr := TVarExpr.Create(FProg, FTok.HotPos, parentSym, methSym.SelfSym);
      try
        Result := ReadPropertyExpr(varExpr, TPropertySymbol(sym), IsWrite);
      except
        varExpr.Free;
        raise;
      end;
    end
    else
      FMsgs.AddCompilerStop(FTok.HotPos, CPE_InheritedWithoutName);
  end
  else
    FMsgs.AddCompilerStop(FTok.HotPos, Format(CPE_InheritedMethodNotFound, [Name]));
end;

function Tdws2Compiler.ReadName(IsWrite: Boolean): TExpr;
var
  name: string;
  sym: TSymbol;
  namePos: TScriptPos;
  varExpr: TDataExpr;
  progMeth: TMethodSymbol;
  baseType: TTypeSymbol;
begin
  Result := nil;

  if FTok.TestDelete(ttINHERITED) then
  begin
    // Name with inherited
    Result := ReadInherited(IsWrite);
    try
      Result := ReadSymbol(Result, IsWrite);
    except
      Result.Free;
      raise;
    end;
  end
  else
  begin
    // Get name
    FTok.TestName;
    name := FTok.GetToken.FString;
    namePos := FTok.HotPos;
    FTok.KillToken;

    // Find name in symboltable
    sym := FProg.Table.FindSymbol(Name);
    try

      baseType := GetBaseType(sym);

      // Add the symbol usage to Dictionary
      if coSymbolDictionary in FCompilerOptions then
        FProg.SymbolDictionary.Add(sym, namePos);

      // Unit prefix found
      if baseType is TUnitSymbol then
      begin
        if not FTok.TestDelete(ttDOT) then
          FMsgs.AddCompilerStop(FTok.HotPos, CPE_DotExpected);
        if not FTok.TestName then
          FMsgs.AddCompilerStop(FTok.HotPos, CPE_NameExpected);
        name := FTok.GetToken.FString;
        namePos := FTok.HotPos;   // reuse token pos variable
        FTok.KillToken;
        sym := TUnitSymbol(baseType).Table.FindLocal(Name);
        // Already added symbol usage of the unit. Now add for the unit's specified symbol.
        if coSymbolDictionary in FCompilerOptions then
          FProg.SymbolDictionary.Add(sym, namePos);
      end;

      if baseType is TEnumerationSymbol then
        baseType := TEnumerationSymbol(baseType).Typ.BaseType;

      if not Assigned(sym) then
        FMsgs.AddCompilerStop(FTok.HotPos, Format(CPE_UnknownName, [name]))
          // "Variables"
      else if sym is TVarParamSymbol then
        Result := ReadSymbol(GetVarParamExpr(TVarParamSymbol(sym)), IsWrite)
      else if sym is TConstSymbol then
        Result := ReadSymbol(TConstExpr.Create(FProg, FTok.HotPos, sym.Typ,
          TConstSymbol(sym).Data), IsWrite)
      else if sym is TDataSymbol then
      begin
        if sym.Typ is TFuncSymbol then
          Result := ReadFunc(TFuncSymbol(sym.Typ), IsWrite, GetVarExpr(TDataSymbol(sym)))
        else
          Result := ReadSymbol(GetVarExpr(TDataSymbol(sym)), IsWrite);
      end
      else if sym is TExternalVarSymbol then
        Result := ReadSymbol(ReadExternalVar(TExternalVarSymbol(sym), IsWrite),
          IsWrite)
          // OOP related stuff
      else if baseType is TClassSymbol then
      begin
        if FTok.TestDelete(ttBLEFT) then
        begin
          // Cast
          Result := ReadExpr;
          Result.Typ := sym;
          if not (FTok.TestDelete(ttBRIGHT)) then
            FMsgs.AddCompilerStop(FTok.HotPos, CPE_BrackRightExpected);
          Result := ReadSymbol(Result, IsWrite);
        end
        else
          Result := ReadSymbol(TConstExpr.Create(FProg, FTok.HotPos,
            TClassSymbol(baseType).ClassOf, sym.Name), IsWrite)
      end
      else if sym is TFieldSymbol then
      begin
        progMeth := TMethodSymbol(TProcedure(FProg).Func);
        if progMeth.IsClassMethod then
          FMsgs.AddCompilerStop(FTok.HotPos, CPE_ObjectReferenceExpected);
        varExpr := TVarExpr.Create(FProg, FTok.HotPos, progMeth.SelfSym.Typ, progMeth.SelfSym);
        try
          Result := ReadSymbol(ReadField(varExpr, TFieldSymbol(sym)), IsWrite);
        except
          varExpr.Free;
          raise;
        end;
      end
      else if sym is TPropertySymbol then
      begin
        progMeth := TMethodSymbol(TProcedure(FProg).Func);
        if progMeth.IsClassMethod then
          varExpr := TConstExpr.Create(FProg, FTok.HotPos, progMeth.ClassSymbol, nil)
        else
          varExpr := TVarExpr.Create(FProg, FTok.HotPos, progMeth.SelfSym.Typ, progMeth.SelfSym);
        try
          Result := ReadSymbol(ReadPropertyExpr(varExpr, TPropertySymbol(sym), IsWrite), IsWrite);
        except
          varExpr.Free;
          raise;
        end;
      end
      else if sym is TMethodSymbol then
      begin
        progMeth := TMethodSymbol(TProcedure(FProg).Func);
        if not progMeth.IsClassMethod then
          Result := GetMethodExpr(TMethodSymbol(sym), TVarExpr.Create(FProg,
            FTok.HotPos, progMeth.SelfSym.Typ, progMeth.SelfSym), rkObjRef, FTok.HotPos, IsWrite)
        else if (TMethodSymbol(sym).Kind = fkConstructor) or (TMethodSymbol(sym).IsClassMethod) then
          Result := GetMethodExpr(TMethodSymbol(sym), TConstExpr.Create(FProg,
            FTok.HotPos, progMeth.ClassSymbol,
            nil), rkClassOfRef, FTok.HotPos, IsWrite, True)
        else
          FMsgs.AddCompilerStop(FTok.HotPos, CPE_StaticMethodExpected);

        ReadFuncArgs(TFuncExpr(Result).AddArg);
        Result := ReadSymbol(Result, IsWrite);
      end
      // Functions/Procedures