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

gir2pascal changes:

Browse Source 
- Added option --max-version. It allows to limit the version of the symbols to a particular version. i.e. Gtk-3.8 when run against 3.14.
 - Added option --keep-deprecated-version. It allow to reduce the version that will exclude deprecated symbols. i.e using --keep-deprecated-version=Gtk-3.8 on version 3.14 will include all symbols from 3.8 up to the current when normally they would be dropped.
 - Some changes to accomodate new nodes in the gir xml files.


git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5356 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
drewski207
2016-11-17 02:54:44 +00:00
parent 1595dc270d
commit 8fdb7bbd70
9 changed files with 534 additions and 116 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@ -30,20 +30,18 @@
<RunParams>
<local>
<FormatVersion Value="1"/>
<CommandLineParams Value="-wCni /home/andrew/programming/lazarus-ccr/applications/gobject-introspection/girfiles-from-felix/Gtk-3.0.gir -o /tmp/gir-out"/>
<LaunchingApplication PathPlusParams="/usr/bin/gnome-terminal -t 'Lazarus Run Output' -e '$(LazarusDir)/tools/runwait.sh $(TargetCmdLine)'"/>
<CommandLineParams Value="-wni /home/andrew/programming/lazarus-ccr.old/applications/gobject-introspection/girfiles-from-felix/Gtk-3.0.gir -o /tmp/gir-out"/>
<LaunchingApplication Use="True" PathPlusParams="/usr/bin/gnome-terminal -t 'Lazarus Run Output' -e '$(LazarusDir)/tools/runwait.sh $(TargetCmdLine)'"/>
</local>
</RunParams>
<Units Count="11">
<Unit0>
<Filename Value="gir2pascal.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="gir2pascal"/>
</Unit0>
<Unit1>
<Filename Value="girpascalwriter.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="girpascalwriter"/>
</Unit1>
<Unit2>
<Filename Value="girnamespaces.pas"/>
@ -83,7 +81,6 @@
<Unit9>
<Filename Value="girpascalwritertypes.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="girpascalwritertypes"/>
</Unit9>
<Unit10>
<Filename Value="commandlineoptions.pas"/>
@ -101,12 +98,6 @@
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Other>
<CompilerMessages>
<UseMsgFile Value="True"/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="4">

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

@ -174,7 +174,7 @@ begin
StartTime := Now;
ReadXMLFile(Doc, FFileToConvert);
girFile := TgirFile.Create(nil);
girFile := TgirFile.Create(Self, FCmdOptions);
girFile.OnNeedGirFile:=@NeedGirFile;
girFile.ParseXMLDocument(Doc);
Doc.Free;
@ -216,6 +216,8 @@ begin
AddOption(['d', 'deprecated'], False, 'Include fields and methods marked as deprecated.');
AddOption(['t', 'test'], False ,'Creates a test program per unit to verify struct sizes.');
AddOption(['P', 'unit-prefix'], True, 'Set a prefix to be added to each unitname.');
AddOption(['M', 'max-version'], True, 'Do not include symbols introduced after <max-version>. Can be used multiple times. i.e "-M gtk-3.12 -M glib-2.23"');
AddOption(['k', 'keep-deprecated-version'], True, 'Include deprecated symbols that are >= to $version. Uses the same format as --max-version. Has no effect if --deprecated is defined');
end;
FCmdOptions.ReadOptions;
if FCmdOptions.OptionsMalformed then
@ -296,6 +298,11 @@ begin
if FCmdOptions.HasOption('seperate-units') then
Include(FOptions, goSeperateConsts);
if FCmdOptions.HasOption('unit-prefix') then
FUnitPrefix:=FCmdOptions.OptionValue('unit-prefix')
else
FUnitPrefix:='';
VerifyOptions;
// does all the heavy lifting

BIN
applications/gobject-introspection/gir2pascal.res
View File

Binary file not shown.

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

@ -24,7 +24,7 @@ unit girFiles;
interface
uses
Classes, SysUtils, DOM, girNameSpaces, girParser;
Classes, SysUtils, DOM, girNameSpaces, girParser, CommandLineOptions;
type
@ -35,16 +35,19 @@ type
FNameSpaces: TgirNamespaces;
FOnNeedGirFile: TgirNeedGirFileEvent;
FOwner: TObject;
FCmdOptions: TCommandLineOptions;
procedure ParseNode(ANode: TDomNode);
procedure SetOnNeedGirFile(AValue: TgirNeedGirFileEvent);
procedure SetOwner(const AValue: TObject);
procedure ParseIncludeNode(ANode: TDomNode; AIncludes: TList);
procedure CheckVersionLimits(const ANameSpace: TgirNamespace);
function CheckVersionOptions(const ANamespace: String; var AMajor, AMinor: Integer): Boolean;
public
constructor Create(AOwner: TObject);
constructor Create(AOwner: TObject; AOptions: TCommandLineOptions);
destructor Destroy; override;
procedure ParseXMLDocument(AXML: TXMLDocument);
property NameSpaces: TgirNamespaces read FNameSpaces;
property Owner: TObject read FOwner write SetOwner;
property Owner: TObject read FOwner write SetOwner; // TGirConsoleConverter
property OnNeedGirFile: TgirNeedGirFileEvent read FOnNeedGirFile write SetOnNeedGirFile;
end;
@ -79,6 +82,7 @@ begin
girError(geDebug, 'Adding Namespace '+NS.NameSpace+' to NameSpaces');
FNameSpaces.Add(NS);
girError(geDebug, 'Added Namespace '+NS.NameSpace);
CheckVersionLimits(NS);
NS.ParseNode(Node);
end;
gtPackage, gtCInclude: ;// ignore for now
@ -126,10 +130,67 @@ begin
end;
end;
procedure TgirFile.CheckVersionLimits(const ANameSpace: TgirNamespace);
constructor TgirFile.Create(AOwner: TObject);
function SplitVersion(AVersionStr: String; out AVersion: TGirVersion): Boolean;
begin
try
AVersion := girVersion(AVersionStr);
Result := True;
except
Result := False;
end;
end;
function SplitNameSpaceVersionCheck(AOptionName: String; var AVersion: TGirVersion): Boolean;
var
i: Integer;
begin
if FCmdOptions.HasOption(AOptionName) then
with FCmdOptions.OptionValues(AOptionName) do
begin
for i := 0 to Count-1 do
begin
if Lowercase(ANameSpace.NameSpace)+'-' = Lowercase(Copy(Strings[i], 1, Length(ANameSpace.NameSpace)+1)) then
begin
Result := SplitVersion(Copy(Strings[i], Length(ANameSpace.NameSpace)+2, MaxInt), AVersion);
break;
end;
end;
end;
end;
var
lVersion: TGirVersion;
begin
if SplitNameSpaceVersionCheck('max-version', lVersion) then
ANameSpace.MaxSymbolVersion := lVersion
else
ANameSpace.MaxSymbolVersion := girVersion(MaxInt, MaxInt);
if SplitNameSpaceVersionCheck('keep-deprecated-version', lVersion) then
ANameSpace.DeprecatedVersion := lVersion
else
ANameSpace.DeprecatedVersion := girVersion(MaxInt, MaxInt);
end;
function TgirFile.CheckVersionOptions(const ANamespace: String; var AMajor, AMinor: Integer): Boolean;
begin
Result := False;
end;
constructor TgirFile.Create(AOwner: TObject; AOptions: TCommandLineOptions);
begin
Owner := AOwner;
FCmdOptions := AOptions;
FNameSpaces := TgirNamespaces.Create(Self);
end;

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

@ -37,7 +37,10 @@ type
FCIncludeName: String;
FConstants: TList;
FCPackageName: String;
FCPrefix: String;
FDeprecatedVersion: TGirVersion;
FFunctions: TList;
FMaxSymbolVersion: TGirVersion;
FNameSpace: String;
FOnlyImplied: Boolean;
FOnNeedGirFile: TgirNeedGirFileEvent;
@ -46,7 +49,7 @@ type
FSharedLibrary: String;
FTypes: TFPHashObjectList;
FUnresolvedTypes: TList;
FVersion: String;
FVersion: TGirVersion;
procedure SetOnNeedGirFile(AValue: TgirNeedGirFileEvent);
protected
function AddFuzzyType(AName: String; ACType: String): TGirBaseType;
@ -69,8 +72,8 @@ 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
procedure AddType(AType: TGirBaseType);
function LookupTypeByName(AName: String; const ACType: String; SearchOnly: Boolean = False): TGirBaseType;
function ResolveFuzzyType(AFuzzyType: TgirFuzzyType): TGirBaseType;
function UsesGLib: Boolean;
@ -83,9 +86,10 @@ type
property NameSpace: String read FNameSpace;
property CIncludeName: String read FCIncludeName;
property CPackageName: String read FCPackageName;
property CPrefix: String read FCPrefix;
property RequiredNameSpaces: TList Read FRequiredNameSpaces;
property SharedLibrary: String read FSharedLibrary;
property Version: String read FVersion;
property Version: TGirVersion read FVersion;
property OnlyImplied: Boolean read FOnlyImplied;
property Owner: TObject Read FOwner;
@ -95,6 +99,10 @@ type
property Functions: TList read FFunctions;
property Constants: TList read FConstants;
property UnresolvedTypes: TList read FUnresolvedTypes write FUnresolvedTypes;
// exclude symbols newer than this version
property MaxSymbolVersion: TGirVersion read FMaxSymbolVersion write FMaxSymbolVersion;
// exclude symbols this version and older that are marked as deprecated
property DeprecatedVersion: TGirVersion read FDeprecatedVersion write FDeprecatedVersion;
end;
{ TgirNamespaces }
@ -208,7 +216,7 @@ var
Item: TgirAlias;
begin
Item := TgirAlias.Create(Self, ANode);
Types.Add(Item.Name, Item);
AddType(Item);
end;
procedure TgirNamespace.HandleConstant(ANode: TDomNode);
@ -224,7 +232,7 @@ var
Item : TgirEnumeration;
begin
Item := TgirEnumeration.Create(Self, ANode);
Types.Add(Item.Name, Item);
AddType(Item);
end;
procedure TgirNamespace.HandleBitField(ANode: TDomNode);
@ -232,7 +240,7 @@ var
Item : TgirBitField;
begin
Item := TgirBitField.Create(Self, ANode);
Types.Add(Item.Name, Item);
AddType(Item);
end;
procedure TgirNamespace.HandleCallback(ANode: TDOMNode);
@ -240,7 +248,7 @@ var
Item: TgirCallback;
begin
Item := TgirCallback.Create(Self, ANode);
Types.Add(Item.Name, Item);
AddType(Item);
end;
procedure TgirNamespace.HandleFunction(ANode: TDOMNode);
@ -256,7 +264,7 @@ var
Item: TgirUnion;
begin
Item := TgirUnion.Create(Self, ANode);
Types.Add(Item.Name, Item);
AddType(Item);
end;
procedure TgirNamespace.HandleRecord(ANode: TDomNode);
@ -274,7 +282,7 @@ begin
else
begin
Item := tgirRecord.Create(Self, ANode);
Types.Add(Item.Name, Item);
AddType(Item);
end;
end;
@ -284,7 +292,7 @@ var
Item: TgirObject;
begin
Item := TgirObject.Create(Self, ANode);
Types.Add(Item.Name, Item);
AddType(Item);
end;
procedure TgirNamespace.HandleGType(ANode: TDomNode);
@ -292,7 +300,7 @@ var
Item: TgirGType;
begin
Item := TgirGType.Create(Self, ANode);
Types.Add(Item.Name, Item);
AddType(Item);
end;
procedure TgirNamespace.HandleClassStruct(ANode: TDomNode);
@ -328,7 +336,7 @@ procedure TgirNamespace.AddGLibBaseTypes;
if TranslatedName <> '' then
NativeType.TranslatedName:=TranslatedName;
NativeType.ImpliedPointerLevel:=3;
Types.Add(NativeType.Name, NativeType);
AddType(NativeType);
Result := NativeType;
end;
@ -347,6 +355,8 @@ begin
if (PrevFound <> nil) and (PrevFound.ObjectType = otFuzzyType) then
begin
(PrevFound as TgirFuzzyType).ResolvedType := AType;
//WriteLn('Resolved FuzzyType: ', AType.Name);
FUnresolvedTypes.Remove(PrevFound);
end;
//if PrevFound <> nil then WriteLn('Found Name Already Added: ', AType.Name, ' ', PrevFound.ObjectType, ' ', AType.ObjectType);
if PrevFound = nil then
@ -387,6 +397,7 @@ begin
begin
Fuzzy.ResolvedType := Tmp;
Tmp.ImpliedPointerLevel:=Fuzzy.ImpliedPointerLevel;
Tmp.DeprecatedOverride:= Tmp.DeprecatedOverride or Fuzzy.DeprecatedOverride;
i := FuzzyI+1;
Fuzzy := nil;
//WriteLn('Resolved Fuzzy Type: ', Tmp.CType);
@ -477,6 +488,9 @@ begin
if (PlainCType = 'GType') {or (AName = 'Type')} or (AName = 'GType')then
AName := 'GLib.Type';
if AName = 'any' then
AName := 'gpointer';
FPos := Pos('.', AName);
if FPos > 0 then // type includes namespace "NameSpace.Type"
@ -507,7 +521,6 @@ begin
if Result <> nil then
Result.ImpliedPointerLevel:=PointerLevel;
end;
function TgirNamespace.ResolveFuzzyType(AFuzzyType: TgirFuzzyType): TGirBaseType;
@ -572,16 +585,19 @@ begin
FNameSpace:=Node.GetAttribute('name');
FRequiredNameSpaces := AIncludes;
FSharedLibrary:=Node.GetAttribute('shared-library');
FVersion:=Node.GetAttribute('version');
FVersion:=girVersion(Node.GetAttribute('version'));
FCPrefix:=Node.GetAttribute('c:prefix');
SetCInclude;
SetPackage;
girError(geDebug, Format('Creating namespace=%s Version=%s LibName=%s',[FNameSpace, FVersion, FSharedLibrary]));
girError(geDebug, Format('Creating namespace=%s Version=%s LibName=%s',[FNameSpace, FVersion.AsString, FSharedLibrary]));
FConstants := TList.Create;
FFunctions := TList.Create;
FTypes := TFPHashObjectList.Create(True);
FUnresolvedTypes := TList.Create;
FMaxSymbolVersion.Major:=MaxInt;
if FNameSpace = 'GLib' then
AddGLibBaseTypes;
end;

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

@ -35,37 +35,52 @@ type
otGType, otInterface, otMethod, otNativeType, otObject, otProperty,
otRecord, otTypeParam, otUnion, otVirtualMethod);
{ TGirBaseType }
TGirBaseType = class
private
FBits: Integer;
FCType: String;
FDeprecated: Boolean;
FDeprecatedMsg: String;
FDeprecatedOverride: Boolean;
FDeprecatedVersion: TGirVersion;
FDoc: String;
FForwardDefinitionWritten: Boolean;
FGLibGetType: String;
FHasFields: Boolean;
FImpliedPointerLevel: Integer;
FName: String;
FObjectType: TGirObjectType;
FDisguised: Boolean;
FOwner: TObject;
FTranslatedName: String;
FVersion: String;
FVersion: TGirVersion;
FWriting: TGirModeState;
procedure SetImpliedPointerLevel(AValue: Integer);
function MaybeResolvedType: TGirBaseType;
function GetPointerLevelFromCType(ACType: String = ''): Integer;
public
constructor Create(AOwner: TObject; ANode: TDomNode); virtual;
property CType: String read FCType write FCType;
property GLibGetType: String read FGLibGetType;
property Name: String read FName;
property TranslatedName: String read FTranslatedName write FTranslatedName;
property ImpliedPointerLevel: Integer read FImpliedPointerLevel write SetImpliedPointerLevel; // only grows
property Owner: TObject Read FOwner; // TgirNameSpace
property Doc: String read FDoc;
property Bits: Integer read FBits;
property Version: String read FVersion;
property Version: TGirVersion read FVersion;
property ForwardDefinitionWritten: Boolean read FForwardDefinitionWritten write FForwardDefinitionWritten;
property Writing: TGirModeState read FWriting write FWriting;
property Disguised: Boolean read FDisguised; // only access this type with the functions given not fieids directly.
property ObjectType: TGirObjectType read FObjectType;
property Deprecated: Boolean read FDeprecated;
property DeprecatedMsg: String read FDeprecatedMsg;
property DeprecatedVersion: TGirVersion read FDeprecatedVersion;
{ if an object that is not deprecated depends on this deprecated item then override it. }
property DeprecatedOverride: Boolean read FDeprecatedOverride write FDeprecatedOverride;
end;
{ TgirNativeTypeDef }
@ -142,6 +157,8 @@ type
private
FFixedSize: Integer;
FParentFieldName: String;
FNode: TDOMNode;
function GetBestPointerLevel: Integer; // only works while the Constructor is active.
public
constructor Create(AOwner: TObject; ANode: TDomNode); override;
property FixedSize: Integer read FFixedSize;
@ -152,6 +169,7 @@ type
TgirConstant = class(TGirBaseType)
private
FCName: String;
FIsString: Boolean;
FTypeDecl: TGirBaseType;
FValue: String;
@ -160,6 +178,7 @@ type
property TypeDecl: TGirBaseType read FTypeDecl;
property Value: String read FValue;
property IsString: Boolean read FIsString;
property CName: String read FCName;
end;
{ TgirEnumeration }
@ -184,12 +203,15 @@ type
TgirEnumeration = class(TGirBaseType)
private
FMembers: TgirEnumList;
procedure AddMember(AName, AValue, ACIdentifier: String);
FNeedsSignedType: Boolean;
FNotIntTypeEnum: Boolean;
procedure AddMember(AName, AValue, ACIdentifier: String; Node: TDomElement);
procedure HandleFunction(ANode: TDomNode);
public
constructor Create(AOwner: TObject; ANode: TDomNode); override;
destructor Destroy; override;
property Members: TgirEnumList read FMembers;
property NeedsSignedType: Boolean read FNeedsSignedType;
end;
{ TgirBitField }
@ -227,9 +249,6 @@ type
TgirFunction = class(TGirBaseType)
private
FCIdentifier: String;
FDeprecated: Boolean;
FDeprecatedMsg: String;
FDeprecatedVersion: String;
FParams: TgirParamList;
FReturns: TgirFunctionReturn;
FThrowsGError: Boolean;
@ -239,9 +258,6 @@ type
property Params: TgirParamList read FParams;
property Returns: TgirFunctionReturn read FReturns;
property CIdentifier: String read FCIdentifier;
property Deprecated: Boolean read FDeprecated;
property DeprecatedMsg: String read FDeprecatedMsg;
property DeprecatedVersion: String read FDeprecatedVersion;
property ThrowsGError: Boolean read FThrowsGError write FThrowsGError;
end;
@ -489,6 +505,9 @@ begin
FOwner := AOwner;
FCType:=AGType;
FName:=AGType; // used by LookupName in namespace
FVersion := TgirNamespace(FOwner).Version.AsMajor;
FDeprecatedVersion := girVersion(MaxInt, MaxInt);
//now some fixups :(
if FName = 'gchar' then
FName := 'utf8';
@ -540,7 +559,8 @@ begin
while Node <> nil do
begin
case GirTokenNameToToken(Node.NodeName) of
gtDoc:; // ignore
gtDoc,
gtDocDeprecated:; // ignore
gtType: FPropType := TgirNamespace(Owner).LookupTypeByName(Node.GetAttribute('name'), Node.GetAttribute('c:type'));
gtArray:
begin
@ -650,23 +670,55 @@ end;
{ TgirArray }
function TgirArray.GetBestPointerLevel: Integer;
var
ArrayCType: String;
TypeCType: String;
TypeNode: TDOMElement;
ArrayCTypeLevel,
TypeCTypeLevel: Integer;
begin
ArrayCType:=TDOMElement(FNode).GetAttribute('c:type');
TypeNode := TdomElement(FNode.FindNode('type'));
TypeCType:=TDOMElement(TypeNode).GetAttribute('c:type');
ArrayCTypeLevel := GetPointerLevelFromCType(ArrayCType);
TypeCTypeLevel := GetPointerLevelFromCType(TypeCType);
if ArrayCTypeLevel > TypeCTypeLevel then
begin
FCType:=ArrayCType;
Exit(ArrayCTypeLevel)
end;
Result := TypeCTypeLevel;
//FCType:=TypeCType; // already assigned in TgirTypeParam.Create
end;
constructor TgirArray.Create(AOwner: TObject; ANode: TDomNode);
var
Node: TDomELement;
begin
FObjectType:=otArray;
FNode := ANode;
inherited Create(AOwner, ANode);
// ctype is in two places for arrays. one as an attribute of the array node.
// and in the subnode 'type' assigned above in inherited Create.
FPointerLevel:=GetBestPointerLevel;
Node := TDomElement(ANode.FindNode('type'));
if Node <> nil then
begin
FVarType := TgirNamespace(Owner).LookupTypeByName(Node.GetAttribute('name'), CType);
FVarType.ImpliedPointerLevel:=FPointerLevel;
TryStrToInt(TDomElement(ANode).GetAttribute('fixed-size'), FFixedSize);
end;
Node := TDOMElement(ANode.ParentNode);
FParentFieldName := Node.GetAttribute('name');
if FName = '' then
FName := FParentFieldName;
FObjectType:=otArray;
end;
{ TgirObject }
@ -712,7 +764,8 @@ begin
while Node <> nil do
begin
case GirTokenNameToToken(Node.NodeName) of
gtDoc:;
gtDoc,
gtDocDeprecated:;
gtType: FFields.Add(TgirTypeParam.Create(Owner, ANode));
gtCallback: FFields.Add(TgirCallback.Create(Owner, Node));
gtArray: Fields.Add(TgirArray.Create(Owner, Node));
@ -730,7 +783,8 @@ var
NameStr: String;
begin
case ANodeType of
gtDoc:;
gtDoc,
gtDocDeprecated:;
gtField : HandleField(ANode);
gtUnion: HandleUnion(ANode);
gtFunction: begin
@ -778,13 +832,12 @@ end;
constructor TGirFunctionParam.Create(AOwner: TObject; ANode: TDomNode);
begin
inherited Create(AOwner, ANode);
FObjectType:=otFunctionParam;
end;
constructor TGirFunctionParam.Create(AOwner: TObject; ANode: TDomNode;
AIsInstanceParam: Boolean);
constructor TGirFunctionParam.Create(AOwner: TObject; ANode: TDomNode; AIsInstanceParam: Boolean);
begin
inherited Create(AOwner, ANode, AIsInstanceParam);
FObjectType:=otFunctionParam;
end;
{ TgirTypeParam }
@ -837,7 +890,7 @@ constructor TgirTypeParam.Create(AOwner: TObject; ANode: TDomNode);
if Pos('const ', C_Type) > 0 then
begin
FIsConst:=True;
Result := Copy(C_Type, 7, Length(C_Type) - 6);
Result := Copy(C_Type, 7, Length(C_Type));
end
else
Result := C_Type;
@ -848,6 +901,10 @@ var
Tmp: String;
Token: TGirToken;
VarTypeName: String;
SubTypeNode: TDomElement;
SubTypeName: String;
ParamDir: TGirToken;
ParamPointerLevel: Integer;
begin
inherited Create(AOwner, ANode);
//NodeURL(ANode);
@ -856,12 +913,24 @@ begin
if Node = nil then
girError(geError, Format(geMissingNode,[ClassName, '', ANode.NodeName]));
FPointerLevel:=-1;
ParamDir:= GirTokenNameToToken(TDomElement(ANode).GetAttribute('direction'));
case ParamDir of
gtIn,
gtEmpty: ParamPointerLevel := 0;
gtOut,
gtInOut: ParamPointerLevel := 1;
end;
while Node <> nil do
begin
// it's one or the other
Token := GirTokenNameToToken(Node.NodeName);
case Token of
gtDoc:;
gtDoc,
gtDocDeprecated:;
gtType: begin
C_Type := AssignC_Type(Node.GetAttribute('c:type'));
@ -870,13 +939,30 @@ begin
if VarTypeName = '' then
VarTypeName:= StringReplace(C_Type, '*', '', [rfReplaceAll]);
FVarType := TgirNamespace(Owner).LookupTypeByName(VarTypeName, C_Type);
SubTypeNode := TDomElement(Node.FindNode('type'));
if SubTypeNode <> nil then
begin
SubTypeName := SubTypeNode.GetAttribute('name');
if (SubTypeName = 'any') or (SubTypeName = 'gpointer') then // 'any' means gpointer for some reason
Inc(ParamPointerLevel);
end;
if InheritsFrom(TgirArray) then
ParamPointerLevel:=TgirArray(Self).GetBestPointerLevel
else if GetPointerLevelFromCType > ParamPointerLevel then
ParamPointerLevel:=GetPointerLevelFromCType;
end;
gtArray: begin
C_Type := AssignC_Type(Node.GetAttribute('c:type'));
FVarType := TgirNamespace(Owner).LookupTypeByName(TDOMElement(Node.FirstChild).GetAttribute('name'), C_Type);
Tmp := Node.GetAttribute('length');
if Tmp <> '' then
FVarType.ImpliedPointerLevel:=StrToInt(Tmp);
if PointerLevelFromVarName(C_Type) > ParamPointerLevel then
ParamPointerLevel:=PointerLevelFromVarName(C_Type);
if (ParamPointerLevel = 0) and (ParamDir in [gtOut, gtInOut]) then
ParamPointerLevel:=1;
end;
gtVarArgs: begin
FVarType := nil
@ -888,11 +974,21 @@ begin
end;
FPointerLevel := PointerLevelFromVarName(C_Type);
//if FPointerLevel = -1 then
// FPointerLevel := PointerLevelFromVarName(C_Type);
if ParamPointerLevel > FPointerLevel then
FPointerLevel:=ParamPointerLevel;
if (FVarType <> nil) {and (GirTokenNameToToken(ANode.NodeName) = gtArray)} then
FVarType.ImpliedPointerLevel := PointerLevelFromVarName(CType);
begin
FVarType.ImpliedPointerLevel:=FPointerLevel;
//FVarType.ImpliedPointerLevel := PointerLevelFromVarName(CType);
if FVarType.Deprecated and (TgirNamespace(Owner).DeprecatedVersion <= DeprecatedVersion) and not FVarType.DeprecatedOverride then
begin
girError(geWarn, Format('Type %s is deprecated but is used by %s. Including %s',[FVarType.CType, Name, FVarType.CType]));
FVarType.DeprecatedOverride:=True;
end;
end;
if (FVarType <> nil) and (Token <> gtVarArgs) then
FVarType.ImpliedPointerLevel:=PointerLevel; //only will grow
@ -911,7 +1007,7 @@ begin
Node := TDOMElement(Node.ParentNode);
end;
WriteLn('Vartype is nil when it shouldnt be! '+VarTypeName );
raise Exception.Create('Vartype is nil when it shouldnt be! ');
raise Exception.Create('Vartype is nil when it shouldn''t be! ');
end;
FObjectType:=otTypeParam;
end;
@ -979,13 +1075,14 @@ var
while PNode <> nil do
begin
case GirTokenNameToToken(PNode.NodeName) of
gtDoc:;
gtDoc,
gtDocDeprecated:;
gtParameter:
begin
Param := TGirFunctionParam.Create(AOwner, PNode);
Param := TGirFunctionParam.Create(AOwner, PNode, False);
FParams.Add(Param);
end;
gtInstanceParameter:
gtInstanceParameter:
begin
Param := TGirFunctionParam.Create(AOwner, PNode, True);
FParams.Add(Param);
@ -1020,7 +1117,8 @@ begin
while Node <> nil do
begin
case GirTokenNameToToken(Node.NodeName) of
gtDoc:;
gtDoc,
gtDocDeprecated:;
gtReturnValue: FReturns := TgirFunctionReturn.Create(AOwner, Node);
gtParameters: CreateParameters(Node);
else
@ -1033,12 +1131,6 @@ begin
WriteLn('Return value not defined for: ', Name);
Halt
end;
FDeprecated:=TDOMElement(ANode).GetAttribute('deprecated') <> '';
if FDeprecated then
begin
FDeprecatedMsg:=TDOMElement(ANode).GetAttribute('deprecated');
FDeprecatedVersion:=TDOMElement(ANode).GetAttribute('deprecated-version');
end;
FObjectType:=otFunction;
end;
@ -1063,14 +1155,40 @@ end;
{ TgirEnumeration }
procedure TgirEnumeration.AddMember(AName, AValue, ACIdentifier: String);
procedure TgirEnumeration.AddMember(AName, AValue, ACIdentifier: String;
Node: TDomElement);
var
Member: PgirEnumMember;
IntValue: LongInt;
FailPoint: Integer;
begin
if (ACIdentifier = '') and Assigned(Node) then
begin
// sometimes there is an attribute child node
Node := TDomElement(Node.FirstChild);
while Node <> nil do
begin
if Node.NodeName = 'attribute' then
begin
if Node.GetAttribute('name') = 'c:identifier' then
ACIdentifier:=Node.GetAttribute('value');
end;
Node := TDomElement(Node.NextSibling);
end;
end;
if ACIdentifier = 'GDK_DRAG_MOTION' then ACIdentifier := 'GDK_DRAG_MOTION_';
if ACIdentifier = 'GDK_DRAG_STATUS' then ACIdentifier := 'GDK_DRAG_STATUS_';
if ACIdentifier = 'GDK_PROPERTY_DELETE' then ACIdentifier := 'GDK_PROPERTY_DELETE_';
// See of the enum needs a signed type or not. Probably not.
if not FNotIntTypeEnum and not FNeedsSignedType then
begin
Val(AValue, IntValue, FailPoint);
if (FailPoint = 0) and (Length(AValue) > 0) and (AValue[1] = '-') then
FNeedsSignedType:=True;
if FailPoint <> 0 then
FNotIntTypeEnum:=True; // so we won't continue trying to convert invalid values to ints.
end;
New(Member);
Member^.Name:=AName;
@ -1100,8 +1218,9 @@ begin
while Node <> nil do
begin
case GirTokenNameToToken(Node.NodeName) of
gtDoc:;
gtMember: AddMember(Node.GetAttribute('name'), Node.GetAttribute('value'),Node.GetAttribute('c:identifier'));
gtDoc,
gtDocDeprecated:;
gtMember: AddMember(Node.GetAttribute('name'), Node.GetAttribute('value'),Node.GetAttribute('c:identifier'), Node);
// some enumerations seem to have functions part of them. They are only functions directly related to the enumeration and cannot be part of the enum
gtFunction: HandleFunction(Node);
else
@ -1127,10 +1246,13 @@ var
Node: TDOMElement;
begin
inherited Create(AOwner, ANode);
FCName:=TDomELement(ANode).GetAttribute('c:type');
if FCName = '' then
FCName := FName;
Node := TDomELement(ANode.FindNode('type'));
FTypeDecl := TgirNamespace(Owner).LookupTypeByName(Node.GetAttribute('name'), Node.GetAttribute('c:type'));
FValue:= TDOMElement(ANode).GetAttribute('value');
FIsString:=Node.GetAttribute('c:type') = 'gchar*';
FIsString:=(Node.GetAttribute('c:type') = 'gchar*') or (Node.GetAttribute('name') = 'utf8');
//girError(geDebug, Format('Added constant "%s" with value "%s" of type "%s"',[Name, Value, FTypeDecl.Name]));
FObjectType:=otConstant;
end;
@ -1158,6 +1280,8 @@ begin
FOwner := AOwner;
FCType:=ACtype;
FObjectType:=otFuzzyType;
FVersion := TgirNamespace(FOwner).Version.AsMajor;
FDeprecatedVersion := girVersion(MaxInt, MaxInt); // not deprecated
//girError(geFuzzy, 'Creating Fuzzy Type "'+AName+'/'+ACtype+'"');
end;
@ -1200,6 +1324,8 @@ begin
FCType:=ACType;
FTranslatedName:=ATranslatedName;
FObjectType:=otAlias;
FVersion := TgirNamespace(FOwner).Version.AsMajor;
FDeprecatedVersion := girVersion(MaxInt, MaxInt); // not deprecated
end;
{ TGirBaseType }
@ -1222,7 +1348,19 @@ begin
Result := Self;
end;
constructor TGirBaseType.Create(AOwner: TObject; ANode: TDOMNode);
function TGirBaseType.GetPointerLevelFromCType(ACType: String): Integer;
var
C: Char;
begin
if ACType = '' then
ACType:=FCType;
Result := 0;
for C in ACType do
if C = '*' then
Inc(Result);
end;
constructor TGirBaseType.Create(AOwner: TObject; ANode: TDomNode);
var
Element: TDOMElement absolute ANode;
Node: TDomNode;
@ -1232,8 +1370,17 @@ begin
girError(geError, 'Creating '+ClassName+' with a nil node');
FOwner := AOwner;
FCType := Element.GetAttribute('c:type');
if FCType = '' then
FCType := Element.GetAttribute('glib:type-name');
FName := Element.GetAttribute('name');
FVersion:= Element.GetAttribute('version');
try
FVersion:= girVersion(Element.GetAttribute('version'));
except
FVersion := TgirNamespace(FOwner).Version.AsMajor;
end;
FDisguised := Element.GetAttribute('disguised') = '1';
FGLibGetType:= Element.GetAttribute('glib:get-type');
AttrValue := Element.GetAttribute('bits');
if AttrValue <> '' then
FBits := StrToInt(AttrValue);
@ -1241,6 +1388,24 @@ begin
if Node <> nil then
FDoc := Node.FirstChild.TextContent;
ImpliedPointerLevel:=2;
FDeprecated:=TDOMElement(ANode).GetAttribute('deprecated') = '1';
if FDeprecated then
begin
Node := ANode.FindNode('doc-deprecated');
if Node <> nil then
begin
FDeprecatedMsg:=StringReplace(Node.TextContent, #10, ' ', [rfReplaceAll]);
FDeprecatedMsg := StringReplace(FDeprecatedMsg, '''', '''''', [rfReplaceAll]); // replace ' with ''
end;
try
FDeprecatedVersion:=girVersion(TDOMElement(ANode).GetAttribute('deprecated-version'));
except
FDeprecatedVersion:=TgirNamespace(FOwner).Version.AsMajor;
end;
end
else
FDeprecatedVersion := girVersion(MaxInt, MaxInt); // not deprecated
FObjectType:=otBaseType;
end;

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

@ -60,6 +60,7 @@ begin
FUnits := TList.Create;
FDefaultUnitExtension:='.pas';
FOptions:=AOptions;
FUnitPrefix:=AUnitPrefix;
end;
procedure TgirPascalWriter.GenerateUnits;

171
applications/gobject-introspection/girpascalwritertypes.pas
View File

@ -49,7 +49,7 @@ type
private
FDynamicFunctions: Boolean;
public
constructor Create(ADynamicFunctions: Boolean);
constructor Create(ADynamicFunctions: Boolean); reintroduce;
function AsString: String; override;
end;
@ -111,7 +111,7 @@ type
FFunctionSection: TPDeclarationFunctions;
FUsesSection: TPUses;
public
constructor Create(AOwner: TObject; AUses: TPUses; ADynamicFunctions: Boolean);
constructor Create(AOwner: TObject; AUses: TPUses; ADynamicFunctions: Boolean); reintroduce;
destructor Destroy; override;
function AsString: String; override;
property UsesSection: TPUses read FUsesSection;
@ -155,7 +155,6 @@ type
FUnitPrefix: String;
FWriter: TObject;//girPascalWriter;
FUnits: TFPList;
//Units: array[TPascalUnitType] of TPascalUnit;
function GetUnitForType(AType: TPascalUnitType): TPascalUnit;
public
constructor Create(AWriter: TObject{TgirPascalWriter}; ANameSpace: TgirNamespace; AOptions: TgirOptions; AUnitPrefix: String);
@ -218,7 +217,7 @@ type
procedure WriteFunctionTypeAndReturnType(AItem: TgirFunction; out AFunctionType, AFunctionReturnType: String);
function WriteFunctionParams(AParams: TgirParamList; AArgs: PString = nil; AIncludeInstanceParam: Boolean = False): String;
function WriteFunction(AFunction: TgirFunction; AItem: TGirBaseType; AIsMethod: Boolean; AWantWrapperForObject: Boolean; AFunctionList: TStrings; AExistingUsedNames: TStringList = nil): String;
function WriteParamAsString(AParam: TgirTypeParam; AIndex: Integer; out ABitSizeSpecified: Boolean; AFirstParam: PString = nil; AExistingUsedNames: TStringList = nil): String;
function WriteParamAsString(AParentName: String; AParam: TgirTypeParam; AIndex: Integer; out ABitSizeSpecified: Boolean; AFirstParam: PString = nil; AExistingUsedNames: TStringList = nil): String;
function WriteRecord(ARecord: TgirRecord; ABaseIndent: Integer = 0; AIsUnion: Boolean = False): String;
function WriteUnion(AUnion: TgirUnion; ASkipRecordName: Boolean; ABaseIndent: Integer = 0): String;
function ParenParams(const AParams: String; const AForceParens: Boolean = False): String;
@ -246,7 +245,8 @@ type
public
constructor Create(AGroup: TPascalUnitGroup; ANameSpace: TgirNamespace; AOptions: TgirOptions; AUnitType: TPascalUnitTypes; AUnitPrefix: String);
destructor Destroy; override;
procedure ProcessConsts(AList:TList); // of TgirBaseType descandants
function MeetsVersionConstraints(AItem: TGirBaseType): Boolean;
procedure ProcessConsts(AList: TList; AUsedNames: TStringList); // of TgirBaseType descandants
procedure ProcessTypes(AList:TFPHashObjectList); // of TgirBaseType descandants
procedure ProcessFunctions(AList:TList);// of TgirFunction
procedure GenerateUnit;
@ -335,6 +335,7 @@ begin
FUnits := TFPList.Create;
FUnitPrefix:=AUnitPrefix;
FSimpleUnit := ([goSeperateConsts, goClasses, goObjects] * AOptions ) = [];
FUnitPrefix:=AUnitPrefix;
if FSimpleUnit then
begin
@ -369,13 +370,31 @@ begin
end;
procedure TPascalUnitGroup.GenerateUnits;
function CollectFunctionNames: TStringList;
var
i: Integer;
begin
Result := TStringList.Create;
Result.Duplicates:=dupError;
if UnitForType[utConsts] <> UnitForType[utFunctions] then
Exit;
Result.Capacity := FNameSpace.Functions.Count;
for i := 0 to FNameSpace.Functions.Count-1 do
Result.Add(TgirFunction(FNameSpace.Functions.Items[i]).CIdentifier);
Result.Sorted:=True;
end;
var
PUnit: TPascalUnit;
lUsedNames: TStringList;
begin
for Pointer(PUnit) in FUnits do
if Assigned(PUnit) then
PUnit.GenerateUnit;
UnitForType[utConsts].ProcessConsts(FNameSpace.Constants);
lUsedNames := CollectFunctionNames;
UnitForType[utConsts].ProcessConsts(FNameSpace.Constants, lUsedNames);
lUsedNames.Free;
UnitForType[utTypes].ProcessTypes(FNameSpace.Types);
UnitForType[utFunctions].ProcessFunctions(FNameSpace.Functions);
for Pointer(PUnit) in FUnits do
@ -559,12 +578,12 @@ end;
function TPascalUnit.GetUnitName: String;
begin
Result := CalculateUnitName(FNameSpace.NameSpace, FNameSpace.Version);
Result := FGroup.FUnitPrefix + CalculateUnitName(FNameSpace.NameSpace, FNameSpace.Version.AsString);
end;
function TPascalUnit.GetUnitFileName: String;
begin
Result := UnitPrefix+UnitName+GetUnitPostfix;
Result := {UnitPrefix+}UnitName+GetUnitPostfix;
end;
function TPascalUnit.GetUnitPostfix: String;
@ -677,13 +696,18 @@ begin
if (AType.CType = '') then //(AType.Name = '') then
begin
girError(geWarn, 'Type.Ctype undefined! : '+ Atype.Name);
//girError(geWarn, 'Type.Ctype undefined! : '+ Atype.Name);
//Halt;
end;
if ProcessLevel > 0 then
begin
WriteForwardDefinition(AType);
if AType.Deprecated and not AType.DeprecatedOverride and not (MeetsVersionConstraints(AType))then
begin
AType.DeprecatedOverride:=True;
girError(girErrors.geWarn, Format('Type %s is deprecated but is pulled in by a field or parameter',[AType.CType]));
end;
if AType.InheritsFrom(TgirCallback) or AType.InheritsFrom(TgirBitField) then
AForceWrite:=True;
if not AForceWrite then
@ -695,6 +719,10 @@ begin
Exit;
end;
if not MeetsVersionConstraints(AType) then
Exit;
//if AForceWrite then
// WriteLn('ForceWriting: ', AType.CType);
@ -756,6 +784,7 @@ begin
if CTypesType <> '' then
begin
FuzzyType.TranslatedName:= CTypesType;
//FuzzyType.TranslatedName:= FNameSpace.CPrefix + FuzzyType.Name;
FuzzyType.Writing := msWritten;
end;
end;
@ -880,6 +909,7 @@ var
ResolvedForName: String;
CType: TGirBaseType = nil;
ProperUnit: TPascalUnit;
TargetType: TGirBaseType = nil;
begin
ProperUnit := FGroup.GetUnitForType(utTypes);
if ProperUnit <> Self then begin
@ -887,12 +917,18 @@ begin
Exit;
end;
ResolveTypeTranslation(AItem);
ResolveTypeTranslation(AItem.ForType);
TargetType := AItem.ForType;
ResolveTypeTranslation(TargetType);
if TargetType.ClassType = TgirFuzzyType then writeln('Alias for type assigned to fuzzy type! ', TargetType.Name);
// some aliases are just for the parser to connect a name to an alias
if AItem.CType = '' then
Exit;
ResolvedForName := aItem.ForType.TranslatedName;
ResolvedForName := TargetType.TranslatedName;
if ResolvedForName = '' then
begin
{
@ -941,7 +977,7 @@ var
CName: String;
TypeName: String;
ProperUnit: TPascalUnit;
IntType: String;
begin
ProperUnit := FGroup.GetUnitForType(utTypes);
if ProperUnit <> Self then begin
@ -960,9 +996,14 @@ begin
TypeName := ': '+AItem.TranslatedName;
if AItem.NeedsSignedType then
IntType := 'Integer'
else
IntType := 'DWord';
// yes we cheat a little here using the const section to write type info
ConstSection.Lines.Add('type');
ConstSection.Lines.Add(IndentText(AItem.TranslatedName+' = Integer;', 2,0));
ConstSection.Lines.Add(IndentText(AItem.TranslatedName+' = '+IntType+';', 2,0));
ConstSection.Lines.Add('const');
end
else
@ -1131,6 +1172,10 @@ begin
ProperUnit.HandleFunction(AItem);
Exit;
end;
if not MeetsVersionConstraints(AItem) then
Exit; // ==>
WriteFunctionTypeAndReturnType(AItem, RoutineType, Returns);
Params := WriteFunctionParams(AItem.Params);
Postfix := ' external;';// '+UnitName+'_library;';
@ -1164,7 +1209,7 @@ begin
Result := '';
OptionsIndicateWrapperMethod:= FUnitType = PascalUnitTypeAll;
// we skip deprecated functions
if AFunction.Deprecated and not (goIncludeDeprecated in FOptions) then //and (CompareStr(AFunction.DeprecatedVersion, NameSpace.Version) >= 0) then
if not MeetsVersionConstraints(AFunction) then
Exit;
// some abstract functions that are to be implemented by a module and shouldn't be declared. There is no indicator in the gir file that this is so :(
@ -1177,7 +1222,14 @@ begin
if AWantWrapperForObject then
InLineS:=' inline;';
if AFunction.Deprecated then DeprecatedS :=' deprecated ''Since ' + NameSpace.NameSpace + ' ' + AFunction.DeprecatedVersion+' '+StringReplace(AFunction.DeprecatedMsg,'''','`', [rfReplaceAll])+''';';
if AFunction.Deprecated then
begin
if AFunction.DeprecatedMsg = '' then
DeprecatedS :=' deprecated ''Since ' + NameSpace.NameSpace + ' ' + AFunction.DeprecatedVersion.AsString+' '+StringReplace(AFunction.DeprecatedMsg,'''','`', [rfReplaceAll])+''';'
else
DeprecatedS :=' deprecated '''+AFunction.DeprecatedMsg+''';';
end;
// this fills in the values for procedure/function and the return type
WriteFunctionTypeAndReturnType(AFunction, RoutineType, Returns);
@ -1328,6 +1380,9 @@ var
Comment: String='';
OptionsIndicateWrapperMethod: Boolean;
begin
Result := '';
if AProperty.Deprecated and not (goIncludeDeprecated in FOptions) then
Exit;
OptionsIndicateWrapperMethod:=FUnitType = PascalUnitTypeAll;
if not OptionsIndicateWrapperMethod or (goNoWrappers in FOptions) then
Exit('');
@ -1360,7 +1415,7 @@ var
Exit;
end;
Param := WriteParamAsString(AParam,i, ParamIsBitSized, nil, UsedNames);
Param := WriteParamAsString(AItem.name, AParam,i, ParamIsBitSized, nil, UsedNames);
if ParamIsBitSized then
PackedBitsAddEntry(PackedBits, AItem, PackedBitsFieldCount, Param, TypeDecl)
@ -1371,7 +1426,7 @@ var
procedure AddLinesIfSet(AList: TStrings; const TextIn: String);
begin
if TextIn <> '' then
if Trim(TextIn) <> '' then
AList.Add(TextIn);
end;
@ -1380,11 +1435,14 @@ var
SetFound: Boolean;
PropType: String;
begin
if not MeetsVersionConstraints(Field) then
Exit;
AddedBitSizedType:=False;
// FIRST PASS
if AFirstPass then
begin
case Field.ObjectType of
otVirtualMethod: ; // ignore. may be usefull if we wrap this in pascal classes instead of objects. Is already written in the class struct
otCallback,
@ -1582,10 +1640,27 @@ begin
Exit;
end;
ResolveTypeTranslation(AItem);
if AItem.ImpliedPointerLevel > 0 then
WriteForwardDefinition(AItem);
WantTypeSection.Lines.Add(WriteUnion(AItem, False, 2));
end;
function TPascalUnit.MeetsVersionConstraints(AItem: TGirBaseType): Boolean;
begin
Result := not AItem.Deprecated;
if not Result then
Result := goIncludeDeprecated in FOptions;
if not Result then
Result := AItem.DeprecatedVersion >= FNameSpace.DeprecatedVersion;
if not Result then
Result := AItem.DeprecatedOverride;
Result := Result and (AItem.Version <= FNameSpace.MaxSymbolVersion);
end;
procedure TPascalUnit.WriteForwardDefinition(AType: TGirBaseType);
procedure WriteForward;
var
@ -1700,7 +1775,10 @@ begin
end
else
begin
CBName:=MakePascalTypeFromCType(AItem.CType);
if AItem.CType <> '' then
CBName:=MakePascalTypeFromCType(AItem.CType)
else
CBName:=MakePascalTypeFromCType(NameSpace.CPrefix+AItem.Name);
Symbol := ' = ';
end;
@ -1714,7 +1792,8 @@ procedure TPascalUnit.WriteFunctionTypeAndReturnType(AItem: TgirFunction;
out AFunctionType, AFunctionReturnType: String);
begin
ResolveTypeTranslation(AItem.Returns.VarType);
if (AItem.Returns.VarType.CType = 'void') and (AItem.Returns.PointerLevel = 0) then
if ((AItem.Returns.VarType.CType = 'void') or (AItem.Returns.VarType.Name = 'none'))
and (AItem.Returns.PointerLevel = 0) then
begin
AFunctionType:='procedure';
AFunctionReturnType := '; cdecl;';
@ -1743,7 +1822,7 @@ begin
// IsInstanceParam is only the ever the first param so this is safe if it's the
// only Param and AArgs is not updated. AArgs := @Self[, ;] is set in WriteFunction
if AIncludeInstanceParam or (not AIncludeInstanceParam and not AParams.Param[i].IsInstanceParam) then
Result := Result+WriteParamAsString(AParams.Param[i], i, Dummy, @ArgName)
Result := Result+WriteParamAsString('', AParams.Param[i], i, Dummy, @ArgName)
else
Continue;
@ -1826,7 +1905,7 @@ begin
end;
end;
function TPascalUnit.WriteParamAsString(AParam: TgirTypeParam; AIndex: Integer; out ABitSizeSpecified: Boolean; AFirstParam: PString = nil; AExistingUsedNames: TStringList = nil): String;
function TPascalUnit.WriteParamAsString(AParentName: String; AParam: TgirTypeParam; AIndex: Integer; out ABitSizeSpecified: Boolean; AFirstParam: PString; AExistingUsedNames: TStringList): String;
var
PT: String;
PN: String;
@ -1841,7 +1920,6 @@ begin
exit;
end;
IsArray := AParam.InheritsFrom(TgirArray) ;
//if Length(AParam.VarType.Name) < 1 then
@ -1858,7 +1936,6 @@ begin
else
PN := AParam.Name;
if PN = '' then
PN := 'param'+IntToStr(AIndex);
PN := SanitizeName(PN, AExistingUsedNames);
@ -1882,6 +1959,9 @@ begin
end;
Result := PN +': '+PT;
if PN = PT then
WriteLn('Dup name and type! : ',AParam.Name,' ' , AParam.VarType.Name, ' ', PN + ': '+ PT);
ProcessType(AParam.VarType, AParam.PointerLevel = 0); // will skip if written
end;
@ -1898,7 +1978,7 @@ var
// Iten
begin
Result := False;
Param := WriteParamAsString(TgirTypeParam(AField),i, Result);
Param := WriteParamAsString(ARecord.Name, TgirTypeParam(AField),i, Result);
if Result and not AIsUnion then
PackedBitsAddEntry(PackedBits, ARecord, PackedBitsCount, Param, TypeDecl)
else
@ -1967,7 +2047,7 @@ begin
Field := AUnion.Fields.Field[i];
case Field.ObjectType of
otArray,
otTypeParam : Union.Add(IndentText(IntToStr(i)+ ' : ' +ParenParams(WriteParamAsString(TgirTypeParam(Field),i, Dummy))+';',ABaseIndent+ 4,0));
otTypeParam : Union.Add(IndentText(IntToStr(i)+ ' : ' +ParenParams(WriteParamAsString(AUnion.NAme, TgirTypeParam(Field),i, Dummy))+';',ABaseIndent+ 4,0));
otCallback : Union.Add(IndentText(IntToStr(i)+ ' : ' +ParenParams(WriteCallBack(TgirCallback(Field),True)),ABaseIndent+4,0));
otRecord : Union.Add(IndentText(IntToStr(i)+ ' : ' +ParenParams(WriteRecord(TgirRecord(Field),6, True))+';',ABaseIndent+4,0));
//WriteFunction(AFunction, AItem, AIsMethod, AWantWrapperForObject, AFunctionList): String;
@ -2123,15 +2203,12 @@ var
Sucess: Boolean;
TestName: String;
begin
Result := AName;
for Name in PascalReservedWords do
if Name = LowerCase(AName) then
Result := Aname+'_';
If Result = '' then
Result := AName;
if AName = 'CSET_A_2_Z' then
Result := 'CSET_A_2_Z_UPPER';
if AName = 'CSET_a_2_z' then
Result := 'CSET_a_2_z_lower';
Result := StringReplace(Result, '-','_',[rfReplaceAll]);
Result := StringReplace(Result, ' ','_',[rfReplaceAll]);
Result := StringReplace(Result, '.','_',[rfReplaceAll]);
@ -2143,7 +2220,7 @@ begin
repeat
Inc(Sanity);
try
AExistingUsedNames.Add(TestName);
AExistingUsedNames.Add(LowerCase(TestName));
Result := TestName;
Sucess := True;
except
@ -2164,7 +2241,7 @@ begin
begin
RawName := ABaseType.CType;
if RawName = '' then
RawName:= ABaseType.Name;
RawName:= NameSpace.CPrefix+ABaseType.Name;
ABaseType.TranslatedName:=MakePascalTypeFromCType(RawName, 0);
end;
end;
@ -2201,6 +2278,7 @@ begin
FDynamicEntryNames.Sorted:=True;
FDynamicEntryNames.Duplicates := dupIgnore;
FNameSpace := ANameSpace;
if goWantTest in FOptions then
begin
//FTestCFile := TStringStream.Create('');
@ -2234,13 +2312,13 @@ begin
inherited Destroy;
end;
procedure TPascalUnit.ProcessConsts(AList: TList);
procedure TPascalUnit.ProcessConsts(AList: TList; AUsedNames: TStringList);
function WriteConst(AConst: TgirConstant; Suffix: String = ''): String;
begin
if AConst.IsString then
Result := SanitizeName(AConst.Name) + Suffix+' = '+QuotedStr(AConst.Value)+';'
Result := AConst.CName + Suffix+' = '+QuotedStr(AConst.Value)+';'
else
Result := SanitizeName(AConst.Name) + Suffix+' = '+AConst.Value+';';
Result := AConst.CName + Suffix+' = '+AConst.Value+';';
end;
var
@ -2263,16 +2341,18 @@ begin
Sanity := 0;
Suffix := '';
Item := TgirConstant(AList.Items[i]);
//if Item.ClassType <> TgirConstant then ; // raise error
Entry := LowerCase(SanitizeName(Item.Name));
repeat
try
Entry := SanitizeName(Item.CName+Suffix, AUsedNames);
if Entry <> Item.CName+Suffix then
raise Exception.Create('');
Consts.AddObject(Entry, TObject(PtrUInt(NewConst.Lines.Count)));
break;
except
Suffix := '__'+IntToStr(Sanity);
Entry := LowerCase(SanitizeName(Item.Name))+Suffix;
if Sanity > 0 then
Suffix := '__'+IntToStr(Sanity)
else Suffix := '_';
end;
Inc(Sanity);
until Sanity > 10;
@ -2293,6 +2373,8 @@ begin
for i := 0 to AList.Count-1 do
begin
BaseType := TGirBaseType(AList.Items[i]);
if not MeetsVersionConstraints(BaseType) then
Continue;
ProcessType(BaseType);
end;
@ -2306,6 +2388,8 @@ begin
for i := 0 to AList.Count-1 do
begin
Func := TgirFunction(AList.Items[i]);
if not MeetsVersionConstraints(Func) then
Continue;
HandleFunction(Func);
end;
end;
@ -2320,7 +2404,7 @@ begin
for i := 0 to FNameSpace.RequiredNameSpaces.Count-1 do
begin
NS := TgirNamespace(FNameSpace.RequiredNameSpaces.Items[i]);
NeedUnit:=UnitPrefix+CalculateUnitName(NS.NameSpace,NS.Version);
NeedUnit:=FGroup.FUnitPrefix + CalculateUnitName(NS.NameSpace,NS.Version.AsString);
if FUnitType = PascalUnitTypeAll then
InterfaceSection.UsesSection.Units.Add(' '+NeedUnit)
@ -2387,7 +2471,7 @@ begin
Libs := GetLibs;
Result := TStringStream.Create('');
Str.WriteString(IndentText('{ This is an autogenerated unit using gobject introspection (gir2pascal). Do not Edit. }',0,1));
Str.WriteString(IndentText('unit '+ UnitPrefix+UnitFileName+';',0,2));
Str.WriteString(IndentText('unit '+ {UnitPrefix+}UnitFileName+';',0,2));
Str.WriteString(IndentText('{$MODE OBJFPC}{$H+}',0,2));
if utTypes in FUnitType then
Str.WriteString(IndentText('{$PACKRECORDS C}',0,1));
@ -2444,6 +2528,7 @@ function TPDeclarationList.AsString: String;
var
i: Integer;
begin
Result := '';
for i := 0 to Count-1 do
begin
Result := Result+Declarations[i].AsString+LineEnding;

100
applications/gobject-introspection/girtokens.pas
View File

@ -26,18 +26,30 @@ uses
Classes;
type
TGirToken = (gtInvalid, gtAlias, gtConstant, gtRecord, gtBitField, gtEnumeration,
TGirToken = (gtInvalid, gtEmpty, gtAlias, gtConstant, gtRecord, gtBitField, gtEnumeration,
gtCallback, gtUnion, gtFunction, gtReturnValue, gtType,
gtParameters, gtParameter, gtInstanceParameter, gtMember, gtField, gtMethod, gtArray,
gtDoc, gtConstructor, gtRepository, gtInclude, gtNameSpace, gtPackage,
gtDoc, gtDocDeprecated, gtConstructor, gtRepository, gtInclude, gtNameSpace, gtPackage,
gtCInclude, gtClass, gtProperty, gtVirtualMethod, gtInterface,
gtGlibSignal, gtImplements, gtPrerequisite,gtVarArgs, gtObject, gtClassStruct, gtGType);
gtGlibSignal, gtImplements, gtPrerequisite,gtVarArgs, gtObject, gtClassStruct, gtGType,
// Direction for parameters. in is default = no pointer. out and inout means one pointer level.
// If subnode is array then increase pointer level.
gtIn, gtOut, gtInOut
);
TGirVersion = object
Major: Integer;
Minor: Integer;
function AsString: String; // '$major.$minor'
function AsMajor: TGirVersion; // return as $major.0 i.e 3.0 instead of 3.8
end;
var
GirTokenName: array[TGirToken] of String = (
'Invalid Name',
'{empty}',
'alias',
'constant',
'record',
@ -56,6 +68,7 @@ var
'method',
'array',
'doc',
'doc-deprecated',
'constructor',
'repository',
'include',
@ -72,21 +85,100 @@ var
'varargs',
'object',
'classstruct',
'gtype'
'gtype',
'in',
'out',
'inout'
);
function GirTokenNameToToken(AName: String): TGirToken;
function girVersion(AVersion: String; ADefaultMajor: Integer = -1; ADefaultMinor: Integer = -1): TGirVersion;
function girVersion(AMajor, AMinor: Integer): TGirVersion;
operator >= (AVersion, BVersion: TGirVersion): Boolean;
operator <= (AVersion, BVersion: TGirVersion): Boolean;
operator > (AVersion, BVersion: TGirVersion): Boolean;
implementation
uses
sysutils;
function GirTokenNameToToken(AName: String): TGirToken;
begin
if AName = '' then
Exit(gtEmpty);
try
for Result in TGirToken do
if GirTokenName[Result][1] <> AName[1] then
continue
else if GirTokenName[Result] = AName then
Exit;
Result := gtInvalid;
except
WriteLn('GirToken Exception: ',AName);
end;
end;
function girVersion(AVersion: String; ADefaultMajor: Integer; ADefaultMinor: Integer): TGirVersion;
var
SplitPoint: Integer;
Minor: String;
begin
if (AVersion = '') and (ADefaultMajor <> -1) and (ADefaultMinor <> -1) then
begin
Result := girVersion(ADefaultMajor, ADefaultMinor);
Exit;
end;
SplitPoint := Pos('.', AVersion);
if SplitPoint < 1 then
raise Exception.Create(Format('Invalid version string format: "%s" (length %d)', [AVersion, Length(AVersion)]));
Result.Major:=StrToInt(Copy(AVersion,1, SplitPoint-1));
Minor := Copy(AVersion,SplitPoint+1, MaxInt);
SplitPoint := Pos('.', AVersion);
// we are not interested in the third version chunk
if SplitPoint > 0 then
Minor := Copy(Minor,1, SplitPoint-1);
Result.Minor:=StrToInt(Minor);
end;
function girVersion(AMajor, AMinor: Integer): TGirVersion;
begin
REsult.Major := AMajor;
Result.Minor := AMinor;
end;
operator >= (AVersion, BVersion: TGirVersion): Boolean;
begin
Result := (AVersion.Major > BVersion.Major)
or ((AVersion.Major = BVersion.Major) and (AVersion.Minor >= BVersion.Minor));
end;
operator<=(AVersion, BVersion: TGirVersion): Boolean;
begin
Result := (AVersion.Major < BVersion.Major)
or ((AVersion.Major = BVersion.Major) and (AVersion.Minor <= BVersion.Minor));
end;
operator > (AVersion, BVersion: TGirVersion): Boolean;
begin
Result := (AVersion.Major > BVersion.Major)
or ((AVersion.Major = BVersion.Major) and (AVersion.Minor > BVersion.Minor));
end;
{ TGirVersion }
function TGirVersion.AsString: String;
begin
Result := IntToStr(Major)+'.'+IntToStr(Minor);
end;
function TGirVersion.AsMajor: TGirVersion;
begin
Result.Major:=Major;
REsult.Minor:=0;
end;
end.