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

Fixed some name resolution which caused some types to be a child of the wrong type.

Browse Source 
Some Code cleanup removed unused vars etc


git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@2004 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
drewski207
2011-09-24 21:06:08 +00:00
parent 2a2c19d7d5
commit 3580e4b530
4 changed files with 180 additions and 79 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
applications/gobject-introspection/girctypesmapping.pas
View File

@ -23,11 +23,12 @@ unit girCTypesMapping;
interface
const
CTypesMax = 31;
CTypesMax = 34;
var
TypesPascalCTypes: array [0..CTypesMax-1] of string =
(
'void',
'pointer',
'cint',
'cint',
@ -44,7 +45,9 @@ var
'clong',
'culong',
'cushort',
'cshort',
'char',
'byte',
'Boolean32',
'PtrInt',
'csize_t',
@ -63,6 +66,7 @@ var
);
TypesGTypes: array [0..CTypesMax-1] of string =
(
'void',
'gpointer',
'int',
'gint',
@ -79,7 +83,9 @@ var
'glong',
'gulong',
'gushort',
'gshort',
'gchar',
'guchar',
'gboolean',
'gssize',
'size_t' ,

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

@ -69,8 +69,9 @@ type
procedure HandleClass(ANode: TDomNode); // one step above GType. Is the object structure and it's methods. ClassStruct is like the VMT
procedure HandleInterface(ANode: TDomNode);
procedure AddGLibBaseTypes;
procedure AddType(AType: TGirBaseType);
public
function LookupTypeByName(AName: String; const ACType: String; const SearchOnly: Boolean = False): TGirBaseType;
function LookupTypeByName(AName: String; const ACType: String; SearchOnly: Boolean = False): TGirBaseType;
function ResolveFuzzyType(AFuzzyType: TgirFuzzyType): TGirBaseType;
function UsesGLib: Boolean;
procedure ResolveFuzzyTypes; // called after done
@ -185,6 +186,7 @@ begin
ParseSubNode(ANode);
ANode := ANode.NextSibling;
end;
ResolveFuzzyTypes;
end;
procedure TgirNamespace.SetOnNeedGirFile(AValue: TgirNeedGirFileEvent);
@ -197,7 +199,7 @@ function TgirNamespace.AddFuzzyType(AName: String; ACType: String
): TGirBaseType;
begin
Result := TgirFuzzyType.Create(Self, AName, ACType);
FTypes.Add(AName, Result);
AddType(Result);
FUnresolvedTypes.Add(Result);
end;
@ -298,7 +300,7 @@ var
Item: TgirClassStruct;
begin
Item := TgirClassStruct.Create(Self, ANode);
FTypes.Add(Item.Name, Item);
AddType(Item);
end;
procedure TgirNamespace.HandleClass(ANode: TDomNode);
@ -306,7 +308,7 @@ var
Item: TgirClass;
begin
Item := TgirClass.Create(Self, ANode);
FTypes.Add(Item.Name, Item);
AddType(Item);
end;
procedure TgirNamespace.HandleInterface(ANode: TDomNode);
@ -314,22 +316,41 @@ var
Item: TgirInterface;
begin
Item := TgirInterface.Create(Self, ANode);
FTypes.Add(Item.Name, Item);
AddType(Item);
end;
procedure TgirNamespace.AddGLibBaseTypes;
procedure AddNativeTypeDef(GType: String; PascalCName: String);
function AddNativeTypeDef(GType: String; PascalCName: String; TranslatedName: String): TgirNativeTypeDef;
var
NativeType: TgirNativeTypeDef;
begin
NativeType:= TgirNativeTypeDef.Create(Self, GType, PascalCName);
if TranslatedName <> '' then
NativeType.TranslatedName:=TranslatedName;
NativeType.ImpliedPointerLevel:=3;
Types.Add(NativeType.Name, NativeType);
Result := NativeType;
end;
var
i: Integer;
begin
for i := 0 to CTypesMax-1 do
AddNativeTypeDef(TypesGTypes[i], TypesPascalCTypes[i]);
AddNativeTypeDef(TypesGTypes[i], TypesPascalCTypes[i], '');
end;
procedure TgirNamespace.AddType(AType: TGirBaseType);
var
PrevFound: TGirBaseType = nil;
begin
PrevFound := TGirBaseType(FTypes.Find(AType.Name));
if (PrevFound <> nil) and (PrevFound.ObjectType = otFuzzyType) then
begin
(PrevFound as TgirFuzzyType).ResolvedType := AType;
end;
//if PrevFound <> nil then WriteLn('Found Name Already Added: ', AType.Name, ' ', PrevFound.ObjectType, ' ', AType.ObjectType);
if PrevFound = nil then
FTypes.Add(AType.Name, AType);
end;
procedure TgirNamespace.ResolveFuzzyTypes;
@ -337,17 +358,23 @@ var
i: Integer;
FuzzyI: Integer;
Fuzzy: TgirFuzzyType;
FuzzyP: Pointer absolute Fuzzy;
Tmp: TGirBaseType;
StillFuzzy: TList;
Current: TGirBaseType;
ReqNS: TgirNamespace;
begin
i:= 0;
FuzzyI := 0;
Fuzzy := nil;
StillFuzzy := TList.Create;
while (i < FTypes.Count) or (Fuzzy <> nil) do
begin
// make our loop safe
if i >= FTypes.Count then
begin
i := FuzzyI+1;
StillFuzzy.Add(Fuzzy);
Fuzzy := nil;
continue;
end;
@ -378,6 +405,25 @@ begin
inc(i);
end;
// if the types are still fuzzy then we will search used namespaces for what we want
for FuzzyP in StillFuzzy do //FuzzyP is Fuzzy absolute
begin
if Fuzzy.ResolvedType <> nil then
continue;
for i := 0 to RequiredNameSpaces.Count-1 do
begin
ReqNS := TgirNamespace(RequiredNameSpaces.Items[i]);
Current := ReqNS.LookupTypeByName(Fuzzy.Name, '', True);
if Current <> nil then
begin
if (Current.ObjectType = otFuzzyType) and (TgirFuzzyType(Current).ResolvedType <> nil) then
Current := TgirFuzzyType(Current).ResolvedType;
Fuzzy.ResolvedType := Current;
Break;
end;
end;
end;
StillFuzzy.Free;
end;
procedure TgirNamespace.ParseSubNode(ANode: TDomNode);
@ -397,10 +443,9 @@ begin
else
girError(geError, 'Unknown NodeType: '+ANode.NodeName);
end;
ResolveFuzzyTypes;
end;
function TgirNamespace.LookupTypeByName(AName: String; const ACType: String; const SearchOnly: Boolean = False): TGirBaseType;
function TgirNamespace.LookupTypeByName(AName: String; const ACType: String; SearchOnly: Boolean = False): TGirBaseType;
function StripPointers(ACPointeredType: String; PtrLevel: PInteger = nil): String;
var
i: Integer;
@ -416,19 +461,23 @@ function TgirNamespace.LookupTypeByName(AName: String; const ACType: String; con
end;
var
ReqNS,
NS: TgirNamespace;
NSString: String;
FPos: Integer;
i: Integer;
Current: TGirBaseType;
PointerLevel: Integer = 0;
PlainCType: String;
begin
Result := nil;
NS := Self;
FPos := Pos('.', AName);
// some basic fixes
PlainCType:=StringReplace(StripPointers(ACType, @PointerLevel), ' ', '_', [rfReplaceAll]);
if (PlainCType = 'gchar') or (PlainCType = 'guchar') or (PlainCType = 'char') then
AName := 'GLib.utf8';
if (PlainCType = 'GType') {or (AName = 'Type')} or (AName = 'GType')then
AName := 'GLib.Type';
FPos := Pos('.', AName);
if FPos > 0 then // type includes namespace "NameSpace.Type"
begin
@ -439,34 +488,14 @@ begin
AName := Copy(AName, FPos+1, Length(AName));
end;
// some basic fixes
if PlainCType = 'gchar' then
AName := 'utf8';
if PlainCType = 'GType' then
AName := 'Type';
if NS <> Self then SearchOnly:=True;
Result := TGirBaseType(NS.Types.Find(AName));
if (Result <> nil) and (Result.ObjectType = otFuzzyType) and (TgirFuzzyType(Result).ResolvedType <> nil) then
Result := TgirFuzzyType(Result).ResolvedType;
if (Result = nil) and not SearchOnly then
begin
for i := 0 to NS.RequiredNameSpaces.Count-1 do
begin
ReqNS := TgirNamespace(NS.RequiredNameSpaces.Items[i]);
Current := ReqNS.LookupTypeByName(AName, ACType, True);
if Current <> nil then
begin
if (Current.ObjectType = otFuzzyType) and (TgirFuzzyType(Current).ResolvedType <> nil) then
Current := TgirFuzzyType(Current).ResolvedType;
Result := Current;
Break;
end;
end;
if Result = nil then
if (Result = nil) and Not SearchOnly then
Result := NS.AddFuzzyType(AName, ACType);
end;
if Result <> nil then
Result.ImpliedPointerLevel:=PointerLevel;
end;

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

@ -71,7 +71,6 @@ type
TgirNativeTypeDef = class(TGirBaseType)
private
FPAs: String;
FPascalName: String;
public
constructor Create(AOwner:TObject; AGType: String; APascalCTypeName: String);
@ -95,9 +94,11 @@ type
TgirAlias = class(TGirBaseType)
private
FForType: TGirBaseType;
function GetForType: TGirBaseType;
public
constructor Create(AOwner: TObject; ANode: TDomNode); override;
property ForType: TGirBaseType read FForType;
constructor Create(AOwner: TObject; AName, ACType, ATranslatedName: String);
property ForType: TGirBaseType read GetForType write FForType;
end;
{ TgirTypeParam }
@ -270,6 +271,7 @@ type
private
FHasFields: Boolean;
function GetField(AIndex: Integer): TGirBaseType;
protected
procedure Notify(Ptr: Pointer; Action: TListNotification); override;
public
property Field[AIndex: Integer]: TGirBaseType read GetField;
@ -324,9 +326,15 @@ type
{ TgirClass }
{ TgirClassStruct }
TgirClass = class;
TgirClassStruct = class(TgirGType)
private
FIsClassStructFor: TgirClass;
function GetIsClassStructFor: TgirClass;
public
constructor Create(AOwner: TObject; ANode: TDomNode); override;
property IsClassStructFor: TgirClass read GetIsClassStructFor;
end;
@ -351,7 +359,7 @@ type
{ TgirInterface }
TgirInterface = class(TgirClass)
protected
public
constructor Create(AOwner: TObject; ANode: TDomNode); override;
procedure ParseNode(ANode: TDomNode; ANodeType: TGirToken); override;
end;
@ -366,10 +374,30 @@ uses girNameSpaces, girErrors;
{ TgirClassStruct }
function TgirClassStruct.GetIsClassStructFor: TgirClass;
begin
Result := nil;
if FIsClassStructFor.ObjectType = otFuzzyType then
begin
if TgirFuzzyType(FIsClassStructFor).ResolvedType <> nil then
FIsClassStructFor := TgirClass(TgirFuzzyType(FIsClassStructFor).ResolvedType);
end;
Result := FIsClassStructFor;
end;
constructor TgirClassStruct.Create(AOwner: TObject; ANode: TDomNode);
var
IsClassForName: String;
begin
inherited Create(AOwner, ANode);
FObjectType:=otClassStruct;
IsClassForName:= (ANode as TDOMElement).GetAttribute('glib:is-gtype-struct-for');
if IsClassForName <> '' then
begin
FIsClassStructFor := TgirClass((Owner as TgirNamespace).LookupTypeByName(IsClassForName, '', True));
if (FIsClassStructFor <> nil) and (FIsClassStructFor.ObjectType = otClass) then
FIsClassStructFor.FClassStruct := Self;
end;
end;
{ TgirConstructor }
@ -601,7 +629,6 @@ end;
constructor TgirArray.Create(AOwner: TObject; ANode: TDomNode);
var
Node: TDomELement;
Tmp: String;
begin
inherited Create(AOwner, ANode);
Node := TDomElement(ANode.FindNode('type'));
@ -656,14 +683,10 @@ end;
procedure TgirRecord.HandleField(ANode: TDomNode);
var
Node: TDOMNode;
attr: TDomNode;
Attrs: TDOMNamedNodeMap;
Item: TGirBaseType;
begin
Node := ANode.FirstChild;
while Node <> nil do
begin
Attrs := ANode.Attributes;
case GirTokenNameToToken(Node.NodeName) of
gtDoc:;
gtType: FFields.Add(TgirTypeParam.Create(Owner, ANode));
@ -748,8 +771,6 @@ begin
end;
function TgirTypeParam.GetPointerLevel: Integer;
var
i: Integer;
begin
Result := FPointerLevel;
end;
@ -1021,6 +1042,13 @@ end;
{ TgirAlias }
function TgirAlias.GetForType: TGirBaseType;
begin
if (FForType <> nil) and (FForType.ObjectType = otFuzzyType) and (TgirFuzzyType(FForType).ResolvedType <> nil) then
FForType := TgirFuzzyType(FForType).ResolvedType;
Result := FForType;
end;
constructor TgirAlias.Create(AOwner: TObject; ANode: TDomNode);
var
Node: TDOMElement;
@ -1031,6 +1059,16 @@ begin
FObjectType:=otAlias;
end;
constructor TgirAlias.Create(AOwner: TObject; AName, ACType,
ATranslatedName: String);
begin
FOwner := AOwner;
FName:=AName;
FCType:=ACType;
FTranslatedName:=ATranslatedName;
FObjectType:=otAlias;
end;
{ TGirBaseType }
procedure TGirBaseType.SetImpliedPointerLevel(AValue: Integer);

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

@ -185,7 +185,7 @@ type
FNameSpace: TgirNamespace;
FWantTest: Boolean;
ProcessLevel: Integer; //used to know if to write forward definitions
FTestCFile: TStringStream;
//FTestCFile: TStringStream;
FTestPascalFile: TStringStream;
FTestPascalBody: TStringList;
function GetUnitName: String;
@ -237,7 +237,7 @@ type
procedure ProcessType(AType: TGirBaseType; AForceWrite: Boolean = False);
procedure ResolveFuzzyTypes;
procedure AddTestType(APascalName: String; ACName: String);
procedure AddTestType(AGType: TgirGType);
public
constructor Create(ANameSpace: TgirNamespace; ALinkDynamic: Boolean; AWantTest: Boolean);
destructor Destroy; override;
@ -559,8 +559,8 @@ end;
procedure TPascalUnit.ProcessType(AType: TGirBaseType; AForceWrite: Boolean = False);
begin
if (AType = nil) or (AType.Owner <> NameSpace) then
Exit; // it's written in another Namespace
if (AType = nil) then
Exit;
if (AType.ObjectType = otFuzzyType) and (TgirFuzzyType(AType).ResolvedType <> nil) then
begin
@ -568,6 +568,9 @@ begin
AType := TgirFuzzyType(AType).ResolvedType;
end;
if (AType.Owner <> NameSpace) then
Exit; // it's written in another Namespace
if (AType.CType = '') then //(AType.Name = '') then
begin
WriteLn('WARNING: Type.Ctype undefined! : ', Atype.Name);
@ -624,8 +627,8 @@ begin
WriteLn('Unknown Type: ', AType.ClassName);
Halt;
end; // case
if (AType.InheritsFrom(TgirRecord)) and (TgirRecord(AType).HasFields) then
AddTestType(AType.TranslatedName, AType.CType);
if (AType.InheritsFrom(TgirGType)) then // and (TgirGType(AType).HasFields) then
AddTestType((TgirGType(AType)));//, AType.TranslatedName, AType.CType, TgirGType(AType).GetTypeFunction);
AType.Writing:=msWritten;
Dec(ProcessLevel);
@ -655,41 +658,49 @@ begin
end;
end;
procedure TPascalUnit.AddTestType(APascalName: String; ACName: String);
procedure TPascalUnit.AddTestType(AGType: TgirGType);
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+
' CClassSize: Integer;' +LineEnding+
'begin' +LineEnding+
' PSize := SizeOf(%s);' +LineEnding+
' CSize := GetSizeOf_%s;' +LineEnding+
' CSize := GTypeSize(%s, CClassSize);' +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;
' WriteLn(''%s size ('',PSize,'') does NOT match %s size ('',CSize,'')''); ' +LineEnding+
'%send;' +LineEnding;
PTest2 =' PSize := SizeOf(%s);' +LineEnding+
' if CClassSize = PSize then' +LineEnding+
' WriteLn(''%s Matches C Size: '',CSize)' +LineEnding+
' else' +LineEnding+
' WriteLn(''%s size ('',PSize,'') does NOT match %s size ('',CSize,'')'');' +LineEnding;
var
CF: String;
PI: String;
PT: String;
PT2: String = '';
Cls: TgirClass absolute AGType;
begin
if not FWantTest then
Exit;
if (ACName = '') or (ACName[1] = '_') then // we skip private types
if (AGType.CType = '') then //or (ACName[1] = '_') then // we skip private types
Exit;
ResolveTypeTranslation(AGType);
CF := Format(CFunction,[ACName, ACName]);
PI := Format(PImport, [ACName]);
PT := Format(PTest, [ACName, APascalName, ACName, APascalName, APascalName, ACName]);
if AGType.GetTypeFunction = '' then exit;
if AGType.InheritsFrom(TgirClass) and (Cls.ClassStruct <> nil) then
begin
ResolveTypeTranslation(Cls.ClassStruct);
PT2 := Format(PTest2, [cls.ClassStruct.TranslatedName, cls.ClassStruct.TranslatedName, cls.ClassStruct.TranslatedName, cls.ClassStruct.CType] );
end;
PT := Format(PTest, [AGType.CType, AGType.TranslatedName, AGType.GetTypeFunction, AGType.TranslatedName, AGType.TranslatedName, AGType.CType, PT2]);
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
FTestPascalBody.Add(Format('Test_%s;',[AGType.CType])); //call pascal testproc
end;
function TPascalUnit.WantTypeSection: TPDeclarationType;
@ -763,7 +774,7 @@ begin
if ResolvedForName = '' then
begin
CType := NameSpace.LookupTypeByName('', AItem.ForType.CType);
//CType := NameSpace.LookupTypeByName('', AItem.ForType.CType);
if CType <> nil then
ResolvedForName := CType.TranslatedName;
@ -775,8 +786,10 @@ begin
WriteForwardDefinition(AItem);
AItem.TranslatedName:=MakePascalTypeFromCType(AItem.CType);
if AItem.Writing < msWritten then
WantTypeSection.Lines.Add(IndentText(MakePascalTypeFromCType(AItem.CType)+' = '+ ResolvedForName+';' ,2,0));
WantTypeSection.Lines.Add(IndentText(Aitem.TranslatedName+' = '+ ResolvedForName+';' ,2,0));
end;
procedure TPascalUnit.HandleCallback(AItem: TgirCallback);
@ -914,6 +927,7 @@ begin
TypeSect.Lines.Add(IndentText('{ opaque type }',4,0));
//TypeSect.Lines.Add(IndentText('Unknown: Pointer;',4,0)); // to prevent crashes of the compiler
TypeSect.Lines.Add(IndentText('end;',2,1));
WriteLn('Wrote Opaque Type Name = ', AItem.Name,' CType = ', AItem.CType);
end;
@ -1722,10 +1736,21 @@ end;
constructor TPascalUnit.Create(ANameSpace: TgirNamespace; ALinkDynamic: Boolean; AWantTest: Boolean);
const
CBasic = '#include <%s>'+LineEnding;
//CBasic = '#include <%s>'+LineEnding;
PBasic = 'program %s_test;'+LineEnding+
'{$LINK %s_c_test}'+LineEnding+
'uses %s;'+LineEnding;
//'{$LINK %s_c_test}'+LineEnding+
'{$MODE OBJFPC}'+LineEnding+
'uses GLib2, GObject2, %s;'+LineEnding;
GTypeSize = 'function GTypeSize(AType: TGType; out AClassSize: Integer): Integer;'+LineEnding+
'var' +LineEnding+
' Query: TGTypeQuery;' +LineEnding+
'begin' +LineEnding+
' g_type_query(AType, @Query);' +LineEnding+
' AClassSize := Query.Class_Size;' +LineEnding+
' GTypeSize := Query.instance_size;' +LineEnding+
' if GTypeSize = 32767 then GTypeSize := 0;' +LineEnding+
' if AClassSize = 32767 then AClassSize := 0;' +LineEnding+
'end;'+LineEnding;
begin
ProcessLevel:=0;
FWantTest:=AWantTest;
@ -1737,12 +1762,15 @@ begin
FNameSpace := ANameSpace;
if FWantTest then
begin
FTestCFile := TStringStream.Create('');
FTestCFile.WriteString(Format(CBasic, [FNameSpace.CIncludeName]));
//FTestCFile := TStringStream.Create('');
//FTestCFile.WriteString(Format(CBasic, [FNameSpace.CIncludeName]));
FTestPascalFile := TStringStream.Create('');
FTestPascalFile.WriteString(Format(PBasic,[UnitName, UnitName, UnitName]));
FTestPascalFile.WriteString(GTypeSize);
FTestPascalBody := TStringList.Create;
FTestPascalBody.Add('begin');
FTestPascalBody.Add(' g_type_init();');
end;
ResolveFuzzyTypes;
GenerateUnit;
@ -1753,7 +1781,7 @@ begin
if FWantTest then
begin
FTestPascalFile.Free;
FTestCFile.Free;
//FTestCFile.Free;
FTestPascalBody.Free;
end;
FFinalizeSection.Free;
@ -1878,7 +1906,7 @@ begin
Str.WriteString(IndentText('unit '+ UnitName+';',0,2));
Str.WriteString(IndentText('{$MODE OBJFPC}{$H+}',0,2));
Str.WriteString(IndentText('{$PACKRECORDS C}',0,1));
//Str.WriteString(IndentText('{$BITPACKING ON}',0,1)); not needed since we set records that need is bitpacked
//Str.WriteString(IndentText('{$BITPACKING ON}',0,1)); not needed since we set records that need it to bitpacked
//Str.WriteString(IndentText('{$CALLING CDECL}',0,2));
Str.WriteString(IndentText('{$MODESWITCH DUPLICATELOCALS+}',0,2));
@ -1907,7 +1935,7 @@ begin
begin
FTestPascalFile.WriteString(FTestPascalBody.Text);
FTestPascalFile.WriteString('end.');
FTestCFile.Position:=0;
//FTestCFile.Position:=0;
FTestPascalFile.Position:=0;
end;
end;
@ -1959,7 +1987,7 @@ begin
if FWantTest then
begin
FOnUnitWriteEvent(Self, FUnit.UnitName+'_test'+FDefaultUnitExtension, FUnit.FTestPascalFile);
FOnUnitWriteEvent(Self, FUnit.UnitName+'_c_test.c', FUnit.FTestCFile);
//FOnUnitWriteEvent(Self, FUnit.UnitName+'_c_test.c', FUnit.FTestCFile);
end;
end;
end;