dpp_macros.pas

East make Tray Icon in delphi

  ArgCount: Integer;
  i: Integer;
begin
  FInterfaceMacro := AInterfaceMacro;
  FHasBrackets := False;

  Result := False;

 // parse Macro name string
  F := Pointer(MacroNameArgReplacement);
  if F = nil then Exit;
  P := F;
  while not (P[0] in [#0, '(', #9, #10, #13, ' ']) do Inc(P);
  SetString(FName, F, P - F);
 // test for valid identifier
  if not IsValidIdent(FName) then
  begin
    ErrorMsg := Format(SMacroArgumentsSyntaxError, [FName]);
    Exit;
  end;

 // parse Macro arguments
  if P[0] = '(' then
  begin
    FHasBrackets := True;

    F := P + 1;
    ArgCount := CountCharsStop(',', ')', F) + 1;
    SetLength(FArguments, ArgCount);

    for i := 0 to ArgCount - 1 do
    begin
      while not (P[0] in [#0, ',', ')']) do Inc(P);
      SetTrimString(FArguments[i], F, P - F);
{      SetString(FArguments[i], F, P - F);
      FArguments[i] := Trim(FArguments[i]); // trim it}
      Inc(P); // next char
      F := P;

     // test for valid identifier
      if not IsValidIdent(FArguments[i]) then
      begin
        ErrorMsg := Format(SMacroArgumentsSyntaxError, [FArguments[i]]);
        Exit;
      end;
    end;

   // only one argument which is empty -> free memory
    if (ArgCount = 1) and (Length(FArguments[0]) = 0) then
      SetLength(FArguments, 0);
    if P[0] = ')' then Inc(P);
  end;

  Result := True;
  
  if P[0] = #0 then Exit;
  while (P[0] <> #0) and (P[0] <= #32) do Inc(P);
  FReplacement := TrimRight(P);
end;

{ TMacroList }

constructor TMacroList.Create(Macros: TMacros);
begin
  inherited Create;
  FMacros := Macros;
end;

procedure TMacroList.Assign(MacroList: TMacroList);
var
  i: Integer;
  Item: TMacroItem;
begin
  Clear;
  for i := 0 to MacroList.Count - 1 do
  begin
    Item := TMacroItem.Create(Self);
    Item.Assign(MacroList.Items[i]);
    Add(Item);
    MakeStringHash(Item.Name, Integer(Item), FHashTable);
  end;
end;

function TMacroList.GetItems(Index: Integer): TMacroItem;
begin
  Result := TMacroItem(inherited Items[Index]);
end;

function TMacroList.IndexOfMacro(const Name: string): Integer;
begin
  for Result := 0 to Count - 1 do
    if FMacros.FCompare(TMacroItem(inherited Items[Result]).Name, Name) = 0 then
      Exit;
  Result := -1;
end;

function TMacroList.FindMacro(const Name: string): TMacroItem;
{$ifndef HASHTABLE}
var
  i: Integer;
  cmp: TMacroCompare;
{$endif}
begin
{$ifdef HASHTABLE}
  Result := TMacroItem(FindStringHash(Name, FHashTable, FMacros.FCaseSensitive));
{$else}
  cmp := FMacros.FCompare;
  for i := 0 to Count - 1 do
  begin
    Result := TMacroItem(inherited Items[i]);
    if cmp(Result.Name, Name) = 0 then Exit;
  end;
  Result := nil;
{$endif}
end;

function TMacroList.IsMacroRegistered(const Name: string): Boolean;
begin
{$ifdef HASHTABLE}
  Result := FindStringHash(Name, FHashTable, FMacros.FCaseSensitive) <> 0;
{$else}
  Result := IndexOfMacro(Name) >= 0;
{$endif}
end;

{ RegisterMacro() registers a new macro. If the macro is already registered and
  the new version is different then the preprocessor warns the user. This
  warning is generated by the caller who test the property ErrorMsg.
  The Macro-string must be left trimmed. }
function TMacroList.RegisterMacro(const Macro: string; AInterfaceMacro: Boolean): TMacroItem;
var Item: TMacroItem;
begin
  FMacros.FErrorMsg := '';

  Result := TMacroItem.Create(Self);
  try
    if not Result.Parse(Macro, FMacros.FErrorMsg, AInterfaceMacro) then
    begin
      Result.Free;
      Result := nil;
      Exit;
    end;

    Item := FindMacro(Result.Name);
    if Item <> nil then
    begin
     // test if it is the same declaration
      if not Result.IsEqual(Item) then
      begin
        FMacros.FErrorMsg := Format(SMacroRedefinitionNotIdentical, [Result.Name]);
{$ifdef HASHTABLE}
        DelStringHash(Integer(Item), FHashTable);
{$endif}
        Remove(Item); // replace macro with the new one
      end;
    end;
{$ifdef HASHTABLE}
    MakeStringHash(Result.Name, Integer(Result), FHashTable);
{$endif}

    Add(Result);
  except
    Result.Free;
    raise;
  end;
end;

procedure TMacroList.UnregisterMacro(const Name: string);
{$ifdef HASHTABLE}
var Item: TMacroItem;
begin
  Item := TMacroItem(FindStringHash(Name, FHashTable, FMacros.FCaseSensitive));
  if Item <> nil then
  begin
    DelStringHash(Integer(Item), FHashTable);
    Delete(IndexOf(Item));
  end;
end;
{$else}
var Index: Integer;
begin
  Index := IndexOfMacro(Name);
  if Index >= 0 then
  begin
    DelStringHash(Integer(Items[Index]), FHashTable);
    Delete(Index);
  end;
end;
{$endif}

procedure TMacroList.Clear;
begin
{$ifdef HASHTABLE}
  SetLength(FHashTable, 0);
{$endif}
  inherited Clear;
end;

{ TMacros }

constructor TMacros.Create(AFileSys: IMacroFileSys);
begin
  inherited Create(Self);
  FUnits := TStringList.Create;
  FIncludeFiles := TStringList.Create;
  FMacroMacroRecursion := TList.Create;
  SetCaseSensitive(True);

  FConditionals := TStringList.Create;
  FCompilerOptions := TStringList.Create;
  FConditionalParseCode := TBooleanList.Create;
  FConditionalParse := False;

  FFileSys := AFileSys;
end;

destructor TMacros.Destroy;
begin
  FConditionalParseCode.Free;
  FCompilerOptions.Free;
  FConditionals.Free;
  FMacroMacroRecursion.Free;
  FIncludeFiles.Free;
  FUnits.Free;

  FFileSys := nil;
  inherited Destroy;
end;

procedure TMacros.SetCaseSensitive(const Value: Boolean);
begin
  FCaseSensitive := Value;
  if FCaseSensitive then FCompare := CompareStr else FCompare := CompareText;
end;

procedure TMacros.Error(const Msg, FileName: string; LineNum: Integer);
begin
  if Assigned(FOnError) then FOnError(Self, FileName, Msg, LineNum);
  Abort; // raise EAbort Exception -> exit all
end;

procedure TMacros.Error(const Msg: string; Token: PTokenInfo);
var
  Filename: string;
begin
  if Token = nil then
    Error(Msg, '', 0)
  else
  begin
    if Token.pFilename <> nil then
      Filename := Token.pFilename^;
    Error(Msg, FileName, Token.StartLine);
  end;
end;

procedure TMacros.Warning(const Msg, FileName: string; LineNum: Integer);
begin
  if Assigned(FOnError) then FOnWarning(Self, FileName, Msg, LineNum);
end;

procedure TMacros.Warning(const Msg: string; Token: PTokenInfo);
begin
  Warning(Msg, Token.pFileName^, Token.StartLine);
end;

procedure TMacros.PredefineMacros;
begin
  if Assigned(FOnPredefineMacros) then FOnPredefineMacros(Self);
end;

{ RegisterMacroByToken() registers a new macro and triggers error and warning
  messages if necessary. }
function TMacros.RegisterMacroByToken(const Macro: string; Token: PTokenInfo): TMacroItem;
begin
  Result := RegisterMacro(TrimLeft(Macro),
                          TPascalParserEx(Token^.Parser).NoReplaceMacros);  // sets ErrorMsg to '' or error message
  if (ErrorMsg <> '') then
  begin
    if Result = nil then Error(FErrorMsg, Token); // Abort
    Warning(FErrorMsg, Token);
    FErrorMsg := '';
  end;
end;

{ Parse() calls for every unit that it finds the ParseFile() method. }
function TMacros.Parse(const FileName: string; OnlyThisFile: Boolean): Boolean;
var i: Integer;
begin
  Result := True;
  FUnits.Clear;
  FIncludeFiles.Clear;
  FAppType := '';

  FUnits.AddObject(FileName, Pointer(0)); // Even if this file is no unit something has to be parsed
  try
   // parse all used units
    i := 0;
    while i < FUnits.Count do
    begin
      Clear; // clear macro list

      FMacroMacroRecursion.Clear; // reset macro macro recursion
      FFileRecursion := 0;        // reset file recursions

     // reset conditionals
      FConditionals.Clear;
      FConditionalParseCode.Clear; // Count=0 -> .LastItem=True
      DefaultConditionals;

     // get user predefined macros
      PredefineMacros;

     // parse macro include file for this unit
      ParseUnitMacroFile(i);
     // parse this unit
      ParseFile(FUnits[i], ptUnit, {TestFileExistence:=}False);

      Inc(i); // next unit

      if OnlyThisFile then Break; // do not parse other units
    end;
  except
    on EAbort do
      Result := False; // return False
  end;
end;


{ ParseUnitMacroFile() first checks if the macro file exists and then parses
  the file. }
function TMacros.ParseUnitMacroFile(UnitIndex: Integer): Integer;
var MacroFilename: string;
begin
 // Assert(UnitIndex >= 0);
  // Objects[]:
  //   -1: no macros file existance tested
  //    0: no macros file
  //    1: macros file exists
  Result := Integer(FUnits.Objects[UnitIndex]);

  case Result of
    -1:
      begin
        Result := 0;
        MacroFilename := ChangeFileExt(FUnits[UnitIndex], SMacroIncludeFileExt);
        if FFileSys.FileExists(MacroFilename) then
          if ParseFile(MacroFileName, ptInterfaceMacros,
                       {TestFileExistence:=}False) <> '' then
            Result := 1;
        FUnits.Objects[UnitIndex] := Pointer(Result);
      end;
    1:
      begin
        MacroFilename := ChangeFileExt(FUnits[UnitIndex], SMacroIncludeFileExt);
        ParseFile(MacroFileName, ptInterfaceMacros, {TestFileExistence:=}False);
      end;
  end;
end;


{ ParseFile() first checks for the existence of the file and then it calls
  ParseString() with the file content. If the file is an include file (called
  by ParseComments() ) then the file name is added to the FIncFiles list.