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

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@1994 8e941d3f-bd1b-0410-a28a-d453659cc2b4

applications/gobject-introspection/gir2pascal.lpi

@@ -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">

applications/gobject-introspection/gir2pascal.lpr

@@ -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;
+procedure TGirConsoleConverter.WriteFile(Sender: TObject; AName: String; AStream: TStringStream);
-  AUnitName: 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 := TgirPascalWriter.Create(girFile.NameSpaces, FWantTest);
-  Writer.OnUnitWriteEvent:= @WritePascalFile;
+  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;
 

applications/gobject-introspection/girfiles.pas

@@ -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
+  while Node <> nil do begin
-    case GirTokenNameToToken(ANode.NodeName) of
+    case GirTokenNameToToken(Node.NodeName) of
-      gtInclude: ParseIncludeNode(ANode, Includes);
+      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;
 
 

applications/gobject-introspection/girnamespaces.pas

@@ -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
+  if ANode.NodeName <> 'repository' then
-    girError(geError, 'expected namespace got '+ANode.NodeName);
+    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;

applications/gobject-introspection/girobjects.pas

@@ -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

applications/gobject-introspection/girpascalwriter.pas

@@ -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
+  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...
-    HandleFieldType(AItem.Fields.Field[i], False);
+  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;