dws2compiler.pas.bak

script language

        unitTables.Free;
      end;

    finally
      unitsResolved.Free;
    end;

    // Filter stuff
    if Assigned(FFilter) then
      Text := FFilter.Process(Text, FMsgs);

    // Initialize tokenizer
    FTok := TTokenizer.Create(Text, MSG_MainModule, FProg.Msgs);
    try
      FTok.SwitchHandler := ReadSwitch;

      // Start compilation
      FProg.Expr := ReadScript('', stMain);

      // Do some optimizations
      if coOptimize in FCompilerOptions then
        FProg.Expr := FProg.Expr.Optimize;

      // Initialize symbol table
      FProg.Table.Initialize;

      // Initialize the expressions
      FProg.Expr.Initialize;

      // Every thing is done, set program state to "prepared"
      FProg.ReadyToInitialize;
    finally
      FTok.Free;
    end;
  except
    on e: EScriptError do
      ;
    on e: EClassMethodImplIncompleteError do
      begin
        with codeCompleteInfo do
        begin
          if e.ClassSymObj is TClassSymbol then
            ErrorClass := TClassSymbol(e.ClassSymObj)
          else
            ErrorClass := nil;
          ErrorType := cceMethodImplMissing;
          SuggestedFix := '';
        end;
        FProg.AddClassCompleteInfo(codeCompleteInfo);
        FMsgs.AddCompilerError(e.Message);
      end;
    on e: Exception do
      FMsgs.AddCompilerError(e.Message);
  end;
end;

function Tdws2Compiler.ReadScript(AName: string; ScriptType: TScriptSourceType): TExpr;
var
  Stmt: TExpr;
begin
  Result := TBlockExpr.Create(FProg, FTok.DefaultPos);
  try
    FProg.SourceList.Add(AName, FTok.HotPos.SourceFile, ScriptType);
    while FTok.HasTokens do
    begin
      Stmt := ReadRootStatement;
      if Assigned(Stmt) then
        TBlockExpr(Result).AddStatement(Stmt);

      if not FTok.TestDelete(ttSEMI) then
      begin
        if FTok.HasTokens then
          FMsgs.AddCompilerStop(FTok.HotPos, CPE_SemiExpected);
      end;
    end;
  except
    Result.Free;
    raise;
  end;
end;

function Tdws2Compiler.ReadRootStatement: TExpr;
begin
  Result := nil;
  if FTok.TestDelete(ttTYPE) then
    ReadTypeDecl
  else if FTok.TestDelete(ttPROCEDURE) then
    ReadProcBody(ReadProcDecl(fkProcedure, nil))
  else if FTok.TestDelete(ttFUNCTION) then
    ReadProcBody(ReadProcDecl(fkFunction, nil))
  else if FTok.TestDelete(ttCONSTRUCTOR) then
    ReadProcBody(ReadProcDecl(fkConstructor, nil))
  else if FTok.TestDelete(ttDESTRUCTOR) then
    ReadProcBody(ReadProcDecl(fkDestructor, nil))
  else if FTok.TestDelete(ttCLASS) then
  begin
    if FTok.TestDelete(ttPROCEDURE) then
      ReadProcBody(ReadProcDecl(fkProcedure, nil, True))
    else if FTok.TestDelete(ttFUNCTION) then
      ReadProcBody(ReadProcDecl(fkFunction, nil, True))
    else
      FMsgs.AddCompilerStop(FTok.HotPos, CPE_ProcOrFuncExpected);
  end
  else
    Result := ReadStatement;
end;

function Tdws2Compiler.ReadStatement: TExpr;
begin
  Result := nil;
  if FTok.TestDelete(ttVAR) then
    Result := ReadVarDecl
  else if FTok.TestDelete(ttCONST) then
    ReadConstDecl
  else if FTok.TestDelete(ttUSES) then
    ReadUses
  else
    Result := ReadBlock;
end;

class function Tdws2Compiler.Evaluate(AContext: TProgram; AExpression: string): TExpr;
var
  OldProgMsgs: TMsgs;
begin
  { This will evaluate an expression by tokenizing it evaluating it in the
    Context provided. }
  with Self.Create do
    try
      FProg := AContext;
      try
        OldProgMsgs := FProg.Msgs;

        FMsgs := TMsgs.Create;
        FProg.Msgs := FMsgs;
        try
          FTok := TTokenizer.Create(AExpression, MSG_MainModule, FMsgs);
          try
            try
              Result := ReadExpr;
              Result.Initialize;
            except
              on E: EScriptError do
              begin
                if FMsgs.Count > 0 then
                begin
                  E.Message := FMsgs[0].AsString;
                  raise E;    // change the message and re-raise the EScriptError exception
                end;
              end;
            end;
          finally
            FreeAndNil(FTok);
          end;
        finally
          FProg.Msgs := OldProgMsgs;
          FreeAndNil(FMsgs);
        end;
      finally
        FProg := nil;
      end;
    finally
      Free;
    end;
end;

function Tdws2Compiler.ReadVarDecl: TExpr;
var
  x: Integer;
  names: TStringList;
  sym, typ: TSymbol;
  pos: TScriptPos;
  posArray: TScriptPosArray;
  vars: TList;
  initData: TData;
  initExpr: TExpr;
begin
  Result := nil;

  names := TStringList.Create;
  vars := TList.Create;
  initExpr := nil;
  try
    // Conditionally pass in dynamic array
    if coSymbolDictionary in FCompilerOptions then
      ReadNameList(names, posArray)     // use overloaded version
    else
      ReadNameList(names);

    if not FTok.TestDelete(ttCOLON) then
      FMsgs.AddCompilerStop(FTok.HotPos, CPE_ColonExpected);

    pos := FTok.HotPos;
    typ := ReadType('');

    for x := 0 to names.Count - 1 do
    begin
      CheckName(names[x]);
      sym := TDataSymbol.Create(names[x], typ);
      vars.Add(sym);
      FProg.Table.AddSymbol(sym);
      if coSymbolDictionary in FCompilerOptions then
        FProg.SymbolDictionary.Add(sym, posArray[x], [suDeclaration]);   // entry for variable
    end;

    if names.Count = 1 then
    begin
      if FTok.TestDelete(ttEQ) then
        initExpr := ReadExpr
    end;

    // Create variable initializations
    for x := 0 to vars.Count - 1 do
    begin
      sym := vars[x];

      if Assigned(initExpr) then
      begin
        // Initialize with an expression
        Result :=
          TAssignExpr.Create(FProg, pos,
          GetVarExpr(vars[x]),
          initExpr);
        initExpr := nil;

        try
          Result.TypeCheck;
        except
          Result.Free;
          raise;
        end;
      end
      else
      begin
        if sym.Typ is TArraySymbol then
        begin // TODO: if Sym.DynamicInit?
          TBlockExpr(FProg.InitExpr).AddStatement(
            TInitDataExpr.Create(FProg, Pos, GetVarExpr(vars[x]) as TDataExpr));
        end
        else
        begin
          // Initialize with default value
          initData := nil;
          SetLength(initData, sym.Typ.Size);
          TDataSymbol(sym).initData(initData, 0);

          TBlockExpr(FProg.InitExpr).AddStatement(
            TAssignDataExpr.Create(FProg, pos,
            GetVarExpr(vars[x]),
            TConstExpr.Create(FProg, pos, sym.Typ, initData)))
        end;
      end;
    end;
  finally
    initExpr.Free;
    names.Free;
    vars.Free;
  end;
end;

procedure Tdws2Compiler.ReadConstDecl;
var
  Name: string;
  Expr: TExpr;
  Typ: TSymbol;
  constPos: TScriptPos;
  sym: TSymbol;
begin
  if not FTok.TestName then
    FMsgs.AddCompilerStop(FTok.HotPos, CPE_NameExpected)
  else
  begin
    Name := FTok.GetToken.FString;
    constPos := FTok.HotPos;
    FTok.KillToken;

    CheckName(Name);

    if FTok.TestDelete(ttCOLON) then
      Typ := ReadType('')
    else
      Typ := nil;

    if Typ is TFuncSymbol then
      FMsgs.AddCompilerStop(FTok.HotPos, Format(CPE_InvalidConstType,[Typ.Caption]));

    if not FTok.TestDelete(ttEQ) then
      FMsgs.AddCompilerStop(FTok.HotPos, CPE_EqualityExpected);

    Expr := ReadExpr;
    try
      Expr.TypeCheck;
      Expr := Expr.Optimize;
      if not (Expr is TConstExpr) then
        FMsgs.AddCompilerStop(FTok.HotPos, CPE_ConstantExpressionExpected);

      if Assigned(Typ) then
      begin
        if not Typ.IsCompatible(Expr.Typ) then
          FMsgs.AddCompilerStop(FTok.HotPos, Format(CPE_AssignIncompatibleTypes, [Expr.Typ.Caption, Typ.Caption]));
      end
      else
        Typ := Expr.Typ;

      if Typ.Size > 1 then
        sym := TConstSymbol.Create(Name, Typ, TConstExpr(Expr).Data, TConstExpr(Expr).Addr)
      else
        sym := TConstSymbol.Create(Name, Typ, Expr.Eval);
      FProg.Table.AddSymbol(sym);
      if coSymbolDictionary in FCompilerOptions then
        FProg.SymbolDictionary.Add(sym, constPos, [suDeclaration]);
    finally
      Expr.Free;
    end;
  end;
end;

procedure Tdws2Compiler.ReadTypeDecl;
var
  Name: string;
  typNew, typOld: TSymbol;
  typePos: TScriptPos;
  oldSymPos: TSymbolPosition; // Mark *where* the old declaration was
begin
  if not FTok.TestName then
    FMsgs.AddCompilerStop(FTok.HotPos, CPE_NameExpected)
  else
  begin
    Name := FTok.GetToken.FString;
    typePos := FTok.HotPos;
    FTok.KillToken;

    if not FTok.TestDelete(ttEQ) then
      FMsgs.AddCompilerStop(FTok.HotPos, CPE_EqualityExpected);

    typOld := FProg.Table.FindSymbol(Name);
    oldSymPos := nil;
    if coSymbolDictionary in FCompilerOptions then
    begin
      if Assigned(typOld) then
        oldSymPos := FProg.SymbolDictionary.FindSymbolUsage(typOld, suDeclaration);  // may be nil
    end;

    typNew := ReadType(Name);

    // Wrap whole type declarations in a context.
    if coContextMap in FCompilerOptions then
      FProg.ContextMap.OpenContext(typePos, typNew);

    try
      try
        // typOld = typNew if a forwarded class declaration was overwritten
        if typOld <> typNew then
        begin
          CheckName(Name);
          FProg.Table.AddSymbol(typNew);
        end
        // Handle overwriting forwards in Dictionary
        // Original symbol was a forward. Update symbol entry
        else
        begin
          // If the type is in the SymbolDictionary (disabled dictionary would leave pointer nil),
          if Assigned(oldSymPos) then              // update original position information
            oldSymPos.SymbolUsages := [suForward]; // update old postion to reflect that the type was forwarded
        end;

        // Add symbol position as being the type being declared (works for forwards too)
        if coSymbolDictionary in FCompilerOptions then
          FProg.SymbolDictionary.Add(typNew, typePos, [suDeclaration]);
      except
        typNew.Free;
        raise;
      end;
    finally
      if coContextMap in FCompilerOptions then
        FProg.ContextMap.CloseContext(FTok.CurrentPos);
    end;
  end;
end;

function Tdws2Compiler.ReadProcDecl(FuncKind: TFuncKind; ClassSym: TClassSymbol;
  IsClassMethod: Boolean; IsType : Boolean): TFuncSymbol;
var
  Name: string;
  sym: TSymbol;
  funcPos: TScriptPos;
  forwardedSym: TFuncSymbol;
  forwardedSymPos: TSymbolPosition;
  methSym: TMethodSymbol;