pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

Added some code to create c and pascal files to test type sizes.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@1994 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
drewski207
2011-09-24 00:21:23 +00:00
parent d4c63d5b73
commit ae75be9603
6 changed files with 194 additions and 36 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
applications/gobject-introspection/gir2pascal.lpi
View File

@ -23,6 +23,7 @@
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<DestinationDirectory Value="/tmp/publishedproject/"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>
</PublishOptions>
@ -30,7 +31,7 @@
<local>
<FormatVersion Value="1"/>
<CommandLineParams Value="-i /usr/share/gir-1.0/Gtk-3.0.gir -o /tmp/gir-out -w"/>
<LaunchingApplication Use="True" PathPlusParams="/usr/bin/gnome-terminal -t 'Lazarus Run Output' -e '$(LazarusDir)/tools/runwait.sh $(TargetCmdLine)'"/>
<LaunchingApplication PathPlusParams="/usr/bin/gnome-terminal -t 'Lazarus Run Output' -e '$(LazarusDir)/tools/runwait.sh $(TargetCmdLine)'"/>
</local>
</RunParams>
<Units Count="8">

18
applications/gobject-introspection/gir2pascal.lpr
View File

@ -38,6 +38,7 @@ type
FOutPutDirectory : String;
FFileToConvert: String;
FOverWriteFiles: Boolean;
FWantTest: Boolean;
procedure AddDefaultPaths;
procedure AddPaths(APaths: String);
procedure VerifyOptions;
@ -45,7 +46,8 @@ type
//callbacks
function NeedGirFile(AGirFile: TObject; NamespaceName: String) : TXMLDocument;
procedure WritePascalFile(Sender: TObject; AUnitName: String; AStream: TStringStream);
// AName is the whole name unit.pas or file.c
procedure WriteFile(Sender: TObject; AName: String; AStream: TStringStream);
protected
procedure DoRun; override;
public
@ -110,14 +112,13 @@ begin
end;
end;
procedure TGirConsoleConverter.WritePascalFile(Sender: TObject;
AUnitName: String; AStream: TStringStream);
procedure TGirConsoleConverter.WriteFile(Sender: TObject; AName: String; AStream: TStringStream);
var
SStream: TFileStream;
OutFileName: String;
begin
Inc(FWriteCount);
OutFileName:=FOutPutDirectory+LowerCase(AUnitName)+'.pas';
OutFileName:=FOutPutDirectory+LowerCase(AName);
if not FileExists(OutFileName)
or (FileExists(OutFileName) and FOverWriteFiles) then
begin
@ -152,8 +153,8 @@ begin
girFile.ParseXMLDocument(Doc);
Doc.Free;
Writer := TgirPascalWriter.Create(girFile.NameSpaces);
Writer.OnUnitWriteEvent:= @WritePascalFile;
Writer := TgirPascalWriter.Create(girFile.NameSpaces, FWantTest);
Writer.OnUnitWriteEvent:= @WriteFile;
Writer.GenerateUnits;
Writer.Free;
@ -168,7 +169,7 @@ var
ErrorMsg: String;
begin
// quick check parameters
ErrorMsg:=CheckOptions('hnp:o:i:w',['help','no-default','paths','output-directory', 'input', 'overwrite-files']);
ErrorMsg:=CheckOptions('hnp:o:i:wt',['help','no-default','paths','output-directory', 'input', 'overwrite-files', 'test']);
if ErrorMsg<>'' then begin
ShowException(Exception.Create(ErrorMsg));
Terminate;
@ -198,6 +199,8 @@ begin
if HasOption('w', 'overwrite-files') then
FOverWriteFiles:=True;
FWantTest := HasOption('t', 'test');
VerifyOptions;
// does all the heavy lifting
@ -232,6 +235,7 @@ begin
Writeln(' -n --no-default /usr/share/gir-1.0 is not added as a search location for ');
Writeln(' needed .gir files.');
Writeln(' -p --paths= List of paths seperated by ":" to search for needed .gir files.');
Writeln(' -t --test Creates a test program and a test c file per unit to verify struct sizes.');
Writeln('');
end;

17
applications/gobject-introspection/girfiles.pas
View File

@ -59,32 +59,33 @@ uses girErrors, girTokens;
procedure TgirFile.ParseNode(ANode: TDomNode);
var
Node: TDomNode;
NS: TgirNamespace;
Includes: TList;
begin
if ANode.NodeName <> 'repository' then
girError(geError, 'Not a Valid Document Type!');
ANode := Anode.FirstChild;
Node := Anode.FirstChild;
Ns := nil;
Includes := TList.Create;
while ANode <> nil do begin
case GirTokenNameToToken(ANode.NodeName) of
gtInclude: ParseIncludeNode(ANode, Includes);
while Node <> nil do begin
case GirTokenNameToToken(Node.NodeName) of
gtInclude: ParseIncludeNode(Node, Includes);
gtNameSpace:
begin
NS := TgirNamespace.CreateFromNamespaceNode(NameSpaces, ANode, Includes);
NS := TgirNamespace.CreateFromRepositoryNode(NameSpaces, ANode, Includes);
girError(geDebug, 'Adding Namespace '+NS.NameSpace+' to NameSpaces');
FNameSpaces.Add(NS);
girError(geDebug, 'Added Namespace '+NS.NameSpace);
NS.ParseNode(ANode);
NS.ParseNode(Node);
end;
gtPackage, gtCInclude: ;// ignore for now
else
girError(geDebug, 'Unknown Node Type for Reposiotory: '+ Anode.NodeName);
girError(geDebug, 'Unknown Node Type for Reposiotory: '+ node.NodeName);
end;
ANode := ANode.NextSibling;
Node := Node.NextSibling;
end;

34
applications/gobject-introspection/girnamespaces.pas
View File

@ -34,7 +34,9 @@ type
TgirNamespace = class(IgirParser)
private
FCIncludeName: String;
FConstants: TList;
FCPackageName: String;
FFunctions: TList;
FNameSpace: String;
FOnlyImplied: Boolean;
@ -75,9 +77,11 @@ type
procedure ParseNode(ANode: TDomNode);
procedure ParseSubNode(ANode: TDomNode); // generally do not use outside of TgirNameSpace
constructor Create(AOwner:TObject; AImpliedNamespace: String);
constructor CreateFromNamespaceNode(AOwner:TObject; ANode: TDOMNode; AIncludes: TList);
constructor CreateFromRepositoryNode(AOwner:TObject; ANode: TDOMNode; AIncludes: TList);
destructor Destroy; override;
property NameSpace: String read FNameSpace;
property CIncludeName: String read FCIncludeName;
property CPackageName: String read FCPackageName;
property RequiredNameSpaces: TList Read FRequiredNameSpaces;
property SharedLibrary: String read FSharedLibrary;
property Version: String read FVersion;
@ -499,19 +503,39 @@ begin
girError(geDebug, 'Creating Stub for namespace: '+ AImpliedNamespace);
end;
constructor TgirNamespace.CreateFromNamespaceNode(AOwner:TObject; ANode: TDOMNode; AIncludes: TList);
constructor TgirNamespace.CreateFromRepositoryNode(AOwner:TObject; ANode: TDOMNode; AIncludes: TList);
procedure SetCInclude;
var
Child: TDomElement;
begin
Child := TDOMElement(ANode.FindNode('c:include name'));
if (Child <> nil) and Child.InheritsFrom(TDOMElement) then
FCIncludeName:= Child.GetAttribute('name');
end;
procedure SetPackage;
var
Child: TDOMElement;
begin
Child := TDOMElement(ANode.FindNode('package'));
if (Child <> nil) and Child.InheritsFrom(TDOMElement) then
FCPackageName:=Child.GetAttribute('name');
end;
var
Node: TDOMElement absolute ANode;
Node: TDOMElement;
begin
FOwner := AOwner;
if ANode = nil then
girError(geError, 'expected namespace got nil');
if ANode.NodeName <> 'namespace' then
girError(geError, 'expected namespace got '+ANode.NodeName);
if ANode.NodeName <> 'repository' then
girError(geError, 'expected "repository" got '+ANode.NodeName);
Node := TDOMElement( ANode.FindNode('namespace') );
FNameSpace:=Node.GetAttribute('name');
FRequiredNameSpaces := AIncludes;
FSharedLibrary:=Node.GetAttribute('shared-library');
FVersion:=Node.GetAttribute('version');
SetCInclude;
SetPackage;
girError(geDebug, Format('Creating namespace=%s Version=%s LibName=%s',[FNameSpace, FVersion, FSharedLibrary]));
FConstants := TList.Create;

21
applications/gobject-introspection/girobjects.pas
View File

@ -43,6 +43,7 @@ type
FCType: String;
FDoc: String;
FForwardDefinitionWritten: Boolean;
FHasFields: Boolean;
FImpliedPointerLevel: Integer;
FName: String;
FObjectType: TGirObjectType;
@ -265,9 +266,11 @@ type
{ TgirFieldsList }
TgirFieldsList = class(TFPList)
TgirFieldsList = class(TList)
private
FHasFields: Boolean;
function GetField(AIndex: Integer): TGirBaseType;
procedure Notify(Ptr: Pointer; Action: TListNotification); override;
public
property Field[AIndex: Integer]: TGirBaseType read GetField;
end;
@ -277,6 +280,7 @@ type
TgirRecord = class(TGirBaseType)
private
FFields: TgirFieldsList;
function GetHasFields: Boolean;
protected
procedure HandleUnion(ANode: TDomNode);
procedure HandleField(ANode: TDomNode);
@ -285,6 +289,7 @@ type
constructor Create(AOwner: TObject; ANode: TDomNode); override;
destructor Destroy; override;
property Fields: TgirFieldsList read FFields;
property HasFields: Boolean read GetHasFields;
end;
{ TgirUnion }
@ -413,6 +418,7 @@ constructor TgirBitField.Create(AOwner: TObject; ANode: TDomNode);
begin
inherited Create(AOwner, ANode);
FObjectType:=otBitfield;
FHasFields:=True;
end;
{ TgirFieldsList }
@ -422,6 +428,15 @@ begin
Result := TGirBaseType(Items[AIndex]);
end;
procedure TgirFieldsList.Notify(Ptr: Pointer; Action: TListNotification);
var
gir: TGirBaseType absolute Ptr;
begin
if FHasFields then
Exit;
FHasFields:= gir.ObjectType in [otTypeParam, otCallback, otArray];
end;
{ TgirParamList }
function TgirParamList.GetParam(AIndex: Integer): TGirFunctionParam;
@ -625,6 +640,10 @@ end;
function TgirRecord.GetHasFields: Boolean;
begin
Result := Fields.FHasFields;
end;
procedure TgirRecord.HandleUnion(ANode: TDomNode);
var

137
applications/gobject-introspection/girpascalwriter.pas
View File

@ -26,19 +26,22 @@ uses
Classes, SysUtils, girNameSpaces, girObjects, girTokens, contnrs;
type
TUnitWriteEvent = procedure (Sender: TObject; AUnitName: AnsiString; AStream: TStringStream) of object;
TgirWriteEvent = procedure (Sender: TObject; AUnitName: AnsiString; AStream: TStringStream) of object;
{ TgirPascalWriter }
TgirPascalWriter = class
private
FOnUnitWriteEvent: TUnitWriteEvent;
FDefaultUnitExtension: String;
FOnUnitWriteEvent: TgirWriteEvent;
FNameSpaces: TgirNamespaces;
FUnits: TList;
FWantTest: Boolean;
public
constructor Create(ANameSpaces: TgirNamespaces);
constructor Create(ANameSpaces: TgirNamespaces; AWantTest: Boolean);
procedure GenerateUnits;
property OnUnitWriteEvent: TUnitWriteEvent read FOnUnitWriteEvent write FOnUnitWriteEvent;
property OnUnitWriteEvent: TgirWriteEvent read FOnUnitWriteEvent write FOnUnitWriteEvent;
property DefaultUnitExtension: String read FDefaultUnitExtension write FDefaultUnitExtension; // is .pas by default
end;
@ -180,7 +183,11 @@ type
FInterfaceSection: TPInterface;
FLibName: String;
FNameSpace: TgirNamespace;
FWantTest: Boolean;
ProcessLevel: Integer; //used to know if to write forward definitions
FTestCFile: TStringStream;
FTestPascalFile: TStringStream;
FTestPascalBody: TStringList;
function GetUnitName: String;
// functions to ensure the type is being written in the correct declaration
@ -230,13 +237,16 @@ type
procedure ProcessType(AType: TGirBaseType; AForceWrite: Boolean = False);
procedure ResolveFuzzyTypes;
procedure AddTestType(APascalName: String; ACName: String);
public
constructor Create(ANameSpace: TgirNamespace; ALinkDynamic: Boolean);
constructor Create(ANameSpace: TgirNamespace; ALinkDynamic: Boolean; AWantTest: Boolean);
destructor Destroy; override;
procedure ProcessConsts(AList:TList); // of TgirBaseType descandants
procedure ProcessTypes(AList:TFPHashObjectList); // of TgirBaseType descandants
procedure ProcessFunctions(AList:TList);// of TgirFunction
procedure GenerateUnit;
function AsStream: TStringStream;
procedure Finish;
property InterfaceSection: TPInterface read FInterfaceSection;
property ImplementationSection: TPImplementation read FImplementationSection;
@ -614,6 +624,8 @@ begin
WriteLn('Unknown Type: ', AType.ClassName);
Halt;
end; // case
if (AType.InheritsFrom(TgirRecord)) and (TgirRecord(AType).HasFields) then
AddTestType(AType.TranslatedName, AType.CType);
AType.Writing:=msWritten;
Dec(ProcessLevel);
@ -643,6 +655,43 @@ begin
end;
end;
procedure TPascalUnit.AddTestType(APascalName: String; ACName: String);
const
CFunction = 'int GetSizeOf_%s(void)'+
'{ return sizeof(%s); };'+LineEnding;
PImport = 'function GetSizeOf_%s: LongInt; cdecl; external;'+LineEnding;
PTest = 'procedure Test_%s;' +LineEnding+
'var' +LineEnding+
' PSize: Integer;' +LineEnding+
' CSize: Integer;' +LineEnding+
'begin' +LineEnding+
' PSize := SizeOf(%s);' +LineEnding+
' CSize := GetSizeOf_%s;' +LineEnding+
' if CSize = PSize then' +LineEnding+
' WriteLn(''%s Matches C Size: '',CSize)' +LineEnding+
' else' +LineEnding+
' WriteLn(''%s size ('',PSize,'') does NOT match %s size ('',CSize,'')'');' +LineEnding+
'end;' +LineEnding;
var
CF: String;
PI: String;
PT: String;
begin
if not FWantTest then
Exit;
if (ACName = '') or (ACName[1] = '_') then // we skip private types
Exit;
CF := Format(CFunction,[ACName, ACName]);
PI := Format(PImport, [ACName]);
PT := Format(PTest, [ACName, APascalName, ACName, APascalName, APascalName, ACName]);
FTestCFile.WriteString(CF); // c sizeof wrapper
FTestPascalFile.WriteString(PI); // c import
FTestPascalFile.WriteString(PT); // pascal testproc
FTestPascalBody.Add(Format('Test_%s;',[ACName])); //call pascal testproc
end;
function TPascalUnit.WantTypeSection: TPDeclarationType;
begin
if (InterfaceSection.Declarations.Count = 0)
@ -961,6 +1010,7 @@ var
TypeFuncs: TStrings;
ParentType: String ='';
UsedNames: TStringList;
WrittenFields: Integer;
function GetTypeForProperty(AProperty: TgirProperty; out SetFound: Boolean): String;
var
@ -1040,10 +1090,12 @@ var
Param: String;
begin
ResolveTypeTranslation(AParam.VarType);
if (ParentType <> '') and (ParenParams(AParam.VarType.TranslatedName) = ParentType) then
Inc(WrittenFields);
if (WrittenFields = 1) and (AObjectType = gtClass) and (TgirClass(AItem).ParentClass <> nil) then
begin
Exit;
end;
Param := WriteParamAsString(AParam,i, nil, UsedNames);
//if Pos('destroy_:', Param) > 0 then
// Param := StringReplace(Param, 'destroy_', 'destroy_f', [rfReplaceAll]);
@ -1063,7 +1115,7 @@ var
otCallback,
otArray,
otTypeParam,
otUnion: ; // these will be done on the second pass. this is to make the field names different if they are the same as some function or property. giving the function priority of the original name
otUnion: Exit; // these will be done on the second pass. this is to avoid duplicate names if they are the same as some function or property. giving the function priority of the original name
otGlibSignal : if AObjectType <> gtClass then TypeDecl.Add(IndentText(WriteCallBack(TgirCallback(Field),True, UsedNames),4,0)); // classes do not have signals They are in the class *struct*
@ -1166,11 +1218,17 @@ begin
AddGetTypeProc(TgirGType(AItem));
end;
TypeDecl.Add(IndentText(AItem.TranslatedName +' = object'+ParentType,2,0));
// two passes to process the fields last for naming reasons
// two passes to process the fields last for naming reasons first for methods/properties second for fields
for i := 0 to Aitem.Fields.Count-1 do
HandleFieldType(AItem.Fields.Field[i], True);
for i := 0 to Aitem.Fields.Count-1 do
HandleFieldType(AItem.Fields.Field[i], False);
if AItem.CType <> 'GInitiallyUnowned' then // empty type GInitiallyUnowned is empty and aliased to GObject which causes object introspection to add the types again since it's empty...how many places does that happen...
begin
WrittenFields:=0;
for i := 0 to Aitem.Fields.Count-1 do
HandleFieldType(AItem.Fields.Field[i], False);
end;
if TypeFuncs.Count > 0 then
@ -1595,19 +1653,50 @@ begin
ABaseType.TranslatedName:=MakePascalTypeFromCType(ABaseType.CType, 0);
end;
constructor TPascalUnit.Create(ANameSpace: TgirNamespace; ALinkDynamic: Boolean);
constructor TPascalUnit.Create(ANameSpace: TgirNamespace; ALinkDynamic: Boolean; AWantTest: Boolean);
const
CBasic = '#include <%s>'+LineEnding;
PBasic = 'program %s_test;'+LineEnding+
'{$LINK %s_c_test}'+LineEnding+
'uses %s;'+LineEnding;
begin
ProcessLevel:=0;
FWantTest:=AWantTest;
FLinkDynamic := ALinkDynamic;
FFinalizeSection := TPFinialization.Create(Self);
FImplementationSection := TPImplementation.Create(Self);
FInitializeSection := TPInitialize.Create(Self);
FInterfaceSection := TPInterface.Create(Self, TPUses.Create);
FNameSpace := ANameSpace;
if FWantTest then
begin
FTestCFile := TStringStream.Create('');
FTestCFile.WriteString(Format(CBasic, [FNameSpace.CIncludeName]));
FTestPascalFile := TStringStream.Create('');
FTestPascalFile.WriteString(Format(PBasic,[UnitName, UnitName, UnitName]));
FTestPascalBody := TStringList.Create;
FTestPascalBody.Add('begin');
end;
ResolveFuzzyTypes;
GenerateUnit;
end;
destructor TPascalUnit.Destroy;
begin
if FWantTest then
begin
FTestPascalFile.Free;
FTestCFile.Free;
FTestPascalBody.Free;
end;
FFinalizeSection.Free;
FImplementationSection.Free;
FInitializeSection.Free;
FInterfaceSection.Free;
inherited Destroy;
end;
procedure TPascalUnit.ProcessConsts(AList: TList);
function WriteConst(AConst: TgirConstant; Suffix: String = ''): String;
begin
@ -1744,6 +1833,17 @@ begin
Result.Position:=0;
end;
procedure TPascalUnit.Finish;
begin
if FWantTest then
begin
FTestPascalFile.WriteString(FTestPascalBody.Text);
FTestPascalFile.WriteString('end.');
FTestCFile.Position:=0;
FTestPascalFile.Position:=0;
end;
end;
{ TPDeclarationList }
function TPDeclarationList.GetDeclarations(AIndex: Integer): TPDeclaration;
@ -1763,10 +1863,12 @@ end;
{ TgirPascalWriter }
constructor TgirPascalWriter.Create(ANameSpaces: TgirNamespaces);
constructor TgirPascalWriter.Create(ANameSpaces: TgirNamespaces; AWantTest: Boolean);
begin
FNameSpaces := ANameSpaces;
FUnits := TList.Create;
FDefaultUnitExtension:='.pas';
FWantTest:=AWantTest;
end;
procedure TgirPascalWriter.GenerateUnits;
@ -1774,16 +1876,23 @@ var
i: Integer;
FUnit: TPascalUnit;
begin
for i := 0 to FNameSpaces.Count-1 do
begin
WriteLn(Format('Converting %s', [FNameSpaces.NameSpace[i].NameSpace]));
FUnit := TPascalUnit.Create(FNameSpaces.NameSpace[i], False);
FUnit := TPascalUnit.Create(FNameSpaces.NameSpace[i], False, FWantTest);
FUnit.ProcessConsts(FNameSpaces.NameSpace[i].Constants);
FUnit.ProcessTypes(FNameSpaces.NameSpace[i].Types);
FUnit.ProcessFunctions(FNameSpaces.NameSpace[i].Functions);
FUnit.Finish;
FUnits.Add(FUnit);
FOnUnitWriteEvent(Self, FUnit.UnitName, FUnit.AsStream);
FOnUnitWriteEvent(Self, FUnit.UnitName+FDefaultUnitExtension, FUnit.AsStream);
if FWantTest then
begin
FOnUnitWriteEvent(Self, FUnit.UnitName+'_test'+FDefaultUnitExtension, FUnit.FTestPascalFile);
FOnUnitWriteEvent(Self, FUnit.UnitName+'_c_test.c', FUnit.FTestCFile);
end;
end;
end;