diff --git a/components/chelper/cconvconfig.pas b/components/chelper/cconvconfig.pas
new file mode 100644
index 000000000..51981cd0f
--- /dev/null
+++ b/components/chelper/cconvconfig.pas
@@ -0,0 +1,89 @@
+{ The unit is part of Lazarus Chelper package
+
+ Copyright (C) 2010 Dmitry Boyarintsev skalogryz dot lists at gmail.com
+
+ This library is free software; you can redistribute it and/or modify it
+ under the terms of the GNU Library General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ This program is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+ for more details.
+
+ You should have received a copy of the GNU Library General Public License
+ along with this library; if not, write to the Free Software Foundation,
+ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+}
+unit cconvconfig;
+
+{$mode delphi}
+
+interface
+
+uses
+ Classes, SysUtils, ctopasconvert, IniFiles;
+
+procedure LoadFromFile(const FileName: AnsiString; cfg: TConvertSettings);
+procedure SaveToFile(const FileName: AnsiString; cfg: TConvertSettings);
+
+implementation
+
+procedure LoadFromFile(const FileName: AnsiString; cfg: TConvertSettings);
+var
+ ini : TIniFile;
+begin
+ if not Assigned(cfg) then Exit;
+ try
+ ini:=TIniFile.Create(FileName);
+ try
+ // C to Pas Types
+ ini.ReadSectionValues('Types', cfg.CtoPasTypes);
+ cfg.RecordsArePacked:=ini.ReadBool('Main','RecordsArePacked', cfg.RecordsArePacked);
+ cfg.FuncsAreExternal:=ini.ReadBool('Main','FuncsAreExternal', cfg.FuncsAreExternal);
+ cfg.EnumsAsConst:=ini.ReadBool('Main','EnumAsConst', cfg.EnumsAsConst);
+
+ cfg.TypeNamePrefix:=ini.ReadString('Main','TypeNamePrefix',cfg.TypeNamePrefix);
+ cfg.RefTypeNamePrefix:=ini.ReadString('Main','RefTypeNamePrefix',cfg.RefTypeNamePrefix);
+ cfg.FuncConv:=ini.ReadString('Main','FuncConv',cfg.FuncConv);
+ cfg.FuncDeclPostfix:=ini.ReadString('Main','FuncDeclPostfix',cfg.FuncDeclPostfix);
+ cfg.ParamPrefix:=ini.ReadString('Main','ParamPrefix',cfg.ParamPrefix);
+ finally
+ ini.Free;
+ end;
+ except
+ end;
+end;
+
+procedure SaveToFile(const FileName: AnsiString; cfg: TConvertSettings);
+var
+ ini : TIniFile;
+ i : Integer;
+begin
+ if not Assigned(cfg) then Exit;
+ try
+ ini:=TIniFile.Create(FileName);
+ try
+
+ // C to Pas Types
+ for i:=0 to cfg.CtoPasTypes.Count-1 do
+ ini.WriteString('Types', cfg.CtoPasTypes.Names[i], cfg.CtoPasTypes.ValueFromIndex[i]);
+ ini.WriteBool('Main','RecordsArePacked', cfg.RecordsArePacked);
+ ini.WriteBool('Main','FuncsAreExternal', cfg.FuncsAreExternal);
+ ini.WriteBool('Main','EnumAsConst', cfg.EnumsAsConst);
+
+ ini.WriteString('Main','TypeNamePrefix',cfg.TypeNamePrefix);
+ ini.WriteString('Main','RefTypeNamePrefix',cfg.RefTypeNamePrefix);
+ ini.WriteString('Main','FuncConv',cfg.FuncConv);
+ ini.WriteString('Main','FuncDeclPostfix',cfg.FuncDeclPostfix);
+ ini.WriteString('Main','ParamPrefix',cfg.ParamPrefix);
+ finally
+ ini.Free;
+ end;
+ except
+ end;
+end;
+
+end.
+
diff --git a/components/chelper/cconvert.lpi b/components/chelper/cconvert.lpi
new file mode 100644
index 000000000..532cd8c58
--- /dev/null
+++ b/components/chelper/cconvert.lpi
@@ -0,0 +1,92 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/chelper/cconvert.lpr b/components/chelper/cconvert.lpr
new file mode 100644
index 000000000..19f992125
--- /dev/null
+++ b/components/chelper/cconvert.lpr
@@ -0,0 +1,113 @@
+{ C-to-Pas converter command-line utility part of Lazarus Chelper package
+
+ Copyright (C) 2010 Dmitry Boyarintsev skalogryz dot lists at gmail.com
+
+ This library is free software; you can redistribute it and/or modify it
+ under the terms of the GNU Library General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ This program is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+ for more details.
+
+ You should have received a copy of the GNU Library General Public License
+ along with this library; if not, write to the Free Software Foundation,
+ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+}
+program cconvert;
+
+{$mode objfpc}{$H+}
+
+uses
+ SysUtils,Classes,
+ ctopasconvert,cparserutils,cconvconfig;
+
+var
+ ConfigFile : AnsiString = '';
+ OutputFile : AnsiString = '';
+ ConfigFileRO : Boolean = false;
+
+function StringFromFile(const FileName: AnsiString): AnsiString;
+var
+ fs : TFileStream;
+begin
+ Result:='';
+ if not FileExists(FileName) then Exit;
+ try
+ fs:=TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
+ try
+ SetLength(Result, fs.Size);
+ fs.Read(Result[1], fs.Size);
+ finally
+ fs.Free;
+ end;
+ except
+ end;
+end;
+
+procedure InitSettings(cfg: TConvertSettings);
+var
+ i : Integer;
+ p : AnsiString;
+ fn : AnsiString;
+begin
+ i:=1;
+ while i<=Paramcount do begin
+ p:=AnsiLowerCase(ParamStr(i));
+ if p='-cfg' then begin
+ inc(i);
+ fn:=Trim(Paramstr(i));
+ ConfigFile:=fn;
+ if FileExists(fn) then cconvconfig.LoadFromFile(fn, cfg);
+ end else if p='-ro' then
+ ConfigFileRO:=True
+ else if p='-defines' then begin
+ inc(i);
+ cfg.CustomDefines:=cfg.CustomDefines+' ' + StringFromFile(ParamStr(i));
+ end else if p='-o' then begin
+ inc(i);
+ OutputFile:=ParamStr(i);
+ end;
+ inc(i);
+ end;
+end;
+
+var
+ inps, outs : TStringList;
+ i : Integer;
+ p : TPoint;
+ cfg : TConvertSettings;
+begin
+ inps := TStringList.Create;
+ outs := TStringList.Create;
+
+ cfg:=TConvertSettings.Create;
+ try
+ InitSettings(cfg);
+
+ inps.LoadFromFile(ParamStr(ParamCount));
+ outs.Text:=ConvertCode(inps.Text, p, cfg);
+ if OutputFile<>'' then begin
+ outs.Insert(0, Format('%d %d', [p.Y,p.X]));
+ outs.SaveToFile(OutputFile)
+ end else begin
+ writeln(p.Y,' ',p.X);
+ for i:=0 to outs.Count-1 do
+ writeln(outs[i]);
+ end;
+ finally
+ if not ConfigFileRO and (ConfigFile<>'') then begin
+ ForceDirectories(ExtractFilePath(ConfigFile));
+ try
+ cconvconfig.SaveToFile(ConfigFile, cfg);
+ except
+ end;
+ end;
+ cfg.Free;
+ inps.Free;
+ outs.Free;
+ end;
+end.
+
diff --git a/components/chelper/chelper.lpk b/components/chelper/chelper.lpk
new file mode 100644
index 000000000..59c6a6f1c
--- /dev/null
+++ b/components/chelper/chelper.lpk
@@ -0,0 +1,66 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/chelper/chelper.pas b/components/chelper/chelper.pas
new file mode 100644
index 000000000..ed3701a9e
--- /dev/null
+++ b/components/chelper/chelper.pas
@@ -0,0 +1,22 @@
+{ This file was automatically created by Lazarus. Do not edit!
+ This source is only used to compile and install the package.
+ }
+
+unit chelper;
+
+interface
+
+uses
+ toSourceEditor, ctopasconvert, extconvdialog, cconvconfig,
+ converteridesettings, LazarusPackageIntf;
+
+implementation
+
+procedure Register;
+begin
+ RegisterUnit('toSourceEditor',@toSourceEditor.Register);
+end;
+
+initialization
+ RegisterPackage('chelper',@Register);
+end.
diff --git a/components/chelper/codewriter.pas b/components/chelper/codewriter.pas
new file mode 100644
index 000000000..bd8cfc207
--- /dev/null
+++ b/components/chelper/codewriter.pas
@@ -0,0 +1,108 @@
+unit codewriter;
+
+{$mode delphi}
+
+interface
+
+uses
+ Classes, SysUtils;
+
+type
+
+ { TCodeWriter }
+
+ TCodeWriter = class(TObject)
+ private
+ fnewline:Boolean;
+ fText : AnsiString;
+ fIdent : AnsiString;
+ fIdDelta : AnsiString;
+ newline : Boolean;
+
+ fCurLine : AnsiString;
+ fSection : AnsiString;
+
+ fMaxLen : Integer;
+ fCheckLineLen : Boolean;
+ public
+ constructor Create;
+ procedure IncIdent;
+ procedure DecIdent;
+ procedure W(const s: AnsiString='');
+ procedure Wln(const s: AnsiString='');
+ procedure StartNewLine;
+ property Section: AnsiString read fSection write fSection;
+ property Text: AnsiString read fText write fText;
+ property LineStarts: Boolean read fnewline;
+
+ property MaxLineLen: Integer read fMaxLen write fMaxLen;
+ property CheckLineLen: Boolean read fCheckLineLen write fCheckLineLen;
+ end;
+
+procedure SetPasSection(wr: TCodeWriter; const SectionName: AnsiString; DoIdent: Boolean=true);
+
+implementation
+
+procedure SetPasSection(wr: TCodeWriter; const SectionName: AnsiString; DoIdent: Boolean);
+begin
+ if wr.Section=SectionName then Exit;
+
+ if (wr.Section<>'') and DoIdent then wr.DecIdent;
+ if SectionName<>'' then wr.Wln(SectionName);
+ wr.Section:=SectionName;
+ if (wr.Section<>'') and DoIdent then wr.IncIdent;
+end;
+
+{ TCodeWriter }
+
+constructor TCodeWriter.Create;
+begin
+ fIdDelta:=' ';
+ newline:=True;
+ fMaxLen:=80;
+end;
+
+procedure TCodeWriter.IncIdent;
+begin
+ fIdent:=fIdent+fIdDelta;
+end;
+
+procedure TCodeWriter.DecIdent;
+begin
+ fIdent:=Copy(fIdent, 1, length(fIdent)-length(fIdDelta));
+end;
+
+procedure TCodeWriter.W(const s:String);
+var
+ AutoBreak: Boolean;
+begin
+ //todo: check eoln symbols in s
+ if s ='' then Exit;
+
+ AutoBreak:=CheckLineLen and (fCurLine<>'') and ( length(fCurLine+fIdent)+length(s) > fMaxLen);
+ if AutoBreak then begin
+ fText:=fText+LineEnding;
+ fCurLine:='';
+ fText:=fText+fIdent+fIdDelta;
+ end;
+
+ if newline then fText:=fText+fIdent;
+ fText:=fText+s;
+ fCurLine:=fCurLine+s;
+ newline:=False;
+end;
+
+procedure TCodeWriter.Wln(const s:String);
+begin
+ W(s+LineEnding);
+ newline:=True;
+ fCurLine:='';
+end;
+
+procedure TCodeWriter.StartNewLine;
+begin
+ if not newline then Wln;
+end;
+
+end.
+
diff --git a/components/chelper/converteridesettings.pas b/components/chelper/converteridesettings.pas
new file mode 100644
index 000000000..473fd6b40
--- /dev/null
+++ b/components/chelper/converteridesettings.pas
@@ -0,0 +1,110 @@
+{ The unit is part of Lazarus Chelper package
+
+ Copyright (C) 2010 Dmitry Boyarintsev skalogryz dot lists at gmail.com
+
+ This library is free software; you can redistribute it and/or modify it
+ under the terms of the GNU Library General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ This program is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+ for more details.
+
+ You should have received a copy of the GNU Library General Public License
+ along with this library; if not, write to the Free Software Foundation,
+ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+}
+unit converteridesettings;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, ctopasconvert, IniFiles;
+
+var
+ ConvSettings : TConvertSettings=nil;
+ ExtTool : AnsiString='';
+ UseExtTool : Boolean=True;
+ ExtTimeOut : LongWord = 5000;
+ ConvFile : AnsiString='';
+ DefineFile : AnsiString='';
+
+procedure StringToFile(const Str, DstFileName: AnsiString);
+function StringFromFile(const SrcFileName: AnsiString): AnsiString;
+
+procedure WriteIDESettings(const FileName: AnsiString);
+procedure ReadIDESettings(const FileName: AnsiString);
+
+implementation
+
+procedure StringToFile(const Str, DstFileName: AnsiString);
+var
+ fs: TFileStream;
+begin
+ fs:=TFileStream.Create(DstFileName, fmCreate);
+ if Str<>'' then fs.Write(Str[1], length(Str));
+ fs.Free;
+end;
+
+function StringFromFile(const SrcFileName: AnsiString): AnsiString;
+var
+ fs : TFileStream;
+begin
+ Result:='';
+ try
+ if not FileExists(SrcFileName) then Exit;
+ fs:=TFileStream.Create(SrcFileName, fmOpenRead or fmShareDenyNone);
+ try
+ SetLength(Result, fs.Size);
+ if fs.Size>0 then fs.Read(Result[1], fs.Size);
+ finally
+ fs.Free;
+ end;
+ except
+ end;
+end;
+
+procedure WriteIDESettings(const FileName:AnsiString);
+var
+ ini : TIniFile;
+begin
+ try
+ ini:=TIniFile.Create(FileName);
+ try
+ ini.WriteString('Tool', 'Exe', ExtTool);
+ ini.WriteString('Tool', 'DefineFile', DefineFile);
+ finally
+ ini.Free;
+ end;
+ except
+ end;
+end;
+
+procedure ReadIDESettings(const FileName:AnsiString);
+var
+ ini : TIniFile;
+begin
+ try
+ ini:=TIniFile.Create(FileName);
+ try
+ ExtTool:=ini.ReadString('Tool', 'Exe', ExtTool);
+ DefineFile:=ini.ReadString('Tool', 'DefineFile',DefineFile);
+ finally
+ ini.Free;
+ end;
+ except
+ end;
+end;
+
+initialization
+ ConvSettings := TConvertSettings.Create;
+
+finalization
+ ConvSettings.Free;
+
+end.
+
diff --git a/components/chelper/cparsertypes.pas b/components/chelper/cparsertypes.pas
new file mode 100755
index 000000000..2d018cb75
--- /dev/null
+++ b/components/chelper/cparsertypes.pas
@@ -0,0 +1,1944 @@
+{ The unit is part of Lazarus Chelper package
+
+ Copyright (C) 2010 Dmitry Boyarintsev skalogryz dot lists at gmail.com
+
+ This library is free software; you can redistribute it and/or modify it
+ under the terms of the GNU Library General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ This program is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+ for more details.
+
+ You should have received a copy of the GNU Library General Public License
+ along with this library; if not, write to the Free Software Foundation,
+ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+}
+unit cparsertypes;
+
+interface
+
+{$ifdef fpc}{$mode delphi}{$h+}
+{$else}
+{$warn unsafe_code off}
+{$warn unsafe_type off}
+{$warn unsafe_cast off}
+{$endif}
+
+uses
+ Classes, SysUtils, TextParsingUtils;
+
+const
+ Err_Ident = 'Identifier';
+ Err_Expect = '%s, excepted, but "%s" found';
+ Err_BadPrecompile = 'Bad precompile directive';
+
+type
+ TTokenType = (tt_Ident, tt_Symbol, tt_Numeric, tt_String);
+
+ TTokenPair = record
+ Open : AnsiString;
+ Close : AnsiString;
+ end;
+
+ { TTokenTable }
+
+ TTokenTable = class(TObject)
+ private
+ fSymbMaxLen : Integer;
+ fSymbStrs : TStringList;
+ public
+ SpaceChars : TCharSet;
+ CmtBlock : array of TTokenPair;
+ CmtCount : Integer;
+ CmtLine : TStrings;
+ StringStart : TCharSet;
+ Symbols : TCharSet;
+ Precompile : AnsiString;
+ MultiLine : AnsiChar;
+ constructor Create;
+ destructor Destroy; override;
+ function AddSymbol(const asym: AnsiString): Boolean;
+ function isSymbol(const asym: AnsiSTring): Boolean;
+ property SymbMaxLen : Integer read fSymbMaxLen;
+ end;
+
+ TTextParser = class;
+
+ TPrecompilerEvent = procedure (Sender: TTextParser; PrecompEntity: TObject) of object;
+
+ TCMacroStruct = class(TObject)
+ MacroName : AnsiString;
+ MacroParams : TStringList;
+ ReplaceText : AnsiString;
+
+ constructor Create;
+ destructor Destroy; override;
+ end;
+
+ { TCMacroHandler }
+
+ TCMacroHandler = class(TObject)
+ public
+ MacrosNames : TStringList;
+ constructor Create;
+ destructor Destroy; override;
+ function ParseMacro(const Parser: TTextParser; var MacroStr, ReplaceStr: AnsiString): Boolean;
+ function isMacroDefined(const Macro: AnsisTring): Boolean;
+
+ procedure AddSimpleMacro(const MacroStr, ReplaceStr: AnsiString);
+ procedure AddParamMacro(const MacroStr, ReplaceStr: AnsiString; Params: TStrings);
+
+ procedure Clear;
+ end;
+
+ { TTextParser }
+
+ TTextParser = class(TObject)
+ protected
+ ProcessingMacro : Boolean;
+ function HandlePrecomiler: Boolean; virtual;
+ function HandleMacro(var MacroStr: AnsiString; var ReplaceStr: AnsiString): Boolean;
+
+ function IsMultiLine: Boolean;
+ procedure SkipSingleEoLnChars;
+
+ function AddChildToStackEntity(ent: TObject): Boolean;
+ public
+ Buf : AnsiString;
+
+ Token : AnsiString;
+ TokenType : TTokenType;
+ TokenCode : Integer; // code for reserved tokens and symbols, otherwiser -1. 0 is EOF
+
+
+ Index : Integer; // current index where text parsing goes on
+ TokenPos : Integer; // position of currently found token by (FindTextToken)
+ MacrosDelta : Integer; // the difference between Buf Index and Original Text index, caused by Macros substitution
+ TokenTable : TTokenTable;
+ OnPrecompile : TPrecompilerEvent;
+ OnComment : procedure (Sender: TObject; const Comment: AnsiString) of object;
+ OnIgnoreToken : procedure (Sender: TObject; const Ignored: AnsiString) of object;
+ Line : Integer;
+
+ Stack : TList;
+ Errors : TStringList;
+ MacroHandler : TCMacroHandler;
+
+ UseCommentEntities : Boolean;
+ UsePrecompileEntities : Boolean;
+
+ Comments : TList;
+
+ constructor Create;
+ destructor Destroy; override;
+
+ procedure BeginParse(AObject: TObject);
+ procedure EndParse;
+
+ function GetBufWideStr(const Cmd: AnsiString): WideString;
+
+ function SkipComments: Boolean;
+
+ function NextToken: Boolean;
+ function FindNextToken(var AToken: AnsiString; var ATokenType: TTokenType): Boolean;
+
+ procedure SetError(const ErrorCmt: AnsiString);
+ end;
+
+ { TEntity }
+
+ TEntity = class(TObject)
+ protected
+ function DoParse(AParser: TTextParser): Boolean; virtual;
+
+ public
+ Offset : Integer;
+ Items : TList;
+
+ TagComment : AnsiString;
+ Specifiers : TStringList;
+
+ constructor Create(AOffset: Integer=-1); virtual;
+ destructor Destroy; override;
+ function Parse(AParser: TTextParser): Boolean; virtual;
+ procedure Assign(AEntity: TEntity); virtual;
+ end;
+ TEntityClass = class of TEntity;
+
+ TCPrepocessor = class(TEntity);
+
+ { TCPrepDefine }
+
+ TCPrepDefine = class(TCPrepocessor)
+ protected
+ function DoParse(AParser: TTextParser): Boolean; override;
+ public
+ Params : TStringList;
+ _Name : AnsiString;
+ SubsText : AnsiString;
+ destructor Destroy; override;
+ end;
+
+ TCPrepInclude = class(TCPrepocessor)
+ protected
+ Params : TStringList;
+ Included : AnsiString;
+ function DoParse(AParser: TTextParser): Boolean; override;
+ end;
+
+ TCPrepElse = class(TCPrepocessor)
+ function DoParse(AParser: TTextParser): Boolean; override;
+ end;
+
+ TCPrepEndif = class(TCPrepocessor)
+ function DoParse(AParser: TTextParser): Boolean; override;
+ end;
+
+ TCPrepIf = class(TCPrepocessor)
+ _Cond : AnsiString;
+ IfOp : AnsiString;
+ function DoParse(AParser: TTextParser): Boolean; override;
+ end;
+
+ TCPrepPragma = class(TCPrepocessor)
+ _Text : AnsiString;
+ function DoParse(AParser: TTextParser): Boolean; override;
+ end;
+
+ //C tokens: /*, //
+ TCommentType = (ctLine, ctBlock);
+
+ { TComment }
+
+ TComment = class(TEntity)
+ protected
+ function DoParse(AParser: TTextParser): Boolean; override;
+ public
+ CommenType : TCommentType;
+ _Comment : AnsiString; // in case sources are UTF8 or Unicode
+ end;
+
+ { TPrecompiler }
+
+ TPrecompiler = class(TEntity)
+ protected
+ function DoParse(AParser: TTextParser): Boolean; override;
+ public
+ _Directive : AnsiString;
+ _Params : AnsiString;
+ end;
+
+// parsing function
+function ParseNextEntity(AParser: TTextParser): TEntity;
+function ParseCExpression(AParser: TTextParser; var ExpS: AnsiString): Boolean;
+procedure ParseCNumeric(const S: AnsiString; var idx: integer; var NumStr: AnsiSTring);
+function ParseCString(const S: AnsiString; var idx: Integer; var CStr: AnsiString): Boolean;
+function ParseCMacroParam(AParser: TTextParser; var ExpS: AnsiString): Boolean;
+
+// utility function
+function SkipEndOfLineChars(const Src: AnsiString; idx: integer): Integer;
+function CToPascalNumeric(const Cnum: AnsiString): AnsiString;
+function ErrExpectStr(const Expected, Found: AnsiString): AnsiString;
+
+// Parser data management functions
+function CreateObjCTokenTable: TTokenTable;
+procedure SetCComments(Table: TTokenTable);
+procedure SetCSymbols(var ch: TCharSet);
+
+function CreateCParser(const CHeaderText: AnsiString;
+ WithCMacroHandler: Boolean = false): TTextParser;
+
+
+type
+ TCustomEntityProc = function (Parent: TEntity; Parser: TTextParser): TEntity;
+
+type
+
+ { TSimpleType }
+
+ TSimpleType = class(TEntity)
+ public
+ Name : AnsiString;
+ end;
+
+ { TExpression }
+
+ TExpression = class(TEntity)
+ function DoParse(AParser: TTextParser): Boolean; override;
+ public
+ Text : AnsiString;
+ end;
+
+procedure ErrorExpect(Parser: TTextParser; const Expect: AnsiString);
+function ConsumeToken(Parser: TTextParser; const Token: AnsiString): Boolean;
+
+function ParseCType(Parser: TTextParser): TEntity;
+
+type
+ TNamePart = class;
+
+ TFuncParam = record
+ prmtype : TEntity;
+ name : TNamePart;
+ end;
+
+ TNameKind = (nk_Ident, nk_Ref, nk_Array, nk_Func);
+
+ { TNamePart }
+
+ TNamePart = class(TObject)
+ private
+ fChild : TNamePart;
+ fOwner : TNamePart;
+ public
+ Kind : TNameKind;
+ RefCount : Integer;
+ Id : AnsiString;
+ arrayexp : array of TExpression;
+ params : array of TFuncParam;
+ constructor Create(AKind: TNameKind);
+ procedure AddParam(prmtype: TEntity; prmname: TNamePart);
+ procedure AddArrayExpr(expr: TExpression);
+ property child: TNamePart read fchild write fChild; // int (*p)[10]; "[10]" is child of (*p)
+ property owner: TNamePart read fowner write fOwner;
+ end;
+
+function ParseNames(Parser: TTextParser; var NameType: TEntity; Names: TList; AllowMultipleNames: Boolean=True): Boolean;
+function ParseName(Parser: TTextParser; var NameType: TEntity; var name: TNamePart): Boolean;
+
+type
+
+ { TVarFuncEntity }
+
+ TVarFuncEntity = class(TEntity)
+ protected
+ function DoParse(AParser:TTextParser): Boolean; override;
+ public
+ Specifiers : TStringList;
+ RetType : TEntity;
+ Names : TList;
+ constructor Create(AOffset: Integer=-1); override;
+ destructor Destroy; override;
+ function FirstName: TNamePart;
+ end;
+
+
+ TStructTypeField = record
+ v : TVarFuncEntity;
+ isbitted : Integer;
+ bits : TExpression;
+ end;
+
+ { TStructType }
+
+ TStructType = class(TEntity)
+ public
+ Name : AnsiString;
+ fields : array oF TStructTypeField;
+ function AddField(ev: TVarFuncEntity): Integer;
+ end;
+
+ { TUnionType }
+
+ TUnionType = class(TEntity)
+ public
+ Name : AnsiString;
+ fields : array oF TStructTypeField;
+ function AddField(ev: TVarFuncEntity): Integer;
+ end;
+
+ { TTypeDefInst }
+
+ TTypeDef = class(TEntity)
+ public
+ origintype : TEntity;
+ name : TNamePart;
+ end;
+
+
+ TEnumItem = record
+ Name : AnsiString;
+ Value : TExpression;
+ Offset : Integer;
+ end;
+
+ { TEnumType }
+
+ TEnumType = class(TEntity)
+ Name : AnsiString;
+ items : array of TEnumItem;
+ function AddItem(const name: AnsiString; x: TExpression; Offset: Integer = -1): Integer;
+ end;
+
+function ParseStruct(AParser: TTextParser): TStructType;
+function ParseUnion(AParser: TTextParser): TUnionType;
+function ParseTypeDef(AParser: TTextParser): TTypeDef;
+function ParseEnum(AParser: TTextParser): TEnumType;
+
+implementation
+
+function SkipEndOfLineChars(const Src: AnsiString; idx: integer): Integer;
+begin
+ if idx < length(Src) then begin
+ if (Src[idx] = #10) and (Src[idx+1]=#13) then inc(idx)
+ else if (Src[idx] = #13) and (Src[idx+1]=#10) then inc(idx);
+ end;
+ Result := idx+1;
+end;
+
+function CreateCParser(const CHeaderText: AnsiString; WithCMacroHandler: Boolean): TTextParser;
+begin
+ Result := TTextParser.Create;
+ Result.TokenTable := CreateObjCTokenTable;
+ if WithCMacroHandler then
+ Result.MacroHandler := TCMacroHandler.Create;
+ Result.Buf := CHeaderText;
+end;
+
+function ErrExpectStr(const Expected, Found: AnsiString): AnsiString;
+begin
+ Result := Format(Err_Expect, [Expected, Found]);
+end;
+
+(* ANSI C reserved words
+auto break case char const continue default do double else enum
+extern float for goto if int long register return short signed
+sizeof static struct switch typedef union unsigned void volatile while
+*)
+
+function CreateObjCTokenTable: TTokenTable;
+begin
+ Result := TTokenTable.Create;
+ SetCComments(Result);
+ SetCSymbols(Result.Symbols);
+
+ Result.AddSymbol('!=');
+ Result.AddSymbol('==');
+ Result.AddSymbol('+=');
+ Result.AddSymbol('-=');
+ Result.AddSymbol('*=');
+ Result.AddSymbol('/=');
+ Result.AddSymbol('%=');
+ Result.AddSymbol('|=');
+ Result.AddSymbol('&=');
+ Result.AddSymbol('<<');
+ Result.AddSymbol('>>');
+ Result.AddSymbol('++');
+ Result.AddSymbol('--');
+ Result.AddSymbol('||');
+ Result.AddSymbol('&&');
+
+ Result.SpaceChars := EoLnChars + InvsChars;
+ Result.Precompile := '#';
+ Result.MultiLine := '\';
+ Result.StringStart := ['"', #39];
+end;
+
+procedure SetCSymbols(var ch: TCharSet);
+begin
+ ch := ['!','~','^','(',')','{','}','%','/',':','=','-','+','<','>','*',';', ',','|','&','[',']'{, #39 ,'"'} ]
+end;
+
+procedure SetCComments(Table: TTokenTable);
+begin
+ SetLength(Table.CmtBlock, 1);
+ Table.CmtCount := 1;
+ Table.CmtBlock[0].Open := '/*';
+ Table.CmtBlock[0].Close := '*/';
+ Table.CmtLine.Add('//');
+end;
+
+function isFloatNum(const num: AnsiString): Boolean;
+begin
+ Result := Pos('.', num)>0;
+end;
+
+function ParseHexNumber(const S:AnsiString; var idx: Integer): AnsiString;
+begin
+ Result := ScanWhile(s, idx, ['0'..'9', 'A'..'F', 'a'..'f']);
+end;
+
+procedure ParseCNumeric(const S: AnsiString; var idx: integer; var NumStr: AnsiSTring);
+var
+ l : integer;
+ i : Integer;
+ f : AnsiString;
+begin
+ l := length(s);
+ if (idx <= 0) or (idx > l) then Exit;
+
+ if (s[idx] = '0') and (idx < l) and ((s[idx+1] = 'x') or (s[idx+1] = 'X')) then begin
+ inc(idx,2);
+ NumStr := '0x'+ParseHexNumber(s, idx);
+ end else begin
+ NumStr := ScanWhile(s, idx, ['0'..'9']);
+ if (idx < l) and (s[idx] = '.') then begin
+ i := idx + 1;
+ f := ScanWhile(s, i, ['0'..'9']);
+ if f <> '' then begin
+ idx := i;
+ NumStr := NumStr + '.' + f;
+ end;
+ end;
+ end;
+
+ ScanWhile(s, idx, ['U','L','u','l']);
+end;
+
+function CToPascalNumeric(const Cnum: AnsiString): AnsiString;
+var
+ i : Integer;
+ num : Int64;
+ c : Int64;
+begin
+ if isFloatNum(cNum) then
+ Result := cNum
+ else if length(cNum) < 3 then
+ Result := cNum
+ else if cNum[1] <> '0' then
+ Result := cNum
+ else begin
+ if cNum[2] = 'x'
+ then Result := '$'+Copy(cNum, 3, length(cNum) - 2)
+ else begin
+ num := 0;
+ c := 1;
+ for i := length(cnum) downto 1 do begin
+ if not (cnum[i] in['0'..'7']) then begin
+ Result := cNum;
+ Exit;
+ end;
+ num := num + c * (byte(cnum[i]) - byte('0'));
+ c := c * 8;
+ end;
+ Result := IntToStr(num);
+ end;
+ end;
+end;
+
+function ParseCString(const S: AnsiString; var idx: Integer; var CStr: AnsiString): Boolean;
+var
+ quit : Boolean;
+ i : Integer;
+ ch : AnsiChar;
+begin
+ Result := false;
+ CStr := '';
+ if not (S[idx] in ['"', #39]) then Exit;
+
+ quit := false;
+ i := idx+1;
+ ch := S[idx];
+
+ while (not quit) and (i <= length(s)) do begin
+ ScanTo(s, i, [ch, #10, #13] );
+ quit := (i > length(s)) or (s[i] in [ch, #10, #13]);
+ if quit and (i <= length(s)) and ((s[i] ='"')) then
+ if ((s[i] = ch) and (s[i-1] = '\')) then begin
+ inc(i);
+ quit := false;
+ end;
+ end;
+
+ Result := (i <= length(s)) and (s[i] = ch);
+ if Result then begin
+ inc(i);
+ CStr := Copy(s, idx, i-idx);
+ idx := i;
+ end;
+end;
+
+function ParseCOperator(AParser: TTextParser; var Vl: AnsiString): Boolean;
+var
+ nm : AnsiSTring;
+ tt : TTokenType;
+begin
+ Result := false;
+ if not AParser.FindNextToken(nm, tt) then Exit;
+ Result := nm <> '';
+ if not Result then Exit;
+ vl := nm[1];
+ case vl[1] of
+ '+', '-', '*': Result := true;
+ '|', '&': begin
+ Result := true;
+ end;
+ '<', '>': begin
+ vl := nm[1];
+ Result := AParser.FindNextToken(nm, tt);
+ if (not Result) or (nm = '') then Exit;
+ Result := nm[1] = vl[1] ;
+ if Result then vl := vl[1] + nm[1];
+ end;
+ else
+ Result := false;
+ end;
+end;
+
+function ParseCMacroParam(AParser: TTextParser; var ExpS: AnsiString): Boolean;
+var
+ brac : Integer;
+ idx : Integer;
+begin
+ idx := AParser.Index;
+ brac:=0;
+
+ while AParser.NextToken do begin
+ if AParser.Token='(' then inc(brac)
+ else if (AParser.Token=')') then begin
+ if brac>0 then dec(brac)
+ else begin
+ AParser.Index:=aParser.TokenPos;
+ Break;
+ end;
+ end else if (AParser.Token=',') and (brac=0) then begin
+ AParser.Index:=AParser.TokenPos;
+ Break;
+ end;
+ end;
+ ExpS:=Copy(APArser.Buf, idx, AParser.Index-idx);
+ Result:=True;
+end;
+
+function ParseCExpression(AParser: TTextParser; var ExpS: AnsiString): Boolean;
+var
+ i : integer;
+ nm : AnsiString;
+ tt : TTokenType;
+ brac : Integer;
+begin
+//todo: better code. it's just a work around
+// i := AParser.Index;
+ brac := 0;
+ ExpS := '';
+ Result := false;
+
+ try
+ while AParser.FindNextToken(nm, tt) do begin
+ if (nm = #39) then begin
+ ExpS := #39 + ScanTo(AParser.Buf, AParser.Index, [#39]) + #39;
+ inc(AParser.Index);
+ Result := true;
+ Exit;
+ end else if (tt = tt_Numeric) or (tt = tt_Ident) then begin
+ ExpS := ExpS + nm;
+ i := AParser.Index;
+ if not ParseCOperator(AParser, nm) then begin
+ AParser.Index := i;
+ Break;
+ end else
+ ExpS := ExpS + ' ' + nm + ' ';
+ end else if (tt = tt_Symbol) then begin
+ if nm ='(' then inc(brac)
+ else if (nm = ')') then begin
+ if brac=0 then dec(brac)
+ else begin
+ AParser.Index:=AParser.TokenPos;
+ Break;
+ end;
+ end;
+ end else begin
+ //i := AParser.Index;
+ Exit;
+ end;
+ end;
+ Result := true;
+
+ finally
+ while (brac > 0) and (AParser.FindNextToken(nm, tt)) do
+ if nm = ')' then
+ dec(brac);
+ end;
+end;
+
+{ TTextParser }
+
+constructor TTextParser.Create;
+begin
+ Index := 1;
+ Line := 1;
+ Stack := TList.Create;
+ Errors := TStringList.Create;
+ //IgnoreTokens := TStringList.Create;
+ UsePrecompileEntities := true;
+ Comments := TList.Create;
+end;
+
+destructor TTextParser.Destroy;
+begin
+ Comments.Free;
+ //IgnoreTokens.Free;
+ Errors.Free;
+ Stack.Free;
+ inherited Destroy;
+end;
+
+procedure TTextParser.BeginParse(AObject: TObject);
+begin
+ Stack.Add(AObject);
+end;
+
+procedure TTextParser.EndParse;
+begin
+ if Stack.Count > 0 then Stack.Delete(Stack.Count - 1);
+end;
+
+function TTextParser.HandlePrecomiler: Boolean;
+var
+ idx : Integer;
+ s : AnsiString;
+ df : TCPrepocessor;
+ i : integer;
+begin
+ Result := false;
+ if ProcessingMacro then Exit;
+
+ ProcessingMacro := true;
+ try
+ idx := Index;
+ i := idx+1;
+ ScanWhile(Buf, i, WhiteSpaceChars);
+ s := ScanTo(Buf, i, WhiteSpaceChars);
+ if s = 'define' then df := TCPrepDefine.Create(idx)
+ else if s = 'include' then df := TCPrepInclude.Create(idx)
+ else if s = 'else' then df := TCPrepInclude.Create(idx)
+ else if s = 'endif' then df := TCPrepEndif.Create(idx)
+ else if s = 'pragma' then df := TCPrepPragma.Create(idx)
+ else if (s = 'if') or (s = 'elif') or (s = 'ifdef') or (s = 'ifndef') then begin
+ df := TCPrepIf.Create(idx);
+ TCPrepIf(df).IfOp:=s;
+ end else
+ df := nil;
+
+ Result := Assigned(df);
+ if Result then begin
+ Index:=i;
+ Result := df.Parse(Self);
+ if UsePrecompileEntities then AddChildToStackEntity(df);
+ if Assigned(OnPrecompile) then
+ OnPrecompile(Self, df);
+ end;
+
+ if not Result then begin
+ SetError('cannot handle preprocessor');
+ Exit;
+ end;
+ finally
+ ProcessingMacro := false;
+ end;
+end;
+
+function TTextParser.FindNextToken(var AToken: AnsiString; var ATokenType: TTokenType): Boolean;
+begin
+ Result:=NextToken;
+ AToken:=Token;
+ ATokenType:=TokenType;
+end;
+
+function TTextParser.SkipComments: Boolean;
+var
+ i : Integer;
+ idx : Integer;
+ cmt : AnsiString;
+ comment : TComment;
+ ct : TCommentType;
+begin
+ cmt := '';
+ Result := false;
+
+ for i := 0 to TokenTable.CmtCount - 1 do begin
+ Result:=IsSubStr(TokenTable.CmtBlock[i].Open, Buf, index);
+ if Result then begin
+ idx:=index;
+ inc(index, length(TokenTable.CmtBlock[i].Open));
+ cmt := SkipCommentBlock(Buf, index, TokenTable.CmtBlock[i].Close);
+ ct:=ctBlock;
+ Break;
+ end;
+ end;
+
+ if not Result then
+ for i := 0 to TokenTable.CmtLine.Count - 1 do begin
+ Result:=IsSubStr(TokenTable.CmtLine[i], Buf, index);
+ if Result then begin
+ idx:=index;
+ cmt := SkipLine(Buf, index);
+ Delete(cmt, 1, length(TokenTable.CmtLine[i]) );
+ ct:=ctLine;
+ Break;
+ end;
+ end;
+
+ if Result then begin
+ if UseCommentEntities then begin
+ comment := TComment.Create(idx);
+ comment._Comment := cmt;
+ comment.CommenType:=ct;
+ Comments.Add(Comment);
+ end;
+ if (Assigned(OnComment)) and (cmt <> '') then OnComment(Self, cmt);
+ end;
+end;
+
+
+function TTextParser.NextToken:Boolean;
+var
+ srch : TCharSet;
+ blck : TCharSet;
+ i, j : Integer;
+ t : AnsiString;
+ spaces : TCharSet;
+ Repl : AnsiString;
+ p : Integer;
+begin
+ Result := Index <= length(Buf);
+ if not Result then begin
+ Token:='';
+ Exit;
+ end;
+
+ srch := TokenTable.SpaceChars;
+ blck := [];
+ for i := 0 to TokenTable.CmtCount - 1 do begin
+ t := TokenTable.CmtBlock[i].Open[1];
+ if t <> '' then blck := blck + [t[1]];
+ end;
+ for i := 0 to TokenTable.CmtLine.Count - 1 do begin
+ t := TokenTable.CmtLine[i];
+ if t <> '' then blck := blck + [t[1]];
+ end;
+ srch := srch + blck;
+
+ Token := '';
+ Result := false;
+ TokenType := tt_Ident;
+
+ spaces := TokenTable.SpaceChars;
+ try
+ while (not Result) and (index <= length(Buf)) do begin
+ ScanWhile(Buf, index, spaces);
+ if isMultiline then begin
+ ScanTo(Buf, index, EoLnChars);
+ SkipSingleEoLnChars;
+
+ end else begin
+ if (IsSubStr(TokenTable.Precompile, Buf, Index) and HandlePrecomiler) then
+ // 1. check is Preprocessor directive is found
+ else if (Buf[index] in TokenTable.Symbols) then begin // 2. symbol has been found, so it's not an ident
+ if (not (Buf[index] in blck)) or (not SkipComments) then begin // 2.1 check if comment is found (comment prefixes match to the symbols)
+ Result := true; // 2.2 check if symbol is found
+ if (Buf[index] = '.') and (index < length(Buf)) and (Buf[index+1] in ['0'..'9']) then begin
+ // is float number
+ inc(index);
+ Token := '.' + ScanWhile(Buf, index, ['0'..'9']);
+ TokenType := tt_Numeric;
+ end else begin
+ j:=index;
+
+ //todo: improve!
+ while (j-index<=TokenTable.SymbMaxLen) and (Buf[j] in (TokenTable.Symbols)) do inc(j);
+
+ if TokenTable.isSymbol( Copy( buf, index, j-index) ) then begin
+ Token:=Copy( buf, index, j-index);
+ index:=j;
+ end else begin
+ Token := Buf[index];
+ inc(index);
+ end;
+ TokenType := tt_Symbol;
+ end;
+ Exit;
+ end;
+ end else if (Buf[index] in ['0'..'9']) then begin // 3. a number is found, so it's possibl a number
+ //todo: Hex and floats support!
+ //todo: Negative numbers support;
+ ParseCNumeric(Buf, index, Token);
+ TokenType := tt_Numeric;
+ Result := true;
+ Exit;
+ end else if (Buf[index] in TokenTable.StringStart) then begin
+ ParseCString(Buf, index, Token);
+ TokenType := tt_String;
+ Result := true;
+ Exit;
+ end else begin
+ Token := Token + ScanTo(Buf, index, srch+TokenTable.Symbols+[TokenTable.MultiLine]); // scanning for token
+ if (Buf[index] in blck) then begin
+ Result := SkipComments;
+ Result := Result or (Buf[index] in TokenTable.SpaceChars);
+ if not Result then begin
+ Token := Token + Buf[index];
+ inc(index);
+ end;
+ end else
+ Result := true;
+ Result := Result and (Token <> '');
+ end;
+ end;
+
+ if (Token <> '') and (TokenType = tt_Ident) and Result then begin
+ p := Index - length(Token);
+ TokenPos:=p;
+ if HandleMacro(Token, Repl) then begin
+ inc(MacrosDelta, length(Token)-length(Repl));
+ Delete(buf, p, length(Token));
+ Insert(Repl, Buf, p);
+ Index := p;
+ Result := false;
+ TokenType := tt_Ident;
+ Token := '';
+ end else
+ TokenPos:=p;
+ end;
+
+ end; {of while}
+ finally
+ if not Result
+ then TokenType := tt_Ident
+ else TokenPos := Index - length(Token);
+ //todo: make an event or something
+ if TokenType = tt_Numeric then
+ Token := CToPascalNumeric(Token);
+ end;
+end;
+
+procedure TTextParser.SetError(const ErrorCmt: AnsiString);
+begin
+ Errors.Add(ErrorCmt);
+end;
+
+function TTextParser.HandleMacro(var MacroStr: AnsiString; var ReplaceStr: AnsiString): Boolean;
+begin
+ Result := false;
+ if ProcessingMacro or not Assigned(MacroHandler) then Exit;
+
+ ProcessingMacro := true;
+ try
+ Result := MacroHandler.isMacroDefined(MacroStr);
+ if not Result then Exit;
+
+ Index := TokenPos;
+ Result := MacroHandler.ParseMacro(Self, MacroStr, ReplaceStr);
+ finally
+ ProcessingMacro := false;
+ end;
+end;
+
+function TTextParser.GetBufWideStr(const Cmd: AnsiString): WideString;
+begin
+ Result := Cmd;
+end;
+
+function TTextParser.AddChildToStackEntity(ent: TObject): Boolean;
+var
+ parent : TEntity;
+begin
+ Result := Assigned(stack) and (stack.Count>0);
+ if not Result then Exit;
+
+ parent := stack[stack.Count-1];
+ if Assigned(parent) and (parent is TEntity) then
+ (parent as TEntity).Items.Add(ent);
+end;
+
+function TTextParser.IsMultiLine: Boolean;
+begin
+ Result := TokenTable.MultiLine <> #0;
+ if not Result then Exit;
+ Result := (Buf[index] = TokenTable.MultiLine);
+end;
+
+procedure TTextParser.SkipSingleEoLnChars;
+var
+ next : integer;
+begin
+ next := index + 1;
+ if next > length(Buf) then next := -1;
+
+ if next < 0 then
+ inc(index)
+ else begin
+ if (Buf[index] = #10) and (Buf[next] = #13) then
+ Index := next+1
+ else if (Buf[index] = #13) and (Buf[next] = #10) then
+ Index := next + 1
+ else
+ inc(Index);
+ end;
+end;
+
+{ TTokenTable }
+
+constructor TTokenTable.Create;
+begin
+ CmtLine:=TStringList.Create;
+ fSymbStrs:=TStringList.Create;
+end;
+
+destructor TTokenTable.Destroy;
+begin
+ fSymbStrs.Free;
+ CmtLine.Free;
+ inherited;
+end;
+
+function TTokenTable.AddSymbol(const asym:AnsiString):Boolean;
+begin
+ Result:=False;
+ if asym='' then Exit;
+ fSymbStrs.Add(asym);
+ if length(asym)>fSymbMaxLen then fSymbMaxLen:=length(asym);
+end;
+
+function TTokenTable.isSymbol(const asym:AnsiSTring):Boolean;
+begin
+ if asym='' then
+ Result:=false
+ else begin
+ if length(asym)=1 then
+ Result:=(asym[1] in Symbols) or (fSymbStrs.IndexOf(asym)>=0)
+ else
+ Result:=fSymbStrs.IndexOf(asym)>=0;
+ end;
+end;
+
+{ TEntity }
+
+procedure TEntity.Assign(AEntity: TEntity);
+begin
+ TagComment := AEntity.TagComment;
+end;
+
+function TEntity.DoParse(AParser:TTextParser):Boolean;
+begin
+ Result:=False;
+end;
+
+constructor TEntity.Create(AOffset: Integer);
+begin
+ inherited Create;
+ Offset := AOffset;
+ Items := TList.Create;
+ Specifiers := TStringList.create;
+end;
+
+destructor TEntity.Destroy;
+begin
+ Specifiers.Free;
+ Items.Free;
+ inherited Destroy;
+end;
+
+function TEntity.Parse(AParser: TTextParser): Boolean;
+begin
+ Result := false;
+ AParser.BeginParse(Self);
+ try
+ Result := DoParse(AParser);
+ except
+ on e: Exception do
+ AParser.SetError('Internal error. Exception: ' + e.Message);
+ end;
+ AParser.EndParse;
+end;
+
+
+{ TPrecompiler }
+
+function TPrecompiler.DoParse(AParser: TTextParser): Boolean;
+var
+ tt : TTokenType;
+begin
+ Result := false;
+ if not AParser.FindNextToken(_Directive, tt) then begin
+ AParser.SetError('precompiler directive not found');
+ Exit;
+ end;
+ if (_Directive = '') or (_Directive[1] <> '#') then begin
+ AParser.Index := AParser.TokenPos;
+ AParser.SetError('identifier is not precompiler directive');
+ Exit;
+ end;
+ _Params := SkipLine(AParser.Buf, AParser.Index);
+ Result := true;
+end;
+
+{ TComment }
+
+function TComment.DoParse(AParser: TTextParser): Boolean;
+begin
+ Result := true;
+end;
+
+function RemoveMacroSlash(const macro: AnsiString): AnsiString;
+var
+ i : integer;
+begin
+ for i := length(macro) downto 1 do
+ if not (macro[i] in WhiteSpaceChars) then begin
+ if macro[i] = '\' then Result := Copy(macro, 1, i-1);
+ Exit;
+ end;
+ Result := macro;
+end;
+
+
+function ConsumePreproc(AParser: TTextParser; const preprocname: AnsiString): Boolean;
+begin
+ AParser.NextToken;
+ Result:=AParser.Token='#'+preprocname;
+ if Result then Exit
+ else begin
+ if AParser.Token<>'#' then Exit;
+ AParser.NextToken;
+ Result:=AParser.Token=preprocname;
+ end;
+end;
+
+{ TCPrepDefine }
+
+function TCPrepDefine.DoParse(AParser: TTextParser): Boolean;
+var
+ tt : TTokenType;
+ prs : AnsiString;
+
+ SpaceChars : TCharSet;
+ SymChars : TCharSet;
+begin
+ AParser.FindNextToken(_name, tt);
+ Result := tt = tt_Ident;
+ if not Result then Exit;
+
+
+ if (AParser.Index<=length(AParser.Buf)) and (AParser.Buf[AParser.Index]='(') then begin
+ AParser.NextToken; // skipping "("
+ AParser.NextToken; // the first ident
+ Params:=TStringList.Create;
+ while AParser.Token<>')' do begin
+ if AParser.TokenType=tt_Ident then begin
+ Params.Add(AParser.Token);
+ AParser.NextToken;
+ end;
+ if AParser.Token=',' then AParser.NextToken;
+ end;
+ end;
+
+ SpaceChars := AParser.TokenTable.SpaceChars;
+ SymChars := AParser.TokenTable.Symbols;
+ with AParser.TokenTable do SpaceChars := SpaceChars - [#10,#13];
+ with AParser.TokenTable do Symbols := [#10, #13];
+
+ try
+ AParser.FindNextToken(prs, tt);
+ while (prs <> '') and (not (prs[1] in [#10, #13])) do begin
+ SubsText := SubsText + ' ' + prs;
+ AParser.FindNextToken(prs, tt);
+ end;
+ RemoveMacroSlash(SubsText);
+ if prs <> '' then
+ AParser.Index := AParser.TokenPos;
+ finally
+ AParser.TokenTable.SpaceChars := SpaceChars;
+ AParser.TokenTable.Symbols := SymChars;
+ end;
+end;
+
+destructor TCPrepDefine.Destroy;
+begin
+ Params.Free;
+ inherited Destroy;
+end;
+
+{ TCPrepInclude }
+
+function TCPrepInclude.DoParse(AParser: TTextParser): Boolean;
+var
+ s : AnsiString;
+ tt : TTokenType;
+ exp : AnsiString;
+ chars : TCharSet;
+begin
+ chars := AParser.TokenTable.Symbols;
+ try
+ AParser.TokenTable.Symbols := AParser.TokenTable.Symbols + ['"'];
+
+ //i := AParser.TokenPos;
+
+ AParser.FindNextToken(s, tt);
+ Result := (s = '"') or (s = '<');
+ if not Result then Exit;
+
+ if s = '"' then exp := '"'
+ else if s = '<' then exp := '>';
+
+ repeat
+ AParser.FindNextToken(s, tt);
+ if (s = '/') or (s = '\') or (tt = tt_Ident) then
+ Included := Included + s;
+ until (tt =tt_Symbol) and ((s <> '\') or (s <> '/'));
+
+ Result := s = exp;
+ SkipLine(AParser.buf, AParser.Index);
+ finally
+ AParser.TokenTable.Symbols := chars ;
+ end;
+end;
+
+{ TCPrepElse }
+
+function TCPrepElse.DoParse(AParser: TTextParser): Boolean;
+begin
+ SkipLine(AParser.buf, AParser.Index);
+ Result:=True;
+end;
+
+{ TCPrepEndif }
+
+function TCPrepEndif.DoParse(AParser: TTextParser): Boolean;
+begin
+ SkipLine(AParser.buf, AParser.Index);
+ Result:=True;
+end;
+
+{ TCPrepIf }
+
+function TCPrepIf.DoParse(AParser: TTextParser): Boolean;
+begin
+ _Cond := SkipLine(AParser.buf, AParser.Index);
+ Result:=True;
+end;
+
+{ TCPrepPragma }
+
+function TCPrepPragma.DoParse(AParser: TTextParser): Boolean;
+begin
+ _Text := SkipLine(AParser.buf, AParser.Index);
+ Result:=True;
+end;
+
+{ TCMacroHandler }
+
+procedure TCMacroHandler.AddSimpleMacro(const MacroStr,
+ ReplaceStr: AnsiString);
+begin
+ AddPAramMacro(MacroStr, ReplaceStr, nil);
+end;
+
+procedure TCMacroHandler.AddParamMacro(const MacroStr,ReplaceStr:AnsiString;
+ Params:TStrings);
+var
+ cm : TCMacroStruct;
+ i : Integer;
+begin
+ cm := TCMacroStruct.Create;
+ cm.MacroName := MacroStr;
+ cm.ReplaceText := ReplaceStr;
+ if Assigned(Params) then cm.MacroParams.Assign(Params);
+
+ i := MacrosNames.IndexOf(MacroStr);
+ if i >= 0 then begin
+ MacrosNames.Objects[i].Free;
+ MacrosNames.Delete(i);
+ end;
+ MacrosNames.AddObject(MacroStr, cm);
+end;
+
+procedure TCMacroHandler.Clear;
+var
+ i : Integer;
+begin
+ for i := 0 to MacrosNames.Count - 1 do MacrosNames.Objects[i].Free;
+ MacrosNames.Clear;
+end;
+
+constructor TCMacroHandler.Create;
+begin
+ MacrosNames := TStringList.Create;
+end;
+
+destructor TCMacroHandler.Destroy;
+begin
+ Clear;
+ MacrosNames.Free;
+ inherited;
+end;
+
+function TCMacroHandler.isMacroDefined(const Macro: AnsisTring): Boolean;
+begin
+ Result := MacrosNames.IndexOf(Macro) >= 0;
+end;
+
+function MakeMacroText(const ParamNames, RepValues: TStrings; const SourceText: AnsiString): AnsiString;
+var
+ p : TTextParser;
+ i : Integer;
+begin
+ if SourceText='' then Result:='';
+
+ p:=CreateCParser(SourceText, False);
+ Result:='';
+ try
+ i:=1;
+ while p.NextToken do begin
+ if (p.TokenType=tt_Ident) and (ParamNames.IndexOf(p.Token)>=0) then begin
+ Result:=Result+Copy(p.Buf, i, p.TokenPos-i)+' ' + RepValues.Values[p.Token]+' ';
+ i:=p.Index;
+ end;
+ end;
+ if i= 0);
+ if not Result then begin
+ Parser.Index := Parser.TokenPos;
+ Exit;
+ end;
+ name:=s;
+ idx:=Parser.TokenPos;
+
+ cm := TCMacroStruct(MacrosNames.Objects[i]);
+
+ if Assigned(cm.MacroParams) and (cm.MacroParams.Count > 0) then begin
+ //j := Parser.TokenPos;
+ Parser.NextToken;
+ Result:=Parser.Token='(';
+
+ if not Result then begin
+ Result := False;
+ Parser.SetError('error while parsing macros usage');
+ Exit;
+ end;
+
+ RVal := TStringList.Create;
+ try
+ i := 0;
+ while Parser.Token<>')' do begin
+ ParseCMacroParam(Parser, x);
+
+ Result:=i tt_Symbol) and (s <> '=') then Exit;
+ AParser.FindNextToken(Result, tt);
+end;
+
+
+function isSomeSpecifier(const s: AnsiString): Boolean;
+begin
+ Result:=length(s)>0;
+ if Result then
+ case s[1] of
+ 'a': Result:=s='auto';
+ 'c': Result:=s='const';
+ 'e': Result:=s='extern';
+ 'r': Result:=s='register';
+ 's': Result:=s='static';
+ 'i': Result:=s='inline';
+ 'o': Result:=s='overload';
+ 'v': Result:=(s='volitile') or (s='virtual');
+ else
+ Result:=False;
+ end;
+end;
+
+procedure ParseSepcifiers(AParser: TTextParser; st: TStrings);
+begin
+ while isSomeSpecifier(AParser.Token) do begin
+ st.Add(AParser.Token);
+ AParser.NextToken;
+ end;
+end;
+
+
+function ParseNextEntity(AParser: TTextParser): TEntity;
+var
+ s : AnsiString;
+ tt : TTokenType;
+
+ tp : TEntity;
+ nm : TNamePart;
+ v : TVarFuncEntity;
+begin
+ Result := nil;
+ if not AParser.FindNextToken(s, tt) then Exit;
+
+ if s = 'typedef' then begin
+ Result:=ParseTypeDef(AParser);
+ end else begin
+ v:=TVarFuncEntity.Create(AParser.TokenPos);
+ ParseNames(AParser, tp, v.Names);
+
+ // declarations like:
+ // fn (int i);
+ // are parsed wrongly, because name of the function "fn" is consumed by typedef
+ // while it's named of the function, and the returning type is unspecified.
+ // the name of function must be added to the name operations tree, and type should be set to nil
+ nm:=v.FirstName;
+ if Assigned(tp) and (tp is TSimpleType) and Assigned(nm) and (nm.Kind=nk_Func) and not Assigned(nm.child) then begin
+ nm.child:=TNamePart.Create(nk_Ident);
+ nm.child.Id:=TSimpleType(tp).Name; // making an untyped function
+ tp.Free;
+ tp:=nil;
+ end;
+ TVarFuncEntity(v).RetType:=tp;
+ if (v.Names.Count=0) and Assigned(TVarFuncEntity(v).RetType) then begin
+ Result:=TVarFuncEntity(v).RetType;
+ TVarFuncEntity(v).RetType:=nil;
+ v.Free;
+ end else
+ Result:=v;
+ end;
+end;
+
+procedure ErrorExpect(Parser:TTextParser;const Expect:AnsiString);
+begin
+ Parser.SetError('Excepcted: '+ Expect);
+end;
+
+function ConsumeToken(Parser:TTextParser;const Token:AnsiString):Boolean;
+begin
+ Result:=Parser.Token=Token;
+ if Result then Parser.NextToken
+ else Parser.SetError('Token expected: '+Token);
+end;
+
+function ParseCType(Parser: TTextParser): TEntity;
+var
+ simple : TSimpleType;
+ isunsig : Boolean;
+ islong : Boolean;
+begin
+ Result:=nil;
+ if (Parser.Token='struct') then
+ Result:=ParseStruct(Parser)
+ else if (Parser.Token='union') then
+ Result:=ParseUnion(Parser)
+ else if (Parser.Token='enum') then
+ Result:=ParseEnum(Parser)
+ else begin
+ if Parser.TokenType<>tt_Ident then Exit;
+
+ simple:=TSimpleType.Create(Parser.TokenPos);
+ simple.Name:=Parser.Token;
+
+ Result:=simple;
+ Parser.NextToken;
+
+ isunsig:=(simple.Name='unsigned') or (simple.Name='signed');
+ islong:=Parser.Token='long';
+ if islong then begin
+ simple.name:=simple.name+' '+Parser.Token;
+ Parser.NextToken;
+ end;
+
+ if islong and (Parser.Token='long') then begin
+ simple.name:=simple.name+' '+Parser.Token;
+ Parser.NextToken;
+ end;
+
+ if isunsig and (Parser.Token='short') then begin
+ simple.name:=simple.name+' '+Parser.Token;
+ Parser.NextToken;
+ end;
+
+ if isunsig and (Parser.Token='char') then begin
+ simple.name:=simple.name+' '+Parser.Token;
+ Parser.NextToken
+ end;
+
+ if (isunsig or islong) and (Parser.Token='int') then begin
+ simple.name:=simple.name+' '+Parser.Token;
+ Parser.NextToken
+ end;
+ if islong and (Parser.Token='double') then begin
+ simple.name:=simple.name+' '+Parser.Token;
+ Parser.NextToken
+ end;
+ end;
+end;
+
+function isEndOfExpr(const t: AnsiString; CommaIsEnd: Boolean): Boolean;
+begin
+ Result:=(t=']') or (t=';') or (t=')') or (CommaIsEnd and (t=','));
+end;
+
+function ParseCExpr(Parser: TTextParser; CommaIsEnd: Boolean=False): TExpression;
+var
+ x : TExpression;
+begin
+ if isEndOfExpr(Parser.Token, CommaIsEnd) then
+ Result:=nil
+ else begin
+ x := TExpression.Create(Parser.Index);
+ while not isEndOfExpr(Parser.Token, CommaIsEnd) do begin
+ x.Text:=x.Text+Parser.Token;
+ Parser.NextToken;
+ end;
+ Result:=x;
+ end;
+end;
+
+{ TExpression }
+
+function TExpression.DoParse(AParser: TTextParser): Boolean;
+begin
+ Result:=False;
+end;
+
+procedure ParseFuncParams(Parser: TTextParser; FuncName: TNamePart);
+var
+ prmtype : TEntity;
+ prmname : TNamePart;
+begin
+ Parser.NextToken;
+ while Parser.Token<>')' do begin
+
+ if ParseName(Parser, prmtype, prmname) then begin
+ FuncName.AddParam(prmtype, prmname)
+ end else
+ Exit; // failure
+
+ if Parser.Token<>')' then begin
+ if Parser.Token=',' then
+ Parser.NextToken
+ else begin
+ ErrorExpect(Parser,')');
+ Break;
+ end;
+ end;
+ end;
+ Parser.NextToken;
+end;
+
+function ParseNamePart(Parser: TTextParser): TNamePart;
+var
+ prefix : TNamePart;
+ id : TNamePart;
+ postfix : TNamePart;
+begin
+ if Parser.Token='*' then begin
+ prefix:=TNamePart.Create(nk_Ref);
+ while Parser.Token='*' do begin
+ inc(prefix.refcount);
+ Parser.NextToken;
+ end;
+ end else
+ prefix:=nil;
+
+ if Parser.Token='(' then begin
+ Parser.NextToken;
+ id:=ParseNamePart(Parser);
+ ConsumeToken(Parser, ')');
+ end else if Parser.TokenType=tt_Ident then begin
+ id:=TNamePart.Create(nk_Ident);
+ id.id:=Parser.Token;
+ Parser.NextToken;
+ end else
+ id:=nil;
+
+ postfix:=nil;
+ if Parser.Token='[' then begin
+ while Parser.Token='[' do begin
+ if Assigned(postfix) then begin
+ postfix.child:=TNamePart.Create(nk_Array);
+ postfix:=postfix.child
+ end else
+ postfix:=TNamePart.Create(nk_Array);
+ Parser.NextToken;
+ postfix.AddArrayExpr(ParseCExpr(Parser));
+ if not ConsumeToken(Parser, ']') then Break;
+ end;
+ end else if Parser.Token='(' then begin
+ postfix:=TNamePart.Create(nk_Func);
+ ParseFuncParams(Parser, postfix);
+ end;
+
+ Result:=id;
+ if Assigned(postfix) then begin
+ postfix.child:=Result;
+ Result.owner:=postfix;
+ Result:=postfix;
+ end;
+
+ if Assigned(prefix) then begin
+ if Assigned(Result) and (Result.Kind=nk_Ref) then begin
+ inc(Result.RefCount, prefix.RefCount);
+ prefix.Free;
+ end else begin
+ prefix.child:=Result;
+ if Assigned(Result) then Result.owner:=prefix;
+ Result:=prefix;
+ end;
+ end;
+end;
+
+function ParseNames(Parser: TTextParser; var NameType: TEntity; Names: TList; AllowMultipleNames: Boolean): Boolean;
+var
+ Name : TNamePart;
+ done : Boolean;
+ specs : TStringList;
+begin
+ specs:=TStringList.Create;
+ ParseSepcifiers(Parser, specs);
+ NameType:=ParseCType(Parser);
+ Result:=Assigned(NameType);
+ if Result then NameType.Specifiers.Assign(specs);
+ specs.Free;
+
+ if not Result then Exit;
+
+ try
+ repeat
+ Name:=ParseNamePart(Parser);
+ if Assigned(Name) then Names.Add(Name);
+ if not AllowMultipleNames then begin
+ Result:=True;
+ Exit;
+ end;
+ done:=(Parser.Token<>',') and (Parser.Token=')');
+ if not done then begin
+ if Parser.Token <> ',' then begin
+ ErrorExpect(Parser, ')');
+ Exit;
+ end;
+ Parser.NextToken;
+ end;
+ until done;
+ finally
+ end;
+end;
+
+function ParseName(Parser: TTextParser; var NameType: TEntity; var name: TNamePart): Boolean;
+var
+ nm : TList;
+begin
+ nm:=TList.Create;
+ try
+ name:=nil;
+ NameType:=nil;
+ Result:=ParseNames(Parser, NameType, nm, False);
+ if Result and (nm.Count>0) then name:=TNamePart(nm[0]);
+ finally
+ nm.Free;
+ end;
+end;
+
+{ TNamePart }
+
+constructor TNamePart.Create(AKind:TNameKind);
+begin
+ inherited Create;
+ Kind:=AKind;
+end;
+
+procedure TNamePart.AddParam(prmtype:TEntity;prmname:TNamePart);
+var
+ i : Integer;
+begin
+ i:=length(Params);
+ SetLength(Params, i+1);
+ Params[i].prmtype:=prmtype;
+ Params[i].name:=prmname;
+end;
+
+procedure TNamePart.AddArrayExpr(expr:TExpression);
+var
+ i : Integer;
+begin
+ i:=length(arrayexp);
+ SetLength(arrayexp, i+1);
+ arrayexp[i]:=expr;
+end;
+
+{ TVarFuncEntity }
+
+function TVarFuncEntity.DoParse(AParser:TTextParser):Boolean;
+begin
+ Result:=False;
+end;
+
+constructor TVarFuncEntity.Create(AOffset: Integer);
+begin
+ inherited Create(AOffset);
+ Specifiers:=TStringList.Create;
+ Names:=TList.Create;
+end;
+
+destructor TVarFuncEntity.Destroy;
+begin
+ Specifiers.Free;
+ inherited Destroy;
+end;
+
+function TVarFuncEntity.FirstName:TNamePart;
+begin
+ if Names.Count>0 then Result:=TNamePart(Names[0]) else Result:=nil;
+end;
+
+{ TStructType }
+
+function TStructType.AddField(ev:TVarFuncEntity):Integer;
+var
+ i : Integer;
+begin
+ i:=length(fields);
+ SetLength(fields, i+1);
+ fields[i].v:=ev;
+ Result:=i;
+end;
+
+function ParseStruct(AParser: TTextParser): TStructType;
+var
+ i : Integer;
+ st : TStructType;
+ v : TVarFuncEntity;
+begin
+ Result:=nil;
+ if AParser.Token<>'struct' then Exit;
+
+ st:=TStructType.Create(AParser.TokenPos);
+ AParser.NextToken;
+
+ Result:=st;
+ if AParser.TokenType=tt_Ident then begin
+ Result.Name:=AParser.Token;
+ AParser.NextToken;
+ end;
+
+ if AParser.Token<>'{' then begin
+ ErrorExpect(AParser, '{');
+ Exit;
+ end;
+ AParser.NextToken;
+
+ try
+ repeat
+ v:=TVarFuncEntity.Create(AParser.TokenPos);
+ if not ParseNames(AParser, v.RetType, v.Names) then begin
+ ErrorExpect(AParser, 'type name');
+ v.Free;
+ Exit;
+ end;
+ i:=st.AddField(v);
+ if AParser.Token=':' then begin
+ AParser.NextToken;
+ st.fields[i].bits:=ParseCExpr(AParser);
+ end;
+ if AParser.Token=';' then AParser.NextToken;
+ until (AParser.Token='}');
+
+ ConsumeToken(AParser, '}');
+ Result:=st;
+ finally
+ if not Assigned(Result) then st.Free;
+ end;
+end;
+
+function ParseUnion(AParser:TTextParser):TUnionType;
+var
+ i : Integer;
+ st : TUnionType;
+ v : TVarFuncEntity;
+begin
+ Result:=nil;
+ if AParser.Token<>'union' then Exit;
+
+ st:=TUnionType.Create(AParser.TokenPos);
+ AParser.NextToken;
+
+ Result:=st;
+ if AParser.TokenType=tt_Ident then begin
+ Result.Name:=AParser.Token;
+ AParser.NextToken;
+ end;
+
+ if AParser.Token<>'{' then begin
+ ErrorExpect(AParser, '{');
+ Exit;
+ end;
+ AParser.NextToken;
+
+ try
+ repeat
+ v:=TVarFuncEntity.Create(AParser.TokenPos);
+ if not ParseNames(AParser, v.RetType, v.Names) then begin
+ ErrorExpect(AParser, 'type name');
+ v.Free;
+ Exit;
+ end;
+ i:=st.AddField(v);
+ if AParser.Token=':' then begin
+ AParser.NextToken;
+ st.fields[i].bits:=ParseCExpr(AParser);
+ end;
+ if AParser.Token=';' then AParser.NextToken;
+ until (AParser.Token='}');
+
+ ConsumeToken(AParser, '}');
+ Result:=st;
+ finally
+ if not Assigned(Result) then st.Free;
+ end;
+end;
+
+function ParseTypeDef(AParser: TTextParser): TTypeDef;
+var
+ td : TTypeDef;
+begin
+ Result:=nil;
+ if AParser.Token<>'typedef' then Exit;
+ try
+ td:=TTypeDef.Create(AParser.TokenPos);
+ AParser.NextToken;
+ Result:=td;
+
+ ParseName(AParser, td.origintype, td.name);
+ finally
+ if not Assigned(Result) then
+ td.Free;
+ end;
+end;
+
+function ParseEnum(AParser: TTextParser): TEnumType;
+var
+ en : TEnumType;
+ nm : AnsiString;
+ x : TExpression;
+ ofs : Integer;
+begin
+ Result:=nil;
+ en:=nil;
+ try
+ if AParser.Token<>'enum' then Exit;
+ en:=TEnumType.Create(AParser.TokenPos);
+ AParser.NextToken;
+ if AParser.TokenType=tt_Ident then begin
+ en.Name:=AParser.Token;
+ AParser.NextToken;
+ end;
+ if AParser.Token='{' then begin
+ AParser.NextToken;
+ while AParser.Token<>'}' do begin
+ if AParser.TokenType<>tt_Ident then begin
+ ErrorExpect(AParser, 'identifier');
+ Exit;
+ end;
+ nm:=AParser.Token;
+ ofs:=AParser.TokenPos;
+ AParser.NextToken;
+ if AParser.Token='=' then begin
+ AParser.NextToken;
+ x:=ParseCExpr(AParser, True);
+ if not Assigned(x) then Exit;
+ end else
+ x:=nil;
+ en.AddItem(nm, x, ofs);
+ if AParser.Token=',' then AParser.NextToken;
+ end;
+ end;
+ AParser.NextToken;
+ Result:=en;
+ finally
+ if not Assigned(Result) then en.Free;
+ end;
+end;
+
+{ TUnionType }
+
+function TUnionType.AddField(ev:TVarFuncEntity):Integer;
+var
+ i : Integer;
+begin
+ i:=length(fields);
+ SetLength(fields, i+1);
+ fields[i].v:=ev;
+ Result:=i;
+end;
+
+{ TEnumType }
+
+function TEnumType.AddItem(const name:AnsiString;x:TExpression; Offset: Integer): Integer;
+var
+ i : Integer;
+begin
+ i:=length(items);
+ SetLength(items, i+1);
+ items[i].Name := name;
+ items[i].Value := x;
+ items[i].Offset:=Offset;
+ Result:=i;
+end;
+
+end.
diff --git a/components/chelper/cparserutils.pas b/components/chelper/cparserutils.pas
new file mode 100644
index 000000000..202bba0fc
--- /dev/null
+++ b/components/chelper/cparserutils.pas
@@ -0,0 +1,240 @@
+{ The unit is part of Lazarus Chelper package
+
+ Copyright (C) 2010 Dmitry Boyarintsev skalogryz dot lists at gmail.com
+
+ This library is free software; you can redistribute it and/or modify it
+ under the terms of the GNU Library General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ This program is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+ for more details.
+
+ You should have received a copy of the GNU Library General Public License
+ along with this library; if not, write to the Free Software Foundation,
+ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+}
+unit cparserutils;
+
+interface
+
+uses
+ cparsertypes;
+
+// is function declared, i.e. int f()
+function isFunc(name: TNamePart): Boolean;
+
+
+// probably an untyped function: fn ().
+// the name of the function has been consumed by TYPE parsing, so ommited!
+// so TNamepart doesn't contain any children
+function isUnnamedFunc(name: TNamepart): Boolean;
+
+// is pointer to a function declared, i.e. int (*f)()
+function isPtrToFunc(name: TNamePart): Boolean;
+
+// is function declared, returning a pointer to a function, i.e. int (* (f)(int i) )()
+// pascal variant of this case:
+// type
+// TRetFunc = function : Integer;
+// function f(i: Integer): TRetFunc; // body or extern modifier must be present!!!
+function isFuncRetFuncPtr(name: TNamePart): Boolean;
+
+// is pointer to a function declared, returning a pointer to a function, i.e.: int (*(*f)(int i))()
+// pascal variant of this case:
+// type
+// TRetFunc = function : Integer;
+// var
+// f : function (i: Integer): TRetFunc;
+function isPtrToFuncRetFuncPtr(name: TNamePart): Boolean;
+
+function GetFuncParam(name: TNamePart): TNamePart;
+
+// is array variable:
+// int a[10], *a[10] (array of 10 integers, or array of 10 pointers to integer)
+function isArray(name: TNamePart): Boolean;
+
+function GetArrayPart(name: TNamePart): TNamePart;
+
+// returns the variable/function name from the struct
+function GetIdFromPart(name: TNamePart): AnsiString;
+
+function GetIdPart(name: TNamePart): TNamePart;
+
+function isNamePartPtrToFunc(part: TNamePart): Boolean; inline;
+
+
+type
+
+ { TLineBreaker }
+
+ TLineInfo = record
+ linestart : Integer;
+ lineend : Integer;
+ end;
+
+ TLineBreaker = class(TObject)
+ private
+ fLines : array of TLineInfo;
+ flineCount : Integer;
+ procedure AddLine(const linestart, lineend: Integer);
+ public
+ procedure SetText(const AText: AnsiString);
+ function LineNumber(Offset: Integer): Integer;
+ end;
+
+implementation
+
+function isNamePartPtrToFunc(part: TNamePart): Boolean; inline;
+begin
+ Result:=Assigned(part) and (part.Kind=nk_Ref) and Assigned(part.owner) and (part.owner.kind=nk_Func);
+end;
+
+function isPtrToFunc(name: TNamePart): Boolean;
+begin
+ Result := Assigned(name) and (name.Kind=nk_Func) and Assigned(name.child) and
+ (name.child.Kind=nk_Ref) and Assigned(name.child.child) and
+ (name.child.child.Kind=nk_Ident);
+end;
+
+function SkipRefPart(name: TNamePart): TNamePart;
+begin
+ if Assigned(name) then begin
+ if name.Kind=nk_Ref then Result:=name.child
+ else Result:=name;
+ end else
+ Result:=nil;
+end;
+
+function isFunc(name: TNamePart): Boolean;
+begin
+ name:=SkipRefPart(name);
+ Result:=Assigned(name) and (name.Kind=nk_Func) and Assigned(name.child) and (name.child.Kind=nk_Ident)
+end;
+
+function isUnnamedFunc(name: TNamepart): Boolean;
+begin
+ Result:=Assigned(name) and not Assigned(name.child) and (name.Kind=nk_Func);
+end;
+
+function isRetFuncPtr(name: TNamePart): Boolean;
+begin
+ Result:=Assigned(name) and Assigned(name.child) and
+ (name.Kind=nk_Func) and (name.child.Kind=nk_Ref);
+end;
+
+function GetFuncParam(name:TNamePart):TNamePart;
+begin
+ while Assigned(name) and (name.Kind<>nk_Func) do name:=name.child;
+ Result:=name;
+end;
+
+function isArray(name: TNamePart): Boolean;
+begin
+ Result:=(name.Kind=nk_Array)
+ or (Assigned(name.child)
+ and (name.child.Kind=nk_Array)
+ and (name.Kind=nk_Ref));
+end;
+
+function isFuncRetFuncPtr(name: TNamePart): Boolean;
+var
+ p : TNamePart;
+begin
+ Result:=isRetFuncPtr(name);
+ if Result then begin
+ p:=name.child.child;
+ Result:=Assigned(p) and Assigned(p.child)
+ and (p.Kind=nk_Func)
+ and (p.child.Kind=nk_Ident)
+ end;
+end;
+
+function isPtrToFuncRetFuncPtr(name: TNamePart): Boolean;
+var
+ p : TNamePart;
+begin
+ Result:=isRetFuncPtr(name);
+ if Result then begin
+ p:=name.child.child;
+ Result:=Assigned(p) and Assigned(p.child) and Assigned(p.child.child)
+ and (p.Kind=nk_Func) and (p.child.Kind=nk_Ref)
+ and (p.child.child.Kind=nk_Ident);
+ end;
+end;
+
+function GetArrayPart(name:TNamePart):TNamePart;
+begin
+ if name.Kind=nk_Array then
+ Result:=name
+ else if (name.Kind=nk_Ref) and (Assigned(name.child)) and (name.child.Kind=nk_array) then
+ Result:=name.child
+ else
+ Result:=nil;
+end;
+
+function GetIdFromPart(name: TNamePart): AnsiString;
+begin
+ while Assigned(name) and (name.Kind<>nk_Ident) do
+ name:=name.child;
+ if Assigned(name) then Result:=name.Id
+ else Result:='';
+end;
+
+function GetIdPart(name: TNamePart): TNamePart;
+begin
+ Result:=nil;
+ while Assigned(name) and (name.Kind<>nk_Ident) do
+ name:=name.child;
+ Result:=name;
+end;
+
+{ TLineBreaker }
+
+procedure TLineBreaker.AddLine(const linestart,lineend:Integer);
+begin
+ if flineCount=length(fLines) then begin
+ if fLineCount=0 then SetLength(fLines, 4)
+ else SetLength(fLines, fLineCount*2)
+ end;
+ fLines[fLineCount].linestart:=linestart;
+ fLines[fLineCount].lineend:=lineend;
+ inc(fLineCount);
+end;
+
+procedure TLineBreaker.SetText(const AText: AnsiString);
+var
+ i : Integer;
+ j : Integer;
+begin
+ flineCount:=0;
+ i:=1;
+ j:=1;
+ while i<=length(AText) do begin
+ if (AText[i] in [#10, #13]) then begin
+ inc(i);
+ if (i<=length(AText)) and (AText[i] in [#10, #13]) and (AText[i-1]<>Atext[i]) then
+ inc(i);
+ AddLine(j, i-1);
+ j:=i;
+ end else
+ inc(i);
+ end;
+ if j<>i-1 then AddLine(j, i-1);
+end;
+
+function TLineBreaker.LineNumber(Offset:Integer):Integer;
+var
+ i : Integer;
+begin
+ for i:=0 to flineCount-1 do
+ if (Offset>=fLines[i].linestart) and (Offset<=flines[i].lineend) then begin
+ Result:=i;
+ Exit;
+ end;
+ Result:=-1;
+end;
+
+end.
diff --git a/components/chelper/ctopasconvert.pas b/components/chelper/ctopasconvert.pas
new file mode 100644
index 000000000..7ee1e76a7
--- /dev/null
+++ b/components/chelper/ctopasconvert.pas
@@ -0,0 +1,1213 @@
+{ The unit is part of Lazarus Chelper package
+
+ Copyright (C) 2010 Dmitry Boyarintsev skalogryz dot lists at gmail.com
+
+ This library is free software; you can redistribute it and/or modify it
+ under the terms of the GNU Library General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ This program is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+ for more details.
+
+ You should have received a copy of the GNU Library General Public License
+ along with this library; if not, write to the Free Software Foundation,
+ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+}
+unit ctopasconvert;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils,
+ cparsertypes, TextParsingUtils, codewriter, cparserutils;
+
+type
+
+ { TConvertSettings }
+
+ TConvertSettings = class
+ RecordsArePacked : Boolean;
+ FuncsAreExternal : Boolean;
+ EnumsAsConst : Boolean;
+ UsedNames : TStringList;
+ CtoPasTypes : TStringList;
+
+ DefaultCType : AnsiString;
+
+ // for unkown types ONLY! (not available at CtoPasTypes);
+ TypeNamePrefix : AnsiString;
+ RefTypeNamePrefix : AnsiString;
+ FuncConv : AnsiString;
+ FuncDeclPostfix : AnsiString;
+ ParamPrefix : AnsiString;
+
+ CustomDefines : AnsiString;
+
+
+ constructor Create;
+ destructor Destroy; override;
+ function GetUniqueName(const n: ansistring): Ansistring;
+ function GetTypeName(const CTypeName: AnsiString): Ansistring;
+ end;
+
+// endPoint contains
+// Y - line number (starting from 1),
+// X - column (starting from 1);
+function ConvertCode(const t: AnsiString; var endPoint: TPoint; cfg: TConvertSettings = nil): AnsiString;
+
+implementation
+
+type
+ TFuncWriterProc = procedure (wr: TCodeWriter; const FunctName, FuncRetName: AnsiString;
+ const Params, ParamTypes: array of AnsiString) of object;
+
+ TVarListItem = record
+ VarName : AnsiString;
+ VarType : AnsiString;
+ Comment : AnsiString;
+ end;
+
+ { TVarList }
+
+ TVarList = class(TObject)
+ public
+ Items : array of TVarListItem;
+ ItemsCount : Integer;
+ procedure Add(const VarName, VarType, Comment: AnsiString); overload;
+ procedure Add(const Comment: AnsiString); overload;
+ constructor Create;
+ destructor Destroy; override;
+ procedure Clear;
+ procedure WriteList(wr: TCodeWriter);
+ end;
+
+ { TCodeConvertor }
+
+ TCodeConvertor = class(TObject)
+ protected
+ CmtList : TList;
+ Breaker : TLineBreaker;
+ LastOffset : Integer;
+ function FindCommentForLine(ln: Integer): TComment;
+ protected
+ fWriters : TList;
+ AuxTypeCounter : Integer;
+
+ procedure DefFuncWrite(wr: TCodeWriter; const FuncName, FuncRetType: AnsiString;
+ const Params, ParamTypes: array of AnsiString);
+
+ function NextAuxTypeName(const Prefix: AnsiString): AnsiString;
+
+ function GetPasTypeName(RetType: TEntity; TypePart: TNamePart): AnsiString;
+
+ procedure DeclarePasType(TypeEntity: TEntity; const PasTypeName: AnsiString);
+ procedure DeclareFuncType(const PasTypeName, RetTypeName: AnsiString; const params: array of TFuncParam);
+
+ procedure WriteLnCommentForOffset(AOffset: Integer);
+ function NextCommentBefore(AOffset: Integer): Integer;
+ procedure WriteLnCommentsBeforeOffset(AOffset: Integer);
+
+ procedure WriteFuncDecl(const FnName, PasRetType: Ansistring; const params : array of TFuncParam);
+ procedure WriteFuncOrVar(cent: TVarFuncEntity; StartVar: Boolean); // todo: deprecate!
+ procedure WriteTypeDef(tp: TTypeDef);
+ procedure WriteEnum(en: TEnumType);
+ procedure WriteEnumAsConst(en: TEnumType);
+ procedure WriteStruct(st: TStructType);
+ procedure WriteCommentToPas(cent: TComment);
+ procedure WriteExp(x: TExpression);
+ procedure WritePreprocessor(cent: TCPrepDefine);
+
+ procedure PushWriter;
+ procedure PopWriter;
+ public
+ wr : TCodeWriter;
+ cfg : TConvertSettings;
+ WriteFunc : TFuncWriterProc;
+ constructor Create(ASettings: TConvertSettings);
+ destructor Destroy; override;
+ procedure WriteCtoPas(cent: TEntity; comments: TList; const ParsedText: AnsiString);
+ end;
+
+procedure TVarList.Add(const VarName,VarType,Comment:AnsiString);
+begin
+ if ItemsCount=length(Items) then begin
+ if ItemsCount=0 then SetLength(Items, 4)
+ else SetLength(Items, ItemsCount*2);
+ end;
+ Items[ItemsCount].VarName:=VarName;
+ Items[ItemsCount].VarType:=VarType;
+ Items[ItemsCount].Comment:=Comment;
+ inc(ItemsCount);
+end;
+
+procedure TVarList.Add(const Comment:AnsiString);
+begin
+ Add('', '', Comment);
+end;
+
+constructor TVarList.Create;
+begin
+
+end;
+
+destructor TVarList.Destroy;
+begin
+ inherited Destroy;
+end;
+
+procedure TVarList.Clear;
+begin
+ ItemsCount:=0;
+end;
+
+
+function MaxStrLen(const s: AnsiString; Max: Integer): Integer; inline;
+begin
+ if Max>length(s) then Result:=Max
+ else Result:=length(s);
+end;
+
+function StrToLen(const s: AnsiString; Len: Integer; const SpChar: AnsiChar = ' '): AnsiString;
+begin
+ if length(s)0 then Move(s[1], Result[1], length(s));
+ end else
+ Result:=s;
+end;
+
+procedure TVarList.WriteList(wr:TCodeWriter);
+var
+ MaxNameLen : Integer;
+ MaxTypeLen : Integer;
+ i : Integer;
+begin
+ if ItemsCount=0 then Exit;
+
+ MaxNameLen:=0;
+ MaxTypeLen:=0;
+
+ for i:=0 to ItemsCount-1 do begin
+ MaxNameLen:=MaxStrLen(Items[i].VarName, MaxNameLen);
+ MaxTypeLen:=MaxStrLen(Items[i].VarType, MaxTypeLen);
+ end;
+ inc(MaxNameLen);
+ inc(MaxTypeLen, 2); // ';' + ' ' after type name
+
+ for i:=0 to ItemsCount-1 do
+ with Items[i] do
+ if Comment<>'' then
+ wr.Wln( StrToLen(VarName, MaxNameLen)+': '+StrToLen(VarType+';', MaxTypeLen) + ' '+Comment)
+ else
+ wr.Wln( StrToLen(VarName, MaxNameLen)+': '+VarType+';');
+end;
+
+
+type
+
+ { TStopComment }
+
+ TStopComment = class(TObject)
+ public
+ FirstComment : boolean;
+ CommentFound : boolean;
+ CommentEnd : Integer;
+ Precomp : TEntity;
+ PrecompEnd : Integer;
+
+ procedure OnComment(Sender: TObject; const Str: ansistring);
+ procedure OnPrecompiler(Sender: TTextParser; PrecompEntity: TObject);
+ end;
+
+procedure TStopComment.OnComment(Sender: TObject; const Str: ansistring);
+var
+ parser: TTextParser;
+begin
+ parser := TTextParser(Sender);
+ if not FirstComment then
+ begin
+ FirstComment := parser.Stack.Count = 0;
+ CommentEnd := parser.Index;
+ end;
+ CommentFound := True;
+end;
+
+procedure TStopComment.OnPrecompiler(Sender: TTextParser; PrecompEntity: TObject);
+begin
+ if not FirstComment and (PrecompEntity is TEntity) then
+ begin
+ FirstComment:=True;
+ Precomp:=PrecompEntity as TEntity;
+ PrecompEnd:=Sender.Index;
+ end;
+end;
+
+function ParseNextEntityOrComment(AParser: TTextParser): TEntity;
+var
+ cmt : TStopComment;
+ ent : TEntity;
+ entidx : Integer;
+begin
+ cmt := TStopComment.Create;
+ AParser.UseCommentEntities := True;
+ AParser.OnComment := @cmt.OnComment;
+ AParser.OnPrecompile:=@cmt.OnPrecompiler;
+ Result:=nil;
+
+ ent := ParseNextEntity(AParser);
+ entidx:=AParser.Index;
+
+ if cmt.FirstComment then begin
+ if Assigned(cmt.Precomp) then begin
+ Result:=cmt.Precomp;
+ AParser.Index:=cmt.PrecompEnd;
+ end else if (AParser.Comments.Count > 0) then
+ begin
+ Result := TComment(AParser.Comments[0]);
+ AParser.Index := cmt.CommentEnd;
+ end;
+ end;
+
+ cmt.Free;
+ if (not Assigned(Result)) or (Assigned(ent) and (ent.Offset'' then PrepareMacros(cfg.CustomDefines, macros);
+
+ p := CreateCParser(t);
+ p.MacroHandler:=macros;
+ try
+ try
+ ent := ParseNextEntityOrComment(p);
+ except
+ on E: Exception do Result:='error while parsing C-code: '+e.Message;
+ end;
+
+ i := 1;
+ le := 0;
+ endPoint.X := 0;
+ endPoint.Y := 0;
+ while i < p.Index do begin
+ Inc(endPoint.Y);
+ le := i;
+ SkipLine(t, i);
+ end;
+ endPoint.X := p.Index - le + 1 + p.MacrosDelta;
+
+ if Assigned(ent) then begin
+
+ cnv := TCodeConvertor.Create(cfg);
+ try
+ cnv.WriteCtoPas(ent, p.Comments, t);
+ except
+ on e: Exception do Result:=Result+LineEnding+ 'error while converting C code: ' + e.Message;
+ end;
+ Result := cnv.wr.Text;
+ cnv.Free;
+ end else
+ Result:='unable to parse C expression';
+
+ finally
+ p.Free;
+ macros.Free;
+
+ end;
+ except
+ on e: Exception do Result:=Result+LineEnding+' internal error: '+ e.Message;
+ end;
+ if owncfg then cfg.Free;
+end;
+
+{ TCodeConvertor }
+
+constructor TCodeConvertor.Create(ASettings:TConvertSettings);
+begin
+ cfg:=ASettings;
+ wr:=TCodeWriter.Create;
+ WriteFunc:=@DefFuncWrite;
+end;
+
+destructor TCodeConvertor.Destroy;
+var
+ i : Integer;
+begin
+ if Assigned(fWriters) then begin
+ for i:=0 to fWriters.Count-1 do TObject(fWriters[i]).Free;
+ fWriters.Free;
+ end;
+ wr.Free;
+ inherited Destroy;
+end;
+
+procedure TCodeConvertor.WriteCommentToPas(cent: TComment);
+var
+ u: ansistring;
+begin
+ u := cent._Comment;
+ if cent.CommenType = ctBlock then
+ begin
+ u := StringReplace(u, '*)', '* )', [rfReplaceAll]);
+ wr.Wln('(*' + u + ' *)');
+ end
+ else
+ begin
+ wr.Wln('//' + u);
+ end;
+end;
+
+procedure TCodeConvertor.WriteExp(x:TExpression);
+begin
+ wr.W('0 {todo writeexp}');
+end;
+
+function CtoPasSymbol(const t: AnsiString): AnsiString;
+begin
+ if (t='>>') then Result:='shr'
+ else if (t='<<') then Result:='shl'
+ else if (t='%') then Result:='mod'
+ else if (t='|') or (t='||') then Result:='or'
+ else if (t='&') or (t='&&') then Result:='and'
+ else if (t='^') then Result:='xor'
+ else if (t='!') or (t='~') then Result:='not'
+ else if (t='!=') then Result:='<>'
+ else Result:=t;
+end;
+
+function CtoPasString(const t: AnsiString; cfg: TConvertSettings): AnsiString;
+begin
+ Result:=#39+Copy(t, 2, length(t)-2)+#39;
+end;
+
+procedure TCodeConvertor.WritePreprocessor(cent:TCPrepDefine);
+var
+ p : TTextParser;
+ s : AnsiString;
+begin
+ if cent.SubsText<>'' then begin
+ SetPasSection(wr, 'const');
+ //wr.Wln(cfg.GetUniqueName(cent._Name) + ' = ' + Trim(cent.SubsText)+';');
+ p:=CreateCParser(cent.SubsText, false);
+ s:='';
+ while p.NextToken do begin
+ case p.TokenType of
+ tt_String: s:=s+' '+CtoPasString(p.Token, cfg);
+ tt_Symbol: s:=s+' '+CtoPasSymbol(p.Token);
+ else
+ s:=s+' '+p.Token;
+ end;
+ end;
+ p.Free;
+ wr.W(cfg.GetUniqueName(cent._Name) + ' =' + s+';');
+
+ WriteLnCommentForOffset(cent.Offset);
+ end;
+end;
+
+procedure TCodeConvertor.PushWriter;
+begin
+ if not Assigned(fWriters) then fWriters:=TList.Create;
+ fWriters.Add(wr);
+ wr:=TCodeWriter.Create;
+end;
+
+procedure TCodeConvertor.PopWriter;
+var
+ t : TCodeWriter;
+ s4 : AnsiString;
+ s5 : AnsiString;
+ i : Integer;
+begin
+ if not Assigned(fWriters) or (fWriters.Count=0) then Exit;
+ t:=wr;
+ i:=fWriters.Count-1;
+ if i<0 then wr:=nil else wr:=TCodeWriter(fWriters[i]);
+
+ fWriters.Delete(i);
+ if t.Text<>'' then begin
+ // HACK: Push/Pop writing takes place for new type declarations only
+ // if there're multiple pop/push operations, the resulting code might look like:
+ // type
+ // A1 = something
+ // type
+ // A2 = something
+ // It's possible to merge them into:
+ // type
+ // A1 = something
+ // A2 = something
+ s4:=Copy(t.Text, 1, 4);
+ s5:=Copy(t.text, 1, 5);
+ if Assigned(wr) then begin
+ if (s4='type') and (Copy(wr.Text, 1, 4)=s4) then
+ wr.Text:=t.Text+Copy(wr.Text, 4+sizeof(LineEnding)+1, length(wr.Text))
+ else if (s5='const') and (Copy(wr.Text, 1, 5)=s5) then
+ wr.Text:=t.Text+Copy(wr.Text, 5+sizeof(LineEnding)+1, length(wr.Text))
+ else
+ wr.Text:=t.Text+wr.Text;
+ end;
+ end;
+ t.Free;
+end;
+
+procedure TCodeConvertor.DeclareFuncType(const PasTypeName, RetTypeName: AnsiString; const params: array of TFuncParam);
+begin
+ SetPasSection(wr, 'type');
+ wr.W(PasTypeName + ' = ');
+ WriteFuncDecl('', RetTypeName, params);
+end;
+
+procedure TCodeConvertor.WriteLnCommentForOffset(AOffset:Integer);
+var
+ cmt : TComment;
+begin
+ cmt:=FindCommentForLine( Breaker.LineNumber(AOffset));
+ if Assigned(cmt) then begin
+ LastOffset:=AOffset;
+ wr.W(' ');
+ WriteCommentToPas(cmt);
+ end else
+ wr.Wln;
+end;
+
+function TCodeConvertor.NextCommentBefore(AOffset:Integer):Integer;
+var
+ i : Integer;
+ c : TComment;
+begin
+ Result:=-1;
+ for i:=0 to CmtList.Count-1 do begin
+ c:=TComment(CmtList[i]);
+ if (c.Offset>LastOffset) and (c.OffsetAOffset then
+ Exit;
+ end;
+end;
+
+procedure TCodeConvertor.WriteLnCommentsBeforeOffset(AOffset:Integer);
+var
+ i : Integer;
+begin
+ i:=NextCommentBefore(AOffset);
+ while i>=0 do begin
+ WriteLnCommentForOffset(i);
+ i:=NextCommentBefore(AOffset);
+ end;
+end;
+
+// returns the name for simple types, or empty structs:
+// struct num n; - returns 'num' (name of the struct),
+// but
+// struct num {int f;} n; returns '', because struct is NOT simple named type
+function GetSimpleName(ent: TEntity): AnsiString;
+begin
+ if ent is TSimpleType then
+ Result:=TSimpleType(ent).Name
+ else if (ent is TStructType) and ( length(TStructType(ent).fields)=0) then
+ Result:=TStructType(ent).Name
+ else if (ent is TEnumType) and (length(TEnumType(ent).items)=0) then
+ Result:=TEnumType(ent).Name
+ else
+ Result:='';
+end;
+
+// returns the declared typename
+// for
+// struct num n;
+// struct num {int f;} n;
+// returns 'num' (name of the struct),
+function GetCDeclTypeName(ent: TEntity): AnsiString;
+begin
+ if ent is TStructType then
+ Result:=TStructType(ent).Name
+ else if ent is TUnionType then
+ Result:=TUnionType(ent).Name
+ else if ent is TEnumType then
+ Result:=TEnumType(ent).Name
+ else
+ Result:='';
+end;
+
+function TCodeConvertor.GetPasTypeName(RetType: TEntity; TypePart: TNamePart): AnsiString;
+var
+ CtypeName : AnsiString;
+ pasRef : AnsiString;
+ pasType : AnsiString;
+ rt : AnsiString;
+ i : Integer;
+begin
+ if isNamePartPtrToFunc(TypePart) then begin
+ PushWriter;
+ rt := GetPasTypeName(RetType, TypePart.owner.owner);
+ PopWriter;
+
+ Result:=NextAuxTypeName('TAuxCallback');
+ DeclareFuncType(Result, rt, TypePart.owner.params);
+ wr.Wln(';');
+
+ end else begin
+
+ CtypeName:=GetSimpleName(RetType);
+ if CtypeName<>'' then begin
+ pasRef:=cfg.RefTypeNamePrefix+cfg.GetTypeName(CtypeName);
+ end else begin
+ CtypeName:=GetCDeclTypeName(RetType);
+ if CTypeName='' then CtypeName:=NextAuxTypeName('TAuxType');
+ DeclarePasType(RetType, CtypeName);
+ cfg.CtoPasTypes.Values[CtypeName]:=CTypeName;
+ pasRef:=cfg.RefTypeNamePrefix+Copy(CtypeName, 2, length(CTypeName));
+ wr.Wln(';');
+ end;
+
+ if Assigned(TypePart) and (TypePart.Kind=nk_Ref) then begin
+ pasType:=cfg.GetTypeName(CtypeName);
+ for i:=1 to TypePart.RefCount do begin
+ CTypeName:=CTypeName+'*';
+ rt:=cfg.CtoPasTypes.Values[CTypeName];
+ if rt='' then begin
+ PushWriter;
+ SetPasSection(wr, 'type');
+ wr.Wln(pasRef+' = ^'+pasType+';');
+ pasType:=pasRef;
+ PopWriter;
+
+ // filling required reference type
+ cfg.CtoPasTypes.Values[CTypeName]:=pasType;
+
+ end else
+ pasType:=rt;
+ pasRef:=cfg.RefTypeNamePrefix+pasType;
+ end;
+ Result:=pasType;
+ end else begin
+ Result:=cfg.GetTypeName(CtypeName);
+ end;
+ end;
+end;
+
+function isVoidParams(const params : array of TFuncParam): Boolean;
+begin
+ Result:=length(params)=0;
+ if Result then Exit;
+ Result:=length(params)=1;
+ if Result then
+ Result:=(params[0].prmtype is TSimpleType) and (TSimpleType(params[0].prmtype).Name='void');
+end;
+
+procedure TCodeConvertor.WriteFuncDecl(const FnName, PasRetType: Ansistring; const params : array of TFuncParam);
+var
+ i : Integer;
+ ptypes : array of String;
+ pnames : array of String;
+ tp : TNamePart;
+begin
+ PushWriter;
+ if not isVoidParams(params) then begin
+ SetLength(ptypes, length(params));
+ SetLength(pnames, length(params));
+ for i:=0 to length(params)-1 do begin
+ tp:=params[i].name;
+ if Assigned(tp) then begin
+ while Assigned(tp.child) do tp:=tp.child;
+ if tp.Kind=nk_Ident then begin
+ pnames[i]:=cfg.GetUniqueName(tp.Id);
+ tp:=tp.owner;
+ end;
+ end;
+ if pnames[i]='' then pnames[i] := cfg.ParamPrefix+IntToStr(i);
+ ptypes[i]:=GetPasTypeName(params[i].prmtype, tp);
+ end;
+ end else begin
+ ptypes:=nil;
+ pnames:=nil;
+ end;
+ PopWriter;
+
+ wr.CheckLineLen:=True;
+ WriteFunc(wr, FnName, PasRetType, pnames, ptypes);
+ wr.CheckLineLen:=False;
+
+ if cfg.FuncConv<>'' then wr.W('; '+cfg.FuncConv);
+ if cfg.FuncDeclPostfix<>'' then wr.W('; '+cfg.FuncDeclPostfix);
+end;
+
+procedure TCodeConvertor.WriteFuncOrVar(cent: TVarFuncEntity; StartVar: Boolean);
+var
+ i, j : integer;
+ Name : TNamePart;
+ n : TNamePart;
+ id : AnsiString;
+ ref : TNamePart;
+ rt : AnsiString;
+begin
+ for j := 0 to cent.Names.Count - 1 do
+ begin
+ Name:=GetIdPart(TNamePart(cent.Names[j]));
+ if not Assigned(name) then begin
+ wr.Wln(' bad declaration synax!');
+ Exit;
+ end;
+ id:=name.Id;
+ n:=name.owner;
+
+ if not Assigned(n) then begin
+ if StartVar then SetPasSection(wr, 'var');
+ wr.W(id + ' : ' + GetPasTypeName(cent.RetType, Name))
+ end else if (n.Kind=nk_Func) then begin
+ SetPasSection(wr, '');
+ rt:=GetPasTypeName(cent.RetType, n.owner);
+ WriteFuncDecl(id, rt, n.params);
+ if cfg.FuncsAreExternal then wr.W('; external');
+ end else if (n.Kind=nk_Ref) then begin
+ if StartVar then SetPasSection(wr, 'var');
+ wr.W(id + ' : ');
+ ref:=n;
+ n:=n.owner;
+ if not Assigned(n) then
+ wr.W( GetPasTypeName(cent.RetType, ref) )
+ else
+ case n.Kind of
+ nk_Array: begin
+ for i:=1 to ref.RefCount do wr.W('^');
+ WriteArray(n, wr);
+ wr.W(GetPasTypeName(cent.RetType, n.owner))
+ end;
+ nk_Func: begin
+ PushWriter;
+ rt:=GetPasTypeName(cent.RetType, n.owner);
+ PopWriter;
+ WriteFuncDecl('', rt, n.params);
+ end;
+ end;
+
+ end else if (n.Kind=nk_Array) then begin
+ if StartVar then SetPasSection(wr, 'var');
+ wr.W(id + ' : ');
+ WriteArray(n, wr);
+ wr.W(GetPasTypeName(cent.RetType, n.owner));
+ end;
+ wr.W(';');
+
+ WriteLnCommentForOffset(cent.Offset)
+ end;
+end;
+
+procedure TCodeConvertor.WriteCtoPas(cent: TEntity; comments: TList; const ParsedText: AnsiString);
+begin
+ CmtList:=comments;
+ Breaker:=TLineBreaker.Create;
+ Breaker.SetText(ParsedText);
+
+ if cent is TVarFuncEntity then
+ WriteFuncOrVar(cent as TVarFuncEntity, True)
+ else if cent is TTypeDef then
+ WriteTypeDef(cent as TTypeDef)
+ else if cent is TStructType then
+ DeclarePasType(cent as TStructType, TStructType(cent).Name)
+ else if cent is TEnumType then
+ DeclarePasType(cent as TEnumType, TEnumType(cent).Name)
+ else if cent is TComment then
+ WriteCommentToPas(cent as TComment)
+ else if cent is TCPrepDefine then
+ WritePreprocessor(cent as TCPrepDefine)
+ else
+ wr.Wln(cent.ClassName);
+
+ Breaker.Free;
+end;
+
+procedure TCodeConvertor.WriteTypeDef(tp: TTypeDef);
+var
+ nm : TNamePart;
+ n : TNamePart;
+ fn : TNamePart;
+ rt : AnsiString;
+ stn : AnsiString;
+ tpart : TNamePart;
+begin
+ nm:=GetIdPart(tp.name);
+ if not Assigned(nm) then Exit;
+ SetPasSection(wr,'type');
+
+ n:=nm.owner;
+
+ if not Assigned(n) then begin
+ stn:=GetCDeclTypeName(tp.origintype);
+ if stn='' then stn:=nm.Id;
+ DeclarePasType(tp.origintype, stn);
+ if stn<>nm.Id then begin
+ wr.Wln(';');
+ wr.W(nm.Id+' = '+stn);
+ end;
+
+ end else begin
+ fn:=n.owner;
+ if n.Kind=nk_Array then begin
+ wr.W(nm.Id+' = ');
+ WriteArray(n, wr);
+ wr.W(GetPasTypeName(tp.origintype, n.owner));
+ //typedef functions and typedef function pointers are converted the same way.
+ end else if (n.Kind=nk_Ref) and (not Assigned(fn) or (fn.Kind<>nk_Func)) then begin
+ wr.W(nm.Id+' = '+GetPasTypeName(tp.origintype, n));
+ fn:=n.owner;
+ end else if isNamePartPtrToFunc(n) or (Assigned(n) and (n.kind=nk_Func) ) then begin
+
+ if isNamePartPtrToFunc(n) then begin
+ tpart:=n.owner.owner // rettype of function pointer
+ end else begin
+ tpart:=n.owner;
+ cfg.CtoPasTypes.Values[nm.id+'*']:=nm.id;
+ end;
+
+ PushWriter;
+ rt := GetPasTypeName(tp.origintype, tpart);
+ PopWriter;
+
+ if n.Kind=nk_Func then fn:=n;
+ DeclareFuncType(nm.id, rt, fn.params);
+ end;
+ end;
+ wr.Wln(';');
+end;
+
+procedure TCodeConvertor.WriteStruct(st:TStructType);
+var
+ i : Integer;
+begin
+ if cfg.RecordsArePacked then wr.W('packed ');
+ wr.Wln('record');
+ wr.IncIdent;
+ //todo: bit fields support
+ for i:=0 to length(st.fields)-1 do begin
+ WriteLnCommentsBeforeOffset(st.fields[i].v.Offset);
+ WriteFuncOrVar(st.fields[i].v, False);
+ end;
+ wr.DecIdent;
+ wr.W('end');
+end;
+
+procedure TCodeConvertor.WriteEnum(en:TEnumType);
+var
+ b : Boolean;
+ i : Integer;
+begin
+ if cfg.EnumsAsConst then
+ WriteEnumAsConst(en)
+ else begin
+ WriteLnCommentsBeforeOffset(en.Offset);
+ wr.W('(');
+ wr.IncIdent;
+ b:=wr.CheckLineLen;
+ wr.CheckLineLen:=True;
+ for i:=0 to length(en.items)-2 do begin
+ WriteLnCommentsBeforeOffset(en.Items[i].Offset);
+ wr.W(en.items[i].Name);
+ if Assigned(en.items[i].Value) then begin
+ wr.W(' = ');
+ WriteExp(en.items[i].Value);
+ end;
+ wr.W(',');
+ WriteLnCommentForOffset(en.Items[i].Offset);
+ end;
+ i:=length(en.items)-1;
+ WriteLnCommentsBeforeOffset(en.Items[i].Offset);
+ wr.W(en.items[i].Name);
+ if Assigned(en.items[i].Value) then begin
+ wr.Wln(' = ');
+ WriteExp(en.Items[i].Value);
+ end else
+ wr.Wln;
+ WriteLnCommentForOffset(en.Items[i].Offset);
+ wr.DecIdent;
+ wr.W(')');
+ wr.CheckLineLen:=b;
+ end;
+end;
+
+procedure TCodeConvertor.WriteEnumAsConst(en:TEnumType);
+var
+ i : Integer;
+begin
+ if length(en.items)>0 then begin
+ PushWriter;
+ WriteLnCommentsBeforeOffset(en.Offset);
+ SetPasSection(wr, 'const');
+ for i:=0 to length(en.items)-1 do begin
+ WriteLnCommentsBeforeOffset(en.items[i].Offset);
+ wr.W(en.items[i].Name + ' = ');
+ if Assigned(en.items[i].Value) then
+ WriteExp(en.items[i].Value)
+ else
+ wr.W(IntToStr(i));
+ wr.W(';');
+ WriteLnCommentForOffset(en.items[i].Offset);
+ end;
+ PopWriter;
+ end;
+ wr.W('Integer');
+end;
+
+function TCodeConvertor.NextAuxTypeName(const Prefix:AnsiString):AnsiString;
+begin
+ if Prefix='' then Result:='AuxType'+IntToStr(AuxTypeCounter)
+ else Result:=Prefix+IntToStr(AuxTypeCounter);
+ inc(AuxTypeCounter);
+end;
+
+procedure TCodeConvertor.DeclarePasType(TypeEntity: TEntity; const PasTypeName: AnsiString);
+begin
+ SetPasSection(wr, 'type');
+ wr.W(PasTypeName + ' = ');
+ if TypeEntity is TStructType then
+ WriteStruct(TStructType(TypeEntity))
+ else if TypeEntity is TEnumType then
+ WriteEnum(TEnumType(TypeEntity))
+ else begin
+ {SetPasSection(wr, 'type');
+ wr.W(PasTypeName + ' = ');}
+ wr.W('todo: '+TypeEntity.ClassName);
+ end;
+ //todo: ...
+end;
+
+function TCodeConvertor.FindCommentForLine(ln:Integer):TComment;
+var
+ i : Integer;
+begin
+ Result:=nil;
+ if not Assigned(CmtList) then Exit;
+ for i:=0 to CmtList.Count-1 do
+ if Breaker.LineNumber(TComment(CmtList[i]).Offset)=ln then begin
+ Result:=TComment(CmtList[i]);
+ Exit;
+ end;
+end;
+
+procedure TCodeConvertor.DefFuncWrite(wr:TCodeWriter;const FuncName,FuncRetType:AnsiString;
+ const Params,ParamTypes: array of AnsiString);
+var
+ isProc : Boolean;
+ tp : AnsiString;
+ p : AnsiString;
+ i : Integer;
+
+const
+ FnKind : array [Boolean] of AnsiString = ('procedure','function');
+begin
+ isProc:=FuncRetType<>'';
+
+ wr.W ( FnKind[isProc] );
+ if FuncName<>'' then wr.W(' '+FuncName);
+ if length(Params)>0 then begin
+ tp:=ParamTypes[0];
+ p:='';
+ wr.W('(');
+ for i:=0 to length(Params)-1 do begin
+ if ParamTypes[i]=tp then begin
+ if p='' then p:=Params[i] else p:=p+', '+Params[i];
+ end else begin
+ wr.W(p+': '+tp+'; ');
+ p:=Params[i];
+ tp:=ParamTypes[i];
+ end;
+ end;
+ wr.W(p+': '+tp+')');
+ end;
+ if FuncRetType<>'' then wr.W(': '+FuncRetType);
+end;
+
+
+{ TConvertSettings }
+
+procedure FillPasReserved(st: TStrings);
+begin
+ with st do
+ begin
+ // turbo pascal reserved
+ Add('absolute');
+ Add('and');
+ Add('array');
+ Add('asm');
+ Add('begin');
+ Add('case');
+ Add('const');
+ Add('constructor');
+ Add('destructor');
+ Add('div');
+ Add('do');
+ Add('downto');
+ Add('else');
+ Add('end');
+ Add('file');
+ Add('for');
+ Add('function');
+ Add('goto');
+ Add('if');
+ Add('implementation');
+ Add('in');
+ Add('inherited');
+ Add('inline');
+ Add('interface');
+ Add('label');
+ Add('mod');
+ Add('nil');
+ Add('not');
+ Add('object');
+ Add('of');
+ Add('on');
+ Add('operator');
+ Add('or');
+ Add('packed');
+ Add('procedure');
+ Add('program');
+ Add('record');
+ Add('reintroduce');
+ Add('repeat');
+ Add('self');
+ Add('set');
+ Add('shl');
+ Add('shr');
+ Add('string');
+ Add('then');
+ Add('to');
+ Add('type');
+ Add('unit');
+ Add('until');
+ Add('uses');
+ Add('var');
+ Add('while');
+ Add('with');
+ Add('xor');
+ // object pascal reserved
+ Add('as');
+ Add('class');
+ Add('dispinterface');
+ Add('except');
+ Add('exports');
+ Add('finalization');
+ Add('finally');
+ Add('initialization');
+ Add('inline');
+ Add('is');
+ Add('library');
+ Add('on');
+ Add('out');
+ Add('packed');
+ Add('property');
+ Add('raise');
+ Add('resourcestring');
+ Add('threadvar');
+ Add('try');
+ // free pascal reserved
+ Add('dispose');
+ Add('exit');
+ Add('false');
+ Add('new');
+ Add('true');
+ // modifiers
+ Add('absolute');
+ Add('abstract');
+ Add('alias');
+ Add('assembler');
+ Add('cdecl');
+ Add('cppdecl');
+ Add('default');
+ Add('export');
+ Add('external');
+ Add('far');
+ Add('far16');
+ Add('forward');
+ Add('index');
+ Add('local');
+ Add('name');
+ Add('near');
+ Add('nostackframe');
+ Add('oldfpccall');
+ Add('override');
+ Add('pascal');
+ Add('private');
+ Add('protected');
+ Add('public');
+ Add('published');
+ Add('read');
+ Add('register');
+ Add('reintroduce');
+ Add('safecall');
+ Add('softfloat');
+ Add('stdcall');
+ Add('virtual');
+ Add('write');
+ // common types
+ Add('integer');
+ Add('char');
+ Add('longword');
+ Add('word');
+ Add('qword');
+ Add('int64');
+ Add('byte');
+ end;
+end;
+
+constructor TConvertSettings.Create;
+begin
+ UsedNames := TStringList.Create;
+ UsedNames.CaseSensitive := False;
+ FillPasReserved(UsedNames);
+ EnumsAsConst := True;
+ FuncsAreExternal := True;
+ RecordsArePacked := True;
+
+ DefaultCType := 'int';
+ FuncConv := 'cdecl';
+ FuncDeclPostfix:='';
+ TypeNamePrefix := '';
+ RefTypeNamePrefix := 'P';
+ ParamPrefix:='par';
+
+ CtoPasTypes := TStringList.Create;
+ CtoPasTypes.Values['bool'] := 'LongBool';
+ CtoPasTypes.Values['double'] := 'Double';
+ CtoPasTypes.Values['float'] := 'Single';
+ CtoPasTypes.Values['float*'] := 'PSingle';
+ CtoPasTypes.Values['int'] := 'Integer';
+ CtoPasTypes.Values['int*'] := 'PInteger';
+ CtoPasTypes.Values['void'] := '';
+ CtoPasTypes.Values['void*'] := 'Pointer';
+ CtoPasTypes.Values['void**'] := 'PPointer';
+ CtoPasTypes.Values['char*'] := 'PChar';
+ CtoPasTypes.Values['char**'] := 'PPChar';
+ CtoPasTypes.Values['long'] := 'Longword';
+ CtoPasTypes.Values['long*'] := 'PLongword';
+ CtoPasTypes.Values['long long'] := 'Int64';
+ CtoPasTypes.Values['long long*'] := 'PInt64';
+ CtoPasTypes.Values['unsigned long long'] := 'QWord';
+ CtoPasTypes.Values['unsigned long long*'] := 'PQWord';
+ CtoPasTypes.Values['short'] := 'SmallInt';
+ CtoPasTypes.Values['short*'] := 'PSmallInt';
+ CtoPasTypes.Values['unsigned short'] := 'Word';
+ CtoPasTypes.Values['unsigned short*'] := 'PWord';
+ CtoPasTypes.Values['unsigned char'] := 'Byte';
+ CtoPasTypes.Values['unsigned char*'] := 'PByte';
+ CtoPasTypes.Values['unsigned long'] := 'LongWord';
+ CtoPasTypes.Values['unsigned int'] := 'LongWord';
+ CtoPasTypes.Values['unsigned long int'] := 'LongWord';
+ CtoPasTypes.Values['signed long'] := 'Integer';
+ CtoPasTypes.Values['...'] := 'array of const';
+ CtoPasTypes.Values['va_list'] := 'array of const';
+end;
+
+destructor TConvertSettings.Destroy;
+begin
+ CtoPasTypes.Free;
+ UsedNames.Free;
+ inherited Destroy;
+end;
+
+function TConvertSettings.GetUniqueName(const n: ansistring): ansistring;
+begin
+ Result := n;
+ while UsedNames.IndexOf(Result) >= 0 do
+ Result := Result + '_';
+end;
+
+function TConvertSettings.GetTypeName(const CTypeName: ansistring): ansistring;
+begin
+ Result := CtoPasTypes.Values[CTypeName];
+ if (Result = '') and (CTypeName<>'void') then
+ begin
+ Result := TypeNamePrefix + CTypeName;
+ Result := GetUniqueName(Result);
+ end;
+end;
+
+end.
+
diff --git a/components/chelper/ctopasexp.pas b/components/chelper/ctopasexp.pas
new file mode 100644
index 000000000..5dbd01524
--- /dev/null
+++ b/components/chelper/ctopasexp.pas
@@ -0,0 +1,20 @@
+unit CToPasExp;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, prsExpression;
+
+function PascalizeCExp(CExp: TExpEntity; PascalExps : TList): Boolean;
+
+implementation
+
+function PascalizeCExp(CExp: TExpEntity; PascalExps : TList): Boolean;
+begin
+ Result:=False;
+end;
+
+end.
+
diff --git a/components/chelper/extconvdialog.lfm b/components/chelper/extconvdialog.lfm
new file mode 100644
index 000000000..41d281be9
--- /dev/null
+++ b/components/chelper/extconvdialog.lfm
@@ -0,0 +1,217 @@
+object CtoPasConfig: TCtoPasConfig
+ Left = 336
+ Height = 446
+ Top = 231
+ Width = 655
+ Caption = 'C to Pascal settings'
+ ClientHeight = 446
+ ClientWidth = 655
+ OnClose = FormClose
+ OnResize = FormResize
+ LCLVersion = '0.9.29'
+ object Notebook1: TNotebook
+ Left = 16
+ Height = 421
+ Top = 8
+ Width = 622
+ Anchors = [akTop, akLeft, akRight, akBottom]
+ PageIndex = 0
+ TabOrder = 0
+ object pageMain: TPage
+ Caption = 'Main'
+ ClientWidth = 616
+ ClientHeight = 382
+ object Panel1: TPanel
+ Left = 0
+ Height = 172
+ Top = 0
+ Width = 616
+ Align = alTop
+ BevelOuter = bvNone
+ ClientHeight = 172
+ ClientWidth = 616
+ TabOrder = 0
+ object Label1: TLabel
+ Left = 6
+ Height = 18
+ Top = 5
+ Width = 150
+ Caption = 'Pascal code generation:'
+ ParentColor = False
+ end
+ object chkRecordsPacked: TCheckBox
+ Left = 6
+ Height = 18
+ Top = 36
+ Width = 144
+ Caption = 'Records are packed'
+ TabOrder = 0
+ end
+ object chkFuncAreExt: TCheckBox
+ Left = 6
+ Height = 18
+ Top = 70
+ Width = 161
+ Caption = 'Functions are external'
+ TabOrder = 1
+ end
+ object chkEnums: TCheckBox
+ Left = 6
+ Height = 18
+ Top = 107
+ Width = 244
+ Caption = 'Enumerations are Integer constants'
+ TabOrder = 2
+ end
+ object Label3: TLabel
+ Left = 197
+ Height = 18
+ Top = 70
+ Width = 115
+ Caption = 'Calling convention'
+ ParentColor = False
+ end
+ object cmbCallConv: TComboBox
+ Left = 325
+ Height = 21
+ Top = 67
+ Width = 160
+ ItemHeight = 0
+ ItemIndex = 0
+ Items.Strings = (
+ 'cdecl'
+ 'stdcall'
+ 'mwpascal'
+ 'fastcall'
+ )
+ TabOrder = 3
+ Text = 'cdecl'
+ end
+ object lblDefines: TLabel
+ Left = 11
+ Height = 18
+ Top = 136
+ Width = 51
+ Caption = 'Defines:'
+ ParentColor = False
+ end
+ object edtDefines: TEdit
+ AnchorSideLeft.Control = lblDefines
+ AnchorSideLeft.Side = asrBottom
+ AnchorSideRight.Control = btnSelect
+ Left = 68
+ Height = 22
+ Top = 136
+ Width = 376
+ Anchors = [akTop, akLeft, akRight]
+ BorderSpacing.Left = 6
+ BorderSpacing.Right = 6
+ TabOrder = 4
+ end
+ object btnSelect: TButton
+ AnchorSideRight.Control = btnEdit
+ Left = 450
+ Height = 20
+ Top = 136
+ Width = 70
+ Anchors = [akTop, akRight]
+ AutoSize = True
+ BorderSpacing.Right = 20
+ Caption = 'Select'
+ OnClick = btnSelectClick
+ TabOrder = 5
+ end
+ object btnEdit: TButton
+ Left = 540
+ Height = 20
+ Top = 136
+ Width = 70
+ Anchors = [akTop, akRight]
+ Caption = 'Edit'
+ OnClick = btnEditClick
+ TabOrder = 6
+ end
+ end
+ object Panel2: TPanel
+ Left = 0
+ Height = 210
+ Top = 172
+ Width = 616
+ Align = alClient
+ Alignment = taLeftJustify
+ BevelOuter = bvNone
+ ClientHeight = 210
+ ClientWidth = 616
+ TabOrder = 1
+ object Splitter1: TSplitter
+ Cursor = crVSplit
+ Left = 0
+ Height = 5
+ Top = 0
+ Width = 616
+ Align = alTop
+ ResizeAnchor = akTop
+ end
+ object Label2: TLabel
+ Left = 6
+ Height = 18
+ Top = 14
+ Width = 181
+ Caption = 'C to Pascal types convertion'
+ ParentColor = False
+ end
+ object Memo1: TMemo
+ Left = 6
+ Height = 160
+ Top = 44
+ Width = 604
+ Align = alBottom
+ Anchors = [akTop, akLeft, akRight, akBottom]
+ BorderSpacing.Left = 6
+ BorderSpacing.Right = 6
+ BorderSpacing.Bottom = 6
+ ScrollBars = ssVertical
+ TabOrder = 1
+ end
+ object Button2: TButton
+ Left = 476
+ Height = 20
+ Top = 14
+ Width = 134
+ Anchors = [akTop, akLeft, akRight]
+ AutoSize = True
+ Caption = 'Reset to defaults'
+ OnClick = Button2Click
+ TabOrder = 2
+ end
+ end
+ end
+ object pageConverter: TPage
+ Caption = 'Converter'
+ ClientWidth = 616
+ ClientHeight = 382
+ object edtExtTool: TEdit
+ Left = 13
+ Height = 22
+ Top = 6
+ Width = 511
+ Anchors = [akTop, akLeft, akRight]
+ TabOrder = 0
+ end
+ object Button1: TButton
+ Left = 538
+ Height = 20
+ Top = 6
+ Width = 70
+ Anchors = [akTop, akRight]
+ Caption = 'Select'
+ OnClick = Button1Click
+ TabOrder = 1
+ end
+ end
+ end
+ object OpenDialog1: TOpenDialog
+ left = 304
+ top = 168
+ end
+end
diff --git a/components/chelper/extconvdialog.pas b/components/chelper/extconvdialog.pas
new file mode 100644
index 000000000..2af29fd15
--- /dev/null
+++ b/components/chelper/extconvdialog.pas
@@ -0,0 +1,151 @@
+unit extconvdialog;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes,SysUtils,FileUtil,Forms,Controls,Graphics,Dialogs,StdCtrls,ExtCtrls,
+ converteridesettings, ctopasconvert, LazIDEIntf;
+
+type
+
+ { TCtoPasConfig }
+
+ TCtoPasConfig = class(TForm)
+ Button1: TButton;
+ btnSelect:TButton;
+ btnEdit:TButton;
+ Button2:TButton;
+ chkRecordsPacked:TCheckBox;
+ chkFuncAreExt:TCheckBox;
+ chkEnums:TCheckBox;
+ cmbCallConv:TComboBox;
+ edtDefines:TEdit;
+ edtExtTool: TEdit;
+ Label1:TLabel;
+ Label2:TLabel;
+ Label3:TLabel;
+ lblDefines:TLabel;
+ Memo1:TMemo;
+ Notebook1:TNotebook;
+ OpenDialog1: TOpenDialog;
+ pageMain:TPage;
+ pageConverter:TPage;
+ Panel1:TPanel;
+ Panel2:TPanel;
+ Splitter1:TSplitter;
+ procedure btnEditClick(Sender:TObject);
+ procedure btnSelectClick(Sender:TObject);
+ procedure Button1Click(Sender: TObject);
+ procedure Button2Click(Sender:TObject);
+ procedure FormClose(Sender:TObject;var CloseAction:TCloseAction);
+ procedure FormResize(Sender: TObject);
+ private
+ { private declarations }
+ public
+ { public declarations }
+ procedure SettingsToUI;
+ procedure UIToSettings;
+ end;
+
+var
+ CtoPasConfig: TCtoPasConfig;
+
+function ShowConfigDialog: TCtoPasConfig;
+
+implementation
+
+{$R *.lfm}
+
+function ShowConfigDialog: TCtoPasConfig;
+begin
+ if not Assigned(CtoPasConfig) then begin
+ CtoPasConfig := TCtoPasConfig.Create(nil);
+ CtoPasConfig.SettingsToUI;
+ end;
+ CtoPasConfig.Show;
+ CtoPasConfig.BringToFront;
+ Result:=CtoPasConfig;
+end;
+
+{ TCtoPasConfig }
+
+procedure TCtoPasConfig.Button1Click(Sender: TObject);
+begin
+ if OpenDialog1.Execute then
+ edtExtTool.Text := OpenDialog1.FileName;
+end;
+
+procedure TCtoPasConfig.Button2Click(Sender:TObject);
+var
+ cfg : TConvertSettings;
+begin
+ if MessageDlg('Reset types',
+ 'Reset c-to-pascal types converting to defaults?',
+ mtConfirmation, mbYesNo, 0)<>mrYes then Exit;
+ cfg := TConvertSettings.Create;
+ try
+ Memo1.Lines.Assign(cfg.CtoPasTypes);
+ finally
+ cfg.Free;
+ end;
+end;
+
+procedure TCtoPasConfig.btnSelectClick(Sender:TObject);
+begin
+ if OpenDialog1.Execute then
+ edtDefines.Text:=OpenDialog1.FileName;
+end;
+
+procedure TCtoPasConfig.btnEditClick(Sender:TObject);
+var
+ fs : TFileStream;
+begin
+ if edtDefines.Text='' then Exit;
+ if not FileExistsUTF8(edtDefines.Text) then begin
+ ForceDirectoriesUTF8( ExtractFileDir(edtDefines.Text));
+ try
+ fs:=TFileStream.Create(edtDefines.Text, fmCreate);
+ fs.Free;
+ except
+ end;
+ end;
+ LazarusIDE.DoOpenEditorFile(edtDefines.Text, 0, 0, [ofQuiet, ofRegularFile, ofDoNotLoadResource, ofDoLoadResource]);
+end;
+
+procedure TCtoPasConfig.FormClose(Sender:TObject;var CloseAction:TCloseAction);
+begin
+ // don't free the form on close.
+ UIToSettings;
+ CloseAction:=caHide;
+end;
+
+procedure TCtoPasConfig.FormResize(Sender: TObject);
+begin
+end;
+
+procedure TCtoPasConfig.SettingsToUI;
+begin
+ chkRecordsPacked.Checked:=ConvSettings.RecordsArePacked;
+ chkFuncAreExt.Checked:=ConvSettings.FuncsAreExternal;
+ chkEnums.Checked:=ConvSettings.EnumsAsConst;
+ cmbCallConv.Text:=ConvSettings.FuncConv;
+ Memo1.Lines.Assign(ConvSettings.CtoPasTypes);
+ edtDefines.Text:=DefineFile;
+ edtExtTool.Text:=ExtTool;
+end;
+
+procedure TCtoPasConfig.UIToSettings;
+begin
+ ConvSettings.RecordsArePacked:=chkRecordsPacked.Checked;
+ ConvSettings.FuncsAreExternal:=chkFuncAreExt.Checked;
+ ConvSettings.EnumsAsConst:=chkEnums.Checked;
+ ConvSettings.FuncConv:=cmbCallConv.Text;
+ ConvSettings.CtoPasTypes.Assign(Memo1.Lines);
+ DefineFile:=edtDefines.Text;
+ ExtTool:=edtExtTool.Text;
+end;
+
+end.
+
diff --git a/components/chelper/textparsingutils.pas b/components/chelper/textparsingutils.pas
new file mode 100644
index 000000000..05742bdab
--- /dev/null
+++ b/components/chelper/textparsingutils.pas
@@ -0,0 +1,151 @@
+{ The unit is part of Lazarus Chelper package
+
+ Copyright (C) 2010 Dmitry Boyarintsev skalogryz dot lists at gmail.com
+
+ This library is free software; you can redistribute it and/or modify it
+ under the terms of the GNU Library General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ This program is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+ for more details.
+
+ You should have received a copy of the GNU Library General Public License
+ along with this library; if not, write to the Free Software Foundation,
+ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+}
+unit TextParsingUtils;
+
+{$ifdef fpc}{$mode delphi}{$h+}{$endif}
+
+interface
+
+type
+ TCharSet = set of Char;
+
+const
+ EoLnChars = [#10,#13];
+ SpaceChars = [#32,#9];
+ InvsChars = SpaceChars;
+ WhiteSpaceChars = SpaceChars;
+ SpaceEolnChars = EoLnChars+SpaceChars;
+ NumericChars = ['0'..'9'];
+ AlphabetChars = ['a'..'z','A'..'Z'];
+ AlphaNumChars = AlphabetChars+NumericChars;
+
+function ScanWhile(const s: AnsiString; var index: Integer; const ch: TCharSet): AnsiString;
+function ScanTo(const s: AnsiString; var index: Integer; const ch: TCharSet): AnsiString;
+function SkipToEoln(const s: AnsiString; var index: Integer): AnsiString;
+
+// returns #10, #13, #10#13 or #13#10, if s[index] is end-of-line sequence
+// otherwise returns empty string
+function EolnStr(const s: AnsiString; index: Integer): String;
+
+function IsSubStr(const sbs, s: AnsiString; index: Integer): Boolean;
+
+// todo: not used?
+function SkipCommentBlock(const s: AnsiString; var index: Integer; const closecmt: AnsiString): AnsiString;
+
+function SkipLine(const s: AnsiString; var index: Integer): AnsiString;
+
+implementation
+
+function ScanWhile(const s: AnsiString; var index: Integer; const ch: TCharSet): AnsiString;
+var
+ i : Integer;
+begin
+ Result := '';
+ if (index <= 0) or (index > length(s)) then Exit;
+ for i := index to length(s) do
+ if not (s[i] in ch) then begin
+ if i = index then Result := ''
+ else Result := Copy(s, index, i - index);
+ index := i;
+ Exit;
+ end;
+ Result := Copy(s, index, length(s) - index + 1);
+ index := length(s) + 1;
+end;
+
+function ScanTo(const s: AnsiString; var index: Integer; const ch: TCharSet): AnsiString;
+var
+ i : Integer;
+begin
+ Result := '';
+ if (index <= 0) or (index > length(s)) then Exit;
+ for i := index to length(s) do
+ if (s[i] in ch) then begin
+ if i = index then Result := ''
+ else Result := Copy(s, index, i - index);
+ index := i;
+ Exit;
+ end;
+ Result := Copy(s, index, length(s) - index + 1);
+ index := length(s) + 1;
+end;
+
+function EolnStr(const s: AnsiString; index: Integer): String;
+begin
+ if (index<=0) or (index>length(s)) or (not (s[index] in EoLnChars)) then
+ Result:=''
+ else begin
+ if (indexs[index+1]) then
+ Result:=Copy(s, index, 2)
+ else
+ Result:=s[index];
+ end;
+end;
+
+function SkipToEoln(const s: AnsiString; var index: Integer): AnsiString;
+begin
+ Result := ScanTo(s, index, EoLnChars);
+end;
+
+function IsSubStr(const sbs, s: AnsiString; index: Integer): Boolean;
+var
+ i : Integer;
+ j : Integer;
+begin
+ Result := false;
+ if (sbs = '') or (length(sbs) > length(s) - index) then Exit;
+ j := index;
+ for i := 1 to length(sbs) do begin
+ if sbs[i] <> s[j] then Exit;
+ inc(j);
+ end;
+ Result := true;
+end;
+
+function SkipCommentBlock(const s: AnsiString; var index: Integer; const closecmt: AnsiString): AnsiString;
+begin
+ Result := '';
+ if closecmt = '' then begin
+ index := length(s) + 1;
+ Exit;
+ end;
+ while index <= length(s) do begin
+ Result := Result + ScanTo(s, index, [closecmt[1]]+EoLnChars);
+ //if (index<=length(s)) and (s in EoLnChars(
+
+ if IsSubStr(closecmt, s, index) then begin
+ inc(index, length(closecmt));
+ Exit;
+ end else begin
+ Result := Result + s[index];
+ inc(index);
+ end;
+ end;
+end;
+
+function SkipLine(const s: AnsiString; var index: Integer): AnsiString;
+begin
+ Result:=ScanTo(s, index, EoLnChars);
+ if (indexs[index+1]) then
+ inc(index);
+ inc(index);
+end;
+
+end.
+
diff --git a/components/chelper/tosourceeditor.pas b/components/chelper/tosourceeditor.pas
new file mode 100644
index 000000000..e685b49ed
--- /dev/null
+++ b/components/chelper/tosourceeditor.pas
@@ -0,0 +1,217 @@
+{ The unit is part of Lazarus Chelper package
+
+ Copyright (C) 2010 Dmitry Boyarintsev skalogryz dot lists at gmail.com
+
+ This library is free software; you can redistribute it and/or modify it
+ under the terms of the GNU Library General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ This program is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+ for more details.
+
+ You should have received a copy of the GNU Library General Public License
+ along with this library; if not, write to the Free Software Foundation,
+ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+}
+unit toSourceEditor;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, Dialogs, LCLType, LCLIntf, Forms,
+ Menus, MenuIntf, SrcEditorIntf, process, LazIDEIntf,
+ extconvdialog, converteridesettings, cconvconfig;
+
+procedure Register;
+
+implementation
+
+function DoExtConvert(const t: AnsiString; var EndPos: TPoint): AnsiString;
+var
+ p : TProcess;
+ d : AnsiString;
+ inp : AnsiString;
+ outp : AnsiString;
+ i, err : Integer;
+ fs : TFileStream;
+ st : TStringList;
+ cmd : AnsiString;
+ tm : LongWord;
+begin
+ if t='' then begin
+ Result:='';
+ EndPos.X:=0;
+ EndPos.Y:=0;
+ Exit;
+ end;
+ EndPos.X:=-1;
+ EndPos.Y:=-1;
+
+ try
+ d:=GetTempDir;
+ ForceDirectories(d);
+ inp:=IncludeTrailingPathDelimiter(d)+'input.txt';
+ outp:=IncludeTrailingPathDelimiter(d)+'output.txt';
+ try
+ fs:=TFileStream.Create(inp, fmCreate or fmShareDenyNone);
+ try
+ fs.Write(t[1], length(t));
+ finally
+ fs.Free;
+ end;
+ except
+ Result:='can''t write input';
+ end;
+
+ p:=TProcess.Create(nil);
+ try
+ cmd:=ExtTool+' ';
+
+ cconvconfig.SaveToFile(ConvFile, converteridesettings.ConvSettings);
+ cmd:=cmd+' -cfg "'+ ConvFile +'"';
+
+ if (DefineFile<>'') and FileExists(DefineFile) then
+ cmd:=cmd+' -defines "'+DefineFile+'" ';
+ cmd:=cmd+' -o "'+outp+'" ';
+ cmd:=cmd+'"'+inp+'"';
+
+ p.CommandLine:=cmd;
+ d:=p.CommandLine;
+ p.Execute;
+
+ tm:=GetTickCount;
+ while p.Active and (GetTickCount-tm=1 then begin
+ Val( copy(d, 1, i-1), EndPos.Y, err);
+ Val( copy(d, i+1, length(d)), EndPos.X, err);
+ end;
+ st.Delete(0);
+ Result:=st.Text;
+ finally
+ st.Free;
+ end;
+ except
+ Result:='can''t read output file';
+ end;
+
+ except
+ on E:Exception do
+ Result:=e.Message;
+ end;
+end;
+
+function DoConvertCode(const t: AnsiString; var EndPoint: TPoint; var txt: AnsiString): Boolean;
+begin
+ Result:=False;
+ if UseExtTool then begin
+ if not FileExists(ExtTool) then begin
+ ShowMessage('No convertor binary specified');
+ Exit;
+ end;
+ cconvconfig.SaveToFile(ConvFile, ConvSettings);
+ txt:=DoExtConvert(t, EndPoint);
+ Result:=(EndPoint.X>=0) and (EndPoint.Y>=0);
+
+ if Result then cconvconfig.LoadFromFile(ConvFile, ConvSettings)
+ else ShowMessage('Error: '+ txt);
+
+ end else
+ txt:='';
+end;
+
+procedure TryParse;
+var
+ editor : TSourceEditorInterface;
+ i : Integer;
+ txt : AnsiString;
+ s : AnsiString;
+ p : TPoint;
+ st : TPoint;
+begin
+ if not Assigned(SourceEditorManagerIntf) or not Assigned(SourceEditorManagerIntf.ActiveEditor) then Exit;
+ editor:=SourceEditorManagerIntf.ActiveEditor;
+
+ if Assigned(CtoPasConfig) then CtoPasConfig.UIToSettings;
+
+ i:=editor.CursorTextXY.Y;
+ dec(i);
+ if i<0 then i:=0;
+ txt:='';
+ for i:=i to editor.Lines.Count-1 do
+ txt:=txt+editor.Lines[i]+#10;
+
+ if DoConvertCode(txt, p, s) then
+ begin
+ inc(p.Y, editor.CursorTextXY.Y-1);
+ st:=editor.CursorTextXY;
+ st.X:=1;
+ editor.ReplaceText(st, p, s);
+ if Assigned(CtoPasConfig) then
+ CtoPasConfig.SettingsToUI;
+ end;
+end;
+
+procedure OnCtoPasClick(Sender: TObject);
+begin
+ TryParse;
+end;
+
+procedure OnCtoPasOptionsClick(Sender: TObject);
+begin
+ ShowConfigDialog;
+end;
+
+procedure InitPackage;
+var
+ cmd : TIDEMenuCommand;
+begin
+ cmd:=RegisterIDEMenuCommand(itmSecondaryTools, 'CtoPas', 'C to Pascal', nil, @OnCtoPasClick);
+ RegisterIDEMenuCommand(itmSecondaryTools, 'CtoPas', 'C to Pascal Options', nil, @OnCtoPasOptionsClick);
+ if Assigned(cmd) and Assigned(cmd.MenuItem) then cmd.MenuItem.ShortCut:=ShortCut(VK_B, [ssCtrl]);
+end;
+
+procedure Register;
+var
+ pth : AnsiString;
+begin
+ InitPackage;
+ pth:=IncludeTrailingPathDelimiter(LazIDEIntf.LazarusIDE.GetPrimaryConfigPath);
+ ConvFile := pth+'cconv.ini';
+ LoadFromFile(ConvFile, ConvSettings);
+ ReadIDESettings(ConvFile);
+ if DefineFile='' then DefineFile:=pth+'cconvdefines.h';
+end;
+
+initialization
+
+finalization
+ SaveToFile(ConvFile, ConvSettings);
+ WriteIDESettings(ConvFile);
+
+end.
+